Showing preview only (1,676K chars total). Download the full file or copy to clipboard to get everything.
Repository: elm/compiler
Branch: master
Commit: cce7a8bbd8fe
Files: 230
Total size: 1.6 MB
Directory structure:
gitextract_rbjgnatp/
├── .github/
│ ├── CONTRIBUTING.md
│ ├── ISSUE_TEMPLATE.md
│ ├── PULL_REQUEST_TEMPLATE.md
│ └── workflows/
│ ├── set-issue-expectations.yml
│ └── set-pull-expectations.yml
├── .gitignore
├── .travis.yml
├── LICENSE
├── README.md
├── builder/
│ └── src/
│ ├── BackgroundWriter.hs
│ ├── Build.hs
│ ├── Deps/
│ │ ├── Bump.hs
│ │ ├── Diff.hs
│ │ ├── Registry.hs
│ │ ├── Solver.hs
│ │ └── Website.hs
│ ├── Elm/
│ │ ├── Details.hs
│ │ └── Outline.hs
│ ├── File.hs
│ ├── Generate.hs
│ ├── Http.hs
│ ├── Reporting/
│ │ ├── Exit/
│ │ │ └── Help.hs
│ │ ├── Exit.hs
│ │ └── Task.hs
│ ├── Reporting.hs
│ └── Stuff.hs
├── cabal.config
├── compiler/
│ └── src/
│ ├── AST/
│ │ ├── Canonical.hs
│ │ ├── Optimized.hs
│ │ ├── Source.hs
│ │ └── Utils/
│ │ ├── Binop.hs
│ │ ├── Shader.hs
│ │ └── Type.hs
│ ├── Canonicalize/
│ │ ├── Effects.hs
│ │ ├── Environment/
│ │ │ ├── Dups.hs
│ │ │ ├── Foreign.hs
│ │ │ └── Local.hs
│ │ ├── Environment.hs
│ │ ├── Expression.hs
│ │ ├── Module.hs
│ │ ├── Pattern.hs
│ │ └── Type.hs
│ ├── Compile.hs
│ ├── Data/
│ │ ├── Bag.hs
│ │ ├── Index.hs
│ │ ├── Map/
│ │ │ └── Utils.hs
│ │ ├── Name.hs
│ │ ├── NonEmptyList.hs
│ │ ├── OneOrMore.hs
│ │ └── Utf8.hs
│ ├── Elm/
│ │ ├── Compiler/
│ │ │ ├── Imports.hs
│ │ │ ├── Type/
│ │ │ │ └── Extract.hs
│ │ │ └── Type.hs
│ │ ├── Constraint.hs
│ │ ├── Docs.hs
│ │ ├── Float.hs
│ │ ├── Interface.hs
│ │ ├── Kernel.hs
│ │ ├── Licenses.hs
│ │ ├── Magnitude.hs
│ │ ├── ModuleName.hs
│ │ ├── Package.hs
│ │ ├── String.hs
│ │ └── Version.hs
│ ├── Generate/
│ │ ├── Html.hs
│ │ ├── JavaScript/
│ │ │ ├── Builder.hs
│ │ │ ├── Expression.hs
│ │ │ ├── Functions.hs
│ │ │ └── Name.hs
│ │ ├── JavaScript.hs
│ │ └── Mode.hs
│ ├── Json/
│ │ ├── Decode.hs
│ │ ├── Encode.hs
│ │ └── String.hs
│ ├── Nitpick/
│ │ ├── Debug.hs
│ │ └── PatternMatches.hs
│ ├── Optimize/
│ │ ├── Case.hs
│ │ ├── DecisionTree.hs
│ │ ├── Expression.hs
│ │ ├── Module.hs
│ │ ├── Names.hs
│ │ └── Port.hs
│ ├── Parse/
│ │ ├── Declaration.hs
│ │ ├── Expression.hs
│ │ ├── Keyword.hs
│ │ ├── Module.hs
│ │ ├── Number.hs
│ │ ├── Pattern.hs
│ │ ├── Primitives.hs
│ │ ├── Shader.hs
│ │ ├── Space.hs
│ │ ├── String.hs
│ │ ├── Symbol.hs
│ │ ├── Type.hs
│ │ └── Variable.hs
│ ├── Reporting/
│ │ ├── Annotation.hs
│ │ ├── Doc.hs
│ │ ├── Error/
│ │ │ ├── Canonicalize.hs
│ │ │ ├── Docs.hs
│ │ │ ├── Import.hs
│ │ │ ├── Json.hs
│ │ │ ├── Main.hs
│ │ │ ├── Pattern.hs
│ │ │ ├── Syntax.hs
│ │ │ └── Type.hs
│ │ ├── Error.hs
│ │ ├── Render/
│ │ │ ├── Code.hs
│ │ │ ├── Type/
│ │ │ │ └── Localizer.hs
│ │ │ └── Type.hs
│ │ ├── Report.hs
│ │ ├── Result.hs
│ │ ├── Suggest.hs
│ │ └── Warning.hs
│ └── Type/
│ ├── Constrain/
│ │ ├── Expression.hs
│ │ ├── Module.hs
│ │ └── Pattern.hs
│ ├── Error.hs
│ ├── Instantiate.hs
│ ├── Occurs.hs
│ ├── Solve.hs
│ ├── Type.hs
│ ├── Unify.hs
│ └── UnionFind.hs
├── docs/
│ ├── elm.json/
│ │ ├── application.md
│ │ └── package.md
│ └── upgrade-instructions/
│ ├── 0.16.md
│ ├── 0.17.md
│ ├── 0.18.md
│ ├── 0.19.0.md
│ ├── 0.19.1.md
│ └── earlier.md
├── elm.cabal
├── hints/
│ ├── bad-recursion.md
│ ├── comparing-custom-types.md
│ ├── comparing-records.md
│ ├── implicit-casts.md
│ ├── import-cycles.md
│ ├── imports.md
│ ├── infinite-type.md
│ ├── init.md
│ ├── missing-patterns.md
│ ├── optimize.md
│ ├── port-modules.md
│ ├── recursive-alias.md
│ ├── repl.md
│ ├── shadowing.md
│ ├── tuples.md
│ └── type-annotations.md
├── installers/
│ ├── README.md
│ ├── linux/
│ │ ├── Dockerfile
│ │ └── README.md
│ ├── mac/
│ │ ├── Distribution.xml
│ │ ├── README.md
│ │ ├── Resources/
│ │ │ └── en.lproj/
│ │ │ ├── conclusion.rtf
│ │ │ └── welcome.rtf
│ │ ├── helper-scripts/
│ │ │ ├── elm-startup.sh
│ │ │ └── uninstall.sh
│ │ ├── make-installer.sh
│ │ ├── postinstall
│ │ └── preinstall
│ ├── npm/
│ │ ├── .gitignore
│ │ ├── .npmignore
│ │ ├── PUBLISHING.md
│ │ ├── README.md
│ │ ├── bin/
│ │ │ └── elm
│ │ ├── binary.js
│ │ ├── install.js
│ │ ├── package.json
│ │ ├── packages/
│ │ │ ├── darwin_arm64/
│ │ │ │ ├── README.md
│ │ │ │ └── package.json
│ │ │ ├── darwin_x64/
│ │ │ │ ├── README.md
│ │ │ │ └── package.json
│ │ │ ├── linux_arm64/
│ │ │ │ ├── README.md
│ │ │ │ └── package.json
│ │ │ ├── linux_x64/
│ │ │ │ ├── README.md
│ │ │ │ └── package.json
│ │ │ └── win32_x64/
│ │ │ ├── README.md
│ │ │ └── package.json
│ │ └── troubleshooting.md
│ └── win/
│ ├── CreateInternetShortcut.nsh
│ ├── Nsisfile.nsi
│ ├── README.md
│ ├── make_installer.cmd
│ ├── removefrompath.vbs
│ └── updatepath.vbs
├── reactor/
│ ├── assets/
│ │ └── styles.css
│ ├── check.py
│ ├── elm.json
│ └── src/
│ ├── Deps.elm
│ ├── Errors.elm
│ ├── Index/
│ │ ├── Icon.elm
│ │ ├── Navigator.elm
│ │ └── Skeleton.elm
│ ├── Index.elm
│ ├── NotFound.elm
│ └── mock.txt
├── roadmap.md
├── terminal/
│ ├── impl/
│ │ ├── Terminal/
│ │ │ ├── Chomp.hs
│ │ │ ├── Error.hs
│ │ │ ├── Helpers.hs
│ │ │ └── Internal.hs
│ │ └── Terminal.hs
│ └── src/
│ ├── Bump.hs
│ ├── Develop/
│ │ ├── Generate/
│ │ │ ├── Help.hs
│ │ │ └── Index.hs
│ │ ├── Socket.hs
│ │ ├── StaticFiles/
│ │ │ └── Build.hs
│ │ └── StaticFiles.hs
│ ├── Develop.hs
│ ├── Diff.hs
│ ├── Init.hs
│ ├── Install.hs
│ ├── Main.hs
│ ├── Make.hs
│ ├── Publish.hs
│ └── Repl.hs
└── worker/
├── elm.cabal
├── elm.json
├── logrotate.conf
├── nginx.conf
├── outlines/
│ ├── compile/
│ │ └── elm.json
│ └── repl/
│ └── elm.json
└── src/
├── Artifacts.hs
├── Cors.hs
├── Endpoint/
│ ├── Compile.hs
│ ├── Quotes.hs
│ ├── Repl.hs
│ └── Slack.hs
├── Errors.elm
└── Main.hs
================================================
FILE CONTENTS
================================================
================================================
FILE: .github/CONTRIBUTING.md
================================================
# Contributing to Elm
Thanks helping with the development of Elm! This document describes the basic
standards for opening pull requests and making the review process as smooth as
possible.
## Expectations
- Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.
- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).
- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.
Finally, please be patient with the core team. They are trying their best with limited resources!
## Style Guide
* Haskell — conform to [these guidelines][haskell]
* JavaScript — use [Google's JS style guide][js]
[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be
[js]: https://google.github.io/styleguide/javascriptguide.xml
## Branches
[The master branch][master] is the home of the next release of the compiler
so new features and improvements get merged there. Most pull requests
should target this branch!
[master]: http://github.com/elm-lang/elm/tree/master
## Licensing
Nothing extra to do for this. The default on GitHub described [here](https://docs.github.com/en/github/site-policy/github-terms-of-service#6-contributions-under-repository-license) is that:
> Whenever you add Content to a repository containing notice of a license, you license that Content under the same terms, and you agree that you have the right to license that Content under those terms. If you have a separate agreement to license that Content under different terms, such as a contributor license agreement, that agreement will supersede.
================================================
FILE: .github/ISSUE_TEMPLATE.md
================================================
**Quick Summary:** ???
## SSCCE
```elm
```
- **Elm:** ???
- **Browser:** ???
- **Operating System:** ???
## Additional Details
???
================================================
FILE: .github/PULL_REQUEST_TEMPLATE.md
================================================
**Quick Summary:** ???
## SSCCE
```elm
```
- **Elm:** ???
- **Browser:** ???
- **Operating System:** ???
## Additional Details
???
================================================
FILE: .github/workflows/set-issue-expectations.yml
================================================
name: Set Issue Expectations
on:
issues:
types: [opened]
jobs:
comment-on-issue:
name: Comment On Issue
runs-on: ubuntu-latest
steps:
- uses: actions/github@v1.0.0
env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
with:
args: |
comment "Thanks for reporting this! To set expectations:
- Issues are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.
- Ask questions in a [community forum](https://elm-lang.org/community). You will get an answer quicker that way!
- If you experience something similar, open a new issue. [We like duplicates](https://github.com/elm/expectations/blob/master/duplicates.md).
Finally, please be patient with the core team. They are trying their best with limited resources."
================================================
FILE: .github/workflows/set-pull-expectations.yml
================================================
on:
pull_request_target:
types: [opened]
jobs:
comment-on-pull:
name: Comment On Pull
runs-on: ubuntu-latest
steps:
- uses: actions/github-script@v3
with:
github-token: ${{secrets.GITHUB_TOKEN}}
script: |
github.issues.createComment({
issue_number: context.issue.number,
owner: context.repo.owner,
repo: context.repo.repo,
body: "Thanks for suggesting these code changes. To set expectations:\n\n- Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.\n- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).\n- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.\n\nFinally, please be patient with the core team. They are trying their best with limited resources."
})
================================================
FILE: .gitignore
================================================
elm-stuff
dist
dist-newstyle
cabal-dev
.cabal-sandbox/
cabal.sandbox.config
.DS_Store
*~
travis.log
================================================
FILE: .travis.yml
================================================
language: minimal
services: docker
env:
global:
- LINUX_ARCHIVE=binary-for-linux-64-bit.gz
before_install:
- docker build -t elm -f installers/linux/Dockerfile .
- docker cp $(docker create elm):/usr/local/bin/elm .
- gzip -9 -c elm > $LINUX_ARCHIVE
deploy:
provider: releases
api_key:
secure: Yz2Lo4u9rZQ7Ee7ohAsrZpkqsYDUerCSMdSQIH8ryrf7phHhiloPEkTKsM+NupHqU/LEAVsunxbau4QrCEjA2vPavAPVk8cKomRUWK/YjbXHKa24hPkal2c+A2bnMQ6w3qYk/PjL9rW+Goq++/SNLcYZwHBV0Chl2blivMwWCSA=
file: $LINUX_ARCHIVE
skip_cleanup: true
on:
branch: master
tags: true
notifications:
email:
recipients:
- rlefevre@dmy.fr
on_success: change
on_failure: change
================================================
FILE: LICENSE
================================================
Copyright 2012-present Evan Czaplicki
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
================================================
FILE: README.md
================================================
# Elm
A delightful language for reliable webapps.
Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)
<br>
## Install
✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
<br>
## Help
If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
[slack]: http://elmlang.herokuapp.com/
================================================
FILE: builder/src/BackgroundWriter.hs
================================================
{-# LANGUAGE BangPatterns #-}
module BackgroundWriter
( Scope
, withScope
, writeBinary
)
where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import qualified Data.Binary as Binary
import Data.Foldable (traverse_)
import qualified File
-- BACKGROUND WRITER
newtype Scope =
Scope (MVar [MVar ()])
withScope :: (Scope -> IO a) -> IO a
withScope callback =
do workList <- newMVar []
result <- callback (Scope workList)
mvars <- takeMVar workList
traverse_ takeMVar mvars
return result
writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
writeBinary (Scope workList) path value =
do mvar <- newEmptyMVar
_ <- forkIO (File.writeBinary path value >> putMVar mvar ())
oldWork <- takeMVar workList
let !newWork = mvar:oldWork
putMVar workList newWork
================================================
FILE: builder/src/Build.hs
================================================
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
module Build
( fromExposed
, fromPaths
, fromRepl
, Artifacts(..)
, Root(..)
, Module(..)
, CachedInterface(..)
, ReplArtifacts(..)
, DocsGoal(..)
, getRootNames
)
where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Monad (filterM)
import qualified Data.ByteString as B
import qualified Data.Char as Char
import qualified Data.Graph as Graph
import qualified Data.List as List
import qualified Data.Map.Utils as Map
import qualified Data.Map.Strict as Map
import Data.Map.Strict ((!))
import qualified Data.Maybe as Maybe
import qualified Data.Name as Name
import qualified Data.NonEmptyList as NE
import qualified Data.OneOrMore as OneOrMore
import qualified Data.Set as Set
import qualified System.Directory as Dir
import qualified System.FilePath as FP
import System.FilePath ((</>), (<.>))
import qualified AST.Canonical as Can
import qualified AST.Source as Src
import qualified AST.Optimized as Opt
import qualified Compile
import qualified Elm.Details as Details
import qualified Elm.Docs as Docs
import qualified Elm.Interface as I
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Outline as Outline
import qualified Elm.Package as Pkg
import qualified File
import qualified Json.Encode as E
import qualified Parse.Module as Parse
import qualified Reporting
import qualified Reporting.Annotation as A
import qualified Reporting.Error as Error
import qualified Reporting.Error.Docs as EDocs
import qualified Reporting.Error.Syntax as Syntax
import qualified Reporting.Error.Import as Import
import qualified Reporting.Exit as Exit
import qualified Reporting.Render.Type.Localizer as L
import qualified Stuff
-- ENVIRONMENT
data Env =
Env
{ _key :: Reporting.BKey
, _root :: FilePath
, _project :: Parse.ProjectType
, _srcDirs :: [AbsoluteSrcDir]
, _buildID :: Details.BuildID
, _locals :: Map.Map ModuleName.Raw Details.Local
, _foreigns :: Map.Map ModuleName.Raw Details.Foreign
}
makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
case validOutline of
Details.ValidApp givenSrcDirs ->
do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
return $ Env key root Parse.Application srcDirs buildID locals foreigns
Details.ValidPkg pkg _ _ ->
do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
-- SOURCE DIRECTORY
newtype AbsoluteSrcDir =
AbsoluteSrcDir FilePath
toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
toAbsoluteSrcDir root srcDir =
AbsoluteSrcDir <$> Dir.canonicalizePath
(
case srcDir of
Outline.AbsoluteSrcDir dir -> dir
Outline.RelativeSrcDir dir -> root </> dir
)
addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
addRelative (AbsoluteSrcDir srcDir) path =
srcDir </> path
-- FORK
-- PERF try using IORef semephore on file crawl phase?
-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
--
fork :: IO a -> IO (MVar a)
fork work =
do mvar <- newEmptyMVar
_ <- forkIO $ putMVar mvar =<< work
return mvar
{-# INLINE forkWithKey #-}
forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
forkWithKey func dict =
Map.traverseWithKey (\k v -> fork (func k v)) dict
-- FROM EXPOSED
fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
fromExposed style root details docsGoal exposed@(NE.List e es) =
Reporting.trackBuild style $ \key ->
do env <- makeEnv key root details
dmvar <- Details.loadInterfaces root details
-- crawl
mvar <- newEmptyMVar
let docsNeed = toDocsNeed docsGoal
roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
putMVar mvar roots
mapM_ readMVar roots
statuses <- traverse readMVar =<< readMVar mvar
-- compile
midpoint <- checkMidpoint dmvar statuses
case midpoint of
Left problem ->
return (Left (Exit.BuildProjectProblem problem))
Right foreigns ->
do rmvar <- newEmptyMVar
resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
putMVar rmvar resultMVars
results <- traverse readMVar resultMVars
writeDetails root details results
finalizeExposed root docsGoal exposed results
-- FROM PATHS
data Artifacts =
Artifacts
{ _name :: Pkg.Name
, _deps :: Dependencies
, _roots :: NE.List Root
, _modules :: [Module]
}
data Module
= Fresh ModuleName.Raw I.Interface Opt.LocalGraph
| Cached ModuleName.Raw Bool (MVar CachedInterface)
type Dependencies =
Map.Map ModuleName.Canonical I.DependencyInterface
fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
fromPaths style root details paths =
Reporting.trackBuild style $ \key ->
do env <- makeEnv key root details
elroots <- findRoots env paths
case elroots of
Left problem ->
return (Left (Exit.BuildProjectProblem problem))
Right lroots ->
do -- crawl
dmvar <- Details.loadInterfaces root details
smvar <- newMVar Map.empty
srootMVars <- traverse (fork . crawlRoot env smvar) lroots
sroots <- traverse readMVar srootMVars
statuses <- traverse readMVar =<< readMVar smvar
midpoint <- checkMidpointAndRoots dmvar statuses sroots
case midpoint of
Left problem ->
return (Left (Exit.BuildProjectProblem problem))
Right foreigns ->
do -- compile
rmvar <- newEmptyMVar
resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
putMVar rmvar resultsMVars
rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
results <- traverse readMVar resultsMVars
writeDetails root details results
toArtifacts env foreigns results <$> traverse readMVar rrootMVars
-- GET ROOT NAMES
getRootNames :: Artifacts -> NE.List ModuleName.Raw
getRootNames (Artifacts _ _ roots _) =
fmap getRootName roots
getRootName :: Root -> ModuleName.Raw
getRootName root =
case root of
Inside name -> name
Outside name _ _ -> name
-- CRAWL
type StatusDict =
Map.Map ModuleName.Raw (MVar Status)
data Status
= SCached Details.Local
| SChanged Details.Local B.ByteString Src.Module DocsNeed
| SBadImport Import.Problem
| SBadSyntax FilePath File.Time B.ByteString Syntax.Error
| SForeign Pkg.Name
| SKernel
crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
crawlDeps env mvar deps blockedValue =
do statusDict <- takeMVar mvar
let depsDict = Map.fromKeys (\_ -> ()) deps
let newsDict = Map.difference depsDict statusDict
statuses <- Map.traverseWithKey crawlNew newsDict
putMVar mvar (Map.union statuses statusDict)
mapM_ readMVar statuses
return blockedValue
where
crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
do let fileName = ModuleName.toFilePath name <.> "elm"
paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
case paths of
[path] ->
case Map.lookup name foreigns of
Just (Details.Foreign dep deps) ->
return $ SBadImport $ Import.Ambiguous path [] dep deps
Nothing ->
do newTime <- File.getTime path
case Map.lookup name locals of
Nothing ->
crawlFile env mvar docsNeed name path newTime buildID
Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
then crawlFile env mvar docsNeed name path newTime lastChange
else crawlDeps env mvar deps (SCached local)
p1:p2:ps ->
return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
[] ->
case Map.lookup name foreigns of
Just (Details.Foreign dep deps) ->
case deps of
[] ->
return $ SForeign dep
d:ds ->
return $ SBadImport $ Import.AmbiguousForeign dep d ds
Nothing ->
if Name.isKernel name && Parse.isKernel projectType then
do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
return $ if exists then SKernel else SBadImport Import.NotFound
else
return $ SBadImport Import.NotFound
crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
do source <- File.readUtf8 (root </> path)
case Parse.fromByteString projectType source of
Left err ->
return $ SBadSyntax path time source err
Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
case maybeActualName of
Nothing ->
return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
Just name@(A.At _ actualName) ->
if expectedName == actualName then
let
deps = map Src.getImportName imports
local = Details.Local path time deps (any isMain values) lastChange buildID
in
crawlDeps env mvar deps (SChanged local source modul docsNeed)
else
return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
isMain :: A.Located Src.Value -> Bool
isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
name == Name._main
-- CHECK MODULE
type ResultDict =
Map.Map ModuleName.Raw (MVar Result)
data Result
= RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
| RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
| RCached Bool Details.BuildID (MVar CachedInterface)
| RNotFound Import.Problem
| RProblem Error.Module
| RBlocked
| RForeign I.Interface
| RKernel
data CachedInterface
= Unneeded
| Loaded I.Interface
| Corrupted
checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
case status of
SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
do results <- readMVar resultsMVar
depsStatus <- checkDeps root results deps lastCompile
case depsStatus of
DepsChange ifaces ->
do source <- File.readUtf8 path
case Parse.fromByteString projectType source of
Right modul -> compile env (DocsNeed False) local source ifaces modul
Left err ->
return $ RProblem $
Error.Module name path time source (Error.BadSyntax err)
DepsSame _ _ ->
do mvar <- newMVar Unneeded
return (RCached hasMain lastChange mvar)
DepsBlock ->
return RBlocked
DepsNotFound problems ->
do source <- File.readUtf8 path
return $ RProblem $ Error.Module name path time source $
case Parse.fromByteString projectType source of
Right (Src.Module _ _ _ imports _ _ _ _ _) ->
Error.BadImports (toImportErrors env results imports problems)
Left err ->
Error.BadSyntax err
SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
do results <- readMVar resultsMVar
depsStatus <- checkDeps root results deps lastCompile
case depsStatus of
DepsChange ifaces ->
compile env docsNeed local source ifaces modul
DepsSame same cached ->
do maybeLoaded <- loadInterfaces root same cached
case maybeLoaded of
Nothing -> return RBlocked
Just ifaces -> compile env docsNeed local source ifaces modul
DepsBlock ->
return RBlocked
DepsNotFound problems ->
return $ RProblem $ Error.Module name path time source $
Error.BadImports (toImportErrors env results imports problems)
SBadImport importProblem ->
return (RNotFound importProblem)
SBadSyntax path time source err ->
return $ RProblem $ Error.Module name path time source $
Error.BadSyntax err
SForeign home ->
case foreigns ! ModuleName.Canonical home name of
I.Public iface -> return (RForeign iface)
I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
SKernel ->
return RKernel
-- CHECK DEPS
data DepsStatus
= DepsChange (Map.Map ModuleName.Raw I.Interface)
| DepsSame [Dep] [CDep]
| DepsBlock
| DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
checkDeps root results deps lastCompile =
checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
type Dep = (ModuleName.Raw, I.Interface)
type CDep = (ModuleName.Raw, MVar CachedInterface)
checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
case deps of
dep:otherDeps ->
do result <- readMVar (results ! dep)
case result of
RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
RCached _ lastChange mvar ->
checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
RNotFound prob ->
checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
RProblem _ ->
checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
RBlocked ->
checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
RForeign iface ->
checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
RKernel ->
checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
[] ->
case reverse importProblems of
p:ps ->
return $ DepsNotFound (NE.List p ps)
[] ->
if isBlocked then
return $ DepsBlock
else if null new && lastDepChange <= lastCompile then
return $ DepsSame same cached
else
do maybeLoaded <- loadInterfaces root same cached
case maybeLoaded of
Nothing -> return DepsBlock
Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
-- TO IMPORT ERROR
toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
let
knownModules =
Set.unions
[ Map.keysSet foreigns
, Map.keysSet locals
, Map.keysSet results
]
unimportedModules =
Set.difference knownModules (Set.fromList (map Src.getImportName imports))
regionDict =
Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
toError (name, problem) =
Import.Error (regionDict ! name) name unimportedModules problem
in
fmap toError problems
-- LOAD CACHED INTERFACES
loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
loadInterfaces root same cached =
do loading <- traverse (fork . loadInterface root) cached
maybeLoaded <- traverse readMVar loading
case sequence maybeLoaded of
Nothing ->
return Nothing
Just loaded ->
return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
loadInterface root (name, ciMvar) =
do cachedInterface <- takeMVar ciMvar
case cachedInterface of
Corrupted ->
do putMVar ciMvar cachedInterface
return Nothing
Loaded iface ->
do putMVar ciMvar cachedInterface
return (Just (name, iface))
Unneeded ->
do maybeIface <- File.readBinary (Stuff.elmi root name)
case maybeIface of
Nothing ->
do putMVar ciMvar Corrupted
return Nothing
Just iface ->
do putMVar ciMvar (Loaded iface)
return (Just (name, iface))
-- CHECK PROJECT
checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
checkMidpoint dmvar statuses =
case checkForCycles statuses of
Nothing ->
do maybeForeigns <- readMVar dmvar
case maybeForeigns of
Nothing -> return (Left Exit.BP_CannotLoadDependencies)
Just fs -> return (Right fs)
Just (NE.List name names) ->
do _ <- readMVar dmvar
return (Left (Exit.BP_Cycle name names))
checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
checkMidpointAndRoots dmvar statuses sroots =
case checkForCycles statuses of
Nothing ->
case checkUniqueRoots statuses sroots of
Nothing ->
do maybeForeigns <- readMVar dmvar
case maybeForeigns of
Nothing -> return (Left Exit.BP_CannotLoadDependencies)
Just fs -> return (Right fs)
Just problem ->
do _ <- readMVar dmvar
return (Left problem)
Just (NE.List name names) ->
do _ <- readMVar dmvar
return (Left (Exit.BP_Cycle name names))
-- CHECK FOR CYCLES
checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
checkForCycles modules =
let
!graph = Map.foldrWithKey addToGraph [] modules
!sccs = Graph.stronglyConnComp graph
in
checkForCyclesHelp sccs
checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
checkForCyclesHelp sccs =
case sccs of
[] ->
Nothing
scc:otherSccs ->
case scc of
Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
type Node =
( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
addToGraph name status graph =
let
dependencies =
case status of
SCached (Details.Local _ _ deps _ _ _) -> deps
SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
SBadImport _ -> []
SBadSyntax _ _ _ _ -> []
SForeign _ -> []
SKernel -> []
in
(name, name, dependencies) : graph
-- CHECK UNIQUE ROOTS
checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
checkUniqueRoots insides sroots =
let
outsidesDict =
Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
in
case Map.traverseWithKey checkOutside outsidesDict of
Left problem ->
Just problem
Right outsides ->
case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
Right () -> Nothing
Left problem -> Just problem
rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
rootStatusToNamePathPair sroot =
case sroot of
SInside _ -> Nothing
SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
SOutsideErr _ -> Nothing
checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
checkOutside name paths =
case OneOrMore.destruct NE.List paths of
NE.List p [] -> Right p
NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
checkInside name p1 status =
case status of
SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
SBadImport _ -> Right ()
SBadSyntax _ _ _ _ -> Right ()
SForeign _ -> Right ()
SKernel -> Right ()
-- COMPILE MODULE
compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
let
pkg = projectTypeToPkg projectType
in
case Compile.compile pkg ifaces modul of
Right (Compile.Artifacts canonical annotations objects) ->
case makeDocs docsNeed canonical of
Left err ->
return $ RProblem $
Error.Module (Src.getName modul) path time source (Error.BadDocs err)
Right docs ->
do let name = Src.getName modul
let iface = I.fromModule pkg canonical annotations
let elmi = Stuff.elmi root name
File.writeBinary (Stuff.elmo root name) objects
maybeOldi <- File.readBinary elmi
case maybeOldi of
Just oldi | oldi == iface ->
do -- iface should be fully forced by equality check
Reporting.report key Reporting.BDone
let local = Details.Local path time deps main lastChange buildID
return (RSame local iface objects docs)
_ ->
do -- iface may be lazy still
File.writeBinary elmi iface
Reporting.report key Reporting.BDone
let local = Details.Local path time deps main buildID buildID
return (RNew local iface objects docs)
Left err ->
return $ RProblem $
Error.Module (Src.getName modul) path time source err
projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
projectTypeToPkg projectType =
case projectType of
Parse.Package pkg -> pkg
Parse.Application -> Pkg.dummyName
-- WRITE DETAILS
writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
File.writeBinary (Stuff.details root) $
Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
addNewLocal name result locals =
case result of
RNew local _ _ _ -> Map.insert name local locals
RSame local _ _ _ -> Map.insert name local locals
RCached _ _ _ -> locals
RNotFound _ -> locals
RProblem _ -> locals
RBlocked -> locals
RForeign _ -> locals
RKernel -> locals
-- FINALIZE EXPOSED
finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
finalizeExposed root docsGoal exposed results =
case foldr (addImportProblems results) [] (NE.toList exposed) of
p:ps ->
return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
[] ->
case Map.foldr addErrors [] results of
[] -> Right <$> finalizeDocs docsGoal results
e:es -> return $ Left $ Exit.BuildBadModules root e es
addErrors :: Result -> [Error.Module] -> [Error.Module]
addErrors result errors =
case result of
RNew _ _ _ _ -> errors
RSame _ _ _ _ -> errors
RCached _ _ _ -> errors
RNotFound _ -> errors
RProblem e -> e:errors
RBlocked -> errors
RForeign _ -> errors
RKernel -> errors
addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
addImportProblems results name problems =
case results ! name of
RNew _ _ _ _ -> problems
RSame _ _ _ _ -> problems
RCached _ _ _ -> problems
RNotFound p -> (name, p) : problems
RProblem _ -> problems
RBlocked -> problems
RForeign _ -> problems
RKernel -> problems
-- DOCS
data DocsGoal a where
KeepDocs :: DocsGoal Docs.Documentation
WriteDocs :: FilePath -> DocsGoal ()
IgnoreDocs :: DocsGoal ()
newtype DocsNeed =
DocsNeed { needsDocs :: Bool }
toDocsNeed :: DocsGoal a -> DocsNeed
toDocsNeed goal =
case goal of
IgnoreDocs -> DocsNeed False
WriteDocs _ -> DocsNeed True
KeepDocs -> DocsNeed True
makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
makeDocs (DocsNeed isNeeded) modul =
if isNeeded then
case Docs.fromModule modul of
Right docs -> Right (Just docs)
Left err -> Left err
else
Right Nothing
finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
finalizeDocs goal results =
case goal of
KeepDocs ->
return $ Map.mapMaybe toDocs results
WriteDocs path ->
E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
IgnoreDocs ->
return ()
toDocs :: Result -> Maybe Docs.Module
toDocs result =
case result of
RNew _ _ _ d -> d
RSame _ _ _ d -> d
RCached _ _ _ -> Nothing
RNotFound _ -> Nothing
RProblem _ -> Nothing
RBlocked -> Nothing
RForeign _ -> Nothing
RKernel -> Nothing
--------------------------------------------------------------------------------
------ NOW FOR SOME REPL STUFF -------------------------------------------------
--------------------------------------------------------------------------------
-- FROM REPL
data ReplArtifacts =
ReplArtifacts
{ _repl_home :: ModuleName.Canonical
, _repl_modules :: [Module]
, _repl_localizer :: L.Localizer
, _repl_annotations :: Map.Map Name.Name Can.Annotation
}
fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
fromRepl root details source =
do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
case Parse.fromByteString projectType source of
Left syntaxError ->
return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
do dmvar <- Details.loadInterfaces root details
let deps = map Src.getImportName imports
mvar <- newMVar Map.empty
crawlDeps env mvar deps ()
statuses <- traverse readMVar =<< readMVar mvar
midpoint <- checkMidpoint dmvar statuses
case midpoint of
Left problem ->
return $ Left $ Exit.ReplProjectProblem problem
Right foreigns ->
do rmvar <- newEmptyMVar
resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
putMVar rmvar resultMVars
results <- traverse readMVar resultMVars
writeDetails root details results
depsStatus <- checkDeps root resultMVars deps 0
finalizeReplArtifacts env source modul depsStatus resultMVars results
finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
let
pkg =
projectTypeToPkg projectType
compileInput ifaces =
case Compile.compile pkg ifaces modul of
Right (Compile.Artifacts canonical annotations objects) ->
let
h = Can._name canonical
m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
ms = Map.foldrWithKey addInside [] results
in
return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
Left errors ->
return $ Left $ Exit.ReplBadInput source errors
in
case depsStatus of
DepsChange ifaces ->
compileInput ifaces
DepsSame same cached ->
do maybeLoaded <- loadInterfaces root same cached
case maybeLoaded of
Just ifaces -> compileInput ifaces
Nothing -> return $ Left $ Exit.ReplBadCache
DepsBlock ->
case Map.foldr addErrors [] results of
[] -> return $ Left $ Exit.ReplBlocked
e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es
DepsNotFound problems ->
return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
toImportErrors env resultMVars imports problems
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- FIND ROOT
data RootLocation
= LInside ModuleName.Raw
| LOutside FilePath
findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
findRoots env paths =
do mvars <- traverse (fork . getRootInfo env) paths
einfos <- traverse readMVar mvars
return $ checkRoots =<< sequence einfos
checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
checkRoots infos =
let
toOneOrMore loc@(RootInfo absolute _ _) =
(absolute, OneOrMore.one loc)
fromOneOrMore loc locs =
case locs of
[] -> Right ()
loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
in
fmap (\_ -> fmap _location infos) $
traverse (OneOrMore.destruct fromOneOrMore) $
Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
-- ROOT INFO
data RootInfo =
RootInfo
{ _absolute :: FilePath
, _relative :: FilePath
, _location :: RootLocation
}
getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
getRootInfo env path =
do exists <- File.exists path
if exists
then getRootInfoHelp env path =<< Dir.canonicalizePath path
else return (Left (Exit.BP_PathUnknown path))
getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
let
(dirs, file) = FP.splitFileName absolutePath
(final, ext) = FP.splitExtension file
in
if ext /= ".elm"
then
return $ Left $ Exit.BP_WithBadExtension path
else
let
absoluteSegments = FP.splitDirectories dirs ++ [final]
in
case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
[] ->
return $ Right $ RootInfo absolutePath path (LOutside path)
[(_, Right names)] ->
do let name = Name.fromChars (List.intercalate "." names)
matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
case matchingDirs of
d1:d2:_ ->
do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
let p2 = addRelative d2 (FP.joinPath names <.> "elm")
return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
_ ->
return $ Right $ RootInfo absolutePath path (LInside name)
[(s, Left names)] ->
return $ Left $ Exit.BP_RootNameInvalid path s names
(s1,_):(s2,_):_ ->
return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
isInsideSrcDirByName names srcDir =
File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
case dropPrefix (FP.splitDirectories srcDir) segments of
Nothing ->
Nothing
Just names ->
if all isGoodName names
then Just (srcDir, Right names)
else Just (srcDir, Left names)
isGoodName :: [Char] -> Bool
isGoodName name =
case name of
[] ->
False
char:chars ->
Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
-- INVARIANT: Dir.canonicalizePath has been run on both inputs
--
dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
dropPrefix roots paths =
case roots of
[] ->
Just paths
r:rs ->
case paths of
[] -> Nothing
p:ps -> if r == p then dropPrefix rs ps else Nothing
-- CRAWL ROOTS
data RootStatus
= SInside ModuleName.Raw
| SOutsideOk Details.Local B.ByteString Src.Module
| SOutsideErr Error.Module
crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
case root of
LInside name ->
do statusMVar <- newEmptyMVar
statusDict <- takeMVar mvar
putMVar mvar (Map.insert name statusMVar statusDict)
putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
return (SInside name)
LOutside path ->
do time <- File.getTime path
source <- File.readUtf8 path
case Parse.fromByteString projectType source of
Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
do let deps = map Src.getImportName imports
let local = Details.Local path time deps (any isMain values) buildID buildID
crawlDeps env mvar deps (SOutsideOk local source modul)
Left syntaxError ->
return $ SOutsideErr $
Error.Module "???" path time source (Error.BadSyntax syntaxError)
-- CHECK ROOTS
data RootResult
= RInside ModuleName.Raw
| ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
| ROutsideErr Error.Module
| ROutsideBlocked
checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
case rootStatus of
SInside name ->
return (RInside name)
SOutsideErr err ->
return (ROutsideErr err)
SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
do depsStatus <- checkDeps root results deps lastCompile
case depsStatus of
DepsChange ifaces ->
compileOutside env local source ifaces modul
DepsSame same cached ->
do maybeLoaded <- loadInterfaces root same cached
case maybeLoaded of
Nothing -> return ROutsideBlocked
Just ifaces -> compileOutside env local source ifaces modul
DepsBlock ->
return ROutsideBlocked
DepsNotFound problems ->
return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
Error.BadImports (toImportErrors env results imports problems)
compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
let
pkg = projectTypeToPkg projectType
name = Src.getName modul
in
case Compile.compile pkg ifaces modul of
Right (Compile.Artifacts canonical annotations objects) ->
do Reporting.report key Reporting.BDone
return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
Left errors ->
return $ ROutsideErr $ Error.Module name path time source errors
-- TO ARTIFACTS
data Root
= Inside ModuleName.Raw
| Outside ModuleName.Raw I.Interface Opt.LocalGraph
toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
case gatherProblemsOrMains results rootResults of
Left (NE.List e es) ->
Left (Exit.BuildBadModules root e es)
Right roots ->
Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
gatherProblemsOrMains results (NE.List rootResult rootResults) =
let
addResult result (es, roots) =
case result of
RInside n -> ( es, Inside n : roots)
ROutsideOk n i o -> ( es, Outside n i o : roots)
ROutsideErr e -> (e:es, roots)
ROutsideBlocked -> ( es, roots)
errors = Map.foldr addErrors [] results
in
case (rootResult, foldr addResult (errors, []) rootResults) of
(RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
(RInside _ , (e:es, _ )) -> Left (NE.List e es)
(ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
(ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
(ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
(ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
(ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
addInside name result modules =
case result of
RNew _ iface objs _ -> Fresh name iface objs : modules
RSame _ iface objs _ -> Fresh name iface objs : modules
RCached main _ mvar -> Cached name main mvar : modules
RNotFound _ -> error (badInside name)
RProblem _ -> error (badInside name)
RBlocked -> error (badInside name)
RForeign _ -> modules
RKernel -> modules
badInside :: ModuleName.Raw -> [Char]
badInside name =
"Error from `" ++ Name.toChars name ++ "` should have been reported already."
addOutside :: RootResult -> [Module] -> [Module]
addOutside root modules =
case root of
RInside _ -> modules
ROutsideOk name iface objs -> Fresh name iface objs : modules
ROutsideErr _ -> modules
ROutsideBlocked -> modules
================================================
FILE: builder/src/Deps/Bump.hs
================================================
module Deps.Bump
( getPossibilities
)
where
import qualified Data.List as List
import qualified Deps.Registry as Registry
import qualified Elm.Magnitude as M
import qualified Elm.Version as V
-- GET POSSIBILITIES
getPossibilities :: Registry.KnownVersions -> [(V.Version, V.Version, M.Magnitude)]
getPossibilities (Registry.KnownVersions latest previous) =
let
allVersions = reverse (latest:previous)
minorPoints = map last (List.groupBy sameMajor allVersions)
patchPoints = map last (List.groupBy sameMinor allVersions)
in
(latest, V.bumpMajor latest, M.MAJOR)
: map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
sameMajor :: V.Version -> V.Version -> Bool
sameMajor (V.Version major1 _ _) (V.Version major2 _ _) =
major1 == major2
sameMinor :: V.Version -> V.Version -> Bool
sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) =
major1 == major2 && minor1 == minor2
================================================
FILE: builder/src/Deps/Diff.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Deps.Diff
( diff
, PackageChanges(..)
, ModuleChanges(..)
, Changes(..)
, moduleChangeMagnitude
, toMagnitude
, bump
, getDocs
)
where
import Control.Monad (zipWithM)
import Data.Function (on)
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.Set as Set
import qualified System.Directory as Dir
import System.FilePath ((</>))
import qualified Deps.Website as Website
import qualified Elm.Compiler.Type as Type
import qualified Elm.Docs as Docs
import qualified Elm.Magnitude as M
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified File
import qualified Http
import qualified Json.Decode as D
import qualified Reporting.Exit as Exit
import qualified Stuff
-- CHANGES
data PackageChanges =
PackageChanges
{ _modules_added :: [ModuleName.Raw]
, _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
, _modules_removed :: [ModuleName.Raw]
}
data ModuleChanges =
ModuleChanges
{ _unions :: Changes Name.Name Docs.Union
, _aliases :: Changes Name.Name Docs.Alias
, _values :: Changes Name.Name Docs.Value
, _binops :: Changes Name.Name Docs.Binop
}
data Changes k v =
Changes
{ _added :: Map.Map k v
, _changed :: Map.Map k (v,v)
, _removed :: Map.Map k v
}
getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
getChanges isEquivalent old new =
let
overlap = Map.intersectionWith (,) old new
changed = Map.filter (not . uncurry isEquivalent) overlap
in
Changes (Map.difference new old) changed (Map.difference old new)
-- DIFF
diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
diff oldDocs newDocs =
let
filterOutPatches chngs =
Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs
(Changes added changed removed) =
getChanges (\_ _ -> False) oldDocs newDocs
in
PackageChanges
(Map.keys added)
(filterOutPatches (Map.map diffModule changed))
(Map.keys removed)
diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges
diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) =
ModuleChanges
(getChanges isEquivalentUnion u1 u2)
(getChanges isEquivalentAlias a1 a2)
(getChanges isEquivalentValue v1 v2)
(getChanges isEquivalentBinop b1 b2)
-- EQUIVALENCE
isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool
isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) =
length oldCtors == length newCtors
&& and (zipWith (==) (map fst oldCtors) (map fst newCtors))
&& and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors)))
where
equiv :: [Type.Type] -> [Type.Type] -> Bool
equiv oldTypes newTypes =
let
allEquivalent =
zipWith
isEquivalentAlias
(map (Docs.Alias oldComment oldVars) oldTypes)
(map (Docs.Alias newComment newVars) newTypes)
in
length oldTypes == length newTypes
&& and allEquivalent
isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool
isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) =
case diffType oldType newType of
Nothing ->
False
Just renamings ->
length oldVars == length newVars
&& isEquivalentRenaming (zip oldVars newVars ++ renamings)
isEquivalentValue :: Docs.Value -> Docs.Value -> Bool
isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) =
isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool
isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
&& a1 == a2
&& p1 == p2
-- DIFF TYPES
diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]
diffType oldType newType =
case (oldType, newType) of
(Type.Var oldName, Type.Var newName) ->
Just [(oldName, newName)]
(Type.Lambda a b, Type.Lambda a' b') ->
(++)
<$> diffType a a'
<*> diffType b b'
(Type.Type oldName oldArgs, Type.Type newName newArgs) ->
if not (isSameName oldName newName) || length oldArgs /= length newArgs then
Nothing
else
concat <$> zipWithM diffType oldArgs newArgs
(Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
case (maybeExt, maybeExt') of
(Nothing, Just _) ->
Nothing
(Just _, Nothing) ->
Nothing
(Nothing, Nothing) ->
diffFields fields fields'
(Just oldExt, Just newExt) ->
(:) (oldExt, newExt) <$> diffFields fields fields'
(Type.Unit, Type.Unit) ->
Just []
(Type.Tuple a b cs, Type.Tuple x y zs) ->
if length cs /= length zs then
Nothing
else
do aVars <- diffType a x
bVars <- diffType b y
cVars <- concat <$> zipWithM diffType cs zs
return (aVars ++ bVars ++ cVars)
(_, _) ->
Nothing
-- handle very old docs that do not use qualified names
isSameName :: Name.Name -> Name.Name -> Bool
isSameName oldFullName newFullName =
let
dedot name =
reverse (Name.splitDots name)
in
case ( dedot oldFullName, dedot newFullName ) of
(oldName:[], newName:_) ->
oldName == newName
(oldName:_, newName:[]) ->
oldName == newName
_ ->
oldFullName == newFullName
diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]
diffFields oldRawFields newRawFields =
let
sort = List.sortBy (compare `on` fst)
oldFields = sort oldRawFields
newFields = sort newRawFields
in
if length oldRawFields /= length newRawFields then
Nothing
else if or (zipWith ((/=) `on` fst) oldFields newFields) then
Nothing
else
concat <$> zipWithM (diffType `on` snd) oldFields newFields
-- TYPE VARIABLES
isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
isEquivalentRenaming varPairs =
let
renamings =
Map.toList (foldr insert Map.empty varPairs)
insert (old,new) dict =
Map.insertWith (++) old [new] dict
verify (old, news) =
case news of
[] ->
Nothing
new : rest ->
if all (new ==) rest then
Just (old, new)
else
Nothing
allUnique list =
length list == Set.size (Set.fromList list)
in
case mapM verify renamings of
Nothing ->
False
Just verifiedRenamings ->
all compatibleVars verifiedRenamings
&&
allUnique (map snd verifiedRenamings)
compatibleVars :: (Name.Name, Name.Name) -> Bool
compatibleVars (old, new) =
case (categorizeVar old, categorizeVar new) of
(CompAppend, CompAppend) -> True
(Comparable, Comparable) -> True
(Appendable, Appendable) -> True
(Number , Number ) -> True
(Number , Comparable) -> True
(_, Var) -> True
(_, _) -> False
data TypeVarCategory
= CompAppend
| Comparable
| Appendable
| Number
| Var
categorizeVar :: Name.Name -> TypeVarCategory
categorizeVar name
| Name.isCompappendType name = CompAppend
| Name.isComparableType name = Comparable
| Name.isAppendableType name = Appendable
| Name.isNumberType name = Number
| otherwise = Var
-- MAGNITUDE
bump :: PackageChanges -> V.Version -> V.Version
bump changes version =
case toMagnitude changes of
M.PATCH ->
V.bumpPatch version
M.MINOR ->
V.bumpMinor version
M.MAJOR ->
V.bumpMajor version
toMagnitude :: PackageChanges -> M.Magnitude
toMagnitude (PackageChanges added changed removed) =
let
addMag = if null added then M.PATCH else M.MINOR
removeMag = if null removed then M.PATCH else M.MAJOR
changeMags = map moduleChangeMagnitude (Map.elems changed)
in
maximum (addMag : removeMag : changeMags)
moduleChangeMagnitude :: ModuleChanges -> M.Magnitude
moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
maximum
[ changeMagnitude unions
, changeMagnitude aliases
, changeMagnitude values
, changeMagnitude binops
]
changeMagnitude :: Changes k v -> M.Magnitude
changeMagnitude (Changes added changed removed) =
if Map.size removed > 0 || Map.size changed > 0 then
M.MAJOR
else if Map.size added > 0 then
M.MINOR
else
M.PATCH
-- GET DOCS
getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
getDocs cache manager name version =
do let home = Stuff.package cache name version
let path = home </> "docs.json"
exists <- File.exists path
if exists
then
do bytes <- File.readUtf8 path
case D.fromByteString Docs.decoder bytes of
Right docs ->
return $ Right docs
Left _ ->
do File.remove path
return $ Left Exit.DP_Cache
else
do let url = Website.metadata name version "docs.json"
Http.get manager url [] Exit.DP_Http $ \body ->
case D.fromByteString Docs.decoder body of
Right docs ->
do Dir.createDirectoryIfMissing True home
File.writeUtf8 path body
return $ Right docs
Left _ ->
return $ Left $ Exit.DP_Data url body
================================================
FILE: builder/src/Deps/Registry.hs
================================================
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
module Deps.Registry
( Registry(..)
, KnownVersions(..)
, read
, fetch
, update
, latest
, getVersions
, getVersions'
)
where
import Prelude hiding (read)
import Control.Monad (liftM2)
import Data.Binary (Binary, get, put)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Deps.Website as Website
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified File
import qualified Http
import qualified Json.Decode as D
import qualified Parse.Primitives as P
import qualified Reporting.Exit as Exit
import qualified Stuff
-- REGISTRY
data Registry =
Registry
{ _count :: !Int
, _versions :: !(Map.Map Pkg.Name KnownVersions)
}
data KnownVersions =
KnownVersions
{ _newest :: V.Version
, _previous :: ![V.Version]
}
-- READ
read :: Stuff.PackageCache -> IO (Maybe Registry)
read cache =
File.readBinary (Stuff.registry cache)
-- FETCH
fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
fetch manager cache =
post manager "/all-packages" allPkgsDecoder $
\versions ->
do let size = Map.foldr' addEntry 0 versions
let registry = Registry size versions
let path = Stuff.registry cache
File.writeBinary path registry
return registry
addEntry :: KnownVersions -> Int -> Int
addEntry (KnownVersions _ vs) count =
count + 1 + length vs
allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
allPkgsDecoder =
let
keyDecoder =
Pkg.keyDecoder bail
versionsDecoder =
D.list (D.mapError (\_ -> ()) V.decoder)
toKnownVersions versions =
case List.sortBy (flip compare) versions of
v:vs -> return (KnownVersions v vs)
[] -> D.failure ()
in
D.dict keyDecoder (toKnownVersions =<< versionsDecoder)
-- UPDATE
update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry)
update manager cache oldRegistry@(Registry size packages) =
post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
\news ->
case news of
[] ->
return oldRegistry
_:_ ->
let
newSize = size + length news
newPkgs = foldr addNew packages news
newRegistry = Registry newSize newPkgs
in
do File.writeBinary (Stuff.registry cache) newRegistry
return newRegistry
addNew :: (Pkg.Name, V.Version) -> Map.Map Pkg.Name KnownVersions -> Map.Map Pkg.Name KnownVersions
addNew (name, version) versions =
let
add maybeKnowns =
case maybeKnowns of
Just (KnownVersions v vs) ->
KnownVersions version (v:vs)
Nothing ->
KnownVersions version []
in
Map.alter (Just . add) name versions
-- NEW PACKAGE DECODER
newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
newPkgDecoder =
D.customString newPkgParser bail
newPkgParser :: P.Parser () (Pkg.Name, V.Version)
newPkgParser =
do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser
P.word1 0x40 {-@-} bail
vsn <- P.specialize (\_ _ _ -> ()) V.parser
return (pkg, vsn)
bail :: row -> col -> ()
bail _ _ =
()
-- LATEST
latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
latest manager cache =
do maybeOldRegistry <- read cache
case maybeOldRegistry of
Just oldRegistry ->
update manager cache oldRegistry
Nothing ->
fetch manager cache
-- GET VERSIONS
getVersions :: Pkg.Name -> Registry -> Maybe KnownVersions
getVersions name (Registry _ versions) =
Map.lookup name versions
getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
getVersions' name (Registry _ versions) =
case Map.lookup name versions of
Just kvs -> Right kvs
Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
-- POST
post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
post manager path decoder callback =
let
url = Website.route path []
in
Http.post manager url [] Exit.RP_Http $
\body ->
case D.fromByteString decoder body of
Right a -> Right <$> callback a
Left _ -> return $ Left $ Exit.RP_Data url body
-- BINARY
instance Binary Registry where
get = liftM2 Registry get get
put (Registry a b) = put a >> put b
instance Binary KnownVersions where
get = liftM2 KnownVersions get get
put (KnownVersions a b) = put a >> put b
================================================
FILE: builder/src/Deps/Solver.hs
================================================
{-# LANGUAGE OverloadedStrings, Rank2Types #-}
module Deps.Solver
( Solver
, Result(..)
, Connection(..)
--
, Details(..)
, verify
--
, AppSolution(..)
, addToApp
--
, Env(..)
, initEnv
)
where
import Control.Monad (foldM)
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
import qualified Data.Map as Map
import Data.Map ((!))
import qualified System.Directory as Dir
import System.FilePath ((</>))
import qualified Deps.Registry as Registry
import qualified Deps.Website as Website
import qualified Elm.Constraint as C
import qualified Elm.Package as Pkg
import qualified Elm.Outline as Outline
import qualified Elm.Version as V
import qualified File
import qualified Http
import qualified Json.Decode as D
import qualified Reporting.Exit as Exit
import qualified Stuff
-- SOLVER
newtype Solver a =
Solver
(
forall b.
State
-> (State -> a -> (State -> IO b) -> IO b)
-> (State -> IO b)
-> (Exit.Solver -> IO b)
-> IO b
)
data State =
State
{ _cache :: Stuff.PackageCache
, _connection :: Connection
, _registry :: Registry.Registry
, _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
}
data Constraints =
Constraints
{ _elm :: C.Constraint
, _deps :: Map.Map Pkg.Name C.Constraint
}
data Connection
= Online Http.Manager
| Offline
-- RESULT
data Result a
= Ok a
| NoSolution
| NoOfflineSolution
| Err Exit.Solver
-- VERIFY -- used by Elm.Details
data Details =
Details V.Version (Map.Map Pkg.Name C.Constraint)
verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
verify cache connection registry constraints =
Stuff.withRegistryLock cache $
case try constraints of
Solver solver ->
solver (State cache connection registry Map.empty)
(\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
(\_ -> return $ noSolution connection)
(\e -> return $ Err e)
addDeps :: State -> Pkg.Name -> V.Version -> Details
addDeps (State _ _ _ constraints) name vsn =
case Map.lookup (name, vsn) constraints of
Just (Constraints _ deps) -> Details vsn deps
Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
noSolution :: Connection -> Result a
noSolution connection =
case connection of
Online _ -> NoSolution
Offline -> NoOfflineSolution
-- ADD TO APP - used in Install
data AppSolution =
AppSolution
{ _old :: Map.Map Pkg.Name V.Version
, _new :: Map.Map Pkg.Name V.Version
, _app :: Outline.AppOutline
}
addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
Stuff.withRegistryLock cache $
let
allIndirects = Map.union indirect testIndirect
allDirects = Map.union direct testDirect
allDeps = Map.union allDirects allIndirects
attempt toConstraint deps =
try (Map.insert pkg C.anything (Map.map toConstraint deps))
in
case
oneOf
( attempt C.exactly allDeps )
[ attempt C.exactly allDirects
, attempt C.untilNextMinor allDirects
, attempt C.untilNextMajor allDirects
, attempt (\_ -> C.anything) allDirects
]
of
Solver solver ->
solver (State cache connection registry Map.empty)
(\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
(\_ -> return $ noSolution connection)
(\e -> return $ Err e)
toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new =
let
d = Map.intersection new (Map.insert pkg V.one direct)
i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
td = Map.intersection new (Map.delete pkg testDirect)
ti = Map.difference new (Map.unions [d,i,td])
in
AppSolution old new (Outline.AppOutline elm srcDirs d i td ti)
getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
getTransitive constraints solution unvisited visited =
case unvisited of
[] ->
visited
info@(pkg,vsn) : infos ->
if Map.member pkg visited
then getTransitive constraints solution infos visited
else
let
newDeps = _deps (constraints ! info)
newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))
newVisited = Map.insert pkg vsn visited
in
getTransitive constraints solution infos $
getTransitive constraints solution newUnvisited newVisited
-- TRY
try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
try constraints =
exploreGoals (Goals constraints Map.empty)
-- EXPLORE GOALS
data Goals =
Goals
{ _pending :: Map.Map Pkg.Name C.Constraint
, _solved :: Map.Map Pkg.Name V.Version
}
exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version)
exploreGoals (Goals pending solved) =
case Map.minViewWithKey pending of
Nothing ->
return solved
Just ((name, constraint), otherPending) ->
do let goals1 = Goals otherPending solved
let addVsn = addVersion goals1 name
(v,vs) <- getRelevantVersions name constraint
goals2 <- oneOf (addVsn v) (map addVsn vs)
exploreGoals goals2
addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals
addVersion (Goals pending solved) name version =
do (Constraints elm deps) <- getConstraints name version
if C.goodElm elm
then
do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
return (Goals newPending (Map.insert name version solved))
else
backtrack
addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
addConstraint solved unsolved (name, newConstraint) =
case Map.lookup name solved of
Just version ->
if C.satisfies newConstraint version
then return unsolved
else backtrack
Nothing ->
case Map.lookup name unsolved of
Nothing ->
return $ Map.insert name newConstraint unsolved
Just oldConstraint ->
case C.intersect oldConstraint newConstraint of
Nothing ->
backtrack
Just mergedConstraint ->
if oldConstraint == mergedConstraint
then return unsolved
else return (Map.insert name mergedConstraint unsolved)
-- GET RELEVANT VERSIONS
getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
getRelevantVersions name constraint =
Solver $ \state@(State _ _ registry _) ok back _ ->
case Registry.getVersions name registry of
Just (Registry.KnownVersions newest previous) ->
case filter (C.satisfies constraint) (newest:previous) of
[] -> back state
v:vs -> ok state (v,vs) back
Nothing ->
back state
-- GET CONSTRAINTS
getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
getConstraints pkg vsn =
Solver $ \state@(State cache connection registry cDict) ok back err ->
do let key = (pkg, vsn)
case Map.lookup key cDict of
Just cs ->
ok state cs back
Nothing ->
do let toNewState cs = State cache connection registry (Map.insert key cs cDict)
let home = Stuff.package cache pkg vsn
let path = home </> "elm.json"
outlineExists <- File.exists path
if outlineExists
then
do bytes <- File.readUtf8 path
case D.fromByteString constraintsDecoder bytes of
Right cs ->
case connection of
Online _ ->
ok (toNewState cs) cs back
Offline ->
do srcExists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
if srcExists
then ok (toNewState cs) cs back
else back state
Left _ ->
do File.remove path
err (Exit.SolverBadCacheData pkg vsn)
else
case connection of
Offline ->
back state
Online manager ->
do let url = Website.metadata pkg vsn "elm.json"
result <- Http.get manager url [] id (return . Right)
case result of
Left httpProblem ->
err (Exit.SolverBadHttp pkg vsn httpProblem)
Right body ->
case D.fromByteString constraintsDecoder body of
Right cs ->
do Dir.createDirectoryIfMissing True home
File.writeUtf8 path body
ok (toNewState cs) cs back
Left _ ->
err (Exit.SolverBadHttpData pkg vsn url)
constraintsDecoder :: D.Decoder () Constraints
constraintsDecoder =
do outline <- D.mapError (const ()) Outline.decoder
case outline of
Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ elmConstraint) ->
return (Constraints elmConstraint deps)
Outline.App _ ->
D.failure ()
-- ENVIRONMENT
data Env =
Env Stuff.PackageCache Http.Manager Connection Registry.Registry
initEnv :: IO (Either Exit.RegistryProblem Env)
initEnv =
do mvar <- newEmptyMVar
_ <- forkIO $ putMVar mvar =<< Http.getManager
cache <- Stuff.getPackageCache
Stuff.withRegistryLock cache $
do maybeRegistry <- Registry.read cache
manager <- readMVar mvar
case maybeRegistry of
Nothing ->
do eitherRegistry <- Registry.fetch manager cache
case eitherRegistry of
Right latestRegistry ->
return $ Right $ Env cache manager (Online manager) latestRegistry
Left problem ->
return $ Left $ problem
Just cachedRegistry ->
do eitherRegistry <- Registry.update manager cache cachedRegistry
case eitherRegistry of
Right latestRegistry ->
return $ Right $ Env cache manager (Online manager) latestRegistry
Left _ ->
return $ Right $ Env cache manager Offline cachedRegistry
-- INSTANCES
instance Functor Solver where
fmap func (Solver solver) =
Solver $ \state ok back err ->
let
okA stateA arg backA = ok stateA (func arg) backA
in
solver state okA back err
instance Applicative Solver where
pure a =
Solver $ \state ok back _ -> ok state a back
(<*>) (Solver solverFunc) (Solver solverArg) =
Solver $ \state ok back err ->
let
okF stateF func backF =
let
okA stateA arg backA = ok stateA (func arg) backA
in
solverArg stateF okA backF err
in
solverFunc state okF back err
instance Monad Solver where
(>>=) (Solver solverA) callback =
Solver $ \state ok back err ->
let
okA stateA a backA =
case callback a of
Solver solverB -> solverB stateA ok backA err
in
solverA state okA back err
oneOf :: Solver a -> [Solver a] -> Solver a
oneOf solver@(Solver solverHead) solvers =
case solvers of
[] ->
solver
s:ss ->
Solver $ \state0 ok back err ->
let
tryTail state1 =
let
(Solver solverTail) = oneOf s ss
in
solverTail state1 ok back err
in
solverHead state0 ok tryTail err
backtrack :: Solver a
backtrack =
Solver $ \state _ back _ -> back state
================================================
FILE: builder/src/Deps/Website.hs
================================================
module Deps.Website
( domain
, route
, metadata
)
where
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified Http
domain :: String
domain =
"https://package.elm-lang.org"
route :: String -> [(String,String)] -> String
route path params =
Http.toUrl (domain ++ path) params
metadata :: Pkg.Name -> V.Version -> String -> String
metadata name version file =
domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file
================================================
FILE: builder/src/Elm/Details.hs
================================================
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
module Elm.Details
( Details(..)
, BuildID
, ValidOutline(..)
, Local(..)
, Foreign(..)
, load
, loadObjects
, loadInterfaces
, verifyInstall
)
where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
import Control.Monad (liftM, liftM2, liftM3)
import Data.Binary (Binary, get, put, getWord8, putWord8)
import qualified Data.Either as Either
import qualified Data.Map as Map
import qualified Data.Map.Utils as Map
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Name as Name
import qualified Data.NonEmptyList as NE
import qualified Data.OneOrMore as OneOrMore
import qualified Data.Set as Set
import qualified Data.Utf8 as Utf8
import Data.Word (Word64)
import qualified System.Directory as Dir
import System.FilePath ((</>), (<.>))
import qualified AST.Canonical as Can
import qualified AST.Source as Src
import qualified AST.Optimized as Opt
import qualified BackgroundWriter as BW
import qualified Compile
import qualified Deps.Registry as Registry
import qualified Deps.Solver as Solver
import qualified Deps.Website as Website
import qualified Elm.Constraint as Con
import qualified Elm.Docs as Docs
import qualified Elm.Interface as I
import qualified Elm.Kernel as Kernel
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Outline as Outline
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified File
import qualified Http
import qualified Json.Decode as D
import qualified Json.Encode as E
import qualified Parse.Module as Parse
import qualified Reporting
import qualified Reporting.Annotation as A
import qualified Reporting.Exit as Exit
import qualified Reporting.Task as Task
import qualified Stuff
-- DETAILS
data Details =
Details
{ _outlineTime :: File.Time
, _outline :: ValidOutline
, _buildID :: BuildID
, _locals :: Map.Map ModuleName.Raw Local
, _foreigns :: Map.Map ModuleName.Raw Foreign
, _extras :: Extras
}
type BuildID = Word64
data ValidOutline
= ValidApp (NE.List Outline.SrcDir)
| ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
-- NOTE: we need two ways to detect if a file must be recompiled:
--
-- (1) _time is the modification time from the last time we compiled the file.
-- By checking EQUALITY with the current modification time, we can detect file
-- saves and `git checkout` of previous versions. Both need a recompile.
--
-- (2) _lastChange is the BuildID from the last time a new interface file was
-- generated, and _lastCompile is the BuildID from the last time the file was
-- compiled. These may be different if a file is recompiled but the interface
-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any
-- imports, we need to recompile. This can happen when a project has multiple
-- entrypoints and some modules are compiled less often than their imports.
--
data Local =
Local
{ _path :: FilePath
, _time :: File.Time
, _deps :: [ModuleName.Raw]
, _main :: Bool
, _lastChange :: BuildID
, _lastCompile :: BuildID
}
data Foreign =
Foreign Pkg.Name [Pkg.Name]
data Extras
= ArtifactsCached
| ArtifactsFresh Interfaces Opt.GlobalGraph
type Interfaces =
Map.Map ModuleName.Canonical I.DependencyInterface
-- LOAD ARTIFACTS
loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
loadObjects root (Details _ _ _ _ _ extras) =
case extras of
ArtifactsFresh _ o -> newMVar (Just o)
ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
loadInterfaces root (Details _ _ _ _ _ extras) =
case extras of
ArtifactsFresh i _ -> newMVar (Just i)
ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
-- VERIFY INSTALL -- used by Install
verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
verifyInstall scope root (Solver.Env cache manager connection registry) outline =
do time <- File.getTime (root </> "elm.json")
let key = Reporting.ignorer
let env = Env key scope root cache manager connection registry
case outline of
Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
Outline.App app -> Task.run (verifyApp env time app >> return ())
-- LOAD -- used by Make, Repl, Reactor
load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
load style scope root =
do newTime <- File.getTime (root </> "elm.json")
maybeDetails <- File.readBinary (Stuff.details root)
case maybeDetails of
Nothing ->
generate style scope root newTime
Just details@(Details oldTime _ buildID _ _ _) ->
if oldTime == newTime
then return (Right details { _buildID = buildID + 1 })
else generate style scope root newTime
-- GENERATE
generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)
generate style scope root time =
Reporting.trackDetails style $ \key ->
do result <- initEnv key scope root
case result of
Left exit ->
return (Left exit)
Right (env, outline) ->
case outline of
Outline.Pkg pkg -> Task.run (verifyPkg env time pkg)
Outline.App app -> Task.run (verifyApp env time app)
-- ENV
data Env =
Env
{ _key :: Reporting.DKey
, _scope :: BW.Scope
, _root :: FilePath
, _cache :: Stuff.PackageCache
, _manager :: Http.Manager
, _connection :: Solver.Connection
, _registry :: Registry.Registry
}
initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
initEnv key scope root =
do mvar <- fork Solver.initEnv
eitherOutline <- Outline.read root
case eitherOutline of
Left problem ->
return $ Left $ Exit.DetailsBadOutline problem
Right outline ->
do maybeEnv <- readMVar mvar
case maybeEnv of
Left problem ->
return $ Left $ Exit.DetailsCannotGetRegistry problem
Right (Solver.Env cache manager connection registry) ->
return $ Right (Env key scope root cache manager connection registry, outline)
-- VERIFY PROJECT
type Task a = Task.Task Exit.Details a
verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =
if Con.goodElm elm
then
do solution <- verifyConstraints env =<< union noDups direct testDirect
let exposedList = Outline.flattenExposed exposed
let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
else
Task.throw $ Exit.DetailsBadElmInPkg elm
verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =
if elmVersion == V.compiler
then
do stated <- checkAppDeps outline
actual <- verifyConstraints env (Map.map Con.exactly stated)
if Map.size stated == Map.size actual
then verifyDependencies env time (ValidApp srcDirs) actual direct
else Task.throw $ Exit.DetailsHandEditedDependencies
else
Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
do x <- union allowEqualDups indirect testDirect
y <- union noDups direct testIndirect
union noDups x y
-- VERIFY CONSTRAINTS
verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
do result <- Task.io $ Solver.verify cache connection registry constraints
case result of
Solver.Ok details -> return details
Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution
Solver.NoOfflineSolution -> Task.throw $ Exit.DetailsNoOfflineSolution
Solver.Err exit -> Task.throw $ Exit.DetailsSolverProblem exit
-- UNION
union :: (Ord k) => (k -> v -> v -> Task v) -> Map.Map k v -> Map.Map k v -> Task (Map.Map k v)
union tieBreaker deps1 deps2 =
Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
noDups :: k -> v -> v -> Task v
noDups _ _ _ =
Task.throw Exit.DetailsHandEditedDependencies
allowEqualDups :: (Eq v) => k -> v -> v -> Task v
allowEqualDups _ v1 v2 =
if v1 == v2
then return v1
else Task.throw Exit.DetailsHandEditedDependencies
-- FORK
fork :: IO a -> IO (MVar a)
fork work =
do mvar <- newEmptyMVar
_ <- forkIO $ putMVar mvar =<< work
return mvar
-- VERIFY DEPENDENCIES
verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
Task.eio id $
do Reporting.report key (Reporting.DStart (Map.size solution))
mvar <- newEmptyMVar
mvars <- Stuff.withRegistryLock cache $
Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
putMVar mvar mvars
deps <- traverse readMVar mvars
case sequence deps of
Left _ ->
do home <- Stuff.getElmHome
return $ Left $ Exit.DetailsBadDeps home $
Maybe.catMaybes $ Either.lefts $ Map.elems deps
Right artifacts ->
let
objs = Map.foldr addObjects Opt.empty artifacts
ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps
details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)
in
do BW.writeBinary scope (Stuff.objects root) objs
BW.writeBinary scope (Stuff.interfaces root) ifaces
BW.writeBinary scope (Stuff.details root) details
return (Right details)
addObjects :: Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph
addObjects (Artifacts _ objs) graph =
Opt.addGlobalGraph objs graph
addInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces
addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
Map.union dependencyInterfaces $ Map.mapKeysMonotonic (ModuleName.Canonical pkg) $
if Map.member pkg directDeps
then ifaces
else Map.map I.privatize ifaces
gatherForeigns :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name)
gatherForeigns pkg (Artifacts ifaces _) foreigns =
let
isPublic di =
case di of
I.Public _ -> Just (OneOrMore.one pkg)
I.Private _ _ _ -> Nothing
in
Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)
-- VERIFY DEPENDENCY
data Artifacts =
Artifacts
{ _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface
, _objects :: Opt.GlobalGraph
}
type Dep =
Either (Maybe Exit.DetailsBadDep) Artifacts
verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
if exists
then
do Reporting.report key Reporting.DCached
maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
case maybeCache of
Nothing ->
build key cache depsMVar pkg details fingerprint Set.empty
Just (ArtifactCache fingerprints artifacts) ->
if Set.member fingerprint fingerprints
then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
else build key cache depsMVar pkg details fingerprint fingerprints
else
do Reporting.report key Reporting.DRequested
result <- downloadPackage cache manager pkg vsn
case result of
Left problem ->
do Reporting.report key (Reporting.DFailed pkg vsn)
return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem
Right () ->
do Reporting.report key (Reporting.DReceived pkg vsn)
build key cache depsMVar pkg details fingerprint Set.empty
-- ARTIFACT CACHE
data ArtifactCache =
ArtifactCache
{ _fingerprints :: Set.Set Fingerprint
, _artifacts :: Artifacts
}
type Fingerprint =
Map.Map Pkg.Name V.Version
-- BUILD
build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep
build key cache depsMVar pkg (Solver.Details vsn _) f fs =
do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
case eitherOutline of
Left _ ->
do Reporting.report key Reporting.DBroken
return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
Right (Outline.App _) ->
do Reporting.report key Reporting.DBroken
return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
do allDeps <- readMVar depsMVar
directDeps <- traverse readMVar (Map.intersection allDeps deps)
case sequence directDeps of
Left _ ->
do Reporting.report key Reporting.DBroken
return $ Left $ Nothing
Right directArtifacts ->
do let src = Stuff.package cache pkg vsn </> "src"
let foreignDeps = gatherForeignInterfaces directArtifacts
let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
docsStatus <- getDocsStatus cache pkg vsn
mvar <- newEmptyMVar
mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict
putMVar mvar mvars
mapM_ readMVar mvars
maybeStatuses <- traverse readMVar =<< readMVar mvar
case sequence maybeStatuses of
Nothing ->
do Reporting.report key Reporting.DBroken
return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
Just statuses ->
do rmvar <- newEmptyMVar
rmvars <- traverse (fork . compile pkg rmvar) statuses
putMVar rmvar rmvars
maybeResults <- traverse readMVar rmvars
case sequence maybeResults of
Nothing ->
do Reporting.report key Reporting.DBroken
return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
Just results ->
let
path = Stuff.package cache pkg vsn </> "artifacts.dat"
ifaces = gatherInterfaces exposedDict results
objects = gatherObjects results
artifacts = Artifacts ifaces objects
fingerprints = Set.insert f fs
in
do writeDocs cache pkg vsn docsStatus results
File.writeBinary path (ArtifactCache fingerprints artifacts)
Reporting.report key Reporting.DBuilt
return (Right artifacts)
-- GATHER
gatherObjects :: Map.Map ModuleName.Raw Result -> Opt.GlobalGraph
gatherObjects results =
Map.foldrWithKey addLocalGraph Opt.empty results
addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph
addLocalGraph name status graph =
case status of
RLocal _ objs _ -> Opt.addLocalGraph objs graph
RForeign _ -> graph
RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
RKernelForeign -> graph
gatherInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw Result -> Map.Map ModuleName.Raw I.DependencyInterface
gatherInterfaces exposed artifacts =
let
onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherInterfaces")
onRight = Map.mapMaybeMissing (\_ iface -> toLocalInterface I.private iface)
onBoth = Map.zipWithMaybeMatched (\_ () iface -> toLocalInterface I.public iface)
in
Map.merge onLeft onRight onBoth exposed artifacts
toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a
toLocalInterface func result =
case result of
RLocal iface _ _ -> Just (func iface)
RForeign _ -> Nothing
RKernelLocal _ -> Nothing
RKernelForeign -> Nothing
-- GATHER FOREIGN INTERFACES
data ForeignInterface
= ForeignAmbiguous
| ForeignSpecific I.Interface
gatherForeignInterfaces :: Map.Map Pkg.Name Artifacts -> Map.Map ModuleName.Raw ForeignInterface
gatherForeignInterfaces directArtifacts =
Map.map (OneOrMore.destruct finalize) $
Map.foldrWithKey gather Map.empty directArtifacts
where
finalize :: I.Interface -> [I.Interface] -> ForeignInterface
finalize i is =
case is of
[] -> ForeignSpecific i
_:_ -> ForeignAmbiguous
gather :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface)
gather _ (Artifacts ifaces _) buckets =
Map.unionWith OneOrMore.more buckets (Map.mapMaybe isPublic ifaces)
isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)
isPublic di =
case di of
I.Public iface -> Just (OneOrMore.one iface)
I.Private _ _ _ -> Nothing
-- CRAWL
type StatusDict =
Map.Map ModuleName.Raw (MVar (Maybe Status))
data Status
= SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module
| SForeign I.Interface
| SKernelLocal [Kernel.Chunk]
| SKernelForeign
crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status)
crawlModule foreignDeps mvar pkg src docsStatus name =
do let path = src </> ModuleName.toFilePath name <.> "elm"
exists <- File.exists path
case Map.lookup name foreignDeps of
Just ForeignAmbiguous ->
return Nothing
Just (ForeignSpecific iface) ->
if exists
then return Nothing
else return (Just (SForeign iface))
Nothing ->
if exists then
crawlFile foreignDeps mvar pkg src docsStatus name path
else if Pkg.isKernel pkg && Name.isKernel name then
crawlKernel foreignDeps mvar pkg src name
else
return Nothing
crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
do bytes <- File.readUtf8 path
case Parse.fromByteString (Parse.Package pkg) bytes of
Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
do deps <- crawlImports foreignDeps mvar pkg src imports
return (Just (SLocal docsStatus deps modul))
_ ->
return Nothing
crawlImports :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> [Src.Import] -> IO (Map.Map ModuleName.Raw ())
crawlImports foreignDeps mvar pkg src imports =
do statusDict <- takeMVar mvar
let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
let news = Map.difference deps statusDict
mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news
putMVar mvar (Map.union mvars statusDict)
mapM_ readMVar mvars
return deps
crawlKernel :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status)
crawlKernel foreignDeps mvar pkg src name =
do let path = src </> ModuleName.toFilePath name <.> "js"
exists <- File.exists path
if exists
then
do bytes <- File.readUtf8 path
case Kernel.fromByteString pkg (Map.mapMaybe getDepHome foreignDeps) bytes of
Nothing ->
return Nothing
Just (Kernel.Content imports chunks) ->
do _ <- crawlImports foreignDeps mvar pkg src imports
return (Just (SKernelLocal chunks))
else
return (Just SKernelForeign)
getDepHome :: ForeignInterface -> Maybe Pkg.Name
getDepHome fi =
case fi of
ForeignSpecific (I.Interface pkg _ _ _ _) -> Just pkg
ForeignAmbiguous -> Nothing
-- COMPILE
data Result
= RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module)
| RForeign I.Interface
| RKernelLocal [Kernel.Chunk]
| RKernelForeign
compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
compile pkg mvar status =
case status of
SLocal docsStatus deps modul ->
do resultsDict <- readMVar mvar
maybeResults <- traverse readMVar (Map.intersection resultsDict deps)
case sequence maybeResults of
Nothing ->
return Nothing
Just results ->
case Compile.compile pkg (Map.mapMaybe getInterface results) modul of
Left _ ->
return Nothing
Right (Compile.Artifacts canonical annotations objects) ->
let
ifaces = I.fromModule pkg canonical annotations
docs = makeDocs docsStatus canonical
in
return (Just (RLocal ifaces objects docs))
SForeign iface ->
return (Just (RForeign iface))
SKernelLocal chunks ->
return (Just (RKernelLocal chunks))
SKernelForeign ->
return (Just RKernelForeign)
getInterface :: Result -> Maybe I.Interface
getInterface result =
case result of
RLocal iface _ _ -> Just iface
RForeign iface -> Just iface
RKernelLocal _ -> Nothing
RKernelForeign -> Nothing
-- MAKE DOCS
data DocsStatus
= DocsNeeded
| DocsNotNeeded
getDocsStatus :: Stuff.PackageCache -> Pkg.Name -> V.Version -> IO DocsStatus
getDocsStatus cache pkg vsn =
do exists <- File.exists (Stuff.package cache pkg vsn </> "docs.json")
if exists
then return DocsNotNeeded
else return DocsNeeded
makeDocs :: DocsStatus -> Can.Module -> Maybe Docs.Module
makeDocs status modul =
case status of
DocsNeeded ->
case Docs.fromModule modul of
Right docs -> Just docs
Left _ -> Nothing
DocsNotNeeded ->
Nothing
writeDocs :: Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO ()
writeDocs cache pkg vsn status results =
case status of
DocsNeeded ->
E.writeUgly (Stuff.package cache pkg vsn </> "docs.json") $
Docs.encode $ Map.mapMaybe toDocs results
DocsNotNeeded ->
return ()
toDocs :: Result -> Maybe Docs.Module
toDocs result =
case result of
RLocal _ _ docs -> docs
RForeign _ -> Nothing
RKernelLocal _ -> Nothing
RKernelForeign -> Nothing
-- DOWNLOAD PACKAGE
downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
downloadPackage cache manager pkg vsn =
let
url = Website.metadata pkg vsn "endpoint.json"
in
do eitherByteString <-
Http.get manager url [] id (return . Right)
case eitherByteString of
Left err ->
return $ Left $ Exit.PP_BadEndpointRequest err
Right byteString ->
case D.fromByteString endpointDecoder byteString of
Left _ ->
return $ Left $ Exit.PP_BadEndpointContent url
Right (endpoint, expectedHash) ->
Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
\(sha, archive) ->
if expectedHash == Http.shaToChars sha
then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
endpointDecoder :: D.Decoder e (String, String)
endpointDecoder =
do url <- D.field "url" D.string
hash <- D.field "hash" D.string
return (Utf8.toChars url, Utf8.toChars hash)
-- BINARY
instance Binary Details where
put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e
get =
do a <- get
b <- get
c <- get
d <- get
e <- get
return (Details a b c d e ArtifactsCached)
instance Binary ValidOutline where
put outline =
case outline of
ValidApp a -> putWord8 0 >> put a
ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
get =
do n <- getWord8
case n of
0 -> liftM ValidApp get
1 -> liftM3 ValidPkg get get get
_ -> fail "binary encoding of ValidOutline was corrupted"
instance Binary Local where
put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
get =
do a <- get
b <- get
c <- get
d <- get
e <- get
f <- get
return (Local a b c d e f)
instance Binary Foreign where
get = liftM2 Foreign get get
put (Foreign a b) = put a >> put b
instance Binary Artifacts where
get = liftM2 Artifacts get get
put (Artifacts a b) = put a >> put b
instance Binary ArtifactCache where
get = liftM2 ArtifactCache get get
put (ArtifactCache a b) = put a >> put b
================================================
FILE: builder/src/Elm/Outline.hs
================================================
{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
module Elm.Outline
( Outline(..)
, AppOutline(..)
, PkgOutline(..)
, Exposed(..)
, SrcDir(..)
, read
, write
, encode
, decoder
, defaultSummary
, flattenExposed
)
where
import Prelude hiding (read)
import Control.Monad (filterM, liftM)
import Data.Binary (Binary, get, put, getWord8, putWord8)
import qualified Data.Map as Map
import qualified Data.NonEmptyList as NE
import qualified Data.OneOrMore as OneOrMore
import Foreign.Ptr (minusPtr)
import qualified System.Directory as Dir
import qualified System.FilePath as FP
import System.FilePath ((</>))
import qualified Elm.Constraint as Con
import qualified Elm.Licenses as Licenses
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified File
import qualified Json.Decode as D
import qualified Json.Encode as E
import Json.Encode ((==>))
import qualified Json.String as Json
import qualified Parse.Primitives as P
import qualified Reporting.Exit as Exit
-- OUTLINE
data Outline
= App AppOutline
| Pkg PkgOutline
data AppOutline =
AppOutline
{ _app_elm_version :: V.Version
, _app_source_dirs :: NE.List SrcDir
, _app_deps_direct :: Map.Map Pkg.Name V.Version
, _app_deps_indirect :: Map.Map Pkg.Name V.Version
, _app_test_direct :: Map.Map Pkg.Name V.Version
, _app_test_indirect :: Map.Map Pkg.Name V.Version
}
data PkgOutline =
PkgOutline
{ _pkg_name :: Pkg.Name
, _pkg_summary :: Json.String
, _pkg_license :: Licenses.License
, _pkg_version :: V.Version
, _pkg_exposed :: Exposed
, _pkg_deps :: Map.Map Pkg.Name Con.Constraint
, _pkg_test_deps :: Map.Map Pkg.Name Con.Constraint
, _pkg_elm_version :: Con.Constraint
}
data Exposed
= ExposedList [ModuleName.Raw]
| ExposedDict [(Json.String, [ModuleName.Raw])]
data SrcDir
= AbsoluteSrcDir FilePath
| RelativeSrcDir FilePath
-- DEFAULTS
defaultSummary :: Json.String
defaultSummary =
Json.fromChars "helpful summary of your project, less than 80 characters"
-- HELPERS
flattenExposed :: Exposed -> [ModuleName.Raw]
flattenExposed exposed =
case exposed of
ExposedList names ->
names
ExposedDict sections ->
concatMap snd sections
-- WRITE
write :: FilePath -> Outline -> IO ()
write root outline =
E.write (root </> "elm.json") (encode outline)
-- JSON ENCODE
encode :: Outline -> E.Value
encode outline =
case outline of
App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
E.object
[ "type" ==> E.chars "application"
, "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
, "elm-version" ==> V.encode elm
, "dependencies" ==>
E.object
[ "direct" ==> encodeDeps V.encode depsDirect
, "indirect" ==> encodeDeps V.encode depsTrans
]
, "test-dependencies" ==>
E.object
[ "direct" ==> encodeDeps V.encode testDirect
, "indirect" ==> encodeDeps V.encode testTrans
]
]
Pkg (PkgOutline name summary license version exposed deps tests elm) ->
E.object
[ "type" ==> E.string (Json.fromChars "package")
, "name" ==> Pkg.encode name
, "summary" ==> E.string summary
, "license" ==> Licenses.encode license
, "version" ==> V.encode version
, "exposed-modules" ==> encodeExposed exposed
, "elm-version" ==> Con.encode elm
, "dependencies" ==> encodeDeps Con.encode deps
, "test-dependencies" ==> encodeDeps Con.encode tests
]
encodeExposed :: Exposed -> E.Value
encodeExposed exposed =
case exposed of
ExposedList modules ->
E.list encodeModule modules
ExposedDict chunks ->
E.object (map (fmap (E.list encodeModule)) chunks)
encodeModule :: ModuleName.Raw -> E.Value
encodeModule name =
E.name name
encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
encodeDeps encodeValue deps =
E.dict Pkg.toJsonString encodeValue deps
encodeSrcDir :: SrcDir -> E.Value
encodeSrcDir srcDir =
case srcDir of
AbsoluteSrcDir dir -> E.chars dir
RelativeSrcDir dir -> E.chars dir
-- PARSE AND VERIFY
read :: FilePath -> IO (Either Exit.Outline Outline)
read root =
do bytes <- File.readUtf8 (root </> "elm.json")
case D.fromByteString decoder bytes of
Left err ->
return $ Left (Exit.OutlineHasBadStructure err)
Right outline ->
case outline of
Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
return $
if Map.notMember Pkg.core deps && pkg /= Pkg.core
then Left Exit.OutlineNoPkgCore
else Right outline
App (AppOutline _ srcDirs direct indirect _ _)
| Map.notMember Pkg.core direct ->
return $ Left Exit.OutlineNoAppCore
| Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->
return $ Left Exit.OutlineNoAppJson
| otherwise ->
do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)
case map toGiven badDirs of
d:ds ->
return $ Left (Exit.OutlineHasMissingSrcDirs d ds)
[] ->
do maybeDups <- detectDuplicates root (NE.toList srcDirs)
case maybeDups of
Nothing ->
return $ Right outline
Just (canonicalDir, (dir1,dir2)) ->
return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)
isSrcDirMissing :: FilePath -> SrcDir -> IO Bool
isSrcDirMissing root srcDir =
not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)
toGiven :: SrcDir -> FilePath
toGiven srcDir =
case srcDir of
AbsoluteSrcDir dir -> dir
RelativeSrcDir dir -> dir
toAbsolute :: FilePath -> SrcDir -> FilePath
toAbsolute root srcDir =
case srcDir of
AbsoluteSrcDir dir -> dir
RelativeSrcDir dir -> root </> dir
detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
detectDuplicates root srcDirs =
do pairs <- traverse (toPair root) srcDirs
return $ Map.lookupMin $ Map.mapMaybe isDup $
Map.fromListWith OneOrMore.more pairs
toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
toPair root srcDir =
do key <- Dir.canonicalizePath (toAbsolute root srcDir)
return (key, OneOrMore.one (toGiven srcDir))
isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
isDup paths =
case paths of
OneOrMore.One _ -> Nothing
OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
-- JSON DECODE
type Decoder a =
D.Decoder Exit.OutlineProblem a
decoder :: Decoder Outline
decoder =
let
application = Json.fromChars "application"
package = Json.fromChars "package"
in
do tipe <- D.field "type" D.string
if | tipe == application -> App <$> appDecoder
| tipe == package -> Pkg <$> pkgDecoder
| otherwise -> D.failure Exit.OP_BadType
appDecoder :: Decoder AppOutline
appDecoder =
AppOutline
<$> D.field "elm-version" versionDecoder
<*> D.field "source-directories" dirsDecoder
<*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
<*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
<*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
<*> D.field "test-dependencies" (D.field "indirect" (depsDecoder versionDecoder))
pkgDecoder :: Decoder PkgOutline
pkgDecoder =
PkgOutline
<$> D.field "name" nameDecoder
<*> D.field "summary" summaryDecoder
<*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
<*> D.field "version" versionDecoder
<*> D.field "exposed-modules" exposedDecoder
<*> D.field "dependencies" (depsDecoder constraintDecoder)
<*> D.field "test-dependencies" (depsDecoder constraintDecoder)
<*> D.field "elm-version" constraintDecoder
-- JSON DECODE HELPERS
nameDecoder :: Decoder Pkg.Name
nameDecoder =
D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
summaryDecoder :: Decoder Json.String
summaryDecoder =
D.customString
(boundParser 80 Exit.OP_BadSummaryTooLong)
(\_ _ -> Exit.OP_BadSummaryTooLong)
versionDecoder :: Decoder V.Version
versionDecoder =
D.mapError (uncurry Exit.OP_BadVersion) V.decoder
constraintDecoder :: Decoder Con.Constraint
constraintDecoder =
D.mapError Exit.OP_BadConstraint Con.decoder
depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
depsDecoder valueDecoder =
D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
dirsDecoder :: Decoder (NE.List SrcDir)
dirsDecoder =
fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
toSrcDir :: FilePath -> SrcDir
toSrcDir path =
if FP.isRelative path
then RelativeSrcDir path
else AbsoluteSrcDir path
-- EXPOSED MODULES DECODER
exposedDecoder :: Decoder Exposed
exposedDecoder =
D.oneOf
[ ExposedList <$> D.list moduleDecoder
, ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
]
moduleDecoder :: Decoder ModuleName.Raw
moduleDecoder =
D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
headerKeyDecoder =
D.KeyDecoder
(boundParser 20 Exit.OP_BadModuleHeaderTooLong)
(\_ _ -> Exit.OP_BadModuleHeaderTooLong)
-- BOUND PARSER
boundParser :: Int -> x -> P.Parser x Json.String
boundParser bound tooLong =
P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
let
len = minusPtr end pos
newCol = col + fromIntegral len
in
if len < bound
then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
else cerr row newCol (\_ _ -> tooLong)
-- BINARY
instance Binary SrcDir where
put outline =
case outline of
AbsoluteSrcDir a -> putWord8 0 >> put a
RelativeSrcDir a -> putWord8 1 >> put a
get =
do n <- getWord8
case n of
0 -> liftM AbsoluteSrcDir get
1 -> liftM RelativeSrcDir get
_ -> fail "binary encoding of SrcDir was corrupted"
================================================
FILE: builder/src/File.hs
================================================
module File
( Time
, getTime
, zeroTime
, writeBinary
, readBinary
, writeUtf8
, readUtf8
, writeBuilder
, writePackage
, exists
, remove
, removeDir
)
where
import qualified Codec.Archive.Zip as Zip
import Control.Exception (catch)
import qualified Data.Binary as Binary
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Fixed as Fixed
import qualified Data.List as List
import qualified Data.Time.Clock as Time
import qualified Data.Time.Clock.POSIX as Time
import qualified Foreign.ForeignPtr as FPtr
import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
import qualified System.Directory as Dir
import qualified System.FilePath as FP
import System.FilePath ((</>))
import qualified System.IO as IO
import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
-- TIME
newtype Time = Time Fixed.Pico
deriving (Eq, Ord)
getTime :: FilePath -> IO Time
getTime path =
fmap
(Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
(Dir.getModificationTime path)
zeroTime :: Time
zeroTime =
Time 0
instance Binary.Binary Time where
put (Time time) = Binary.put time
get = Time <$> Binary.get
-- BINARY
writeBinary :: (Binary.Binary a) => FilePath -> a -> IO ()
writeBinary path value =
do let dir = FP.dropFileName path
Dir.createDirectoryIfMissing True dir
Binary.encodeFile path value
readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
readBinary path =
do pathExists <- Dir.doesFileExist path
if pathExists
then
do result <- Binary.decodeFileOrFail path
case result of
Right a ->
return (Just a)
Left (offset, message) ->
do IO.hPutStrLn IO.stderr $ unlines $
[ "+-------------------------------------------------------------------------------"
, "| Corrupt File: " ++ path
, "| Byte Offset: " ++ show offset
, "| Message: " ++ message
, "|"
, "| Please report this to https://github.com/elm/compiler/issues"
, "| Trying to continue anyway."
, "+-------------------------------------------------------------------------------"
]
return Nothing
else
return Nothing
-- WRITE UTF-8
writeUtf8 :: FilePath -> BS.ByteString -> IO ()
writeUtf8 path content =
withUtf8 path IO.WriteMode $ \handle ->
BS.hPut handle content
withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
withUtf8 path mode callback =
IO.withFile path mode $ \handle ->
do IO.hSetEncoding handle IO.utf8
callback handle
-- READ UTF-8
readUtf8 :: FilePath -> IO BS.ByteString
readUtf8 path =
withUtf8 path IO.ReadMode $ \handle ->
modifyIOError (encodingError path) $
do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
let readSize = max 0 (fromIntegral fileSize) + 1
hGetContentsSizeHint handle readSize (max 255 readSize)
useZeroIfNotRegularFile :: IOException -> IO Integer
useZeroIfNotRegularFile _ =
return 0
hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
hGetContentsSizeHint handle =
readChunks []
where
readChunks chunks readSize incrementSize =
do fp <- BS.mallocByteString readSize
readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
let chunk = BS.PS fp 0 readCount
if readCount < readSize && readSize > 0
then return $! BS.concat (reverse (chunk:chunks))
else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
encodingError :: FilePath -> IOError -> IOError
encodingError path ioErr =
case ioeGetErrorType ioErr of
InvalidArgument ->
annotateIOError
(userError "Bad encoding; the file must be valid UTF-8")
""
Nothing
(Just path)
_ ->
ioErr
-- WRITE BUILDER
writeBuilder :: FilePath -> B.Builder -> IO ()
writeBuilder path builder =
IO.withBinaryFile path IO.WriteMode $ \handle ->
do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
B.hPutBuilder handle builder
-- WRITE PACKAGE
writePackage :: FilePath -> Zip.Archive -> IO ()
writePackage destination archive =
case Zip.zEntries archive of
[] ->
return ()
entry:entries ->
do let root = length (Zip.eRelativePath entry)
mapM_ (writeEntry destination root) entries
writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()
writeEntry destination root entry =
let
path = drop root (Zip.eRelativePath entry)
in
if List.isPrefixOf "src/" path
|| path == "LICENSE"
|| path == "README.md"
|| path == "elm.json"
then
if not (null path) && last path == '/'
then Dir.createDirectoryIfMissing True (destination </> path)
else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
else
return ()
-- EXISTS
exists :: FilePath -> IO Bool
exists path =
Dir.doesFileExist path
-- REMOVE FILES
remove :: FilePath -> IO ()
remove path =
do exists_ <- Dir.doesFileExist path
if exists_
then Dir.removeFile path
else return ()
removeDir :: FilePath -> IO ()
removeDir path =
do exists_ <- Dir.doesDirectoryExist path
if exists_
then Dir.removeDirectoryRecursive path
else return ()
================================================
FILE: builder/src/Generate.hs
================================================
{-# LANGUAGE BangPatterns #-}
module Generate
( debug
, dev
, prod
, repl
)
where
import Prelude hiding (cycle, print)
import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
import Control.Monad (liftM2)
import qualified Data.ByteString.Builder as B
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Name as N
import qualified Data.NonEmptyList as NE
import qualified AST.Optimized as Opt
import qualified Build
import qualified Elm.Compiler.Type.Extract as Extract
import qualified Elm.Details as Details
import qualified Elm.Interface as I
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified File
import qualified Generate.JavaScript as JS
import qualified Generate.Mode as Mode
import qualified Nitpick.Debug as Nitpick
import qualified Reporting.Exit as Exit
import qualified Reporting.Task as Task
import qualified Stuff
-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
-- desireable to have Repl and Reactor to keep foreign objects in memory
-- to make things a bit faster?
-- GENERATORS
type Task a =
Task.Task Exit.Generate a
debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
debug root details (Build.Artifacts pkg ifaces roots modules) =
do loading <- loadObjects root details modules
types <- loadTypes root ifaces modules
objects <- finalizeObjects loading
let mode = Mode.Dev (Just types)
let graph = objectsToGlobalGraph objects
let mains = gatherMains pkg objects roots
return $ JS.generate mode graph mains
dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
dev root details (Build.Artifacts pkg _ roots modules) =
do objects <- finalizeObjects =<< loadObjects root details modules
let mode = Mode.Dev Nothing
let graph = objectsToGlobalGraph objects
let mains = gatherMains pkg objects roots
return $ JS.generate mode graph mains
prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
prod root details (Build.Artifacts pkg _ roots modules) =
do objects <- finalizeObjects =<< loadObjects root details modules
checkForDebugUses objects
let graph = objectsToGlobalGraph objects
let mode = Mode.Prod (Mode.shortenFieldNames graph)
let mains = gatherMains pkg objects roots
return $ JS.generate mode graph mains
repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
do objects <- finalizeObjects =<< loadObjects root details modules
let graph = objectsToGlobalGraph objects
return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
-- CHECK FOR DEBUG
checkForDebugUses :: Objects -> Task ()
checkForDebugUses (Objects _ locals) =
case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
[] -> return ()
m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
-- GATHER MAINS
gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
gatherMains pkg (Objects _ locals) roots =
Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
lookupMain pkg locals root =
let
toPair name (Opt.LocalGraph maybeMain _ _) =
(,) (ModuleName.Canonical pkg name) <$> maybeMain
in
case root of
Build.Inside name -> toPair name =<< Map.lookup name locals
Build.Outside name _ g -> toPair name g
-- LOADING OBJECTS
data LoadingObjects =
LoadingObjects
{ _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
, _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
}
loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
loadObjects root details modules =
Task.io $
do mvar <- Details.loadObjects root details
mvars <- traverse (loadObject root) modules
return $ LoadingObjects mvar (Map.fromList mvars)
loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
loadObject root modul =
case modul of
Build.Fresh name _ graph ->
do mvar <- newMVar (Just graph)
return (name, mvar)
Build.Cached name _ _ ->
do mvar <- newEmptyMVar
_ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
return (name, mvar)
-- FINALIZE OBJECTS
data Objects =
Objects
{ _foreign :: Opt.GlobalGraph
, _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
}
finalizeObjects :: LoadingObjects -> Task Objects
finalizeObjects (LoadingObjects mvar mvars) =
Task.eio id $
do result <- readMVar mvar
results <- traverse readMVar mvars
case liftM2 Objects result (sequence results) of
Just loaded -> return (Right loaded)
Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
objectsToGlobalGraph (Objects globals locals) =
foldr Opt.addLocalGraph globals locals
-- LOAD TYPES
loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
loadTypes root ifaces modules =
Task.eio id $
do mvars <- traverse (loadTypesHelp root) modules
let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
results <- traverse readMVar mvars
case sequence results of
Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
loadTypesHelp root modul =
case modul of
Build.Fresh name iface _ ->
newMVar (Just (Extract.fromInterface name iface))
Build.Cached name _ ciMVar ->
do cachedInterface <- readMVar ciMVar
case cachedInterface of
Build.Unneeded ->
do mvar <- newEmptyMVar
_ <- forkIO $
do maybeIface <- File.readBinary (Stuff.elmi root name)
putMVar mvar (Extract.fromInterface name <$> maybeIface)
return mvar
Build.Loaded iface ->
newMVar (Just (Extract.fromInterface name iface))
Build.Corrupted ->
newMVar Nothing
================================================
FILE: builder/src/Http.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Http
( Manager
, getManager
, toUrl
-- fetch
, get
, post
, Header
, accept
, Error(..)
-- archives
, Sha
, shaToChars
, getArchive
-- upload
, upload
, filePart
, jsonPart
, stringPart
)
where
import Prelude hiding (zip)
import qualified Codec.Archive.Zip as Zip
import Control.Exception (SomeException, handle)
import qualified Data.Binary as Binary
import qualified Data.Binary.Get as Binary
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BS
import qualified Data.Digest.Pure.SHA as SHA
import qualified Data.String as String
import Network.HTTP (urlEncodeVars)
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
import Network.HTTP.Types.Method (Method, methodGet, methodPost)
import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
import qualified Network.HTTP.Client.MultipartFormData as Multi
import qualified Json.Encode as Encode
import qualified Elm.Version as V
-- MANAGER
getManager :: IO Manager
getManager =
newManager tlsManagerSettings
-- URL
toUrl :: String -> [(String,String)] -> String
toUrl url params =
case params of
[] -> url
_:_ -> url ++ "?" ++ urlEncodeVars params
-- FETCH
get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
get =
fetch methodGet
post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
post =
fetch methodPost
fetch :: Method -> Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
fetch methodVerb manager url headers onError onSuccess =
handle (handleSomeException url onError) $
handle (handleHttpException url onError) $
do req0 <- parseUrlThrow url
let req1 =
req0
{ method = methodVerb
, requestHeaders = addDefaultHeaders headers
}
withResponse req1 manager $ \response ->
do chunks <- brConsume (responseBody response)
onSuccess (BS.concat chunks)
addDefaultHeaders :: [Header] -> [Header]
addDefaultHeaders headers =
(hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
{-# NOINLINE userAgent #-}
userAgent :: BS.ByteString
userAgent =
BS.pack ("elm/" ++ V.toChars V.compiler)
accept :: BS.ByteString -> Header
accept mime =
(hAccept, mime)
-- EXCEPTIONS
data Error
= BadUrl String String
| BadHttp String HttpExceptionContent
| BadMystery String SomeException
handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)
handleHttpException url onError httpException =
case httpException of
InvalidUrlException _ reason ->
return (Left (onError (BadUrl url reason)))
HttpExceptionRequest _ content ->
return (Left (onError (BadHttp url content)))
handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)
handleSomeException url onError exception =
return (Left (onError (BadMystery url exception)))
-- SHA
type Sha = SHA.Digest SHA.SHA1State
shaToChars :: Sha -> String
shaToChars =
SHA.showDigest
-- FETCH ARCHIVE
getArchive
:: Manager
-> String
-> (Error -> e)
-> e
-> ((Sha, Zip.Archive) -> IO (Either e a))
-> IO (Either e a)
getArchive manager url onError err onSuccess =
handle (handleSomeException url onError) $
handle (handleHttpException url onError) $
do req0 <- parseUrlThrow url
let req1 =
req0
{ method = methodGet
, requestHeaders = addDefaultHeaders []
}
withResponse req1 manager $ \response ->
do result <- readArchive (responseBody response)
case result of
Nothing -> return (Left err)
Just shaAndArchive -> onSuccess shaAndArchive
readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
readArchive body =
readArchiveHelp body $
AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
data ArchiveState =
AS
{ _len :: !Int
, _sha :: !(Binary.Decoder SHA.SHA1State)
, _zip :: !(Binary.Decoder Zip.Archive)
}
readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))
readArchiveHelp body (AS len sha zip) =
case zip of
Binary.Fail _ _ _ ->
return Nothing
Binary.Partial k ->
do chunk <- brRead body
readArchiveHelp body $
AS
{ _len = len + BS.length chunk
, _sha = Binary.pushChunk sha chunk
, _zip = k (if BS.null chunk then Nothing else Just chunk)
}
Binary.Done _ _ archive ->
return $ Just ( SHA.completeSha1Incremental sha len, archive )
-- UPLOAD
upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
upload manager url parts =
handle (handleSomeException url id) $
handle (handleHttpException url id) $
do req0 <- parseUrlThrow url
req1 <-
Multi.formDataBody parts $
req0
{ method = methodPost
, requestHeaders = addDefaultHeaders []
, responseTimeout = responseTimeoutNone
}
withResponse req1 manager $ \_ ->
return (Right ())
filePart :: String -> FilePath -> Multi.Part
filePart name filePath =
Multi.partFileSource (String.fromString name) filePath
jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part
jsonPart name filePath value =
let
body =
Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value
in
Multi.partFileRequestBody (String.fromString name) filePath body
stringPart :: String -> String -> Multi.Part
stringPart name string =
Multi.partBS (String.fromString name) (BS.pack string)
================================================
FILE: builder/src/Reporting/Exit/Help.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Exit.Help
( Report
, report
, docReport
, jsonReport
, compilerReport
, reportToDoc
, reportToJson
, toString
, toStdout
, toStderr
)
where
import GHC.IO.Handle (hIsTerminalDevice)
import System.IO (Handle, hPutStr, stderr, stdout)
import qualified Json.Encode as E
import Json.Encode ((==>))
import Reporting.Doc ((<+>))
import qualified Reporting.Doc as D
import qualified Reporting.Error as Error
-- REPORT
data Report
= CompilerReport FilePath Error.Module [Error.Module]
| Report
{ _title :: String
, _path :: Maybe FilePath
, _message :: D.Doc
}
report :: String -> Maybe FilePath -> String -> [D.Doc] -> Report
report title path startString others =
Report title path $ D.stack (D.reflow startString:others)
docReport :: String -> Maybe FilePath -> D.Doc -> [D.Doc] -> Report
docReport title path startDoc others =
Report title path $ D.stack (startDoc:others)
jsonReport :: String -> Maybe FilePath -> D.Doc -> Report
jsonReport =
Report
compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
compilerReport =
CompilerReport
-- TO DOC
reportToDoc :: Report -> D.Doc
reportToDoc report_ =
case report_ of
CompilerReport root e es ->
Error.toDoc root e es
Report title maybePath message ->
let
makeDashes n =
replicate (max 1 (80 - n)) '-'
errorBarEnd =
case maybePath of
Nothing ->
makeDashes (4 + length title)
Just path ->
makeDashes (5 + length title + length path) ++ " " ++ path
errorBar =
D.dullcyan $
"--" <+> D.fromChars title <+> D.fromChars errorBarEnd
in
D.stack [errorBar, message, ""]
-- TO JSON
reportToJson :: Report -> E.Value
reportToJson report_ =
case report_ of
CompilerReport _ e es ->
E.object
[ "type" ==> E.chars "compile-errors"
, "errors" ==> E.list Error.toJson (e:es)
]
Report title maybePath message ->
E.object
[ "type" ==> E.chars "error"
, "path" ==> maybe E.null E.chars maybePath
, "title" ==> E.chars title
, "message" ==> D.encode message
]
-- OUTPUT
toString :: D.Doc -> String
toString =
D.toString
toStdout :: D.Doc -> IO ()
toStdout doc =
toHandle stdout doc
toStderr :: D.Doc -> IO ()
toStderr doc =
toHandle stderr doc
toHandle :: Handle -> D.Doc -> IO ()
toHandle handle doc =
do isTerminal <- hIsTerminalDevice handle
if isTerminal
then D.toAnsi handle doc
else hPutStr handle (toString doc)
================================================
FILE: builder/src/Reporting/Exit.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Exit
( Init(..), initToReport
, Diff(..), diffToReport
, Make(..), makeToReport
, Bump(..), bumpToReport
, Repl(..), replToReport
, Publish(..), publishToReport
, Install(..), installToReport
, Reactor(..), reactorToReport
, newPackageOverview
--
, Solver(..)
, Outline(..)
, OutlineProblem(..)
, Details(..)
, DetailsBadDep(..)
, PackageProblem(..)
, RegistryProblem(..)
, BuildProblem(..)
, BuildProjectProblem(..)
, DocsProblem(..)
, Generate(..)
--
, toString
, toStderr
, toJson
)
where
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as BS_UTF8
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Name as N
import qualified Data.NonEmptyList as NE
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types.Header as HTTP
import qualified Network.HTTP.Types.Status as HTTP
import qualified System.FilePath as FP
import System.FilePath ((</>), (<.>))
import qualified Elm.Constraint as C
import qualified Elm.Magnitude as M
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified File
import qualified Http
import qualified Json.Decode as Decode
import qualified Json.Encode as Encode
import qualified Json.String as Json
import Parse.Primitives (Row, Col)
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import qualified Reporting.Error.Import as Import
import qualified Reporting.Error.Json as Json
import qualified Reporting.Exit.Help as Help
import qualified Reporting.Error as Error
import qualified Reporting.Render.Code as Code
-- RENDERERS
toString :: Help.Report -> String
toString report =
Help.toString (Help.reportToDoc report)
toStderr :: Help.Report -> IO ()
toStderr report =
Help.toStderr (Help.reportToDoc report)
toJson :: Help.Report -> Encode.Value
toJson report =
Help.reportToJson report
-- INIT
data Init
= InitNoSolution [Pkg.Name]
| InitNoOfflineSolution [Pkg.Name]
| InitSolverProblem Solver
| InitAlreadyExists
| InitRegistryProblem RegistryProblem
initToReport :: Init -> Help.Report
initToReport exit =
case exit of
InitNoSolution pkgs ->
Help.report "NO SOLUTION" Nothing
"I tried to create an elm.json with the following direct dependencies:"
[ D.indent 4 $ D.vcat $
map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
, D.reflow $
"I could not find compatible versions though! This should not happen, so please\
\ ask around one of the community forums at https://elm-lang.org/community to learn\
\ what is going on!"
]
InitNoOfflineSolution pkgs ->
Help.report "NO OFFLINE SOLUTION" Nothing
"I tried to create an elm.json with the following direct dependencies:"
[ D.indent 4 $ D.vcat $
map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
, D.reflow $
"I could not find compatible versions though, but that may be because I could not\
\ connect to https://package.elm-lang.org to get the latest list of packages. Are\
\ you able to connect to the internet? Please ask around one of the community\
\ forums at https://elm-lang.org/community for help!"
]
InitSolverProblem solver ->
toSolverReport solver
InitAlreadyExists ->
Help.report "EXISTING PROJECT" Nothing
"You already have an elm.json file, so there is nothing for me to initialize!"
[ D.fillSep
["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help"
,"you","figure","out","what","to","do","next?"
]
]
InitRegistryProblem problem ->
toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
"I need the list of published packages before I can start initializing projects"
-- DIFF
data Diff
= DiffNoOutline
| DiffBadOutline Outline
| DiffApplication
| DiffNoExposed
| DiffUnpublished
| DiffUnknownPackage Pkg.Name [Pkg.Name]
| DiffUnknownVersion Pkg.Name V.Version [V.Version]
| DiffDocsProblem V.Version DocsProblem
| DiffMustHaveLatestRegistry RegistryProblem
| DiffBadDetails Details
| DiffBadBuild BuildProblem
diffToReport :: Diff -> Help.Report
diffToReport diff =
case diff of
DiffNoOutline ->
Help.report "DIFF WHAT?" Nothing
"I cannot find an elm.json so I am not sure what you want me to diff.\
\ Normally you run `elm diff` from within a project!"
[ D.reflow $ "If you are just curious to see a diff, try running this command:"
, D.indent 4 $ D.green $ "elm diff elm/http 1.0.0 2.0.0"
]
DiffBadOutline outline ->
toOutlineReport outline
DiffApplication ->
Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")
"Your elm.json says this project is an application, but `elm diff` only works\
\ with packages. That way there are previously published versions of the API to\
\ diff against!"
[ D.reflow $ "If you are just curious to see a diff, try running this command:"
, D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"
]
DiffNoExposed ->
Help.report "NO EXPOSED MODULES" (Just "elm.json")
"Your elm.json has no \"exposed-modules\" which means there is no public API at\
\ all right now! What am I supposed to diff?"
[ D.reflow $
"Try adding some modules back to the \"exposed-modules\" field."
]
DiffUnpublished ->
Help.report "UNPUBLISHED" Nothing
"This package is not published yet. There is nothing to diff against!"
[]
DiffUnknownPackage pkg suggestions ->
Help.report "UNKNOWN PACKAGE" Nothing
( "I cannot find a package called:"
)
[ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
, "Maybe you want one of these instead?"
, D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions
, "But check <https://package.elm-lang.org> to see all possibilities!"
]
DiffUnknownVersion _pkg vsn realVersions ->
Help.docReport "UNKNOWN VERSION" Nothing
( D.fillSep $
[ "Version", D.red (D.fromVersion vsn)
, "has", "never", "been", "published,", "so", "I"
, "cannot", "diff", "against", "it."
]
)
[ "Here are all the versions that HAVE been published:"
, D.indent 4 $ D.dullyellow $ D.vcat $
let
sameMajor v1 v2 = V._major v1 == V._major v2
mkRow vsns = D.hsep $ map D.fromVersion vsns
in
map mkRow $ List.groupBy sameMajor (List.sort realVersions)
, "Want one of those instead?"
]
DiffDocsProblem version problem ->
toDocsProblemReport problem $
"I need the docs for " ++ V.toChars version ++ " to compute this diff"
DiffMustHaveLatestRegistry problem ->
toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
"I need the latest list of published packages before I do this diff"
DiffBadDetails details ->
toDetailsReport details
DiffBadBuild buildProblem ->
toBuildProblemReport buildProblem
-- BUMP
data Bump
= BumpNoOutline
| BumpBadOutline Outline
| BumpApplication
| BumpUnexpectedVersion V.Version [V.Version]
| BumpMustHaveLatestRegistry RegistryProblem
| BumpCannotFindDocs Pkg.Name V.Version DocsProblem
| BumpBadDetails Details
| BumpNoExposed
| BumpBadBuild BuildProblem
bumpToReport :: Bump -> Help.Report
bumpToReport bump =
case bump of
BumpNoOutline ->
Help.report "BUMP WHAT?" Nothing
"I cannot find an elm.json so I am not sure what you want me to bump."
[ D.reflow $
"Elm packages always have an elm.json that says current the version number. If\
\ you run this command from a directory with an elm.json file, I will try to bump\
\ the version in there based on the API changes."
]
BumpBadOutline outline ->
toOutlineReport outline
BumpApplication ->
Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
"Your elm.json says this is an application. That means it cannot be published\
\ on <https://package.elm-lang.org> and therefore has no version to bump!"
[]
BumpUnexpectedVersion vsn versions ->
Help.docReport "CANNOT BUMP" (Just "elm.json")
( D.fillSep
["Your","elm.json","says","I","should","bump","relative","to","version"
,D.red (D.fromVersion vsn) <> ","
,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
,"That","means","there","is","no","API","for","me","to","diff","against","and"
,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
]
)
[ D.fillSep $
["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
, D.vcat $ map (D.green . D.fromVersion) versions
]
BumpMustHaveLatestRegistry problem ->
toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
"I need the latest list of published packages before I can bump any versions"
BumpCannotFindDocs _ version problem ->
toDocsProblemReport problem $
"I need the docs for " ++ V.toChars version ++ " to compute the next version number"
BumpBadDetails details ->
toDetailsReport details
BumpNoExposed ->
Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
( D.fillSep $
[ "To", "bump", "a", "package,", "the"
, D.dullyellow "\"exposed-modules\"", "field", "of", "your"
, "elm.json", "must", "list", "at", "least", "one", "module."
]
)
[ D.reflow $
"Try adding some modules back to the \"exposed-modules\" field."
]
BumpBadBuild problem ->
toBuildProblemReport problem
-- OVERVIEW OF VERSIONING
newPackageOverview :: String
newPackageOverview =
unlines
[ "This package has never been published before. Here's how things work:"
, ""
, " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
, ""
, " - All packages start with initial version " ++ V.toChars V.one
, ""
, " - Versions are incremented based on how the API changes:"
, ""
, " PATCH = the API is the same, no risk of breaking code"
, " MINOR = values have been added, existing values are unchanged"
, " MAJOR = existing values have been changed or removed"
, ""
, " - I will bump versions for you, automatically enforcing these rules"
, ""
]
-- PUBLISH
data Publish
= PublishNoOutline
| PublishBadOutline Outline
| PublishBadDetails Details
| PublishMustHaveLatestRegistry RegistryProblem
| PublishApplication
| PublishNotInitialVersion V.Version
| PublishAlreadyPublished V.Version
| PublishInvalidBump V.Version V.Version
| PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
| PublishNoSummary
| PublishNoExposed
| PublishNoReadme
| PublishShortReadme
| PublishNoLicense
| PublishBuildProblem BuildProblem
| PublishMissingTag V.Version
| PublishCannotGetTag V.Version Http.Error
| PublishCannotGetTagData V.Version String BS.ByteString
| PublishCannotGetZip Http.Error
| PublishCannotDecodeZip String
| PublishCannotGetDocs V.Version V.Version DocsProblem
| PublishCannotRegister Http.Error
| PublishNoGit
| PublishLocalChanges V.Version
--
| PublishZipBadDetails Details
| PublishZipApplication
| PublishZipNoExposed
| PublishZipBuildProblem BuildProblem
publishToReport :: Publish -> Help.Report
publishToReport publish =
case publish of
PublishNoOutline ->
Help.report "PUBLISH WHAT?" Nothing
"I cannot find an elm.json so I am not sure what you want me to publish."
[ D.reflow $
"Elm packages always have an elm.json that states the version number,\
\ dependencies, exposed modules, etc."
]
PublishBadOutline outline ->
toOutlineReport outline
PublishBadDetails problem ->
toDetailsReport problem
PublishMustHaveLatestRegistry problem ->
toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
"I need the latest list of published packages to make sure this is safe to publish"
PublishApplication ->
Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
PublishNotInitialVersion vsn ->
Help.docReport "INVALID VERSION" Nothing
( D.fillSep
["I","cannot","publish"
,D.red (D.fromVersion vsn)
,"as","the","initial","version."
]
)
[ D.fillSep
["Change","it","to",D.green "1.0.0","which","is"
,"the","initial","version","for","all","Elm","packages."
]
]
PublishAlreadyPublished vsn ->
Help.docReport "ALREADY PUBLISHED" Nothing
( D.vcat
[ D.fillSep
[ "Version", D.green (D.fromVersion vsn)
, "has", "already", "been", "published.", "You", "cannot"
, "publish", "it", "again!"
]
, "Try using the `bump` command:"
]
)
[ D.dullyellow $ D.indent 4 "elm bump"
, D.reflow $
"It computes the version number based on API changes, ensuring\
\ that no breaking changes end up in PATCH releases!"
]
PublishInvalidBump statedVersion latestVersion ->
Help.docReport "INVALID VERSION" (Just "elm.json")
( D.fillSep $
["Your","elm.json","says","the","next","version","should","be"
,D.red (D.fromVersion statedVersion) <> ","
,"but","that","is","not","valid","based","on","the","previously"
,"published","versions."
]
)
[ D.fillSep $
["Change","the","version","back","to"
,D.green (D.fromVersion latestVersion)
,"which","is","the","most","recently","published","version."
,"From","there,","have","Elm","bump","the","version","by","running:"
]
, D.indent 4 $ D.green "elm bump"
, D.reflow $
"If you want more insight on the API changes Elm detects, you\
\ can run `elm diff` at this point as well."
]
PublishBadBump old new magnitude realNew realMagnitude ->
Help.docReport "INVALID VERSION" (Just "elm.json")
(
D.fillSep $
["Your","elm.json","says","the","next","version","should","be"
,D.red (D.fromVersion new) <> ","
,"indicating","a",D.fromChars (M.toChars magnitude)
,"change","to","the","public","API."
,"This","does","not","match","the","API","diff","given","by:"
]
)
[ D.indent 4 $ D.fromChars $
"elm diff " ++ V.toChars old
, D.fillSep $
["This","command","says","this","is","a"
,D.fromChars (M.toChars realMagnitude)
,"change,","so","the","next","version","should","be"
,D.green (D.fromVersion realNew) <> "."
,"Double","check","everything","to","make","sure","you"
,"are","publishing","what","you","want!"
]
, D.reflow $
"Also, next time use `elm bump` and I'll figure all this out for you!"
]
PublishNoSummary ->
Help.docReport "NO SUMMARY" (Just "elm.json")
( D.fillSep $
[ "To", "publish", "a", "package,", "your", "elm.json", "must"
, "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives"
, "a", "consice", "overview", "of", "your", "project."
]
)
[ D.reflow $
"The summary must be less than 80 characters. It should describe\
\ the concrete use of your package as clearly and as plainly as possible."
]
PublishNoExposed ->
Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
( D.fillSep $
[ "To", "publish", "a", "package,", "the"
, D.dullyellow "\"exposed-modules\"", "field", "of", "your"
, "elm.json", "must", "list", "at", "least", "one", "module."
]
)
[ D.reflow $
"Which modules do you want users of the package to have access to? Add their\
\ names to the \"exposed-modules\" list."
]
PublishNoReadme ->
toBadReadmeReport "NO README" $
"Every published package must have a helpful README.md\
\ file, but I do not see one in your project."
PublishShortReadme ->
toBadReadmeReport "SHORT README" $
"This README.md is too short. Having more details will help\
\ people assess your package quickly and fairly."
PublishNoLicense ->
Help.report "NO LICENSE FILE" (Just "LICENSE")
"By publishing a package you are inviting the Elm community to build\
\ upon your work. But without knowing your license, we have no idea if\
\ that is legal!"
[ D.reflow $
"Once you pick an OSI approved license from <https://spdx.org/licenses/>,\
\ you must share that choice in two places. First, the license\
\ identifier must appear in your elm.json file. Second, the full\
\ license text must appear in the root of your project in a file\
\ named LICENSE. Add that file and you will be all set!"
]
PublishBuildProblem buildProblem ->
toBuildProblemReport buildProblem
PublishMissingTag version ->
let vsn = V.toChars version in
Help.docReport "NO TAG" Nothing
( D.fillSep $
[ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"
, "cannot", "find", "a", D.green (D.fromChars vsn), "tag."
]
)
[ D.vcat
[ "These tags make it possible to find this specific version on GitHub."
, "To tag the most recent commit and push it to GitHub, run this:"
]
, D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $
[ "git tag -a " ++ vsn ++ " -m \"new release\""
, "git push origin " ++ vsn
]
, "The -m flag is for a helpful message. Try to make it more informative!"
]
PublishCannotGetTag version httpError ->
case httpError of
Http.BadHttp _ (HTTP.StatusCodeException response _)
| HTTP.statusCode (HTTP.responseStatus response) == 404 ->
let vsn = V.toChars version in
Help.report "NO TAG ON GITHUB" Nothing
("You have version " ++ vsn ++ " tagged locally, but not on GitHub.")
[ D.reflow
"Run the following command to make this tag available on GitHub:"
, D.indent 4 $ D.dullyellow $ D.fromChars $
"git push origin " ++ vsn
, D.reflow
"This will make it possible to find your code online based on the version number."
]
_ ->
toHttpErrorReport "PROBLEM VERIFYING TAG" httpError
"I need to check that the version tag is registered on GitHub"
PublishCannotGetTagData version url body ->
Help.report "PROBLEM VERIFYING TAG" Nothing
("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:")
[ D.indent 4 $ D.dullyellow $ D.fromChars url
, D.reflow $
"I got the data back, but it was not what I was expecting. The response\
\ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
++ if BS.length body <= 76 then "whole thing:" else "beginning:"
, D.indent 4 $ D.dullyellow $ D.fromChars $
if BS.length body <= 76
then BS_UTF8.toString body
else take 73 (BS_UTF8.toString body) ++ "..."
, D.reflow $
"Does this error keep showing up? Maybe there is something weird with your\
\ internet connection. We have gotten reports that schools, businesses,\
\ airports, etc. sometimes intercept requests and add things to the body\
\ or change its contents entirely. Could that be the problem?"
]
PublishCannotGetZip httpError ->
toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $
"I need to check that folks can download and build the source code when they\
\ install this package"
PublishCannotDecodeZip url ->
Help.report "PROBLEM DOWNLOADING CODE" Nothing
"I need to check that folks can download and build the source code when they\
\ install this package, so I downloaded the code from:"
[ D.indent 4 $ D.dullyellow $ D.fromChars url
, D.reflow $
"I was unable to unzip the archive though. Maybe there is something weird with\
\ your internet connection. We have gotten reports that schools, businesses,\
\ airports, etc. sometimes intercept requests and add things to the body or\
\ change its contents entirely. Could that be the problem?"
]
PublishCannotGetDocs old new docsProblem ->
toDocsProblemReport docsProblem $
"I need the docs for " ++ V.toChars old ++ " to verify that "
++ V.toChars new ++ " really does come next"
PublishCannotRegister httpError ->
toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $
"I need to send information about your package to the package website"
PublishNoGit ->
Help.report "NO GIT" Nothing
"I searched your PATH environment variable for `git` and could not\
\ find it. Is it available through your PATH?"
[ D.reflow $
"Who cares about this? Well, I currently use `git` to check if there\
\ are any local changes in your code. Local changes are a good sign\
\ that some important improvements have gotten mistagged, so this\
\ check can be extremely helpful for package authors!"
, D.toSimpleNote $
"We plan to do this without the `git` binary in a future release."
]
PublishLocalChanges version ->
let vsn = V.toChars version in
Help.docReport "LOCAL CHANGES" Nothing
( D.fillSep $
[ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in"
, "git", "does", "not", "match", "the", "code", "in", "your"
, "working", "directory.", "This", "means", "you", "have"
, "commits", "or", "local", "changes", "that", "are", "not"
, "going", "to", "be", "published!"
]
)
[ D.toSimpleNote $
"If you are sure everything is in order, you can run `git checkout "
++ vsn ++ "` and publish your code from there."
]
PublishZipBadDetails _ ->
badZipReport
PublishZipApplication ->
badZipReport
PublishZipNoExposed ->
badZipReport
PublishZipBuildProblem _ ->
badZipReport
toBadReadmeReport :: String -> String -> Help.Report
toBadReadmeReport title summary =
Help.report title (Just "README.md") summary
[ D.reflow $
"When people look at your README, they are wondering:"
, D.vcat
[ " - What does this package even do?"
, " - Will it help me solve MY problems?"
]
, D.reflow $
"So I recommend starting your README with a small example of the\
\ most common usage scenario. Show people what they can expect if\
\ they learn more!"
, D.toSimpleNote $
"By publishing your package, you are inviting people to invest time in\
\ understanding your work. Spending an hour on your README to communicate your\
\ knowledge more clearly can save the community days or weeks of time in\
\ aggregate, and saving time in aggregate is the whole point of publishing\
\ packages! People really appreciate it, and it makes the whole ecosystem feel\
\ nicer!"
]
badZipReport :: Help.Report
badZipReport =
Help.report "PROBLEM VERIFYING PACKAGE" Nothing
"Before publishing packages, I download the code from GitHub and try to build it\
\ from scratch. That way I can be more confident that it will work for other\
\ people too. But I am not able to build it!"
[ D.reflow $
"I was just able to build your local copy though. Is there some way the version\
\ on GitHub could be different?"
]
-- DOCS
data DocsProblem
= DP_Http Http.Error
| DP_Data String BS.ByteString
| DP_Cache
toDocsProblemReport :: DocsProblem -> String -> Help.Report
toDocsProblemReport problem context =
case problem of
DP_Http httpError ->
toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
DP_Data url body ->
Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
[ D.indent 4 $ D.dullyellow $ D.fromChars url
, D.reflow $
"I got the data back, but it was not what I was expecting. The response\
\ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
++ if BS.length body <= 76 then "whole thing:" else "beginning:"
, D.indent 4 $ D.dullyellow $ D.fromChars $
if BS.length body <= 76
then BS_UTF8.toString body
else take 73 (BS_UTF8.toString body) ++ "..."
, D.reflow $
"Does this error keep showing up? Maybe there is something weird with your\
\ internet connection. We have gotten reports that schools, businesses,\
\ airports, etc. sometimes intercept requests and add things to the body\
\ or change its contents entirely. Could that be the problem?"
]
DP_Cache ->
Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
[ D.reflow $
"I deleted the cached version, so the next run should download a fresh copy of\
\ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
\ problem if, for example, a 3rd party editor plugin is modifing cached files\
\ for some reason."
]
-- INSTALL
data Install
= InstallNoOutline
| InstallBadOutline Outline
| InstallBadRegistry RegistryProblem
| InstallNoArgs FilePath
| InstallNoOnlineAppSolution Pkg.Name
| InstallNoOfflineAppSolution Pkg.Name
| InstallNoOnlinePkgSolution Pkg.Name
| InstallNoOfflinePkgSolution Pkg.Name
| InstallHadSolverTrouble Solver
| InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
| InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
| InstallBadDetails Details
installToReport :: Install -> Help.Report
installToReport exit =
case exit of
InstallNoOutline ->
Help.report "NEW PROJECT?" Nothing
"Are you trying to start a new project? Try this command instead:"
[ D.indent 4 $ D.green "elm init"
, D.reflow "It will help you get started!"
]
InstallBadOutline outline ->
toOutlineReport outline
InstallBadRegistry problem ->
toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
"I need the list of published packages to figure out how to install things"
InstallNoArgs elmHome ->
Help.report "INSTALL WHAT?" Nothing
"I am expecting commands like:"
[ D.green $ D.indent 4 $ D.vcat $
[ "elm install elm/http"
, "elm install elm/json"
, "elm install elm/random"
]
, D.toFancyHint
["In","JavaScript","folks","run","`npm install`","to","start","projects."
,"\"Gotta","download","everything!\"","But","why","download","packages"
,"again","and","again?","Instead,","Elm","caches","packages","in"
,D.dullyellow (D.fromChars elmHome)
,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
,"Elm","projects","check","that","cache","before","trying","the","internet."
,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
,"easier","to","work","offline.","As","a","result"
,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
]
]
InstallNoOnlineAppSolution pkg ->
Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
(
"I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
\ with your existing dependencies."
)
[ D.reflow $
"I checked all the published versions. When that failed, I tried to find any\
\ compatible combination of these packages, even if it meant changing all your\
\ existing dependencies! That did not work either!"
, D.reflow $
"This is most likely to happen when a package is not upgraded yet. Maybe a new\
\ version of Elm came out recently? Maybe a common package was changed recently?\
\ Maybe a better package came along, so there was no need to upgrade this one?\
\ Try asking around https://elm-lang.org/community to learn what might be going on\
\ with this package."
, D.toSimpleNote $
"Whatever the case, please be kind to the relevant package authors! Having\
\ friendly interactions with users is great motivation, and conversely, getting\
\ berated by strangers on the internet sucks your soul dry. Furthermore, package\
\ authors are humans with families, friends, jobs, vacations, responsibilities,\
\ goals, etc. They face obstacles outside of their technical work you will never\
\ know about, so please assume the best and try to be patient and supportive!"
]
InstallNoOfflineAppSolution pkg ->
Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
(
"I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
\ with your existing dependencies."
)
[ D.reflow $
"I was not able to connect to https://package.elm-lang.org/ though, so I was only\
\ able to look through packages that you have downloaded in the past."
, D.reflow $
"Try again later when you have internet!"
]
InstallNoOnlinePkgSolution pkg ->
Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
(
"I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
\ with your existing constraints."
)
[ D.reflow $
"With applications, I try to broaden the constraints to see if anything works,\
\ but messing with package constraints is much more delicate business. E.g. making\
\ your constraints stricter may make it harder for applications to find compatible\
\ dependencies. So fixing something here may break it for a lot of other people!"
, D.reflow $
"So I recommend making an application with the same dependencies as your package.\
\ See if there is a solution at all. From there it may be easier to figure out\
\ how to proceed in a way that will disrupt your users as little as possible. And\
\ the solution may be to help other package authors to get their packages updated,\
\ or to drop a dependency entirely."
]
InstallNoOfflinePkgSolution pkg ->
Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
(
"I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
\ with your existing constraints."
)
[ D.reflow $
"I was not able to connect to https://package.elm-lang.org/ though, so I was only\
\ able to look through packages that you have downloaded in the past."
, D.reflow $
"Try again later when you have internet!"
]
InstallHadSolverTrouble solver ->
toSolverReport solver
InstallUnknownPackageOnline pkg suggestions ->
Help.docReport "UNKNOWN PACKAGE" Nothing
(
D.fillSep
["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
)
[ D.reflow $
"I looked through https://package.elm-lang.org for packages with similar names\
\ and found these:"
, D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
, D.reflow $ "Maybe you want one of these instead?"
]
InstallUnknownPackageOffline pkg suggestions ->
Help.docReport "UNKNOWN PACKAGE" Nothing
(
D.fillSep
["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
)
[ D.reflow $
"I could not connect to https://package.elm-lang.org though, so new packages may\
\ have been published since I last updated my local cache of package names."
, D.reflow $
"Looking through the locally cached names, the closest ones are:"
, D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
, D.reflow $ "Maybe you want one of these instead?"
]
InstallBadDetails details ->
toDetailsReport details
-- SOLVER
data Solver
= SolverBadCacheData Pkg.Name V.Version
| SolverBadHttpData Pkg.Name V.Version String
| SolverBadHttp Pkg.Name V.Version Http.Error
toSolverReport :: Solver -> Help.Report
toSolverReport problem =
case problem of
SolverBadCacheData pkg vsn ->
Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
(
"I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
\ help me search for a set of compatible packages. I had it cached locally, but\
\ it looks like the file was corrupted!"
)
[ D.reflow $
"I deleted the cached version, so the next run should download a fresh copy.\
\ Hopefully that will get you unstuck, but it will not resolve the root\
\ problem if a 3rd party tool is modifing cached files for some reason."
]
SolverBadHttpData pkg vsn url ->
Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
(
"I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
\ help me search for a set of compatible packages, but I ran into corrupted\
\ information from:"
)
[ D.indent 4 $ D.dullyellow $ D.fromChars url
, D.reflow $
"Is something weird with your internet connection. We have gotten reports that\
\ schools, businesses, airports, etc. sometimes intercept requests and add things\
\ to the body or change its contents entirely. Could that be the problem?"
]
SolverBadHttp pkg vsn httpError ->
toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $
"I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
++ " to help me search for a set of compatible packages"
-- OUTLINE
data Outline
= OutlineHasBadStructure (Decode.Error OutlineProblem)
| OutlineHasMissingSrcDirs FilePath [FilePath]
| OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
| OutlineNoPkgCore
| OutlineNoAppCore
| OutlineNoAppJson
data OutlineProblem
= OP_BadType
| OP_BadPkgName Row Col
| OP_BadVersion Row Col
| OP_BadConstraint C.Error
| OP_BadModuleName Row Col
| OP_BadModuleHeaderTooLong
| OP_BadDependencyName Row Col
| OP_BadLicense Json.String [Json.String]
| OP_BadSummaryTooLong
| OP_NoSrcDirs
toOutlineReport :: Outline -> Help.Report
toOutlineReport problem =
case problem of
OutlineHasBadStructure decodeError ->
Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $
Json.ExplicitReason "I ran into a problem with your elm.json file."
OutlineHasMissingSrcDirs dir dirs ->
case dirs of
[] ->
Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")
"I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"
[ D.indent 4 $ D.red $ D.fromChars dir
, D.reflow $
"I cannot find it though. Is it missing? Is there a typo?"
]
_:_ ->
Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")
"I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"
[ D.indent 4 $ D.vcat $
map (D.red . D.fromChars) (dir:dirs)
, D.reflow $
"I cannot find them though. Are they missing? Are there typos?"
]
OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->
if dir1 == dir2 then
Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
"I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"
[ D.indent 4 $ D.vcat $
map (D.red . D.fromChars) [dir1,dir2]
, D.reflow $
"Remove one of the entries!"
]
else
Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
"I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"
[ D.indent 4 $ D.vcat $
map (D.red . D.fromChars) [dir1,dir2]
, D.reflow $
"These are two different ways of refering to the same directory:"
, D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir
, D.reflow $
"Remove one of the redundant entries from your \"source-directories\" field."
]
OutlineNoPkgCore ->
Help.report "MISSING DEPENDENCY" (Just "elm.json")
"I need to see an \"elm/core\" dependency your elm.json file. The default imports\
\ of `List` and `Maybe` do not work without it."
[ D.reflow $
"If you modified your elm.json by hand, try to change it back! And if you are\
\ having trouble getting back to a working elm.json, it may be easier to find a\
\ working package and start fresh with their elm.json file."
]
OutlineNoAppCore ->
Help.report "MISSING DEPENDENCY" (Just "elm.json")
"I need to see an \"elm/core\" dependency your elm.json file. The default imports\
\ of `List` and `Maybe` do not work without it."
[ D.reflow $
"If you modified your elm.json by hand, try to change it back! And if you are\
\ having trouble getting back to a working elm.json, it may be easier to delete it\
\ and use `elm init` to start fresh."
]
OutlineNoAppJson ->
Help.report "MISSING DEPENDENCY" (Just "elm.json")
"I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\
\ flags and ports."
[ D.reflow $
"If you modified your elm.json by hand, try to change it back! And if you are\
\ having trouble getting back to a working elm.json, it may be easier to delete it\
\ and use `elm init` to start fresh."
]
toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
toOutlineProblemReport path source _ region problem =
let
toHighlight row col =
Just $ A.Region (A.Position row col) (A.Position row col)
toSnippet title highlight pair =
Help.jsonReport title (Just path) $
Code.toSnippet source region highlight pair
in
case problem of
OP_BadType ->
toSnippet "UNEXPECTED TYPE" Nothing
( D.reflow $
"I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"
, D.fillSep
["Try","changing","the","\"type\"","to"
,D.green "\"application\"","or",D.green "\"package\"","instead."
]
)
OP_BadPkgName row col ->
toSnippet "INVALID PACKAGE NAME" (toHighlight row col)
( D.reflow $
"I got stuck while reading your elm.json file. I ran into trouble with the package name:"
, D.stack
[ D.fillSep
["Package","names","are","always","written","as"
,D.green "\"author/project\""
,"so","I","am","expecting","to","see","something","like:"
]
, D.dullyellow $ D.indent 4 $ D.vcat $
[ "\"mdgriffith/elm-ui\""
, "\"w0rm/elm-physics\""
, "\"Microsoft/elm-json-tree-view\""
, "\"FordLabs/elm-star-rating\""
, "\"1602/json-schema\""
]
, D.reflow
"The author name should match your GitHub name exactly, and the project name\
\ needs to follow these rules:"
, D.indent 4 $ D.vcat $
[ "+--------------------------------------+-----------+-----------+"
, "| RULE | BAD | GOOD |"
, "+--------------------------------------+-----------+-----------+"
, "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"
, "| no leading digits | 3D | elm-3d |"
, "| no non-ASCII characters | elm-bjørn | elm-bear |"
, "| no underscores | elm_ui | elm-ui |"
, "| no double hyphens | elm--hash | elm-hash |"
, "| no starting or ending hyphen | -elm-tar- | elm-tar |"
, "+--------------------------------------+-----------+-----------+"
]
, D.toSimpleNote $
"These rules only apply to the project name, so you should never need\
\ to change your GitHub name!"
]
)
OP_BadVersion row col ->
toSnippet "PROBLEM WITH VERSION" (toHighlight row col)
( D.reflow $
"I got stuck while reading your elm.json file. I was expecting a version number here:"
, D.fillSep
["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""
,"that","explicitly","states","all","three","numbers!"
]
)
OP_BadConstraint constraintError ->
case constraintError of
C.BadFormat row col ->
toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)
( D.reflow $
"I got stuck while reading your elm.json file. I do not understand this version constraint:"
, D.stack
[ D.fillSep
["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""
,"that","explicitly","lists","the","lower","and","upper","bounds."
]
, D.toSimpleNote $
"The spaces in there are required! Taking them out will confuse me. Adding\
\ extra spaces confuses me too. I recommend starting with a valid example\
\ and just changing the version numbers."
]
)
C.InvalidRange before after ->
if before == after then
toSnippet "PROBLEM WITH CONSTRAINT" Nothing
( D.reflow $
"I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
, D.fillSep
["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"
,"so","it","is","best","to","use","wide","constraints.","I","recommend"
,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""
,"since","it","is","guaranteed","that","breaking","API","changes","cannot"
,"happen","in","any","of","the","versions","in","that","range."
]
)
else
toSnippet "PROBLEM WITH CONSTRAINT" Nothing
( D.reflow $
"I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
, D.fillSep
["Maybe","you","want","something","like"
,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""
,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"
,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"
,"cannot","happen","in","any","of","the","versions","in","that","range."
]
)
OP_BadModuleName row col ->
toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)
( D.reflow $
"I got stuck while reading your elm.json file. I was expecting a module name here:"
, D.fillSep
["I","need","something","like",D.green "\"Html.Events\""
,"or",D.green "\"Browser.Navigation\""
,"where","each","segment","starts","with","a","capital"
,"letter","and","the","segments","are","separated","by","dots."
]
)
OP_BadModuleHeaderTooLong ->
toSnippet "HEADER TOO LONG" Nothing
( D.reflow $
"I got stuck while reading your elm.json file. This section header is too long:"
, D.stack
[ D.fillSep
["I","need","it","to","be"
,D.green "under",D.green "20",D.green "bytes"
,"so","it","renders","nicely","on","the","package","website!"
]
, D.toSimpleNote
"I count the length in bytes, so using non-ASCII characters costs extra.\
\ Please report your case at https://github.com/elm/compiler/issues if this seems\
\ overly restrictive for your needs."
]
)
OP_BadDependencyName row col ->
toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)
( D.reflow $
"I got stuck while reading your elm.json file. There is something wrong with this dependency name:"
, D.stack
[ D.fillSep
["Package","names","always","include","the","name","of","the","author,"
,"so","I","am","expecting","to","see","dependencies","like"
,D.dullyellow "\"mdgriffith/elm-ui\"","and"
,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."
]
, D.fillSep $
["I","generally","recommend","finding","the","package","you","want","on"
,"the","package","website,","and","installing","it","with","the"
,D.green "elm install","command!"
]
]
)
OP_BadLicense _ suggestions ->
toSnippet "UNKNOWN LICENSE" Nothing
( D.reflow $
"I got stuck while reading your elm.json file. I do not know about this type of license:"
,
D.stack
[ D.fillSep
["Elm","packages","generally","use"
,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","
,"but","I","accept","any","OSI","approved","SPDX","license."
,"Here","some","that","seem","close","to","what","you","wrote:"
]
, D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions
, D.reflow $
"Check out https://spdx.org/licenses/ for the full list of options."
]
)
OP_BadSummaryTooLong ->
toSnippet "SUMMARY TOO LONG" Nothing
( D.reflow $
"I got stuck while reading your elm.json file. Your \"summary\" is too long:"
, D.stack
[ D.fillSep
["I","need","it","to","be"
,D.green "under",D.green "80",D.green "bytes"
,"so","it","renders","nicely","on","the","package","website!"
]
, D.toSimpleNote
"I count the length in bytes, so using non-ASCII characters costs extra.\
\ Please report your case at https://github.com/elm/compiler/issues if this seems\
\ overly restrictive for your needs."
]
)
OP_NoSrcDirs ->
toSnippet "NO SOURCE DIRECTORIES" Nothing
( D.reflow $
"I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
, D.fillSep
["I","need","something","like",D.green "[\"src\"]"
,"so","I","know","where","to","look","for","your","modules!"
]
)
-- DETAILS
data Details
= DetailsNoSolution
| DetailsNoOfflineSolution
| DetailsSolverProblem Solver
| DetailsBadElmInPkg C.Constraint
| DetailsBadElmInAppOutline V.Version
| DetailsHandEditedDependencies
| DetailsBadOutline Outline
| DetailsCannotGetRegistry RegistryProblem
| DetailsBadDeps FilePath [DetailsBadDep]
data DetailsBadDep
= BD_BadDownload Pkg.Name V.Version PackageProblem
| BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version)
toDetailsReport :: Details -> Help.Report
toDetailsReport details =
case details of
DetailsNoSolution ->
Help.report "INCOMPATIBLE DEPENDENCIES" (Just "elm.json")
"The dependencies in your elm.json are not compatible."
[ D.fillSep
["Did","you","change","them","by","hand?","Try","to","change","it","back!"
,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
]
, D.reflow $
"Please ask for help on the community forums if you try those paths and are still\
\ having problems!"
]
DetailsNoOfflineSolution ->
Help.report "TROUBLE VERIFYING DEPENDENCIES" (Just "elm.json")
"I could not connect to https://package.elm-lang.org to get the latest list of\
\ packages, and I was unable to verify your dependencies with the information I\
\ have cached locally."
[ D.reflow $
"Are you able to connect to the internet? These dependencies may work once you\
\ get access to the registry!"
, D.toFancyNote
["If","you","changed","your","dependencies","by","hand,","try","to","change","them","back!"
,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
]
]
DetailsSolverProblem solver ->
toSolverReport solver
DetailsBadElmInPkg constraint ->
Help.report "ELM VERSION MISMATCH" (Just "elm.json")
"Your elm.json says this package needs a version of Elm in this range:"
[ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint
, D.fillSep
[ "But", "you", "are", "using", "Elm"
, D.red (D.fromVersion V.compiler)
, "right", "now."
]
]
DetailsBadElmInAppOutline version ->
Help.report "ELM VERSION MISMATCH" (Just "elm.json")
"Your elm.json says this application needs a different version of Elm."
[ D.fillSep
[ "It", "requires"
, D.green (D.fromVersion version) <> ","
, "but", "you", "are", "using"
, D.red (D.fromVersion V.compiler)
, "right", "now."
]
]
DetailsHandEditedDependencies ->
Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")
"It looks like the dependencies elm.json in were edited by hand (or by a 3rd\
\ party tool) leaving them in an invalid state."
[ D.fillSep
["Try","to","change","them","back","to","what","they","were","before!"
,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
]
, D.reflow $
"Please ask for help on the community forums if you try those paths and are still\
\ having problems!"
]
DetailsBadOutline outline ->
toOutlineReport outline
DetailsCannotGetRegistry problem ->
toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
"I need the list of published packages to verify your dependencies"
DetailsBadDeps cacheDir deps ->
case List.sortOn toBadDepRank deps of
[] ->
Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
"I am not sure what is going wrong though."
[ D.reflow $
"I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\
\ trying to build again. That will work if some cached files got corrupted\
\ somehow."
, D.reflow $
"If that does not work, go to https://elm-lang.org/community and ask for\
\ help. This is a weird case!"
]
d:_ ->
case d of
BD_BadDownload pkg vsn packageProblem ->
toPackageProblemReport pkg vsn packageProblem
BD_BadBuild pkg vsn fingerprint ->
Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
"I ran into a compilation error when trying to build the following package:"
[ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
, D.reflow $
"This probably means it has package constraints that are too wide. It may be\
\ possible to tweak your elm.json to avoid the root problem as a stopgap. Head\
\ over to https://elm-lang.org/community to get help figuring out how to take\
\ this path!"
, D.toSimpleNote $
"To help with the root problem, please report this to the package author along\
\ with the following information:"
, D.indent 4 $ D.vcat $
map (\(p,v) -> D.fromChars $ Pkg.toChars p ++ " " ++ V.toChars v) $
Map.toList fingerprint
, D.reflow $
"If you want to help out even more, try building the package locally. That should\
\ give you much more specific information about why this package is failing to\
\ build, which will in turn make it easier for the package author to fix it!"
]
toBadDepRank :: DetailsBadDep -> Int -- lower is better
toBadDepRank badDep =
case badDep of
BD_BadDownload _ _ _ -> 0
BD_BadBuild _ _ _ -> 1
-- PACKAGE PROBLEM
data PackageProblem
= PP_BadEndpointRequest Http.Error
| PP_BadEndpointContent String
| PP_BadArchiveRequest Http.Error
| PP_BadArchiveContent String
| PP_BadArchiveHash String String String
toPackageProblemReport :: Pkg.Name -> V.Version -> PackageProblem -> Help.Report
toPackageProblemReport pkg vsn problem =
let
thePackage =
Pkg.toChars pkg ++ " " ++ V.toChars vsn
in
case problem of
PP_BadEndpointRequest httpError ->
toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
"I need to find the latest download link for " ++ thePackage
PP_BadEndpointContent url ->
Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
(
"I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:"
)
[ D.indent 4 $ D.dullyellow $ D.fromChars url
, D.reflow $
"Is something weird with your internet connection. We have gotten reports that\
\ schools, businesses, airports, etc. sometimes intercept requests and add things\
\ to the body or change its contents entirely. Could that be the problem?"
]
PP_BadArchiveRequest httpError ->
toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
"I was trying to download the source code for " ++ thePackage
PP_BadArchiveContent url ->
Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
(
"I downloaded the source code for " ++ thePackage ++ " from:"
)
[ D.indent 4 $ D.dullyellow $ D.fromChars url
, D.reflow $
"But I was unable to unzip the data. Maybe there is something weird with\
\ your internet connection. We have gotten reports that schools, businesses,\
\ airports, etc. sometimes intercept requests and add things to the body or\
\ change its contents entirely. Could that be the problem?"
]
PP_BadArchiveHash url expectedHash actualHash ->
Help.report "CORRUPT PACKAGE DATA" Nothing
(
"I downloaded the source code for " ++ thePackage ++ " from:"
)
[ D.indent 4 $ D.dullyellow $ D.fromChars url
, D.reflow "But it looks like the hash of the archive has changed since publication:"
, D.vcat $ map D.fromChars $
[ " Expected: " ++ expectedHash
, " Actual: " ++ actualHash
]
, D.reflow $
"This usually means that the package author moved the version\
\ tag, so report it to them and see if that is the issue. Folks\
\ on Elm slack can probably help as well."
]
-- REGISTRY PROBLEM
data RegistryProblem
= RP_Http Http.Error
| RP_Data String BS.ByteString
toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report
toRegistryProblemReport title problem context =
case problem of
RP_Http err ->
toHttpErrorReport title err context
RP_Data url body ->
Help.report title Nothing (context ++ ", so I fetched:")
[ D.indent 4 $ D.dullyellow $ D.fromChars url
, D.reflow $
"I got the data back, but it was not what I was expecting. The response\
\ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
++ if BS.length body <= 76 then "whole thing:" else "beginning:"
, D.indent 4 $ D.dullyellow $ D.fromChars $
if BS.length body <= 76
then BS_UTF8.toString body
else take 73 (BS_UTF8.toString body) ++ "..."
, D.reflow $
"Does this error keep showing up? Maybe there is something weird with your\
\ internet connection. We have gotten reports that schools, businesses,\
\ airports, etc. sometimes intercept requests and add things to the body\
\ or change its contents entirely. Could that be the problem?"
]
toHttpErrorReport :: String -> Http.Error -> String -> Help.Report
toHttpErrorReport title err context =
let
toHttpReport intro url details =
Help.report title Nothing intro $
D.indent 4 (D.dullyellow (D.fromChars url)) : details
in
case err of
Http.BadUrl url reason ->
toHttpReport (context ++ ", so I wanted to fetch:") url
[ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"
, D.indent 4 $ D.fromChars reason
, D.reflow $
"This may indicate that there is some problem in the compiler, so please op
gitextract_rbjgnatp/
├── .github/
│ ├── CONTRIBUTING.md
│ ├── ISSUE_TEMPLATE.md
│ ├── PULL_REQUEST_TEMPLATE.md
│ └── workflows/
│ ├── set-issue-expectations.yml
│ └── set-pull-expectations.yml
├── .gitignore
├── .travis.yml
├── LICENSE
├── README.md
├── builder/
│ └── src/
│ ├── BackgroundWriter.hs
│ ├── Build.hs
│ ├── Deps/
│ │ ├── Bump.hs
│ │ ├── Diff.hs
│ │ ├── Registry.hs
│ │ ├── Solver.hs
│ │ └── Website.hs
│ ├── Elm/
│ │ ├── Details.hs
│ │ └── Outline.hs
│ ├── File.hs
│ ├── Generate.hs
│ ├── Http.hs
│ ├── Reporting/
│ │ ├── Exit/
│ │ │ └── Help.hs
│ │ ├── Exit.hs
│ │ └── Task.hs
│ ├── Reporting.hs
│ └── Stuff.hs
├── cabal.config
├── compiler/
│ └── src/
│ ├── AST/
│ │ ├── Canonical.hs
│ │ ├── Optimized.hs
│ │ ├── Source.hs
│ │ └── Utils/
│ │ ├── Binop.hs
│ │ ├── Shader.hs
│ │ └── Type.hs
│ ├── Canonicalize/
│ │ ├── Effects.hs
│ │ ├── Environment/
│ │ │ ├── Dups.hs
│ │ │ ├── Foreign.hs
│ │ │ └── Local.hs
│ │ ├── Environment.hs
│ │ ├── Expression.hs
│ │ ├── Module.hs
│ │ ├── Pattern.hs
│ │ └── Type.hs
│ ├── Compile.hs
│ ├── Data/
│ │ ├── Bag.hs
│ │ ├── Index.hs
│ │ ├── Map/
│ │ │ └── Utils.hs
│ │ ├── Name.hs
│ │ ├── NonEmptyList.hs
│ │ ├── OneOrMore.hs
│ │ └── Utf8.hs
│ ├── Elm/
│ │ ├── Compiler/
│ │ │ ├── Imports.hs
│ │ │ ├── Type/
│ │ │ │ └── Extract.hs
│ │ │ └── Type.hs
│ │ ├── Constraint.hs
│ │ ├── Docs.hs
│ │ ├── Float.hs
│ │ ├── Interface.hs
│ │ ├── Kernel.hs
│ │ ├── Licenses.hs
│ │ ├── Magnitude.hs
│ │ ├── ModuleName.hs
│ │ ├── Package.hs
│ │ ├── String.hs
│ │ └── Version.hs
│ ├── Generate/
│ │ ├── Html.hs
│ │ ├── JavaScript/
│ │ │ ├── Builder.hs
│ │ │ ├── Expression.hs
│ │ │ ├── Functions.hs
│ │ │ └── Name.hs
│ │ ├── JavaScript.hs
│ │ └── Mode.hs
│ ├── Json/
│ │ ├── Decode.hs
│ │ ├── Encode.hs
│ │ └── String.hs
│ ├── Nitpick/
│ │ ├── Debug.hs
│ │ └── PatternMatches.hs
│ ├── Optimize/
│ │ ├── Case.hs
│ │ ├── DecisionTree.hs
│ │ ├── Expression.hs
│ │ ├── Module.hs
│ │ ├── Names.hs
│ │ └── Port.hs
│ ├── Parse/
│ │ ├── Declaration.hs
│ │ ├── Expression.hs
│ │ ├── Keyword.hs
│ │ ├── Module.hs
│ │ ├── Number.hs
│ │ ├── Pattern.hs
│ │ ├── Primitives.hs
│ │ ├── Shader.hs
│ │ ├── Space.hs
│ │ ├── String.hs
│ │ ├── Symbol.hs
│ │ ├── Type.hs
│ │ └── Variable.hs
│ ├── Reporting/
│ │ ├── Annotation.hs
│ │ ├── Doc.hs
│ │ ├── Error/
│ │ │ ├── Canonicalize.hs
│ │ │ ├── Docs.hs
│ │ │ ├── Import.hs
│ │ │ ├── Json.hs
│ │ │ ├── Main.hs
│ │ │ ├── Pattern.hs
│ │ │ ├── Syntax.hs
│ │ │ └── Type.hs
│ │ ├── Error.hs
│ │ ├── Render/
│ │ │ ├── Code.hs
│ │ │ ├── Type/
│ │ │ │ └── Localizer.hs
│ │ │ └── Type.hs
│ │ ├── Report.hs
│ │ ├── Result.hs
│ │ ├── Suggest.hs
│ │ └── Warning.hs
│ └── Type/
│ ├── Constrain/
│ │ ├── Expression.hs
│ │ ├── Module.hs
│ │ └── Pattern.hs
│ ├── Error.hs
│ ├── Instantiate.hs
│ ├── Occurs.hs
│ ├── Solve.hs
│ ├── Type.hs
│ ├── Unify.hs
│ └── UnionFind.hs
├── docs/
│ ├── elm.json/
│ │ ├── application.md
│ │ └── package.md
│ └── upgrade-instructions/
│ ├── 0.16.md
│ ├── 0.17.md
│ ├── 0.18.md
│ ├── 0.19.0.md
│ ├── 0.19.1.md
│ └── earlier.md
├── elm.cabal
├── hints/
│ ├── bad-recursion.md
│ ├── comparing-custom-types.md
│ ├── comparing-records.md
│ ├── implicit-casts.md
│ ├── import-cycles.md
│ ├── imports.md
│ ├── infinite-type.md
│ ├── init.md
│ ├── missing-patterns.md
│ ├── optimize.md
│ ├── port-modules.md
│ ├── recursive-alias.md
│ ├── repl.md
│ ├── shadowing.md
│ ├── tuples.md
│ └── type-annotations.md
├── installers/
│ ├── README.md
│ ├── linux/
│ │ ├── Dockerfile
│ │ └── README.md
│ ├── mac/
│ │ ├── Distribution.xml
│ │ ├── README.md
│ │ ├── Resources/
│ │ │ └── en.lproj/
│ │ │ ├── conclusion.rtf
│ │ │ └── welcome.rtf
│ │ ├── helper-scripts/
│ │ │ ├── elm-startup.sh
│ │ │ └── uninstall.sh
│ │ ├── make-installer.sh
│ │ ├── postinstall
│ │ └── preinstall
│ ├── npm/
│ │ ├── .gitignore
│ │ ├── .npmignore
│ │ ├── PUBLISHING.md
│ │ ├── README.md
│ │ ├── bin/
│ │ │ └── elm
│ │ ├── binary.js
│ │ ├── install.js
│ │ ├── package.json
│ │ ├── packages/
│ │ │ ├── darwin_arm64/
│ │ │ │ ├── README.md
│ │ │ │ └── package.json
│ │ │ ├── darwin_x64/
│ │ │ │ ├── README.md
│ │ │ │ └── package.json
│ │ │ ├── linux_arm64/
│ │ │ │ ├── README.md
│ │ │ │ └── package.json
│ │ │ ├── linux_x64/
│ │ │ │ ├── README.md
│ │ │ │ └── package.json
│ │ │ └── win32_x64/
│ │ │ ├── README.md
│ │ │ └── package.json
│ │ └── troubleshooting.md
│ └── win/
│ ├── CreateInternetShortcut.nsh
│ ├── Nsisfile.nsi
│ ├── README.md
│ ├── make_installer.cmd
│ ├── removefrompath.vbs
│ └── updatepath.vbs
├── reactor/
│ ├── assets/
│ │ └── styles.css
│ ├── check.py
│ ├── elm.json
│ └── src/
│ ├── Deps.elm
│ ├── Errors.elm
│ ├── Index/
│ │ ├── Icon.elm
│ │ ├── Navigator.elm
│ │ └── Skeleton.elm
│ ├── Index.elm
│ ├── NotFound.elm
│ └── mock.txt
├── roadmap.md
├── terminal/
│ ├── impl/
│ │ ├── Terminal/
│ │ │ ├── Chomp.hs
│ │ │ ├── Error.hs
│ │ │ ├── Helpers.hs
│ │ │ └── Internal.hs
│ │ └── Terminal.hs
│ └── src/
│ ├── Bump.hs
│ ├── Develop/
│ │ ├── Generate/
│ │ │ ├── Help.hs
│ │ │ └── Index.hs
│ │ ├── Socket.hs
│ │ ├── StaticFiles/
│ │ │ └── Build.hs
│ │ └── StaticFiles.hs
│ ├── Develop.hs
│ ├── Diff.hs
│ ├── Init.hs
│ ├── Install.hs
│ ├── Main.hs
│ ├── Make.hs
│ ├── Publish.hs
│ └── Repl.hs
└── worker/
├── elm.cabal
├── elm.json
├── logrotate.conf
├── nginx.conf
├── outlines/
│ ├── compile/
│ │ └── elm.json
│ └── repl/
│ └── elm.json
└── src/
├── Artifacts.hs
├── Cors.hs
├── Endpoint/
│ ├── Compile.hs
│ ├── Quotes.hs
│ ├── Repl.hs
│ └── Slack.hs
├── Errors.elm
└── Main.hs
SYMBOL INDEX (4 symbols across 2 files) FILE: installers/npm/binary.js function verifyPlatform (line 73) | function verifyPlatform(version, subPackageName) function exitFailure (line 97) | function exitFailure(version, message) function missingSubPackageHelp (line 115) | function missingSubPackageHelp(subPackageName) FILE: reactor/check.py function mostRecentModification (line 9) | def mostRecentModification(directory):
Condensed preview — 230 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (1,731K chars).
[
{
"path": ".github/CONTRIBUTING.md",
"chars": 1918,
"preview": "# Contributing to Elm\n\nThanks helping with the development of Elm! This document describes the basic\nstandards for openi"
},
{
"path": ".github/ISSUE_TEMPLATE.md",
"chars": 139,
"preview": "\n**Quick Summary:** ???\n\n\n## SSCCE\n\n```elm\n\n```\n\n- **Elm:** ???\n- **Browser:** ???\n- **Operating System:** ???\n\n\n## Addi"
},
{
"path": ".github/PULL_REQUEST_TEMPLATE.md",
"chars": 140,
"preview": "\n**Quick Summary:** ???\n\n\n## SSCCE\n\n```elm\n\n```\n\n- **Elm:** ???\n- **Browser:** ???\n- **Operating System:** ???\n\n\n## Addi"
},
{
"path": ".github/workflows/set-issue-expectations.yml",
"chars": 901,
"preview": "name: Set Issue Expectations\non:\n issues:\n types: [opened]\njobs:\n comment-on-issue:\n name: Comment On Issue\n "
},
{
"path": ".github/workflows/set-pull-expectations.yml",
"chars": 1182,
"preview": "on:\n pull_request_target:\n types: [opened]\n\njobs:\n comment-on-pull:\n name: Comment On Pull\n runs-on: ubuntu-l"
},
{
"path": ".gitignore",
"chars": 100,
"preview": "elm-stuff\ndist\ndist-newstyle\ncabal-dev\n.cabal-sandbox/\ncabal.sandbox.config\n.DS_Store\n*~\ntravis.log\n"
},
{
"path": ".travis.yml",
"chars": 685,
"preview": "language: minimal\nservices: docker\n\nenv:\n global:\n - LINUX_ARCHIVE=binary-for-linux-64-bit.gz\n\nbefore_install:\n - d"
},
{
"path": "LICENSE",
"chars": 1467,
"preview": "Copyright 2012-present Evan Czaplicki\n\nRedistribution and use in source and binary forms, with or without modification, "
},
{
"path": "README.md",
"chars": 602,
"preview": "# Elm\n\nA delightful language for reliable webapps.\n\nCheck out the [Home Page](http://elm-lang.org/), [Try Online](http:/"
},
{
"path": "builder/src/BackgroundWriter.hs",
"chars": 907,
"preview": "{-# LANGUAGE BangPatterns #-}\nmodule BackgroundWriter\n ( Scope\n , withScope\n , writeBinary\n )\n where\n\n\nimport Contr"
},
{
"path": "builder/src/Build.hs",
"chars": 41404,
"preview": "{-# OPTIONS_GHC -Wno-unused-do-bind #-}\n{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}\nmodule Build\n ( fromExp"
},
{
"path": "builder/src/Deps/Bump.hs",
"chars": 984,
"preview": "module Deps.Bump\n ( getPossibilities\n )\n where\n\n\nimport qualified Data.List as List\n\nimport qualified Deps.Registry a"
},
{
"path": "builder/src/Deps/Diff.hs",
"chars": 9750,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Deps.Diff\n ( diff\n , PackageChanges(..)\n , ModuleChanges(..)\n , Changes(.."
},
{
"path": "builder/src/Deps/Registry.hs",
"chars": 4632,
"preview": "{-# LANGUAGE BangPatterns, OverloadedStrings #-}\nmodule Deps.Registry\n ( Registry(..)\n , KnownVersions(..)\n , read\n "
},
{
"path": "builder/src/Deps/Solver.hs",
"chars": 12726,
"preview": "{-# LANGUAGE OverloadedStrings, Rank2Types #-}\nmodule Deps.Solver\n ( Solver\n , Result(..)\n , Connection(..)\n --\n , "
},
{
"path": "builder/src/Deps/Website.hs",
"chars": 498,
"preview": "module Deps.Website\n ( domain\n , route\n , metadata\n )\n where\n\n\nimport qualified Elm.Package as Pkg\nimport qualified"
},
{
"path": "builder/src/Elm/Details.hs",
"chars": 27149,
"preview": "{-# LANGUAGE BangPatterns, OverloadedStrings #-}\nmodule Elm.Details\n ( Details(..)\n , BuildID\n , ValidOutline(..)\n ,"
},
{
"path": "builder/src/Elm/Outline.hs",
"chars": 10518,
"preview": "{-# LANGUAGE MultiWayIf, OverloadedStrings #-}\nmodule Elm.Outline\n ( Outline(..)\n , AppOutline(..)\n , PkgOutline(..)\n"
},
{
"path": "builder/src/File.hs",
"chars": 5724,
"preview": "module File\n ( Time\n , getTime\n , zeroTime\n , writeBinary\n , readBinary\n , writeUtf8\n , readUtf8\n , writeBuilder"
},
{
"path": "builder/src/Generate.hs",
"chars": 6624,
"preview": "{-# LANGUAGE BangPatterns #-}\nmodule Generate\n ( debug\n , dev\n , prod\n , repl\n )\n where\n\n\nimport Prelude hiding (c"
},
{
"path": "builder/src/Http.hs",
"chars": 5912,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Http\n ( Manager\n , getManager\n , toUrl\n -- fetch\n , get\n , post\n , Head"
},
{
"path": "builder/src/Reporting/Exit/Help.hs",
"chars": 2684,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Exit.Help\n ( Report\n , report\n , docReport\n , jsonReport\n , com"
},
{
"path": "builder/src/Reporting/Exit.hs",
"chars": 82228,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Exit\n ( Init(..), initToReport\n , Diff(..), diffToReport\n , Make("
},
{
"path": "builder/src/Reporting/Task.hs",
"chars": 1782,
"preview": "{-# LANGUAGE Rank2Types #-}\nmodule Reporting.Task\n ( Task\n , run\n , throw\n , mapError\n --\n , io\n , mio\n , eio\n "
},
{
"path": "builder/src/Reporting.hs",
"chars": 10938,
"preview": "{-# LANGUAGE BangPatterns, OverloadedStrings #-}\nmodule Reporting\n ( Style\n , silent\n , json\n , terminal\n --\n , at"
},
{
"path": "builder/src/Stuff.hs",
"chars": 3294,
"preview": "module Stuff\n ( details\n , interfaces\n , objects\n , prepublishDir\n , elmi\n , elmo\n , temp\n , findRoot\n , withRo"
},
{
"path": "cabal.config",
"chars": 41,
"preview": "profiling: False\nlibrary-profiling: True\n"
},
{
"path": "compiler/src/AST/Canonical.hs",
"chars": 8835,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule AST.Canonical\n ( Expr, Expr_(..)\n , CaseBranch(..)\n , FieldUpdate(..)\n , C"
},
{
"path": "compiler/src/AST/Optimized.hs",
"chars": 11503,
"preview": "module AST.Optimized\n ( Def(..)\n , Expr(..)\n , Global(..)\n , Path(..)\n , Destructor(..)\n , Decider(..)\n , Choice("
},
{
"path": "compiler/src/AST/Source.hs",
"chars": 3580,
"preview": "module AST.Source\n ( Expr, Expr_(..), VarType(..)\n , Def(..)\n , Pattern, Pattern_(..)\n , Type, Type_(..)\n , Module("
},
{
"path": "compiler/src/AST/Utils/Binop.hs",
"chars": 770,
"preview": "module AST.Utils.Binop\n ( Precedence(..)\n , Associativity(..)\n )\n where\n\n\nimport Prelude hiding (Either(..))\nimport "
},
{
"path": "compiler/src/AST/Utils/Shader.hs",
"chars": 1357,
"preview": "{-# LANGUAGE EmptyDataDecls #-}\nmodule AST.Utils.Shader\n ( Source\n , Types(..)\n , Type(..)\n , fromChars\n , toJsStri"
},
{
"path": "compiler/src/AST/Utils/Type.hs",
"chars": 2286,
"preview": "module AST.Utils.Type\n ( delambda\n , dealias\n , deepDealias\n , iteratedDealias\n )\n where\n\n\nimport qualified Data.M"
},
{
"path": "compiler/src/Canonicalize/Effects.hs",
"chars": 6938,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Canonicalize.Effects\n ( canonicalize\n , checkPayload\n )\n where\n\nimport qua"
},
{
"path": "compiler/src/Canonicalize/Environment/Dups.hs",
"chars": 2628,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Canonicalize.Environment.Dups\n ( detect\n , checkFields\n , checkFields'\n , "
},
{
"path": "compiler/src/Canonicalize/Environment/Foreign.hs",
"chars": 8671,
"preview": "{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Canonicalize.Environment.Foreign\n ( createIniti"
},
{
"path": "compiler/src/Canonicalize/Environment/Local.hs",
"chars": 10771,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Canonicalize.Environment.Local\n ( add\n )\n where\n\n\nimport Control.Monad (fol"
},
{
"path": "compiler/src/Canonicalize/Environment.hs",
"chars": 6309,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Canonicalize.Environment\n ( Env(..)\n , Exposed\n , Qualified\n , Info(..)\n "
},
{
"path": "compiler/src/Canonicalize/Expression.hs",
"chars": 21870,
"preview": "{-# OPTIONS_GHC -fno-warn-x-partial #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Canonicalize.Expression\n ( canonicali"
},
{
"path": "compiler/src/Canonicalize/Module.hs",
"chars": 8705,
"preview": "module Canonicalize.Module\n ( canonicalize\n )\n where\n\n\nimport qualified Data.Graph as Graph\nimport qualified Data.Map"
},
{
"path": "compiler/src/Canonicalize/Pattern.hs",
"chars": 4773,
"preview": "module Canonicalize.Pattern\n ( verify\n , Bindings\n , DupsDict\n , canonicalize\n )\n where\n\n\nimport qualified Data.Li"
},
{
"path": "compiler/src/Canonicalize/Type.hs",
"chars": 4205,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Canonicalize.Type\n ( toAnnotation\n , canonicalize\n )\n where\n\n\nimport quali"
},
{
"path": "compiler/src/Compile.hs",
"chars": 2527,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}\nmodule Compile\n ( Artifacts(..)\n , compile\n )\n where\n\n\nimport qua"
},
{
"path": "compiler/src/Data/Bag.hs",
"chars": 1227,
"preview": "module Data.Bag\n ( Bag(..)\n , empty\n , one\n , append\n , map\n , toList\n , fromList\n )\n where\n\n\nimport Prelude hi"
},
{
"path": "compiler/src/Data/Index.hs",
"chars": 2301,
"preview": "module Data.Index\n ( ZeroBased\n , first\n , second\n , third\n , next\n , toMachine\n , toHuman\n , indexedMap\n , ind"
},
{
"path": "compiler/src/Data/Map/Utils.hs",
"chars": 790,
"preview": "module Data.Map.Utils\n ( fromKeys\n , fromKeysA\n , fromValues\n , any\n )\n where\n\n\nimport Prelude hiding (any)\nimport"
},
{
"path": "compiler/src/Data/Name.hs",
"chars": 11529,
"preview": "{-# OPTIONS_GHC -fno-warn-name-shadowing #-}\n{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, Un"
},
{
"path": "compiler/src/Data/NonEmptyList.hs",
"chars": 1242,
"preview": "module Data.NonEmptyList\n ( List(..)\n , singleton\n , toList\n , sortBy\n )\n where\n\n\nimport Control.Monad (liftM2)\nim"
},
{
"path": "compiler/src/Data/OneOrMore.hs",
"chars": 1396,
"preview": "module Data.OneOrMore\n ( OneOrMore(..)\n , one\n , more\n , map\n , destruct\n , getFirstTwo\n )\n where\n\n\nimport Prelu"
},
{
"path": "compiler/src/Data/Utf8.hs",
"chars": 14536,
"preview": "{-# OPTIONS_GHC -fno-warn-name-shadowing #-}\n{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}\n"
},
{
"path": "compiler/src/Elm/Compiler/Imports.hs",
"chars": 1534,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Elm.Compiler.Imports\n ( defaults\n )\n where\n\n\nimport qualified Data.Name as "
},
{
"path": "compiler/src/Elm/Compiler/Type/Extract.hs",
"chars": 6707,
"preview": "{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}\nmodule Elm.Compiler.Type.Extract\n ( fromAnnotation\n , fro"
},
{
"path": "compiler/src/Elm/Compiler/Type.hs",
"chars": 4021,
"preview": "{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Elm.Compiler.Type\n ( Ty"
},
{
"path": "compiler/src/Elm/Constraint.hs",
"chars": 4813,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Elm.Constraint\n ( Constraint\n , exactly\n , anything\n , toChars\n , satisfi"
},
{
"path": "compiler/src/Elm/Docs.hs",
"chars": 15316,
"preview": "{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}\nmodule Elm.Docs\n ( Documentation\n , Module"
},
{
"path": "compiler/src/Elm/Float.hs",
"chars": 665,
"preview": "{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}\nmodule Elm.Float\n ( Float\n , fromPtr\n , toBuilder\n )\n where\n\n\nim"
},
{
"path": "compiler/src/Elm/Interface.hs",
"chars": 5990,
"preview": "module Elm.Interface\n ( Interface(..)\n , Union(..)\n , Alias(..)\n , Binop(..)\n , fromModule\n , toPublicUnion\n , to"
},
{
"path": "compiler/src/Elm/Kernel.hs",
"chars": 9115,
"preview": "{-# LANGUAGE BangPatterns, EmptyDataDecls, OverloadedStrings, UnboxedTuples #-}\nmodule Elm.Kernel\n ( Content(..)\n , Ch"
},
{
"path": "compiler/src/Elm/Licenses.hs",
"chars": 6735,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Elm.Licenses\n ( License\n , bsd3\n , encode\n , decoder\n )\n where\n\n\nimport "
},
{
"path": "compiler/src/Elm/Magnitude.hs",
"chars": 283,
"preview": "module Elm.Magnitude\n ( Magnitude(..)\n , toChars\n )\n where\n\n\n\n-- MAGNITUDE\n\n\ndata Magnitude\n = PATCH\n | MINOR\n | "
},
{
"path": "compiler/src/Elm/ModuleName.hs",
"chars": 5062,
"preview": "{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}\nmodule Elm.ModuleName\n ( Raw\n , toChars\n , toFilePath"
},
{
"path": "compiler/src/Elm/Package.hs",
"chars": 7361,
"preview": "{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}\nmodule Elm.Package\n ( Name(..)\n , Auth"
},
{
"path": "compiler/src/Elm/String.hs",
"chars": 3001,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}\n{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}\nmodu"
},
{
"path": "compiler/src/Elm/Version.hs",
"chars": 3836,
"preview": "{-# LANGUAGE BangPatterns, UnboxedTuples #-}\nmodule Elm.Version\n ( Version(..)\n , one\n , max\n , compiler\n , bumpPat"
},
{
"path": "compiler/src/Generate/Html.hs",
"chars": 1034,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE QuasiQuotes #-}\nmodule Generate.Html\n ( sandwich\n )\n where\n\n\nimport q"
},
{
"path": "compiler/src/Generate/JavaScript/Builder.hs",
"chars": 11637,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Generate.JavaScript.Builder\n ( stmtToBuilder\n , exprToBuilder\n , Expr(..), "
},
{
"path": "compiler/src/Generate/JavaScript/Expression.hs",
"chars": 27911,
"preview": "{-# OPTIONS_GHC -fno-warn-x-partial #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Generate.JavaScript.Expression\n ( gen"
},
{
"path": "compiler/src/Generate/JavaScript/Functions.hs",
"chars": 2818,
"preview": "{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}\nmodule Generate.JavaScript.Functions\n ( functions\n )\n where\n\n\nimport "
},
{
"path": "compiler/src/Generate/JavaScript/Name.hs",
"chars": 5719,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Generate.JavaScript.Name\n ( Name\n , toBuilder\n , fromIndex\n , fromInt\n , "
},
{
"path": "compiler/src/Generate/JavaScript.hs",
"chars": 16630,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Generate.JavaScript\n ( generate\n , generateForRepl\n , generateForReplEndpoi"
},
{
"path": "compiler/src/Generate/Mode.hs",
"chars": 1366,
"preview": "module Generate.Mode\n ( Mode(..)\n , isDebug\n , ShortFieldNames\n , shortenFieldNames\n )\n where\n\n\nimport qualified D"
},
{
"path": "compiler/src/Json/Decode.hs",
"chars": 17026,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}\n{-# LANGUAGE BangPatterns, Rank2Types, Overl"
},
{
"path": "compiler/src/Json/Encode.hs",
"chars": 5343,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Json.Encode\n ( write\n , encode\n , writeUgly\n , encodeUgly\n , Value(..)\n "
},
{
"path": "compiler/src/Json/String.hs",
"chars": 3927,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}\n{-# LANGUAGE BangPatterns, EmptyDataDecls #-}\nmodule Json.String\n ( "
},
{
"path": "compiler/src/Nitpick/Debug.hs",
"chars": 2781,
"preview": "module Nitpick.Debug\n ( hasDebugUses\n )\n where\n\n\nimport qualified Data.Map.Utils as Map\n\nimport qualified AST.Optimiz"
},
{
"path": "compiler/src/Nitpick/PatternMatches.hs",
"chars": 14451,
"preview": "{-# OPTIONS_GHC -fno-warn-x-partial #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Nitpick.PatternMatches\n ( check\n , E"
},
{
"path": "compiler/src/Optimize/Case.hs",
"chars": 4093,
"preview": "module Optimize.Case\n ( optimize\n )\n where\n\n\nimport Control.Arrow (second)\nimport qualified Data.Map as Map\nimport Da"
},
{
"path": "compiler/src/Optimize/DecisionTree.hs",
"chars": 14962,
"preview": "{-# OPTIONS_GHC -fno-warn-x-partial #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Optimize.DecisionTree\n ( DecisionTree"
},
{
"path": "compiler/src/Optimize/Expression.hs",
"chars": 14390,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Optimize.Expression\n ( optimize\n , destructArgs\n , optimizePotentialTailCal"
},
{
"path": "compiler/src/Optimize/Module.hs",
"chars": 10858,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Optimize.Module\n ( optimize\n )\n where\n\n\nimport Prelude hiding (cycle)\nimpor"
},
{
"path": "compiler/src/Optimize/Names.hs",
"chars": 4084,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE Rank2Types #-}\nmodule Optimize.Names\n ( Tracker\n , run\n , generate\n "
},
{
"path": "compiler/src/Optimize/Port.hs",
"chars": 8234,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Optimize.Port\n ( toEncoder\n , toFlagsDecoder\n , toDecoder\n )\n where\n\n\nimp"
},
{
"path": "compiler/src/Parse/Declaration.hs",
"chars": 8815,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Parse.Declaration\n ( Decl("
},
{
"path": "compiler/src/Parse/Expression.hs",
"chars": 18451,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Parse.Expression\n ( expres"
},
{
"path": "compiler/src/Parse/Keyword.hs",
"chars": 7542,
"preview": "{-# LANGUAGE BangPatterns #-}\nmodule Parse.Keyword\n ( type_, alias_, port_\n , if_, then_, else_\n , case_, of_\n , let"
},
{
"path": "compiler/src/Parse/Module.hs",
"chars": 15171,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Parse.Module\n ( fromByteString\n , ProjectType(..)\n , isKernel\n , chompImpo"
},
{
"path": "compiler/src/Parse/Number.hs",
"chars": 6758,
"preview": "{-# LANGUAGE BangPatterns, UnboxedTuples #-}\nmodule Parse.Number\n ( Number(..)\n , number\n , Outcome(..)\n , chompInt\n"
},
{
"path": "compiler/src/Parse/Pattern.hs",
"chars": 8266,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}\n{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}\nmodul"
},
{
"path": "compiler/src/Parse/Primitives.hs",
"chars": 9717,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}\n{-# LANGUAGE BangPatterns, Rank2Types, Unbox"
},
{
"path": "compiler/src/Parse/Shader.hs",
"chars": 5274,
"preview": "{-# LANGUAGE BangPatterns, UnboxedTuples #-}\nmodule Parse.Shader\n ( shader\n )\n where\n\n\nimport qualified Data.ByteStri"
},
{
"path": "compiler/src/Parse/Space.hs",
"chars": 7045,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}\n{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}\nmodul"
},
{
"path": "compiler/src/Parse/String.hs",
"chars": 9531,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}\n{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuple"
},
{
"path": "compiler/src/Parse/Symbol.hs",
"chars": 1920,
"preview": "{-# LANGUAGE BangPatterns, OverloadedStrings #-}\nmodule Parse.Symbol\n ( operator\n , BadOperator(..)\n , binopCharSet\n "
},
{
"path": "compiler/src/Parse/Type.hs",
"chars": 6487,
"preview": "{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Parse.Type\n ( expression\n "
},
{
"path": "compiler/src/Parse/Variable.hs",
"chars": 9400,
"preview": "{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}\nmodule Parse.Variable\n ( lower\n , upper\n ,"
},
{
"path": "compiler/src/Reporting/Annotation.hs",
"chars": 1568,
"preview": "module Reporting.Annotation\n ( Located(..)\n , Position(..)\n , Region(..)\n , traverse\n , toValue\n , merge\n , at\n "
},
{
"path": "compiler/src/Reporting/Doc.hs",
"chars": 8991,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Doc\n ( P.Doc\n , (P.<+>), (<>)\n , P.align, P.cat, P.empty, P.fill,"
},
{
"path": "compiler/src/Reporting/Error/Canonicalize.hs",
"chars": 46550,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error.Canonicalize\n ( Error(..)\n , BadArityContext(..)\n , Invalid"
},
{
"path": "compiler/src/Reporting/Error/Docs.hs",
"chars": 7527,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error.Docs\n ( Error(..)\n , SyntaxProblem(..)\n , NameProblem(..)\n "
},
{
"path": "compiler/src/Reporting/Error/Import.hs",
"chars": 5988,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error.Import\n ( Error(..)\n , Problem(..)\n , toReport\n )\n where\n"
},
{
"path": "compiler/src/Reporting/Error/Json.hs",
"chars": 11278,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error.Json\n ( toReport\n , FailureToReport(..)\n , Context(..)\n , "
},
{
"path": "compiler/src/Reporting/Error/Main.hs",
"chars": 3980,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error.Main\n ( Error(..)\n , toReport\n )\n where\n\n\nimport qualified"
},
{
"path": "compiler/src/Reporting/Error/Pattern.hs",
"chars": 5583,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error.Pattern\n ( P.Error(..)\n , toReport\n )\n where\n\nimport quali"
},
{
"path": "compiler/src/Reporting/Error/Syntax.hs",
"chars": 211378,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error.Syntax\n ( Error(..)\n , toReport\n --\n , Module(..)\n , Expo"
},
{
"path": "compiler/src/Reporting/Error/Type.hs",
"chars": 53837,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error.Type\n ( Error(..)\n -- expectations\n , Expected(..)\n , Cont"
},
{
"path": "compiler/src/Reporting/Error.hs",
"chars": 4871,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Error\n ( Module(..)\n , Error(..)\n , toDoc\n , toJson\n )\n where\n"
},
{
"path": "compiler/src/Reporting/Render/Code.hs",
"chars": 7063,
"preview": "{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Render.Code\n "
},
{
"path": "compiler/src/Reporting/Render/Type/Localizer.hs",
"chars": 2404,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Render.Type.Localizer\n ( Localizer\n , toDoc\n , toChars\n , empty\n"
},
{
"path": "compiler/src/Reporting/Render/Type.hs",
"chars": 5367,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Render.Type\n ( Context(..)\n , lambda\n , apply\n , tuple\n , recor"
},
{
"path": "compiler/src/Reporting/Report.hs",
"chars": 323,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Report\n ( Report(..)\n )\n where\n\n\nimport qualified Reporting"
},
{
"path": "compiler/src/Reporting/Result.hs",
"chars": 2363,
"preview": "{-# LANGUAGE Rank2Types #-}\nmodule Reporting.Result\n ( Result(..)\n , run\n , ok\n , warn\n , throw\n , mapError\n )\n "
},
{
"path": "compiler/src/Reporting/Suggest.hs",
"chars": 840,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Suggest\n ( distance\n , sort\n , rank\n )\n where\n\n\nimport qualifie"
},
{
"path": "compiler/src/Reporting/Warning.hs",
"chars": 3161,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Reporting.Warning\n ( Warning(..)\n , Context(..)\n , toReport\n )\n where\n\n\ni"
},
{
"path": "compiler/src/Type/Constrain/Expression.hs",
"chars": 23734,
"preview": "module Type.Constrain.Expression\n ( constrain\n , constrainDef\n , constrainRecursiveDefs\n )\n where\n\n\nimport qualifie"
},
{
"path": "compiler/src/Type/Constrain/Module.hs",
"chars": 5996,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Type.Constrain.Module\n ( constrain\n )\n where\n\n\nimport qualified Data.Map.St"
},
{
"path": "compiler/src/Type/Constrain/Pattern.hs",
"chars": 7286,
"preview": "module Type.Constrain.Pattern\n ( State(..)\n , emptyState\n , add\n )\n where\n\n\nimport Control.Arrow (second)\nimport Co"
},
{
"path": "compiler/src/Type/Error.hs",
"chars": 15864,
"preview": "{-# OPTIONS_GHC -fno-warn-x-partial #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Type.Error\n ( Type(..)\n , Super(..)\n"
},
{
"path": "compiler/src/Type/Instantiate.hs",
"chars": 1706,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Type.Instantiate\n ( FreeVars\n , fromSrcType\n )\n where\n\n\nimport qualified D"
},
{
"path": "compiler/src/Type/Occurs.hs",
"chars": 1941,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Type.Occurs\n ( occurs\n )\n where\n\n\nimport Data.Foldable (foldrM)\nimport qual"
},
{
"path": "compiler/src/Type/Solve.hs",
"chars": 21665,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Type.Solve\n ( run\n )\n where\n\n\nimport Control.Monad\nimport qualified Data.Ma"
},
{
"path": "compiler/src/Type/Type.hs",
"chars": 17159,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Type.Type\n ( Constraint(..)\n , exists\n , Variable\n , FlatType(..)\n , Type"
},
{
"path": "compiler/src/Type/Unify.hs",
"chars": 17354,
"preview": "{-# LANGUAGE OverloadedStrings, Rank2Types #-}\nmodule Type.Unify\n ( Answer(..)\n , unify\n )\n where\n\n\nimport qualified"
},
{
"path": "compiler/src/Type/UnionFind.hs",
"chars": 3849,
"preview": "{-# OPTIONS_GHC -funbox-strict-fields #-}\n{-# LANGUAGE BangPatterns #-}\nmodule Type.UnionFind\n ( Point\n , fresh\n , un"
},
{
"path": "docs/elm.json/application.md",
"chars": 2064,
"preview": "# `elm.json` for applications\n\nThis is a decent baseline for pretty much any applications made with Elm. You will need t"
},
{
"path": "docs/elm.json/package.md",
"chars": 3326,
"preview": "# `elm.json` for packages\n\nThis is roughly `elm.json` for the `elm/json` package:\n\n```json\n{\n \"type\": \"package\",\n "
},
{
"path": "docs/upgrade-instructions/0.16.md",
"chars": 5519,
"preview": "# Upgrading to 0.16\n\nUpgrading should be pretty easy. Everything is quite mechanical, so I would not be very afraid of t"
},
{
"path": "docs/upgrade-instructions/0.17.md",
"chars": 8996,
"preview": "\n# Upgrading to 0.17\n\nUpgrading should be pretty easy. Everything is quite mechanical, so I would not be very afraid of "
},
{
"path": "docs/upgrade-instructions/0.18.md",
"chars": 6706,
"preview": "# Upgrading to 0.18\n\nLike always, not that much has really changed. To make the process as smooth as possible, this docu"
},
{
"path": "docs/upgrade-instructions/0.19.0.md",
"chars": 7508,
"preview": "# Upgrading to 0.19\n\nTo make the process as smooth as possible, this document outlines all the things you need to do to "
},
{
"path": "docs/upgrade-instructions/0.19.1.md",
"chars": 2443,
"preview": "# Upgrading to 0.19.1\n\n**There are no language changes**, so once you swap to `\"elm-version\": \"0.19.1\"` in your `elm.jso"
},
{
"path": "docs/upgrade-instructions/earlier.md",
"chars": 14992,
"preview": "\n# 0.16\n\nRead all about it at these links:\n\n * http://elm-lang.org/blog/compilers-as-assistants\n * https://github.com/"
},
{
"path": "elm.cabal",
"chars": 5116,
"preview": "\nName: elm\nVersion: 0.19.1\n\nSynopsis:\n The `elm` command line interface.\n\nDescription:\n This includes commands lik"
},
{
"path": "hints/bad-recursion.md",
"chars": 6822,
"preview": "\n# Hints for Bad Recursion\n\nThere are two problems that will lead you here, both of them pretty tricky:\n\n 1. [**No Muta"
},
{
"path": "hints/comparing-custom-types.md",
"chars": 3338,
"preview": "# Comparing Custom Types\n\nThe built-in comparison operators work on a fixed set of types, like `Int` and `String`. That "
},
{
"path": "hints/comparing-records.md",
"chars": 3335,
"preview": "# Comparing Records\n\nThe built-in comparison operators work on a fixed set of types, like `Int` and `String`. That cover"
},
{
"path": "hints/implicit-casts.md",
"chars": 3190,
"preview": "\n# Implicit Casts\n\nMany languages automatically convert from `Int` to `Float` when they think it is necessary. This conv"
},
{
"path": "hints/import-cycles.md",
"chars": 7316,
"preview": "\n# Import Cycles\n\nWhat is an import cycle? In practice you may see it if you create two modules with interrelated `User`"
},
{
"path": "hints/imports.md",
"chars": 5482,
"preview": "\n# Hints for Imports\n\nWhen getting started with Elm, it is pretty common to have questions about how the `import` declar"
},
{
"path": "hints/infinite-type.md",
"chars": 2241,
"preview": "\n# Hints for Infinite Types\n\nInfinite types are probably the trickiest kind of bugs to track down. **Writing down type a"
},
{
"path": "hints/init.md",
"chars": 3720,
"preview": "\n# Creating an Elm project\n\nThe main goal of `elm init` is to get you to this page!\n\nIt just creates an `elm.json` file "
},
{
"path": "hints/missing-patterns.md",
"chars": 4025,
"preview": "\n# Hints for Missing Patterns\n\nElm checks to make sure that all possible inputs to a function or `case` are handled. Thi"
},
{
"path": "hints/optimize.md",
"chars": 2825,
"preview": "\n# How to optimize Elm code\n\nWhen you are serving a website, there are two kinds of optimizations you want to do:\n\n1. **"
},
{
"path": "hints/port-modules.md",
"chars": 3041,
"preview": "\n# No Ports in Packages\n\nThe package ecosystem is one of the most important parts of Elm. Right now, our ecosystem has s"
},
{
"path": "hints/recursive-alias.md",
"chars": 4358,
"preview": "\n# Hints for Recursive Type Aliases\n\nAt the root of this issue is the distinction between a `type` and a `type alias`.\n\n"
},
{
"path": "hints/repl.md",
"chars": 1464,
"preview": "\n# REPL\n\nThe REPL lets you interact with Elm values and functions in your terminal.\n\n\n## Use\n\nYou can type in expression"
},
{
"path": "hints/shadowing.md",
"chars": 3389,
"preview": "\n# Variable Shadowing\n\nVariable shadowing is when you define the same variable name twice in an ambiguous way. Here is a"
},
{
"path": "hints/tuples.md",
"chars": 952,
"preview": "\n# From Tuples to Records\n\nThe largest tuple possible in Elm has three entries. Once you get to four, it is best to make"
},
{
"path": "hints/type-annotations.md",
"chars": 2710,
"preview": "\n# Hints for Type Annotation Problems\n\nAt the root of this kind of issue is always the fact that a type annotation in yo"
},
{
"path": "installers/README.md",
"chars": 1498,
"preview": "# Installing Elm\n\nThe normal path is to work through [the guide](https://guide.elm-lang.org/) until you need to install,"
},
{
"path": "installers/linux/Dockerfile",
"chars": 1137,
"preview": "# Based initially on https://gist.github.com/rlefevre/1523f47e75310e28eee243c9c5651ac9\n#\n# Build Linux x64 binary from e"
},
{
"path": "installers/linux/README.md",
"chars": 3581,
"preview": "# Install Instructions\n\nThe pre-compiled binary for Linux works on a very wide range of distributions.\n\nIt should be pos"
},
{
"path": "installers/mac/Distribution.xml",
"chars": 1284,
"preview": "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>\n<installer-script minSpecVersion=\"1.000000\" authoringTool=\"com.ap"
},
{
"path": "installers/mac/README.md",
"chars": 3634,
"preview": "# Install Instructions\n\nThe easiest way to install is to to use [the Mac installer](https://github.com/elm/compiler/rele"
},
{
"path": "installers/mac/Resources/en.lproj/conclusion.rtf",
"chars": 657,
"preview": "{\\rtf1\\ansi\\ansicpg1252\\cocoartf2509\n\\cocoatextscaling0\\cocoaplatform0{\\fonttbl\\f0\\fswiss\\fcharset0 Helvetica;\\f1\\fmoder"
},
{
"path": "installers/mac/Resources/en.lproj/welcome.rtf",
"chars": 519,
"preview": "{\\rtf1\\ansi\\ansicpg1252\\cocoartf2509\n\\cocoatextscaling0\\cocoaplatform0{\\fonttbl\\f0\\fswiss\\fcharset0 Helvetica;\\f1\\fmoder"
},
{
"path": "installers/mac/helper-scripts/elm-startup.sh",
"chars": 44,
"preview": "#!/bin/sh\n\nopen 'http://guide.elm-lang.org'\n"
},
{
"path": "installers/mac/helper-scripts/uninstall.sh",
"chars": 423,
"preview": "#!/bin/sh\n\nset -e\n\necho \"Warning: You are about to remove all Elm executables!\"\n\ninstalldir=/usr/local/bin\n\nfor bin in e"
},
{
"path": "installers/mac/make-installer.sh",
"chars": 1582,
"preview": "#!/bin/sh\n# Run the following command to create an installer:\n#\n# bash make-installer.sh\n#\n\n\n\n#### SETUP ####\n\nset -"
},
{
"path": "installers/mac/postinstall",
"chars": 60,
"preview": "#!/bin/sh\n\nset -ex\n\necho \"$(date)\" > /tmp/elm-installer.log\n"
},
{
"path": "installers/mac/preinstall",
"chars": 324,
"preview": "#!/bin/sh\n\nset -e\n\ninstalldir=/usr/local/bin\n\nfor bin in elm elm-compiler elm-package elm-reactor elm-repl\ndo\n\tif [ -f $"
},
{
"path": "installers/npm/.gitignore",
"chars": 48,
"preview": "node_modules/\npackages/*/elm\npackages/*/elm.exe\n"
},
{
"path": "installers/npm/.npmignore",
"chars": 26,
"preview": "README.md\n.gitignore\n.git\n"
},
{
"path": "installers/npm/PUBLISHING.md",
"chars": 5131,
"preview": "# Publishing\n\nHere's how to update the `npm` installer.\n\n## 0. Overview\n\n- There is one _main npm package_ called `elm`."
},
{
"path": "installers/npm/README.md",
"chars": 2048,
"preview": "# Elm Installer\n\n[Elm](https://elm-lang.org) is a functional programming language that compiles to JavaScript.\n\nHead ove"
},
{
"path": "installers/npm/bin/elm",
"chars": 1038,
"preview": "#!/usr/bin/env node\n\nvar child_process = require('child_process');\n\n\n// Some npm users enable --ignore-scripts (a good s"
},
{
"path": "installers/npm/binary.js",
"chars": 3619,
"preview": "var fs = require('fs');\nvar package = require('./package.json');\nvar path = require('path');\n\n\n\n// MAIN\n//\n// This funct"
},
{
"path": "installers/npm/install.js",
"chars": 26,
"preview": "require('./binary.js')();\n"
},
{
"path": "installers/npm/package.json",
"chars": 1014,
"preview": "{\n \"name\": \"elm\",\n \"version\": \"0.19.1-6\",\n \"description\": \"Installer for Elm: just downloads the binary into node_mod"
},
{
"path": "installers/npm/packages/darwin_arm64/README.md",
"chars": 411,
"preview": "# Elm Binary for macOS (arm64)\n\nSome people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`n"
},
{
"path": "installers/npm/packages/darwin_arm64/package.json",
"chars": 254,
"preview": "{\n \"name\": \"@elm_binaries/darwin_arm64\",\n \"version\": \"0.19.1-0\",\n \"description\": \"Download the Elm binary for macOS ("
},
{
"path": "installers/npm/packages/darwin_x64/README.md",
"chars": 409,
"preview": "# Elm Binary for macOS (x64)\n\nSome people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`npm"
},
{
"path": "installers/npm/packages/darwin_x64/package.json",
"chars": 248,
"preview": "{\n \"name\": \"@elm_binaries/darwin_x64\",\n \"version\": \"0.19.1-0\",\n \"description\": \"Download the Elm binary for macOS (x6"
},
{
"path": "installers/npm/packages/linux_arm64/README.md",
"chars": 411,
"preview": "# Elm Binary for Linux (arm64)\n\nSome people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`n"
},
{
"path": "installers/npm/packages/linux_arm64/package.json",
"chars": 252,
"preview": "{\n \"name\": \"@elm_binaries/linux_arm64\",\n \"version\": \"0.19.1-0\",\n \"description\": \"Download the Elm binary for Linux (a"
},
{
"path": "installers/npm/packages/linux_x64/README.md",
"chars": 409,
"preview": "# Elm Binary for Linux (x64)\n\nSome people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`npm"
},
{
"path": "installers/npm/packages/linux_x64/package.json",
"chars": 246,
"preview": "{\n \"name\": \"@elm_binaries/linux_x64\",\n \"version\": \"0.19.1-0\",\n \"description\": \"Download the Elm binary for Linux (x64"
},
{
"path": "installers/npm/packages/win32_x64/README.md",
"chars": 411,
"preview": "# Elm Binary for Windows (x64)\n\nSome people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`n"
},
{
"path": "installers/npm/packages/win32_x64/package.json",
"chars": 248,
"preview": "{\n \"name\": \"@elm_binaries/win32_x64\",\n \"version\": \"0.19.1-0\",\n \"description\": \"Download the Elm binary for Windows (x"
},
{
"path": "installers/npm/troubleshooting.md",
"chars": 3316,
"preview": "# Troubleshooting\n\nI very highly recommend asking for help on [the Elm slack](https://elmlang.herokuapp.com).\n\nThere are"
},
{
"path": "installers/win/CreateInternetShortcut.nsh",
"chars": 289,
"preview": "!macro CreateInternetShortcut FILENAME URL ICONFILE ICONINDEX\r\nWriteINIStr \"${FILENAME}.url\" \"InternetShortcut\" \"URL\" \"$"
},
{
"path": "installers/win/Nsisfile.nsi",
"chars": 7542,
"preview": "; Elm Installer\r\n\r\n;--------------------------------\r\n;Includes\r\n\r\n !Include \"FileFunc.nsh\"\r\n !Include \"LogicLib.nsh\"\r"
},
{
"path": "installers/win/README.md",
"chars": 774,
"preview": "# Installing on Windows\n\nThe installer for Windows is available [here](https://guide.elm-lang.org/install.html).\n\n\n<br/>"
},
{
"path": "installers/win/make_installer.cmd",
"chars": 354,
"preview": "\r\nset version=%1\r\n\r\nmkdir files\r\nmkdir files\\bin\r\n\r\nxcopy ..\\..\\dist\\build\\elm\\elm.exe files\\bin /s /e\r\nxcopy updatepath"
},
{
"path": "installers/win/removefrompath.vbs",
"chars": 675,
"preview": "Set WshShell = CreateObject(\"WScript.Shell\")\n' Make sure there is no trailing slash at the end of elmBasePath\nelmBasePat"
},
{
"path": "installers/win/updatepath.vbs",
"chars": 421,
"preview": "Set WshShell = CreateObject(\"WScript.Shell\")\nelmPath = WScript.Arguments(0)\n'const PathRegKey = \"HKLM\\SYSTEM\\CurrentCont"
},
{
"path": "reactor/assets/styles.css",
"chars": 2227,
"preview": "@charset \"UTF-8\";\n\n\n/* FONTS */\n\n@font-face {\n font-family: 'Source Code Pro';\n font-style: normal;\n font-weight: 400"
},
{
"path": "reactor/check.py",
"chars": 1163,
"preview": "#!/usr/bin/env python\n\nimport os\nimport sys\n\n\n## FIGURE OUT NEW MODIFICATION TIME\n\ndef mostRecentModification(directory)"
},
{
"path": "reactor/elm.json",
"chars": 785,
"preview": "{\n \"type\": \"application\",\n \"source-directories\": [\n \"src\"\n ],\n \"elm-version\": \"0.19.1\",\n \"dependen"
},
{
"path": "reactor/src/Deps.elm",
"chars": 28291,
"preview": "module Deps exposing (main)\n\n\nimport Browser\nimport Browser.Dom as Dom\nimport Dict exposing (Dict)\nimport Elm.Constraint"
},
{
"path": "reactor/src/Errors.elm",
"chars": 4701,
"preview": "module Errors exposing (main)\n\n\nimport Browser\nimport Char\nimport Html exposing (..)\nimport Html.Attributes exposing (.."
},
{
"path": "reactor/src/Index/Icon.elm",
"chars": 3825,
"preview": "module Index.Icon exposing\n ( home\n , image\n , file\n , gift\n , folder\n , package\n , plus\n , lookup\n )\n\nimport D"
},
{
"path": "reactor/src/Index/Navigator.elm",
"chars": 1306,
"preview": "module Index.Navigator exposing (view)\n\n\nimport Html exposing (..)\nimport Html.Attributes exposing (..)\nimport Index.Ico"
},
{
"path": "reactor/src/Index/Skeleton.elm",
"chars": 1142,
"preview": "module Index.Skeleton exposing\n ( box\n , readmeBox\n )\n\nimport Html exposing (..)\nimport Html.Attributes exposing (..)"
},
{
"path": "reactor/src/Index.elm",
"chars": 6151,
"preview": "module Index exposing (main)\n\n\nimport Browser\nimport Dict\nimport Html exposing (..)\nimport Html.Attributes exposing (cla"
},
{
"path": "reactor/src/NotFound.elm",
"chars": 567,
"preview": "module NotFound exposing (main)\n\n\nimport Browser\nimport Html exposing (..)\nimport Html.Attributes exposing (..)\n\n\n\nmain "
},
{
"path": "reactor/src/mock.txt",
"chars": 1186,
"preview": "# Dependency Explorer\n\nMass Updates: | RESET | PATCH | MINOR | MAJOR |\n\n⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣇ ←→\n\nDEPENDENCIES\n\n D"
},
{
"path": "roadmap.md",
"chars": 3590,
"preview": "# Roadmap\n\nIf you like what you see now, that's pretty much what Elm is going to be for a while.\n\nI'm currently doing so"
},
{
"path": "terminal/impl/Terminal/Chomp.hs",
"chars": 12265,
"preview": "{-# LANGUAGE GADTs, Rank2Types #-}\nmodule Terminal.Chomp\n ( chomp\n )\n where\n\n\nimport qualified Data.List as List\n\nimp"
},
{
"path": "terminal/impl/Terminal/Error.hs",
"chars": 11737,
"preview": "{-# OPTIONS_GHC -fno-warn-x-partial #-}\n{-# LANGUAGE GADTs, OverloadedStrings #-}\nmodule Terminal.Error\n ( Error(..)\n "
},
{
"path": "terminal/impl/Terminal/Helpers.hs",
"chars": 3213,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Terminal.Helpers\n ( version\n , elmFile\n , package\n )\n where\n\n\nimport qual"
}
]
// ... and 30 more files (download for full content)
About this extraction
This page contains the full source code of the elm/compiler GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 230 files (1.6 MB), approximately 415.7k tokens, and a symbol index with 4 extracted functions, classes, methods, constants, and types. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.