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/)
## 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).
## 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 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 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","." ,"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 ,\ \ 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 open an\ \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\ \ version, the command you ran, the terminal output, and any additional information\ \ that might help others reproduce the error." ] Http.BadHttp url httpExceptionContent -> case httpExceptionContent of HTTP.StatusCodeException response body -> let (HTTP.Status code message) = HTTP.responseStatus response in toHttpReport (context ++ ", so I tried to fetch:") url [ D.fillSep $ ["But","it","came","back","as",D.red (D.fromInt code)] ++ map D.fromChars (words (BS_UTF8.toString message)) , D.indent 4 $ D.reflow $ BS_UTF8.toString body , D.reflow $ "This may mean some online endpoint changed in an unexpected way, so if does not\ \ seem like something on your side is causing this (e.g. firewall) please report\ \ this to https://github.com/elm/compiler/issues with your operating system, Elm\ \ version, the command you ran, the terminal output, and any additional information\ \ that can help others reproduce the error!" ] HTTP.TooManyRedirects responses -> toHttpReport (context ++ ", so I tried to fetch:") url [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:" , D.indent 4 $ D.vcat $ map toRedirectDoc responses , D.reflow $ "Is it possible that your internet connection intercepts certain requests? That\ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\ \ and certain countries. Try asking for help locally or in a community forum!" ] otherException -> toHttpReport (context ++ ", so I tried to fetch:") url [ D.reflow $ "But my HTTP library is giving me the following error message:" , D.indent 4 $ D.fromChars (show otherException) , D.reflow $ "Are you somewhere with a slow internet connection? Or no internet?\ \ Does the link I am trying to fetch work in your browser? Maybe the\ \ site is down? Does your internet connection have a firewall that\ \ blocks certain domains? It is usually something like that!" ] Http.BadMystery url someException -> toHttpReport (context ++ ", so I tried to fetch:") url [ D.reflow $ "But I ran into something weird! I was able to extract this error message:" , D.indent 4 $ D.fromChars (show someException) , D.reflow $ "Is it possible that your internet connection intercepts certain requests? That\ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\ \ and certain countries. Try asking for help locally or in a community forum!" ] toRedirectDoc :: HTTP.Response body -> D.Doc toRedirectDoc response = let (HTTP.Status code message) = HTTP.responseStatus response in case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc) Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message) -- MAKE data Make = MakeNoOutline | MakeCannotOptimizeAndDebug | MakeBadDetails Details | MakeAppNeedsFileNames | MakePkgNeedsExposing | MakeMultipleFilesIntoHtml | MakeNoMain | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw] | MakeCannotBuild BuildProblem | MakeBadGenerate Generate makeToReport :: Make -> Help.Report makeToReport make = case make of MakeNoOutline -> Help.report "NO elm.json FILE" Nothing "It looks like you are starting a new Elm project. Very exciting! Try running:" [ D.indent 4 $ D.green $ "elm init" , D.reflow $ "It will help you get set up. It is really simple!" ] MakeCannotOptimizeAndDebug -> Help.docReport "CLASHING FLAGS" Nothing ( D.fillSep ["I","cannot","compile","with",D.red "--optimize","and" ,D.red "--debug","at","the","same","time." ] ) [ D.reflow "I need to take away information to optimize things, and I need to\ \ add information to add the debugger. It is impossible to do both\ \ at once though! Pick just one of those flags and it should work!" ] MakeBadDetails detailsProblem -> toDetailsReport detailsProblem MakeAppNeedsFileNames -> Help.report "NO INPUT" Nothing "What should I make though? I need specific files like:" [ D.vcat [ D.indent 4 $ D.green "elm make src/Main.elm" , D.indent 4 $ D.green "elm make src/This.elm src/That.elm" ] , D.reflow $ "I recommend reading through https://guide.elm-lang.org for guidance on what to\ \ actually put in those files!" ] MakePkgNeedsExposing -> Help.report "NO INPUT" Nothing "What should I make though? I need specific files like:" [ D.vcat [ D.indent 4 $ D.green "elm make src/Main.elm" , D.indent 4 $ D.green "elm make src/This.elm src/That.elm" ] , D.reflow $ "You can also entries to the \"exposed-modules\" list in your elm.json file, and\ \ I will try to compile the relevant files." ] MakeMultipleFilesIntoHtml -> Help.report "TOO MANY FILES" Nothing ( "When producing an HTML file, I can only handle one file." ) [ D.fillSep ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want" ,"to","get","compile","errors.","This","skips","the","code","gen","phase," ,"so","it","can","be","a","bit","faster","than","other","options","sometimes." ] , D.fillSep ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple" ,"`main`","values","available","in","a","single","JavaScript","file.","Then" ,"you","can","make","your","own","customized","HTML","file","that","embeds" ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares" ,"dependencies","between","modules,","so","it","should","be","smaller","than" ,"compiling","each","module","separately." ] ] MakeNoMain -> Help.report "NO MAIN" Nothing ( "When producing an HTML file, I require that the given file has a `main` value.\ \ That way I have something to show on screen!" ) [ D.reflow $ "Try adding a `main` value to your file? Or if you just want to verify that this\ \ module compiles, switch to --output=/dev/null to skip the code gen phase\ \ altogether." , D.toSimpleNote $ "Adding a `main` value can be as brief as adding something like this:" , D.vcat [ D.fillSep [D.cyan "import","Html"] , "" , D.fillSep [D.green "main","="] , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""] ] , D.reflow $ "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\ \ looking through https://guide.elm-lang.org for more guidance on how to fill in\ \ the `main` value." ] MakeNonMainFilesIntoJavaScript m ms -> case ms of [] -> Help.report "NO MAIN" Nothing ( "When producing a JS file, I require that the given file has a `main` value. That\ \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\ \ resulting file!" ) [ D.reflow $ "Try adding a `main` value to your file? Or if you just want to verify that this\ \ module compiles, switch to --output=/dev/null to skip the code gen phase\ \ altogether." , D.toSimpleNote $ "Adding a `main` value can be as brief as adding something like this:" , D.vcat [ D.fillSep [D.cyan "import","Html"] , "" , D.fillSep [D.green "main","="] , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""] ] , D.reflow $ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\ \ make a `main` with no user interface." ] _:_ -> Help.report "NO MAIN" Nothing ( "When producing a JS file, I require that given files all have `main` values.\ \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\ \ definitely defined in the resulting file. I am missing `main` values in:" ) [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms) , D.reflow $ "Try adding a `main` value to them? Or if you just want to verify that these\ \ modules compile, switch to --output=/dev/null to skip the code gen phase\ \ altogether." , D.toSimpleNote $ "Adding a `main` value can be as brief as adding something like this:" , D.vcat [ D.fillSep [D.cyan "import","Html"] , "" , D.fillSep [D.green "main","="] , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""] ] , D.reflow $ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\ \ make a `main` with no user interface." ] MakeCannotBuild buildProblem -> toBuildProblemReport buildProblem MakeBadGenerate generateProblem -> toGenerateReport generateProblem -- BUILD PROBLEM data BuildProblem = BuildBadModules FilePath Error.Module [Error.Module] | BuildProjectProblem BuildProjectProblem data BuildProjectProblem = BP_PathUnknown FilePath | BP_WithBadExtension FilePath | BP_WithAmbiguousSrcDir FilePath FilePath FilePath | BP_MainPathDuplicate FilePath FilePath | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath | BP_RootNameInvalid FilePath FilePath [String] | BP_CannotLoadDependencies | BP_Cycle ModuleName.Raw [ModuleName.Raw] | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem)) toBuildProblemReport :: BuildProblem -> Help.Report toBuildProblemReport problem = case problem of BuildBadModules root e es -> Help.compilerReport root e es BuildProjectProblem projectProblem -> toProjectProblemReport projectProblem toProjectProblemReport :: BuildProjectProblem -> Help.Report toProjectProblemReport projectProblem = case projectProblem of BP_PathUnknown path -> Help.report "FILE NOT FOUND" Nothing "I cannot find this file:" [ D.indent 4 $ D.red $ D.fromChars path , D.reflow $ "Is there a typo?" , D.toSimpleNote $ "If you are just getting started, try working through the examples in the\ \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\ \ that typically go in a src/Main.elm file." ] BP_WithBadExtension path -> Help.report "UNEXPECTED FILE EXTENSION" Nothing "I can only compile Elm files (with a .elm extension) but you want me to compile:" [ D.indent 4 $ D.red $ D.fromChars path , D.reflow $ "Is there a typo? Can the file extension be changed?" ] BP_WithAmbiguousSrcDir path srcDir1 srcDir2 -> Help.report "CONFUSING FILE" Nothing "I am getting confused when I try to compile this file:" [ D.indent 4 $ D.red $ D.fromChars path , D.reflow $ "I always check if files appear in any of the \"source-directories\" listed in\ \ your elm.json to see if there might be some cached information about them. That\ \ can help me compile faster! But in this case, it looks like this file may be in\ \ either of these directories:" , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2] , D.reflow $ "Try to make it so no source directory contains another source directory!" ] BP_MainPathDuplicate path1 path2 -> Help.report "CONFUSING FILES" Nothing "You are telling me to compile these two files:" [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ] , D.reflow $ if path1 == path2 then "Why are you telling me twice? Is something weird going on with a script?\ \ I figured I would let you know about it just in case something is wrong.\ \ Only list it once and you should be all set!" else "But seem to be the same file though... It makes me think something tricky is\ \ going on with symlinks in your project, so I figured I would let you know\ \ about it just in case. Remove one of these files from your command to get\ \ unstuck!" ] BP_RootNameDuplicate name outsidePath otherPath -> Help.report "MODULE NAME CLASH" Nothing "These two files are causing a module name clash:" [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ] , D.reflow $ "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\ \ at the top, but they cannot have the same name!" , D.reflow $ "Try changing to a different module name in one of them!" ] BP_RootNameInvalid givenPath srcDir _ -> Help.report "UNEXPECTED FILE NAME" Nothing "I am having trouble with this file name:" [ D.indent 4 $ D.red $ D.fromChars givenPath , D.reflow $ "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\ \ which is good, but I expect all of the files in there to use the following\ \ module naming convention:" , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ] , D.reflow $ "Notice that the names always start with capital letters! Can you make your file\ \ use this naming convention?" , D.toSimpleNote $ "Having a strict naming convention like this makes it a lot easier to find\ \ things in large projects. If you see a module imported, you know where to look\ \ for the corresponding file every time!" ] BP_CannotLoadDependencies -> corruptCacheReport BP_Cycle name names -> Help.report "IMPORT CYCLE" Nothing "Your module imports form a cycle:" [ D.cycle 4 name names , D.reflow $ "Learn more about why this is disallowed and how to break cycles here:" ++ D.makeLink "import-cycles" ] BP_MissingExposed (NE.List (name, problem) _) -> case problem of Import.NotFound -> Help.report "MISSING MODULE" (Just "elm.json") "The \"exposed-modules\" of your elm.json lists the following module:" [ D.indent 4 $ D.red $ D.fromName name , D.reflow $ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?" ] Import.Ambiguous _ _ pkg _ -> Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json") "The \"exposed-modules\" of your elm.json lists the following module:" [ D.indent 4 $ D.red $ D.fromName name , D.reflow $ "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\ \ choosing a different name for your local file." ] Import.AmbiguousLocal path1 path2 paths -> Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json") "The \"exposed-modules\" of your elm.json lists the following module:" [ D.indent 4 $ D.red $ D.fromName name , D.reflow $ "But I found multiple files with that name:" , D.dullyellow $ D.indent 4 $ D.vcat $ map D.fromChars (path1:path2:paths) , D.reflow $ "Change the module names to be distinct!" ] Import.AmbiguousForeign _ _ _ -> Help.report "MISSING MODULE" (Just "elm.json") "The \"exposed-modules\" of your elm.json lists the following module:" [ D.indent 4 $ D.red $ D.fromName name , D.reflow $ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?" , D.toSimpleNote $ "It is not possible to \"re-export\" modules from other packages. You can only\ \ expose modules that you define in your own code." ] toModuleNameConventionTable :: FilePath -> [String] -> D.Doc toModuleNameConventionTable srcDir names = let toPair name = ( name , srcDir map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm" ) namePairs = map toPair names nameWidth = maximum (11 : map (length . fst) namePairs) pathWidth = maximum ( 9 : map (length . snd) namePairs) padded width str = str ++ replicate (width - length str) ' ' toRow (name, path) = D.fromChars $ "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |" bar = D.fromChars $ "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+" in D.indent 4 $ D.vcat $ [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ] -- GENERATE data Generate = GenerateCannotLoadArtifacts | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw] toGenerateReport :: Generate -> Help.Report toGenerateReport problem = case problem of GenerateCannotLoadArtifacts -> corruptCacheReport GenerateCannotOptimizeDebugValues m ms -> Help.report "DEBUG REMNANTS" Nothing "There are uses of the `Debug` module in the following modules:" [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms) , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!" , D.toSimpleNote $ "The issue is that --optimize strips out info needed by `Debug` functions.\ \ Here are two examples:" , D.indent 4 $ D.reflow $ "(1) It shortens record field names. This makes the generated JavaScript\ \ smaller, but `Debug.toString` cannot know the real field names anymore." , D.indent 4 $ D.reflow $ "(2) Values like `type Height = Height Float` are unboxed. This reduces\ \ allocation, but it also means that `Debug.toString` cannot tell if it is\ \ looking at a `Height` or `Float` value." , D.reflow $ "There are a few other cases like that, and it will be much worse once we start\ \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\ \ resulting in unpredictable behavior. I hope that clarifies why this restriction\ \ exists!" ] -- CORRUPT CACHE corruptCacheReport :: Help.Report corruptCacheReport = Help.report "CORRUPT CACHE" Nothing "It looks like some of the information cached in elm-stuff/ has been corrupted." [ D.reflow $ "Try deleting your elm-stuff/ directory to get unstuck." , D.toSimpleNote $ "This almost certainly means that a 3rd party tool (or editor plugin) is\ \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\ \ one by one until you figure out which it is!" ] -- REACTOR data Reactor = ReactorNoOutline | ReactorBadDetails Details | ReactorBadBuild BuildProblem | ReactorBadGenerate Generate reactorToReport :: Reactor -> Help.Report reactorToReport problem = case problem of ReactorNoOutline -> Help.report "NEW PROJECT?" Nothing "Are you trying to start a new project? Try this command in the terminal:" [ D.indent 4 $ D.green "elm init" , D.reflow "It will help you get started!" ] ReactorBadDetails details -> toDetailsReport details ReactorBadBuild buildProblem -> toBuildProblemReport buildProblem ReactorBadGenerate generate -> toGenerateReport generate -- REPL data Repl = ReplBadDetails Details | ReplBadInput BS.ByteString Error.Error | ReplBadLocalDeps FilePath Error.Module [Error.Module] | ReplProjectProblem BuildProjectProblem | ReplBadGenerate Generate | ReplBadCache | ReplBlocked replToReport :: Repl -> Help.Report replToReport problem = case problem of ReplBadDetails details -> toDetailsReport details ReplBadInput source err -> Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) [] ReplBadLocalDeps root e es -> Help.compilerReport root e es ReplProjectProblem projectProblem -> toProjectProblemReport projectProblem ReplBadGenerate generate -> toGenerateReport generate ReplBadCache -> corruptCacheReport ReplBlocked -> corruptCacheReport ================================================ FILE: builder/src/Reporting/Task.hs ================================================ {-# LANGUAGE Rank2Types #-} module Reporting.Task ( Task , run , throw , mapError -- , io , mio , eio ) where -- TASKS newtype Task x a = Task ( forall result. (a -> IO result) -> (x -> IO result) -> IO result ) run :: Task x a -> IO (Either x a) run (Task task) = task (return . Right) (return . Left) throw :: x -> Task x a throw x = Task $ \_ err -> err x mapError :: (x -> y) -> Task x a -> Task y a mapError func (Task task) = Task $ \ok err -> task ok (err . func) -- IO {-# INLINE io #-} io :: IO a -> Task x a io work = Task $ \ok _ -> work >>= ok mio :: x -> IO (Maybe a) -> Task x a mio x work = Task $ \ok err -> do result <- work case result of Just a -> ok a Nothing -> err x eio :: (x -> y) -> IO (Either x a) -> Task y a eio func work = Task $ \ok err -> do result <- work case result of Right a -> ok a Left x -> err (func x) -- INSTANCES instance Functor (Task x) where {-# INLINE fmap #-} fmap func (Task taskA) = Task $ \ok err -> let okA arg = ok (func arg) in taskA okA err instance Applicative (Task x) where {-# INLINE pure #-} pure a = Task $ \ok _ -> ok a {-# INLINE (<*>) #-} (<*>) (Task taskFunc) (Task taskArg) = Task $ \ok err -> let okFunc func = let okArg arg = ok (func arg) in taskArg okArg err in taskFunc okFunc err instance Monad (Task x) where {-# INLINE return #-} return = pure {-# INLINE (>>=) #-} (>>=) (Task taskA) callback = Task $ \ok err -> let okA a = case callback a of Task taskB -> taskB ok err in taskA okA err ================================================ FILE: builder/src/Reporting.hs ================================================ {-# LANGUAGE BangPatterns, OverloadedStrings #-} module Reporting ( Style , silent , json , terminal -- , attempt , attemptWithStyle -- , Key , report , ignorer , ask -- , DKey , DMsg(..) , trackDetails -- , BKey , BMsg(..) , trackBuild -- , reportGenerate ) where import Control.Concurrent import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw) import Control.Monad (when) import qualified Data.ByteString.Builder as B import qualified Data.NonEmptyList as NE import qualified System.Exit as Exit import qualified System.Info as Info import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout) import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Elm.Version as V import qualified Json.Encode as Encode import Reporting.Doc ((<+>)) import qualified Reporting.Doc as D import qualified Reporting.Exit as Exit import qualified Reporting.Exit.Help as Help -- STYLE data Style = Silent | Json | Terminal (MVar ()) silent :: Style silent = Silent json :: Style json = Json terminal :: IO Style terminal = Terminal <$> newMVar () -- ATTEMPT attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a attempt toReport work = do result <- work `catch` reportExceptionsNicely case result of Right a -> return a Left x -> do Exit.toStderr (toReport x) Exit.exitFailure attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a attemptWithStyle style toReport work = do result <- work `catch` reportExceptionsNicely case result of Right a -> return a Left x -> case style of Silent -> do Exit.exitFailure Json -> do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x))) Exit.exitFailure Terminal mvar -> do readMVar mvar Exit.toStderr (toReport x) Exit.exitFailure -- MARKS goodMark :: D.Doc goodMark = D.green $ if isWindows then "+" else "●" badMark :: D.Doc badMark = D.red $ if isWindows then "X" else "✗" isWindows :: Bool isWindows = Info.os == "mingw32" -- KEY newtype Key msg = Key (msg -> IO ()) report :: Key msg -> msg -> IO () report (Key send) msg = send msg ignorer :: Key msg ignorer = Key (\_ -> return ()) -- ASK ask :: D.Doc -> IO Bool ask doc = do Help.toStdout doc askHelp askHelp :: IO Bool askHelp = do hFlush stdout input <- getLine case input of "" -> return True "Y" -> return True "y" -> return True "n" -> return False _ -> do putStr "Must type 'y' for yes or 'n' for no: " askHelp -- DETAILS type DKey = Key DMsg trackDetails :: Style -> (DKey -> IO a) -> IO a trackDetails style callback = case style of Silent -> callback (Key (\_ -> return ())) Json -> callback (Key (\_ -> return ())) Terminal mvar -> do chan <- newChan _ <- forkIO $ do takeMVar mvar detailsLoop chan (DState 0 0 0 0 0 0 0) putMVar mvar () answer <- callback (Key (writeChan chan . Just)) writeChan chan Nothing return answer detailsLoop :: Chan (Maybe DMsg) -> DState -> IO () detailsLoop chan state@(DState total _ _ _ _ built _) = do msg <- readChan chan case msg of Just dmsg -> detailsLoop chan =<< detailsStep dmsg state Nothing -> putStrLn $ clear (toBuildProgress total total) $ if built == total then "Dependencies ready!" else "Dependency problem!" data DState = DState { _total :: !Int , _cached :: !Int , _requested :: !Int , _received :: !Int , _failed :: !Int , _built :: !Int , _broken :: !Int } data DMsg = DStart Int | DCached | DRequested | DReceived Pkg.Name V.Version | DFailed Pkg.Name V.Version | DBuilt | DBroken detailsStep :: DMsg -> DState -> IO DState detailsStep msg (DState total cached rqst rcvd failed built broken) = case msg of DStart numDependencies -> return (DState numDependencies 0 0 0 0 0 0) DCached -> putTransition (DState total (cached + 1) rqst rcvd failed built broken) DRequested -> do when (rqst == 0) (putStrLn "Starting downloads...\n") return (DState total cached (rqst + 1) rcvd failed built broken) DReceived pkg vsn -> do putDownload goodMark pkg vsn putTransition (DState total cached rqst (rcvd + 1) failed built broken) DFailed pkg vsn -> do putDownload badMark pkg vsn putTransition (DState total cached rqst rcvd (failed + 1) built broken) DBuilt -> putBuilt (DState total cached rqst rcvd failed (built + 1) broken) DBroken -> putBuilt (DState total cached rqst rcvd failed built (broken + 1)) putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO () putDownload mark pkg vsn = Help.toStdout $ D.indent 2 $ mark <+> D.fromPackage pkg <+> D.fromVersion vsn <> "\n" putTransition :: DState -> IO DState putTransition state@(DState total cached _ rcvd failed built broken) = if cached + rcvd + failed < total then return state else do let char = if rcvd + failed == 0 then '\r' else '\n' putStrFlush (char : toBuildProgress (built + broken + failed) total) return state putBuilt :: DState -> IO DState putBuilt state@(DState total cached _ rcvd failed built broken) = do when (total == cached + rcvd + failed) $ putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total return state toBuildProgress :: Int -> Int -> [Char] toBuildProgress built total = "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")" clear :: [Char] -> [Char] -> [Char] clear before after = '\r' : replicate (length before) ' ' ++ '\r' : after -- BUILD type BKey = Key BMsg type BResult a = Either Exit.BuildProblem a trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a) trackBuild style callback = case style of Silent -> callback (Key (\_ -> return ())) Json -> callback (Key (\_ -> return ())) Terminal mvar -> do chan <- newChan _ <- forkIO $ do takeMVar mvar putStrFlush "Compiling ..." buildLoop chan 0 putMVar mvar () result <- callback (Key (writeChan chan . Left)) writeChan chan (Right result) return result data BMsg = BDone buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO () buildLoop chan done = do msg <- readChan chan case msg of Left BDone -> do let !done1 = done + 1 putStrFlush $ "\rCompiling (" ++ show done1 ++ ")" buildLoop chan done1 Right result -> let !message = toFinalMessage done result !width = 12 + length (show done) in putStrLn $ if length message < width then '\r' : replicate width ' ' ++ '\r' : message else '\r' : message toFinalMessage :: Int -> BResult a -> [Char] toFinalMessage done result = case result of Right _ -> case done of 0 -> "Success!" 1 -> "Success! Compiled 1 module." n -> "Success! Compiled " ++ show n ++ " modules." Left problem -> case problem of Exit.BuildBadModules _ _ [] -> "Detected problems in 1 module." Exit.BuildBadModules _ _ (_:ps) -> "Detected problems in " ++ show (2 + length ps) ++ " modules." Exit.BuildProjectProblem _ -> "Detected a problem." -- GENERATE reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO () reportGenerate style names output = case style of Silent -> return () Json -> return () Terminal mvar -> do readMVar mvar let cnames = fmap ModuleName.toChars names putStrLn ('\n' : toGenDiagram cnames output) toGenDiagram :: NE.List [Char] -> FilePath -> [Char] toGenDiagram (NE.List name names) output = let width = 3 + foldr (max . length) (length name) names in case names of [] -> toGenLine width name ('>' : ' ' : output ++ "\n") _:_ -> unlines $ toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output) : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle])) toGenLine :: Int -> [Char] -> [Char] -> [Char] toGenLine width name end = " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end hbar :: Char hbar = if isWindows then '-' else '─' vtop :: Char vtop = if isWindows then '+' else '┬' vmiddle :: Char vmiddle = if isWindows then '+' else '┤' vbottom :: Char vbottom = if isWindows then '+' else '┘' -- putStrFlush :: String -> IO () putStrFlush str = hPutStr stdout str >> hFlush stdout -- REPORT EXCEPTIONS NICELY reportExceptionsNicely :: SomeException -> IO a reportExceptionsNicely e = case fromException e of Just UserInterrupt -> throw e _ -> putException e >> throw e putException :: SomeException -> IO () putException e = do hPutStrLn stderr "" Help.toStderr $ D.stack $ [ D.dullyellow "-- ERROR -----------------------------------------------------------------------" , D.reflow $ "I ran into something that bypassed the normal error reporting process!\ \ I extracted whatever information I could from the internal error:" , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e)) , D.reflow $ "These errors are usually pretty confusing, so start by asking around on one of\ \ forums listed at https://elm-lang.org/community to see if anyone can get you\ \ unstuck quickly." , D.dullyellow "-- REQUEST ---------------------------------------------------------------------" , D.reflow $ "If you are feeling up to it, please try to get your code down to the smallest\ \ version that still triggers this message. Ideally in a single Main.elm and\ \ elm.json file." , D.reflow $ "From there open a NEW issue at https://github.com/elm/compiler/issues with\ \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\ \ worry about if someone else saw something similar. More examples is better!" , D.reflow $ "This kind of error is usually tied up in larger architectural choices that are\ \ hard to change, so even when we have a couple good examples, it can take some\ \ time to resolve in a solid way." ] ================================================ FILE: builder/src/Stuff.hs ================================================ module Stuff ( details , interfaces , objects , prepublishDir , elmi , elmo , temp , findRoot , withRootLock , withRegistryLock , PackageCache , getPackageCache , registry , package , getReplCache , getElmHome ) where import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.FileLock as Lock import qualified System.FilePath as FP import System.FilePath ((), (<.>)) import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Elm.Version as V -- PATHS stuff :: FilePath -> FilePath stuff root = root "elm-stuff" compilerVersion details :: FilePath -> FilePath details root = stuff root "d.dat" interfaces :: FilePath -> FilePath interfaces root = stuff root "i.dat" objects :: FilePath -> FilePath objects root = stuff root "o.dat" prepublishDir :: FilePath -> FilePath prepublishDir root = stuff root "prepublish" compilerVersion :: FilePath compilerVersion = V.toChars V.compiler -- ELMI and ELMO elmi :: FilePath -> ModuleName.Raw -> FilePath elmi root name = toArtifactPath root name "elmi" elmo :: FilePath -> ModuleName.Raw -> FilePath elmo root name = toArtifactPath root name "elmo" toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath toArtifactPath root name ext = stuff root ModuleName.toHyphenPath name <.> ext -- TEMP temp :: FilePath -> String -> FilePath temp root ext = stuff root "temp" <.> ext -- ROOT findRoot :: IO (Maybe FilePath) findRoot = do dir <- Dir.getCurrentDirectory findRootHelp (FP.splitDirectories dir) findRootHelp :: [String] -> IO (Maybe FilePath) findRootHelp dirs = case dirs of [] -> return Nothing _:_ -> do exists <- Dir.doesFileExist (FP.joinPath dirs "elm.json") if exists then return (Just (FP.joinPath dirs)) else findRootHelp (init dirs) -- LOCKS withRootLock :: FilePath -> IO a -> IO a withRootLock root work = do let dir = stuff root Dir.createDirectoryIfMissing True dir Lock.withFileLock (dir "lock") Lock.Exclusive (\_ -> work) withRegistryLock :: PackageCache -> IO a -> IO a withRegistryLock (PackageCache dir) work = Lock.withFileLock (dir "lock") Lock.Exclusive (\_ -> work) -- PACKAGE CACHES newtype PackageCache = PackageCache FilePath getPackageCache :: IO PackageCache getPackageCache = PackageCache <$> getCacheDir "packages" registry :: PackageCache -> FilePath registry (PackageCache dir) = dir "registry.dat" package :: PackageCache -> Pkg.Name -> V.Version -> FilePath package (PackageCache dir) name version = dir Pkg.toFilePath name V.toChars version -- CACHE getReplCache :: IO FilePath getReplCache = getCacheDir "repl" getCacheDir :: FilePath -> IO FilePath getCacheDir projectName = do home <- getElmHome let root = home compilerVersion projectName Dir.createDirectoryIfMissing True root return root getElmHome :: IO FilePath getElmHome = do maybeCustomHome <- Env.lookupEnv "ELM_HOME" case maybeCustomHome of Just customHome -> return customHome Nothing -> Dir.getAppUserDataDirectory "elm" ================================================ FILE: cabal.config ================================================ profiling: False library-profiling: True ================================================ FILE: compiler/src/AST/Canonical.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module AST.Canonical ( Expr, Expr_(..) , CaseBranch(..) , FieldUpdate(..) , CtorOpts(..) -- definitions , Def(..) , Decls(..) -- patterns , Pattern, Pattern_(..) , PatternCtorArg(..) -- types , Annotation(..) , Type(..) , AliasType(..) , FieldType(..) , fieldsToList -- modules , Module(..) , Alias(..) , Binop(..) , Union(..) , Ctor(..) , Exports(..) , Export(..) , Effects(..) , Port(..) , Manager(..) ) where {- Creating a canonical AST means finding the home module for all variables. So if you have L.map, you need to figure out that it is from the elm/core package in the List module. In later phases (e.g. type inference, exhaustiveness checking, optimization) you need to look up additional info from these modules. What is the type? What are the alternative type constructors? These lookups can be quite costly, especially in type inference. To reduce costs the canonicalization phase caches info needed in later phases. This means we no longer build large dictionaries of metadata with O(log(n)) lookups in those phases. Instead there is an O(1) read of an existing field! I have tried to mark all cached data with comments like: -- CACHE for exhaustiveness -- CACHE for inference So it is clear why the data is kept around. -} import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM) import Data.Binary import qualified Data.List as List import qualified Data.Map as Map import Data.Name (Name) import qualified AST.Source as Src import qualified AST.Utils.Binop as Binop import qualified AST.Utils.Shader as Shader import qualified Data.Index as Index import qualified Elm.Float as EF import qualified Elm.ModuleName as ModuleName import qualified Elm.String as ES import qualified Reporting.Annotation as A -- EXPRESSIONS type Expr = A.Located Expr_ -- CACHE Annotations for type inference data Expr_ = VarLocal Name | VarTopLevel ModuleName.Canonical Name | VarKernel Name Name | VarForeign ModuleName.Canonical Name Annotation | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation | VarDebug ModuleName.Canonical Name Annotation | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization | Chr ES.String | Str ES.String | Int Int | Float EF.Float | List [Expr] | Negate Expr | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization | Lambda [Pattern] Expr | Call Expr [Expr] | If [(Expr, Expr)] Expr | Let Def Expr | LetRec [Def] Expr | LetDestruct Pattern Expr Expr | Case Expr [CaseBranch] | Accessor Name | Access Expr (A.Located Name) | Update Name Expr (Map.Map Name FieldUpdate) | Record (Map.Map Name Expr) | Unit | Tuple Expr Expr (Maybe Expr) | Shader Shader.Source Shader.Types data CaseBranch = CaseBranch Pattern Expr data FieldUpdate = FieldUpdate A.Region Expr -- DEFS data Def = Def (A.Located Name) [Pattern] Expr | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type -- DECLARATIONS data Decls = Declare Def Decls | DeclareRec Def [Def] Decls | SaveTheEnvironment -- PATTERNS type Pattern = A.Located Pattern_ data Pattern_ = PAnything | PVar Name | PRecord [Name] | PAlias Pattern Name | PUnit | PTuple Pattern Pattern (Maybe Pattern) | PList [Pattern] | PCons Pattern Pattern | PBool Union Bool | PChr ES.String | PStr ES.String | PInt Int | PCtor { _p_home :: ModuleName.Canonical , _p_type :: Name , _p_union :: Union , _p_name :: Name , _p_index :: Index.ZeroBased , _p_args :: [PatternCtorArg] } -- CACHE _p_home, _p_type, and _p_vars for type inference -- CACHE _p_index to replace _p_name in PROD code gen -- CACHE _p_opts to allocate less in PROD code gen -- CACHE _p_alts and _p_numAlts for exhaustiveness checker data PatternCtorArg = PatternCtorArg { _index :: Index.ZeroBased -- CACHE for destructors/errors , _type :: Type -- CACHE for type inference , _arg :: Pattern } -- TYPES data Annotation = Forall FreeVars Type deriving (Eq) type FreeVars = Map.Map Name () data Type = TLambda Type Type | TVar Name | TType ModuleName.Canonical Name [Type] | TRecord (Map.Map Name FieldType) (Maybe Name) | TUnit | TTuple Type Type (Maybe Type) | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType deriving (Eq) data AliasType = Holey Type | Filled Type deriving (Eq) data FieldType = FieldType {-# UNPACK #-} !Word16 Type deriving (Eq) -- NOTE: The Word16 marks the source order, but it may not be available -- for every canonical type. For example, if the canonical type is inferred -- the orders will all be zeros. -- fieldsToList :: Map.Map Name FieldType -> [(Name, Type)] fieldsToList fields = let getIndex (_, FieldType index _) = index dropIndex (name, FieldType _ tipe) = (name, tipe) in map dropIndex (List.sortOn getIndex (Map.toList fields)) -- MODULES data Module = Module { _name :: ModuleName.Canonical , _exports :: Exports , _docs :: Src.Docs , _decls :: Decls , _unions :: Map.Map Name Union , _aliases :: Map.Map Name Alias , _binops :: Map.Map Name Binop , _effects :: Effects } data Alias = Alias [Name] Type deriving (Eq) data Binop = Binop_ Binop.Associativity Binop.Precedence Name deriving (Eq) data Union = Union { _u_vars :: [Name] , _u_alts :: [Ctor] , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking , _u_opts :: CtorOpts -- CACHE which optimizations are available } deriving (Eq) data CtorOpts = Normal | Enum | Unbox deriving (Eq, Ord) data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args deriving (Eq) -- EXPORTS data Exports = ExportEverything A.Region | Export (Map.Map Name (A.Located Export)) data Export = ExportValue | ExportBinop | ExportAlias | ExportUnionOpen | ExportUnionClosed | ExportPort -- EFFECTS data Effects = NoEffects | Ports (Map.Map Name Port) | Manager A.Region A.Region A.Region Manager data Port = Incoming { _freeVars :: FreeVars, _payload :: Type, _func :: Type } | Outgoing { _freeVars :: FreeVars, _payload :: Type, _func :: Type } data Manager = Cmd Name | Sub Name | Fx Name Name -- BINARY instance Binary Alias where get = liftM2 Alias get get put (Alias a b) = put a >> put b instance Binary Union where put (Union a b c d) = put a >> put b >> put c >> put d get = liftM4 Union get get get get instance Binary Ctor where get = liftM4 Ctor get get get get put (Ctor a b c d) = put a >> put b >> put c >> put d instance Binary CtorOpts where put opts = case opts of Normal -> putWord8 0 Enum -> putWord8 1 Unbox -> putWord8 2 get = do n <- getWord8 case n of 0 -> return Normal 1 -> return Enum 2 -> return Unbox _ -> fail "binary encoding of CtorOpts was corrupted" instance Binary Annotation where get = liftM2 Forall get get put (Forall a b) = put a >> put b instance Binary Type where put tipe = case tipe of TLambda a b -> putWord8 0 >> put a >> put b TVar a -> putWord8 1 >> put a TRecord a b -> putWord8 2 >> put a >> put b TUnit -> putWord8 3 TTuple a b c -> putWord8 4 >> put a >> put b >> put c TAlias a b c d -> putWord8 5 >> put a >> put b >> put c >> put d TType home name ts -> let potentialWord = length ts + 7 in if potentialWord <= fromIntegral (maxBound :: Word8) then do putWord8 (fromIntegral potentialWord) put home put name mapM_ put ts else putWord8 6 >> put home >> put name >> put ts get = do word <- getWord8 case word of 0 -> liftM2 TLambda get get 1 -> liftM TVar get 2 -> liftM2 TRecord get get 3 -> return TUnit 4 -> liftM3 TTuple get get get 5 -> liftM4 TAlias get get get get 6 -> liftM3 TType get get get n -> liftM3 TType get get (replicateM (fromIntegral (n - 7)) get) instance Binary AliasType where put aliasType = case aliasType of Holey tipe -> putWord8 0 >> put tipe Filled tipe -> putWord8 1 >> put tipe get = do n <- getWord8 case n of 0 -> liftM Holey get 1 -> liftM Filled get _ -> fail "binary encoding of AliasType was corrupted" instance Binary FieldType where get = liftM2 FieldType get get put (FieldType a b) = put a >> put b ================================================ FILE: compiler/src/AST/Optimized.hs ================================================ module AST.Optimized ( Def(..) , Expr(..) , Global(..) , Path(..) , Destructor(..) , Decider(..) , Choice(..) , GlobalGraph(..) , LocalGraph(..) , Main(..) , Node(..) , EffectsType(..) , empty , addGlobalGraph , addLocalGraph , addKernel , toKernelGlobal ) where import Control.Monad (liftM, liftM2, liftM3, liftM4) import Data.Binary (Binary, get, put, getWord8, putWord8) import qualified Data.Map as Map import qualified Data.Name as Name import Data.Name (Name) import qualified Data.Set as Set import qualified AST.Canonical as Can import qualified AST.Utils.Shader as Shader import qualified Data.Index as Index import qualified Elm.Float as EF import qualified Elm.Kernel as K import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Elm.String as ES import qualified Optimize.DecisionTree as DT import qualified Reporting.Annotation as A -- EXPRESSIONS data Expr = Bool Bool | Chr ES.String | Str ES.String | Int Int | Float EF.Float | VarLocal Name | VarGlobal Global | VarEnum Global Index.ZeroBased | VarBox Global | VarCycle ModuleName.Canonical Name | VarDebug Name ModuleName.Canonical A.Region (Maybe Name) | VarKernel Name Name | List [Expr] | Function [Name] Expr | Call Expr [Expr] | TailCall Name [(Name, Expr)] | If [(Expr, Expr)] Expr | Let Def Expr | Destruct Destructor Expr | Case Name Name (Decider Choice) [(Int, Expr)] | Accessor Name | Access Expr Name | Update Expr (Map.Map Name Expr) | Record (Map.Map Name Expr) | Unit | Tuple Expr Expr (Maybe Expr) | Shader Shader.Source (Set.Set Name) (Set.Set Name) data Global = Global ModuleName.Canonical Name -- DEFINITIONS data Def = Def Name Expr | TailDef Name [Name] Expr data Destructor = Destructor Name Path data Path = Index Index.ZeroBased Path | Field Name Path | Unbox Path | Root Name -- BRANCHING data Decider a = Leaf a | Chain { _testChain :: [(DT.Path, DT.Test)] , _success :: Decider a , _failure :: Decider a } | FanOut { _path :: DT.Path , _tests :: [(DT.Test, Decider a)] , _fallback :: Decider a } deriving (Eq) data Choice = Inline Expr | Jump Int -- OBJECT GRAPH data GlobalGraph = GlobalGraph { _g_nodes :: Map.Map Global Node , _g_fields :: Map.Map Name Int } data LocalGraph = LocalGraph { _l_main :: Maybe Main , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name , _l_fields :: Map.Map Name Int } data Main = Static | Dynamic { _message :: Can.Type , _decoder :: Expr } data Node = Define Expr (Set.Set Global) | DefineTailFunc [Name] Expr (Set.Set Global) | Ctor Index.ZeroBased Int | Enum Index.ZeroBased | Box | Link Global | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global) | Manager EffectsType | Kernel [K.Chunk] (Set.Set Global) | PortIncoming Expr (Set.Set Global) | PortOutgoing Expr (Set.Set Global) data EffectsType = Cmd | Sub | Fx -- GRAPHS {-# NOINLINE empty #-} empty :: GlobalGraph empty = GlobalGraph Map.empty Map.empty addGlobalGraph :: GlobalGraph -> GlobalGraph -> GlobalGraph addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) = GlobalGraph { _g_nodes = Map.union nodes1 nodes2 , _g_fields = Map.union fields1 fields2 } addLocalGraph :: LocalGraph -> GlobalGraph -> GlobalGraph addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) = GlobalGraph { _g_nodes = Map.union nodes1 nodes2 , _g_fields = Map.union fields1 fields2 } addKernel :: Name.Name -> [K.Chunk] -> GlobalGraph -> GlobalGraph addKernel shortName chunks (GlobalGraph nodes fields) = let global = toKernelGlobal shortName node = Kernel chunks (foldr addKernelDep Set.empty chunks) in GlobalGraph { _g_nodes = Map.insert global node nodes , _g_fields = Map.union (K.countFields chunks) fields } addKernelDep :: K.Chunk -> Set.Set Global -> Set.Set Global addKernelDep chunk deps = case chunk of K.JS _ -> deps K.ElmVar home name -> Set.insert (Global home name) deps K.JsVar shortName _ -> Set.insert (toKernelGlobal shortName) deps K.ElmField _ -> deps K.JsField _ -> deps K.JsEnum _ -> deps K.Debug -> deps K.Prod -> deps toKernelGlobal :: Name.Name -> Global toKernelGlobal shortName = Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar -- INSTANCES instance Eq Global where (==) (Global home1 name1) (Global home2 name2) = name1 == name2 && home1 == home2 instance Ord Global where compare (Global home1 name1) (Global home2 name2) = case compare name1 name2 of LT -> LT EQ -> compare home1 home2 GT -> GT -- BINARY instance Binary Global where get = liftM2 Global get get put (Global a b) = put a >> put b instance Binary Expr where put expr = case expr of Bool a -> putWord8 0 >> put a Chr a -> putWord8 1 >> put a Str a -> putWord8 2 >> put a Int a -> putWord8 3 >> put a Float a -> putWord8 4 >> put a VarLocal a -> putWord8 5 >> put a VarGlobal a -> putWord8 6 >> put a VarEnum a b -> putWord8 7 >> put a >> put b VarBox a -> putWord8 8 >> put a VarCycle a b -> putWord8 9 >> put a >> put b VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d VarKernel a b -> putWord8 11 >> put a >> put b List a -> putWord8 12 >> put a Function a b -> putWord8 13 >> put a >> put b Call a b -> putWord8 14 >> put a >> put b TailCall a b -> putWord8 15 >> put a >> put b If a b -> putWord8 16 >> put a >> put b Let a b -> putWord8 17 >> put a >> put b Destruct a b -> putWord8 18 >> put a >> put b Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d Accessor a -> putWord8 20 >> put a Access a b -> putWord8 21 >> put a >> put b Update a b -> putWord8 22 >> put a >> put b Record a -> putWord8 23 >> put a Unit -> putWord8 24 Tuple a b c -> putWord8 25 >> put a >> put b >> put c Shader a b c -> putWord8 26 >> put a >> put b >> put c get = do word <- getWord8 case word of 0 -> liftM Bool get 1 -> liftM Chr get 2 -> liftM Str get 3 -> liftM Int get 4 -> liftM Float get 5 -> liftM VarLocal get 6 -> liftM VarGlobal get 7 -> liftM2 VarEnum get get 8 -> liftM VarBox get 9 -> liftM2 VarCycle get get 10 -> liftM4 VarDebug get get get get 11 -> liftM2 VarKernel get get 12 -> liftM List get 13 -> liftM2 Function get get 14 -> liftM2 Call get get 15 -> liftM2 TailCall get get 16 -> liftM2 If get get 17 -> liftM2 Let get get 18 -> liftM2 Destruct get get 19 -> liftM4 Case get get get get 20 -> liftM Accessor get 21 -> liftM2 Access get get 22 -> liftM2 Update get get 23 -> liftM Record get 24 -> pure Unit 25 -> liftM3 Tuple get get get 26 -> liftM3 Shader get get get _ -> fail "problem getting Opt.Expr binary" instance Binary Def where put def = case def of Def a b -> putWord8 0 >> put a >> put b TailDef a b c -> putWord8 1 >> put a >> put b >> put c get = do word <- getWord8 case word of 0 -> liftM2 Def get get 1 -> liftM3 TailDef get get get _ -> fail "problem getting Opt.Def binary" instance Binary Destructor where get = liftM2 Destructor get get put (Destructor a b) = put a >> put b instance Binary Path where put destructor = case destructor of Index a b -> putWord8 0 >> put a >> put b Field a b -> putWord8 1 >> put a >> put b Unbox a -> putWord8 2 >> put a Root a -> putWord8 3 >> put a get = do word <- getWord8 case word of 0 -> liftM2 Index get get 1 -> liftM2 Field get get 2 -> liftM Unbox get 3 -> liftM Root get _ -> fail "problem getting Opt.Path binary" instance (Binary a) => Binary (Decider a) where put decider = case decider of Leaf a -> putWord8 0 >> put a Chain a b c -> putWord8 1 >> put a >> put b >> put c FanOut a b c -> putWord8 2 >> put a >> put b >> put c get = do word <- getWord8 case word of 0 -> liftM Leaf get 1 -> liftM3 Chain get get get 2 -> liftM3 FanOut get get get _ -> fail "problem getting Opt.Decider binary" instance Binary Choice where put choice = case choice of Inline expr -> putWord8 0 >> put expr Jump index -> putWord8 1 >> put index get = do word <- getWord8 case word of 0 -> liftM Inline get 1 -> liftM Jump get _ -> fail "problem getting Opt.Choice binary" instance Binary GlobalGraph where get = liftM2 GlobalGraph get get put (GlobalGraph a b) = put a >> put b instance Binary LocalGraph where get = liftM3 LocalGraph get get get put (LocalGraph a b c) = put a >> put b >> put c instance Binary Main where put main = case main of Static -> putWord8 0 Dynamic a b -> putWord8 1 >> put a >> put b get = do word <- getWord8 case word of 0 -> return Static 1 -> liftM2 Dynamic get get _ -> fail "problem getting Opt.Main binary" instance Binary Node where put node = case node of Define a b -> putWord8 0 >> put a >> put b DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c Ctor a b -> putWord8 2 >> put a >> put b Enum a -> putWord8 3 >> put a Box -> putWord8 4 Link a -> putWord8 5 >> put a Cycle a b c d -> putWord8 6 >> put a >> put b >> put c >> put d Manager a -> putWord8 7 >> put a Kernel a b -> putWord8 8 >> put a >> put b PortIncoming a b -> putWord8 9 >> put a >> put b PortOutgoing a b -> putWord8 10 >> put a >> put b get = do word <- getWord8 case word of 0 -> liftM2 Define get get 1 -> liftM3 DefineTailFunc get get get 2 -> liftM2 Ctor get get 3 -> liftM Enum get 4 -> return Box 5 -> liftM Link get 6 -> liftM4 Cycle get get get get 7 -> liftM Manager get 8 -> liftM2 Kernel get get 9 -> liftM2 PortIncoming get get 10 -> liftM2 PortOutgoing get get _ -> fail "problem getting Opt.Node binary" instance Binary EffectsType where put effectsType = case effectsType of Cmd -> putWord8 0 Sub -> putWord8 1 Fx -> putWord8 2 get = do word <- getWord8 case word of 0 -> return Cmd 1 -> return Sub 2 -> return Fx _ -> fail "problem getting Opt.EffectsType binary" ================================================ FILE: compiler/src/AST/Source.hs ================================================ module AST.Source ( Expr, Expr_(..), VarType(..) , Def(..) , Pattern, Pattern_(..) , Type, Type_(..) , Module(..) , getName , getImportName , Import(..) , Value(..) , Union(..) , Alias(..) , Infix(..) , Port(..) , Effects(..) , Manager(..) , Docs(..) , Comment(..) , Exposing(..) , Exposed(..) , Privacy(..) ) where import Data.Name (Name) import qualified Data.Name as Name import qualified AST.Utils.Binop as Binop import qualified AST.Utils.Shader as Shader import qualified Elm.Float as EF import qualified Elm.String as ES import qualified Parse.Primitives as P import qualified Reporting.Annotation as A -- EXPRESSIONS type Expr = A.Located Expr_ data Expr_ = Chr ES.String | Str ES.String | Int Int | Float EF.Float | Var VarType Name | VarQual VarType Name Name | List [Expr] | Op Name | Negate Expr | Binops [(Expr, A.Located Name)] Expr | Lambda [Pattern] Expr | Call Expr [Expr] | If [(Expr, Expr)] Expr | Let [A.Located Def] Expr | Case Expr [(Pattern, Expr)] | Accessor Name | Access Expr (A.Located Name) | Update (A.Located Name) [(A.Located Name, Expr)] | Record [(A.Located Name, Expr)] | Unit | Tuple Expr Expr [Expr] | Shader Shader.Source Shader.Types data VarType = LowVar | CapVar -- DEFINITIONS data Def = Define (A.Located Name) [Pattern] Expr (Maybe Type) | Destruct Pattern Expr -- PATTERN type Pattern = A.Located Pattern_ data Pattern_ = PAnything | PVar Name | PRecord [A.Located Name] | PAlias Pattern (A.Located Name) | PUnit | PTuple Pattern Pattern [Pattern] | PCtor A.Region Name [Pattern] | PCtorQual A.Region Name Name [Pattern] | PList [Pattern] | PCons Pattern Pattern | PChr ES.String | PStr ES.String | PInt Int -- TYPE type Type = A.Located Type_ data Type_ = TLambda Type Type | TVar Name | TType A.Region Name [Type] | TTypeQual A.Region Name Name [Type] | TRecord [(A.Located Name, Type)] (Maybe (A.Located Name)) | TUnit | TTuple Type Type [Type] -- MODULE data Module = Module { _name :: Maybe (A.Located Name) , _exports :: A.Located Exposing , _docs :: Docs , _imports :: [Import] , _values :: [A.Located Value] , _unions :: [A.Located Union] , _aliases :: [A.Located Alias] , _binops :: [A.Located Infix] , _effects :: Effects } getName :: Module -> Name getName (Module maybeName _ _ _ _ _ _ _ _) = case maybeName of Just (A.At _ name) -> name Nothing -> Name._Main getImportName :: Import -> Name getImportName (Import (A.At _ name) _ _) = name data Import = Import { _import :: A.Located Name , _alias :: Maybe Name , _exposing :: Exposing } data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type) data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])] data Alias = Alias (A.Located Name) [A.Located Name] Type data Infix = Infix Name Binop.Associativity Binop.Precedence Name data Port = Port (A.Located Name) Type data Effects = NoEffects | Ports [Port] | Manager A.Region Manager data Manager = Cmd (A.Located Name) | Sub (A.Located Name) | Fx (A.Located Name) (A.Located Name) data Docs = NoDocs A.Region | YesDocs Comment [(Name, Comment)] newtype Comment = Comment P.Snippet -- EXPOSING data Exposing = Open | Explicit [Exposed] data Exposed = Lower (A.Located Name) | Upper (A.Located Name) Privacy | Operator A.Region Name data Privacy = Public A.Region | Private ================================================ FILE: compiler/src/AST/Utils/Binop.hs ================================================ module AST.Utils.Binop ( Precedence(..) , Associativity(..) ) where import Prelude hiding (Either(..)) import Control.Monad (liftM) import Data.Binary -- BINOP STUFF newtype Precedence = Precedence Int deriving (Eq, Ord) data Associativity = Left | Non | Right deriving (Eq) -- BINARY instance Binary Precedence where get = liftM Precedence get put (Precedence n) = put n instance Binary Associativity where get = do n <- getWord8 case n of 0 -> return Left 1 -> return Non 2 -> return Right _ -> fail "Error reading valid associativity from serialized string" put assoc = putWord8 $ case assoc of Left -> 0 Non -> 1 Right -> 2 ================================================ FILE: compiler/src/AST/Utils/Shader.hs ================================================ {-# LANGUAGE EmptyDataDecls #-} module AST.Utils.Shader ( Source , Types(..) , Type(..) , fromChars , toJsStringBuilder ) where import Control.Monad (liftM) import Data.Binary (Binary, get, put) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B import qualified Data.ByteString.UTF8 as BS_UTF8 import qualified Data.Map as Map import qualified Data.Name as Name -- SOURCE newtype Source = Source BS.ByteString -- TYPES data Types = Types { _attribute :: Map.Map Name.Name Type , _uniform :: Map.Map Name.Name Type , _varying :: Map.Map Name.Name Type } data Type = Int | Float | V2 | V3 | V4 | M4 | Texture -- TO BUILDER toJsStringBuilder :: Source -> B.Builder toJsStringBuilder (Source src) = B.byteString src -- FROM CHARS fromChars :: [Char] -> Source fromChars chars = Source (BS_UTF8.fromString (escape chars)) escape :: [Char] -> [Char] escape chars = case chars of [] -> [] c:cs | c == '\r' -> escape cs | c == '\n' -> '\\' : 'n' : escape cs | c == '\"' -> '\\' : '"' : escape cs | c == '\'' -> '\\' : '\'' : escape cs | c == '\\' -> '\\' : '\\' : escape cs | otherwise -> c : escape cs -- BINARY instance Binary Source where get = liftM Source get put (Source a) = put a ================================================ FILE: compiler/src/AST/Utils/Type.hs ================================================ module AST.Utils.Type ( delambda , dealias , deepDealias , iteratedDealias ) where import qualified Data.Map as Map import qualified Data.Name as Name import AST.Canonical (Type(..), AliasType(..), FieldType(..)) -- DELAMBDA delambda :: Type -> [Type] delambda tipe = case tipe of TLambda arg result -> arg : delambda result _ -> [tipe] -- DEALIAS dealias :: [(Name.Name, Type)] -> AliasType -> Type dealias args aliasType = case aliasType of Holey tipe -> dealiasHelp (Map.fromList args) tipe Filled tipe -> tipe dealiasHelp :: Map.Map Name.Name Type -> Type -> Type dealiasHelp typeTable tipe = case tipe of TLambda a b -> TLambda (dealiasHelp typeTable a) (dealiasHelp typeTable b) TVar x -> Map.findWithDefault tipe x typeTable TRecord fields ext -> TRecord (Map.map (dealiasField typeTable) fields) ext TAlias home name args t' -> TAlias home name (map (fmap (dealiasHelp typeTable)) args) t' TType home name args -> TType home name (map (dealiasHelp typeTable) args) TUnit -> TUnit TTuple a b maybeC -> TTuple (dealiasHelp typeTable a) (dealiasHelp typeTable b) (fmap (dealiasHelp typeTable) maybeC) dealiasField :: Map.Map Name.Name Type -> FieldType -> FieldType dealiasField typeTable (FieldType index tipe) = FieldType index (dealiasHelp typeTable tipe) -- DEEP DEALIAS deepDealias :: Type -> Type deepDealias tipe = case tipe of TLambda a b -> TLambda (deepDealias a) (deepDealias b) TVar _ -> tipe TRecord fields ext -> TRecord (Map.map deepDealiasField fields) ext TAlias _ _ args tipe' -> deepDealias (dealias args tipe') TType home name args -> TType home name (map deepDealias args) TUnit -> TUnit TTuple a b c -> TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c) deepDealiasField :: FieldType -> FieldType deepDealiasField (FieldType index tipe) = FieldType index (deepDealias tipe) -- ITERATED DEALIAS iteratedDealias :: Type -> Type iteratedDealias tipe = case tipe of TAlias _ _ args realType -> iteratedDealias (dealias args realType) _ -> tipe ================================================ FILE: compiler/src/Canonicalize/Effects.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Canonicalize.Effects ( canonicalize , checkPayload ) where import qualified Data.Foldable as F import qualified Data.Map as Map import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Source as Src import qualified AST.Utils.Type as Type import qualified Canonicalize.Environment as Env import qualified Canonicalize.Type as Type import qualified Elm.ModuleName as ModuleName import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result -- RESULT type Result i w a = Result.Result i w Error.Error a -- CANONICALIZE canonicalize :: Env.Env -> [A.Located Src.Value] -> Map.Map Name.Name union -> Src.Effects -> Result i w Can.Effects canonicalize env values unions effects = case effects of Src.NoEffects -> Result.ok Can.NoEffects Src.Ports ports -> do pairs <- traverse (canonicalizePort env) ports return $ Can.Ports (Map.fromList pairs) Src.Manager region manager -> let dict = Map.fromList (map toNameRegion values) in Can.Manager <$> verifyManager region dict "init" <*> verifyManager region dict "onEffects" <*> verifyManager region dict "onSelfMsg" <*> case manager of Src.Cmd cmdType -> Can.Cmd <$> verifyEffectType cmdType unions <* verifyManager region dict "cmdMap" Src.Sub subType -> Can.Sub <$> verifyEffectType subType unions <* verifyManager region dict "subMap" Src.Fx cmdType subType -> Can.Fx <$> verifyEffectType cmdType unions <*> verifyEffectType subType unions <* verifyManager region dict "cmdMap" <* verifyManager region dict "subMap" -- CANONICALIZE PORT canonicalizePort :: Env.Env -> Src.Port -> Result i w (Name.Name, Can.Port) canonicalizePort env (Src.Port (A.At region portName) tipe) = do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe case reverse (Type.delambda (Type.deepDealias ctipe)) of Can.TType home name [msg] : revArgs | home == ModuleName.cmd && name == Name.cmd -> case revArgs of [] -> Result.throw (Error.PortTypeInvalid region portName Error.CmdNoArg) [outgoingType] -> case msg of Can.TVar _ -> case checkPayload outgoingType of Right () -> Result.ok (portName, Can.Outgoing freeVars outgoingType ctipe) Left (badType, err) -> Result.throw (Error.PortPayloadInvalid region portName badType err) _ -> Result.throw (Error.PortTypeInvalid region portName Error.CmdBadMsg) _ -> Result.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (length revArgs))) | home == ModuleName.sub && name == Name.sub -> case revArgs of [Can.TLambda incomingType (Can.TVar msg1)] -> case msg of Can.TVar msg2 | msg1 == msg2 -> case checkPayload incomingType of Right () -> Result.ok (portName, Can.Incoming freeVars incomingType ctipe) Left (badType, err) -> Result.throw (Error.PortPayloadInvalid region portName badType err) _ -> Result.throw (Error.PortTypeInvalid region portName Error.SubBad) _ -> Result.throw (Error.PortTypeInvalid region portName Error.SubBad) _ -> Result.throw (Error.PortTypeInvalid region portName Error.NotCmdOrSub) -- VERIFY MANAGER verifyEffectType :: A.Located Name.Name -> Map.Map Name.Name a -> Result i w Name.Name verifyEffectType (A.At region name) unions = if Map.member name unions then Result.ok name else Result.throw (Error.EffectNotFound region name) toNameRegion :: A.Located Src.Value -> (Name.Name, A.Region) toNameRegion (A.At _ (Src.Value (A.At region name) _ _ _)) = (name, region) verifyManager :: A.Region -> Map.Map Name.Name A.Region -> Name.Name -> Result i w A.Region verifyManager tagRegion values name = case Map.lookup name values of Just region -> Result.ok region Nothing -> Result.throw (Error.EffectFunctionNotFound tagRegion name) -- CHECK PAYLOAD TYPES checkPayload :: Can.Type -> Either (Can.Type, Error.InvalidPayload) () checkPayload tipe = case tipe of Can.TAlias _ _ args aliasedType -> checkPayload (Type.dealias args aliasedType) Can.TType home name args -> case args of [] | isJson home name -> Right () | isString home name -> Right () | isIntFloatBool home name -> Right () [arg] | isList home name -> checkPayload arg | isMaybe home name -> checkPayload arg | isArray home name -> checkPayload arg _ -> Left (tipe, Error.UnsupportedType name) Can.TUnit -> Right () Can.TTuple a b maybeC -> do checkPayload a checkPayload b case maybeC of Nothing -> Right () Just c -> checkPayload c Can.TVar name -> Left (tipe, Error.TypeVariable name) Can.TLambda _ _ -> Left (tipe, Error.Function) Can.TRecord _ (Just _) -> Left (tipe, Error.ExtendedRecord) Can.TRecord fields Nothing -> F.traverse_ checkFieldPayload fields checkFieldPayload :: Can.FieldType -> Either (Can.Type, Error.InvalidPayload) () checkFieldPayload (Can.FieldType _ tipe) = checkPayload tipe isIntFloatBool :: ModuleName.Canonical -> Name.Name -> Bool isIntFloatBool home name = home == ModuleName.basics && (name == Name.int || name == Name.float || name == Name.bool) isString :: ModuleName.Canonical -> Name.Name -> Bool isString home name = home == ModuleName.string && name == Name.string isJson :: ModuleName.Canonical -> Name.Name -> Bool isJson home name = home == ModuleName.jsonEncode && name == Name.value isList :: ModuleName.Canonical -> Name.Name -> Bool isList home name = home == ModuleName.list && name == Name.list isMaybe :: ModuleName.Canonical -> Name.Name -> Bool isMaybe home name = home == ModuleName.maybe && name == Name.maybe isArray :: ModuleName.Canonical -> Name.Name -> Bool isArray home name = home == ModuleName.array && name == Name.array ================================================ FILE: compiler/src/Canonicalize/Environment/Dups.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Canonicalize.Environment.Dups ( detect , checkFields , checkFields' , Dict , none , one , insert , union , unions ) where import qualified Data.Map as Map import qualified Data.Name as Name import qualified Data.OneOrMore as OneOrMore import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result -- DUPLICATE TRACKER type Dict value = Map.Map Name.Name (OneOrMore.OneOrMore (Info value)) data Info value = Info { _region :: A.Region , _value :: value } -- DETECT type ToError = Name.Name -> A.Region -> A.Region -> Error.Error detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name a) detect toError dict = Map.traverseWithKey (detectHelp toError) dict detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a detectHelp toError name values = case values of OneOrMore.One (Info _ value) -> return value OneOrMore.More left right -> let (Info r1 _, Info r2 _) = OneOrMore.getFirstTwo left right in Result.throw (toError name r1 r2) -- CHECK FIELDS checkFields :: [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name a) checkFields fields = detect Error.DuplicateField (foldr addField none fields) addField :: (A.Located Name.Name, a) -> Dict a -> Dict a addField (A.At region name, value) dups = Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups checkFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name b) checkFields' toValue fields = detect Error.DuplicateField (foldr (addField' toValue) none fields) addField' :: (A.Region -> a -> b) -> (A.Located Name.Name, a) -> Dict b -> Dict b addField' toValue (A.At region name, value) dups = Map.insertWith OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups -- BUILDING DICTIONARIES none :: Dict a none = Map.empty one :: Name.Name -> A.Region -> value -> Dict value one name region value = Map.singleton name (OneOrMore.one (Info region value)) insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a insert name region value dict = Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict union :: Dict a -> Dict a -> Dict a union a b = Map.unionWith OneOrMore.more a b unions :: [Dict a] -> Dict a unions dicts = Map.unionsWith OneOrMore.more dicts ================================================ FILE: compiler/src/Canonicalize/Environment/Foreign.hs ================================================ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Canonicalize.Environment.Foreign ( createInitialEnv ) where import Control.Monad (foldM) import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Map.Strict ((!)) import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Source as Src import qualified Canonicalize.Environment as Env import qualified Elm.Interface as I import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result -- RESULT type Result i w a = Result.Result i w Error.Error a createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env createInitialEnv home ifaces imports = do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports) Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs) infoToVar :: Env.Info Can.Annotation -> Env.Var infoToVar info = case info of Env.Specific home tipe -> Env.Foreign home tipe Env.Ambiguous h hs -> Env.Foreigns h hs -- STATE data State = State { _vars :: Env.Exposed Can.Annotation , _types :: Env.Exposed Env.Type , _ctors :: Env.Exposed Env.Ctor , _binops :: Env.Exposed Env.Binop , _q_vars :: Env.Qualified Can.Annotation , _q_types :: Env.Qualified Env.Type , _q_ctors :: Env.Qualified Env.Ctor } emptyState :: State emptyState = State Map.empty emptyTypes Map.empty Map.empty Map.empty Map.empty Map.empty emptyTypes :: Env.Exposed Env.Type emptyTypes = Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list)) -- TO SAFE IMPORTS toSafeImports :: ModuleName.Canonical -> [Src.Import] -> [Src.Import] toSafeImports (ModuleName.Canonical pkg _) imports = if Pkg.isKernel pkg then filter isNormal imports else imports isNormal :: Src.Import -> Bool isNormal (Src.Import (A.At _ name) maybeAlias _) = if Name.isKernel name then case maybeAlias of Nothing -> False Just _ -> error "kernel imports cannot use `as`" else True -- ADD IMPORTS addImport :: Map.Map ModuleName.Raw I.Interface -> State -> Src.Import -> Result i w State addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybeAlias exposing) = let (I.Interface pkg defs unions aliases binops) = ifaces ! name !prefix = maybe name id maybeAlias !home = ModuleName.Canonical pkg name !rawTypeInfo = Map.union (Map.mapMaybeWithKey (unionToType home) unions) (Map.mapMaybeWithKey (aliasToType home) aliases) !vars = Map.map (Env.Specific home) defs !types = Map.map (Env.Specific home . fst) rawTypeInfo !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo !qvs2 = addQualified prefix vars qvs !qts2 = addQualified prefix types qts !qcs2 = addQualified prefix ctors qcs in case exposing of Src.Open -> let !vs2 = addExposed vs vars !ts2 = addExposed ts types !cs2 = addExposed cs ctors !bs2 = addExposed bs (Map.mapWithKey (binopToBinop home) binops) in Result.ok (State vs2 ts2 cs2 bs2 qvs2 qts2 qcs2) Src.Explicit exposedList -> foldM (addExposedValue home vars rawTypeInfo binops) (State vs ts cs bs qvs2 qts2 qcs2) exposedList addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a addExposed = Map.unionWith Env.mergeInfo addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a addQualified prefix exposed qualified = Map.insertWith addExposed prefix exposed qualified -- UNION unionToType :: ModuleName.Canonical -> Name.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor) unionToType home name union = unionToTypeHelp home name <$> I.toPublicUnion union unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor) unionToTypeHelp home name union@(Can.Union vars ctors _ _) = let addCtor dict (Can.Ctor ctor index _ args) = Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict in ( Env.Union (length vars) home , List.foldl' addCtor Map.empty ctors ) -- ALIAS aliasToType :: ModuleName.Canonical -> Name.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor) aliasToType home name alias = aliasToTypeHelp home name <$> I.toPublicAlias alias aliasToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor) aliasToTypeHelp home name (Can.Alias vars tipe) = ( Env.Alias (length vars) home vars tipe , case tipe of Can.TRecord fields Nothing -> let avars = map (\var -> (var, Can.TVar var)) vars alias = foldr (\(_,t1) t2 -> Can.TLambda t1 t2) (Can.TAlias home name avars (Can.Filled tipe)) (Can.fieldsToList fields) in Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias)) _ -> Map.empty ) -- BINOP binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop binopToBinop home op (I.Binop name annotation associativity precedence) = Env.Specific home (Env.Binop op home name annotation associativity precedence) -- ADD EXPOSED VALUE addExposedValue :: ModuleName.Canonical -> Env.Exposed Can.Annotation -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name I.Binop -> State -> Src.Exposed -> Result i w State addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed = case exposed of Src.Lower (A.At region name) -> case Map.lookup name vars of Just info -> Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs) Nothing -> Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars)) Src.Upper (A.At region name) privacy -> case privacy of Src.Private -> case Map.lookup name types of Just (tipe, ctors) -> case tipe of Env.Union _ _ -> let !ts2 = Map.insert name (Env.Specific home tipe) ts in Result.ok (State vs ts2 cs bs qvs qts qcs) Env.Alias _ _ _ _ -> let !ts2 = Map.insert name (Env.Specific home tipe) ts !cs2 = addExposed cs ctors in Result.ok (State vs ts2 cs2 bs qvs qts qcs) Nothing -> case checkForCtorMistake name types of tipe:_ -> Result.throw $ Error.ImportCtorByName region name tipe [] -> Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types) Src.Public dotDotRegion -> case Map.lookup name types of Just (tipe, ctors) -> case tipe of Env.Union _ _ -> let !ts2 = Map.insert name (Env.Specific home tipe) ts !cs2 = addExposed cs ctors in Result.ok (State vs ts2 cs2 bs qvs qts qcs) Env.Alias _ _ _ _ -> Result.throw (Error.ImportOpenAlias dotDotRegion name) Nothing -> Result.throw (Error.ImportExposingNotFound region home name (Map.keys types)) Src.Operator region op -> case Map.lookup op binops of Just binop -> let !bs2 = Map.insert op (binopToBinop home op binop) bs in Result.ok (State vs ts cs bs2 qvs qts qcs) Nothing -> Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops)) checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name] checkForCtorMistake givenName types = Map.foldr addMatches [] types where addMatches (_, exposedCtors) matches = Map.foldrWithKey addMatch matches exposedCtors addMatch ctorName info matches = if ctorName /= givenName then matches else case info of Env.Specific _ (Env.Ctor _ tipeName _ _ _) -> tipeName : matches Env.Specific _ (Env.RecordCtor _ _ _) -> matches Env.Ambiguous _ _ -> matches ================================================ FILE: compiler/src/Canonicalize/Environment/Local.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Canonicalize.Environment.Local ( add ) where import Control.Monad (foldM) import qualified Data.Graph as Graph import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Source as Src import qualified Canonicalize.Environment as Env import qualified Canonicalize.Environment.Dups as Dups import qualified Canonicalize.Type as Type import qualified Data.Index as Index import qualified Elm.ModuleName as ModuleName import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result -- RESULT type Result i w a = Result.Result i w Error.Error a type Unions = Map.Map Name.Name Can.Union type Aliases = Map.Map Name.Name Can.Alias add :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases) add module_ env = addCtors module_ =<< addVars module_ =<< addTypes module_ env -- ADD VARS addVars :: Src.Module -> Env.Env -> Result i w Env.Env addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) = do topLevelVars <- collectVars module_ let vs2 = Map.union topLevelVars vs -- Use union to overwrite foreign stuff. Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var) collectVars (Src.Module _ _ _ _ values _ _ _ effects) = let addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) = Dups.insert name region (Env.TopLevel region) dict in Dups.detect Error.DuplicateDecl $ List.foldl' addDecl (toEffectDups effects) values toEffectDups :: Src.Effects -> Dups.Dict Env.Var toEffectDups effects = case effects of Src.NoEffects -> Dups.none Src.Ports ports -> let addPort dict (Src.Port (A.At region name) _) = Dups.insert name region (Env.TopLevel region) dict in List.foldl' addPort Dups.none ports Src.Manager _ manager -> case manager of Src.Cmd (A.At region _) -> Dups.one "command" region (Env.TopLevel region) Src.Sub (A.At region _) -> Dups.one "subscription" region (Env.TopLevel region) Src.Fx (A.At regionCmd _) (A.At regionSub _) -> Dups.union (Dups.one "command" regionCmd (Env.TopLevel regionCmd)) (Dups.one "subscription" regionSub (Env.TopLevel regionSub)) -- ADD TYPES addTypes :: Src.Module -> Env.Env -> Result i w Env.Env addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) = let addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups typeNameDups = List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions in do _ <- Dups.detect Error.DuplicateType typeNameDups ts1 <- foldM (addUnion home) ts unions addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs) addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type) addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) = do arity <- checkUnionFreeVars union let one = Env.Specific home (Env.Union arity home) Result.ok $ Map.insert name one types -- ADD TYPE ALIASES addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env addAliases aliases env = let nodes = map toNode aliases sccs = Graph.stronglyConnComp nodes in foldM addAlias env sccs addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc = case scc of Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) -> do args <- checkAliasFreeVars alias ctype <- Type.canonicalize env tipe let one = Env.Specific home (Env.Alias (length args) home args ctype) let ts1 = Map.insert name one ts Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs Graph.CyclicSCC [] -> Result.ok env Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) -> do args <- checkAliasFreeVars alias let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others)) -- DETECT TYPE ALIAS CYCLES toNode :: A.Located Src.Alias -> (A.Located Src.Alias, Name.Name, [Name.Name]) toNode alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) = ( alias, name, getEdges [] tipe ) getEdges :: [Name.Name] -> Src.Type -> [Name.Name] getEdges edges (A.At _ tipe) = case tipe of Src.TLambda arg result -> getEdges (getEdges edges arg) result Src.TVar _ -> edges Src.TType _ name args -> List.foldl' getEdges (name:edges) args Src.TTypeQual _ _ _ args -> List.foldl' getEdges edges args Src.TRecord fields _ -> List.foldl' (\es (_,t) -> getEdges es t) edges fields Src.TUnit -> edges Src.TTuple a b cs -> List.foldl' getEdges (getEdges (getEdges edges a) b) cs -- CHECK FREE VARIABLES checkUnionFreeVars :: A.Located Src.Union -> Result i w Int checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) = let addArg (A.At region arg) dict = Dups.insert arg region region dict addCtorFreeVars (_, tipes) freeVars = List.foldl' addFreeVars freeVars tipes in do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addArg Dups.none args) let freeVars = foldr addCtorFreeVars Map.empty ctors case Map.toList (Map.difference freeVars boundVars) of [] -> Result.ok (length args) unbound:unbounds -> Result.throw $ Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name] checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) = let addArg (A.At region arg) dict = Dups.insert arg region region dict in do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addArg Dups.none args) let freeVars = addFreeVars Map.empty tipe let overlap = Map.size (Map.intersection boundVars freeVars) if Map.size boundVars == overlap && Map.size freeVars == overlap then Result.ok (map A.toValue args) else Result.throw $ Error.TypeVarsMessedUpInAlias aliasRegion name (map A.toValue args) (Map.toList (Map.difference boundVars freeVars)) (Map.toList (Map.difference freeVars boundVars)) addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region addFreeVars freeVars (A.At region tipe) = case tipe of Src.TLambda arg result -> addFreeVars (addFreeVars freeVars arg) result Src.TVar name -> Map.insert name region freeVars Src.TType _ _ args -> List.foldl' addFreeVars freeVars args Src.TTypeQual _ _ _ args -> List.foldl' addFreeVars freeVars args Src.TRecord fields maybeExt -> let extFreeVars = case maybeExt of Nothing -> freeVars Just (A.At extRegion ext) -> Map.insert ext extRegion freeVars in List.foldl' (\fvs (_,t) -> addFreeVars fvs t) extFreeVars fields Src.TUnit -> freeVars Src.TTuple a b cs -> List.foldl' addFreeVars (addFreeVars (addFreeVars freeVars a) b) cs -- ADD CTORS addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases) addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) = do unionInfo <- traverse (canonicalizeUnion env) unions aliasInfo <- traverse (canonicalizeAlias env) aliases ctors <- Dups.detect Error.DuplicateCtor $ Dups.union (Dups.unions (map snd unionInfo)) (Dups.unions (map snd aliasInfo)) let cs2 = Map.union ctors cs Result.ok ( Env.Env home vs ts cs2 bs qvs qts qcs , Map.fromList (map fst unionInfo) , Map.fromList (map fst aliasInfo) ) type CtorDups = Dups.Dict (Env.Info Env.Ctor) -- CANONICALIZE ALIAS canonicalizeAlias :: Env.Env -> A.Located Src.Alias -> Result i w ( (Name.Name, Can.Alias), CtorDups ) canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At region name) args tipe)) = do let vars = map A.toValue args ctipe <- Type.canonicalize env tipe Result.ok ( (name, Can.Alias vars ctipe) , case ctipe of Can.TRecord fields Nothing -> Dups.one name region (Env.Specific home (toRecordCtor home name vars fields)) _ -> Dups.none ) toRecordCtor :: ModuleName.Canonical -> Name.Name -> [Name.Name] -> Map.Map Name.Name Can.FieldType -> Env.Ctor toRecordCtor home name vars fields = let avars = map (\var -> (var, Can.TVar var)) vars alias = foldr (\(_,t1) t2 -> Can.TLambda t1 t2) (Can.TAlias home name avars (Can.Filled (Can.TRecord fields Nothing))) (Can.fieldsToList fields) in Env.RecordCtor home vars alias -- CANONICALIZE UNION canonicalizeUnion :: Env.Env -> A.Located Src.Union -> Result i w ( (Name.Name, Can.Union), CtorDups ) canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Union (A.At _ name) avars ctors)) = do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors let vars = map A.toValue avars let alts = map A.toValue cctors let union = Can.Union vars alts (length alts) (toOpts ctors) Result.ok ( (name, union) , Dups.unions $ map (toCtor home name union) cctors ) canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located Name.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor) canonicalizeCtor env index (A.At region ctor, tipes) = do ctipes <- traverse (Type.canonicalize env) tipes Result.ok $ A.At region $ Can.Ctor ctor index (length ctipes) ctipes toOpts :: [(A.Located Name.Name, [Src.Type])] -> Can.CtorOpts toOpts ctors = case ctors of [ (_,[_]) ] -> Can.Unbox _ -> if all (null . snd) ctors then Can.Enum else Can.Normal toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups toCtor home typeName union (A.At region (Can.Ctor name index _ args)) = Dups.one name region $ Env.Specific home $ Env.Ctor home typeName union index args ================================================ FILE: compiler/src/Canonicalize/Environment.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Canonicalize.Environment ( Env(..) , Exposed , Qualified , Info(..) , mergeInfo , Var(..) , Type(..) , Ctor(..) , addLocals , findType , findTypeQual , findCtor , findCtorQual , findBinop , Binop(..) ) where import qualified Data.Map.Merge.Strict as Map import qualified Data.Map.Strict as Map import qualified Data.Name as Name import qualified Data.OneOrMore as OneOrMore import qualified AST.Utils.Binop as Binop import qualified AST.Canonical as Can import qualified Data.Index as Index import qualified Elm.ModuleName as ModuleName import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result -- RESULT type Result i w a = Result.Result i w Error.Error a -- ENVIRONMENT data Env = Env { _home :: ModuleName.Canonical , _vars :: Map.Map Name.Name Var , _types :: Exposed Type , _ctors :: Exposed Ctor , _binops :: Exposed Binop , _q_vars :: Qualified Can.Annotation , _q_types :: Qualified Type , _q_ctors :: Qualified Ctor } type Exposed a = Map.Map Name.Name (Info a) type Qualified a = Map.Map Name.Name (Map.Map Name.Name (Info a)) -- INFO data Info a = Specific ModuleName.Canonical a | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical) mergeInfo :: Info a -> Info a -> Info a mergeInfo info1 info2 = case info1 of Specific h1 _ -> case info2 of Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2) Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2) Ambiguous h1 hs1 -> case info2 of Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2)) Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2)) -- VARIABLES data Var = Local A.Region | TopLevel A.Region | Foreign ModuleName.Canonical Can.Annotation | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical) -- TYPES data Type = Alias Int ModuleName.Canonical [Name.Name] Can.Type | Union Int ModuleName.Canonical -- CTORS data Ctor = RecordCtor ModuleName.Canonical [Name.Name] Can.Type | Ctor { _c_home :: ModuleName.Canonical , _c_type :: Name.Name , _c_union :: Can.Union , _c_index :: Index.ZeroBased , _c_args :: [Can.Type] } -- BINOPS data Binop = Binop { _op :: Name.Name , _op_home :: ModuleName.Canonical , _op_name :: Name.Name , _op_annotation :: Can.Annotation , _op_associativity :: Binop.Associativity , _op_precedence :: Binop.Precedence } -- VARIABLE -- ADD LOCALS addLocals :: Map.Map Name.Name A.Region -> Env -> Result i w Env addLocals names (Env home vars ts cs bs qvs qts qcs) = do newVars <- Map.mergeA (Map.mapMissing addLocalLeft) (Map.mapMissing (\_ homes -> homes)) (Map.zipWithAMatched addLocalBoth) names vars Result.ok (Env home newVars ts cs bs qvs qts qcs) addLocalLeft :: Name.Name -> A.Region -> Var addLocalLeft _ region = Local region addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var addLocalBoth name region var = case var of Foreign _ _ -> Result.ok (Local region) Foreigns _ _ -> Result.ok (Local region) Local parentRegion -> Result.throw (Error.Shadowing name parentRegion region) TopLevel parentRegion -> Result.throw (Error.Shadowing name parentRegion region) -- FIND TYPE findType :: A.Region -> Env -> Name.Name -> Result i w Type findType region (Env _ _ ts _ _ _ qts _) name = case Map.lookup name ts of Just (Specific _ tipe) -> Result.ok tipe Just (Ambiguous h hs) -> Result.throw (Error.AmbiguousType region Nothing name h hs) Nothing -> Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts)) findTypeQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Type findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name = case Map.lookup prefix qts of Just qualified -> case Map.lookup name qualified of Just (Specific _ tipe) -> Result.ok tipe Just (Ambiguous h hs) -> Result.throw (Error.AmbiguousType region (Just prefix) name h hs) Nothing -> Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts)) Nothing -> Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts)) -- FIND CTOR findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor findCtor region (Env _ _ _ cs _ _ _ qcs) name = case Map.lookup name cs of Just (Specific _ ctor) -> Result.ok ctor Just (Ambiguous h hs) -> Result.throw (Error.AmbiguousVariant region Nothing name h hs) Nothing -> Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs)) findCtorQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Ctor findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name = case Map.lookup prefix qcs of Just qualified -> case Map.lookup name qualified of Just (Specific _ pattern) -> Result.ok pattern Just (Ambiguous h hs) -> Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs) Nothing -> Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs)) Nothing -> Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs)) -- FIND BINOP findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop findBinop region (Env _ _ _ _ binops _ _ _) name = case Map.lookup name binops of Just (Specific _ binop) -> Result.ok binop Just (Ambiguous h hs) -> Result.throw (Error.AmbiguousBinop region name h hs) Nothing -> Result.throw (Error.NotFoundBinop region name (Map.keysSet binops)) -- TO POSSIBLE NAMES toPossibleNames :: Exposed a -> Qualified a -> Error.PossibleNames toPossibleNames exposed qualified = Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified) ================================================ FILE: compiler/src/Canonicalize/Expression.hs ================================================ {-# OPTIONS_GHC -fno-warn-x-partial #-} {-# LANGUAGE OverloadedStrings #-} module Canonicalize.Expression ( canonicalize , FreeLocals , Uses(..) , verifyBindings , gatherTypedArgs ) where import Control.Monad (foldM) import qualified Data.Graph as Graph import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Source as Src import qualified AST.Utils.Binop as Binop import qualified AST.Utils.Type as Type import qualified Canonicalize.Environment as Env import qualified Canonicalize.Environment.Dups as Dups import qualified Canonicalize.Pattern as Pattern import qualified Canonicalize.Type as Type import qualified Data.Index as Index import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result import qualified Reporting.Warning as W -- RESULTS type Result i w a = Result.Result i w Error.Error a type FreeLocals = Map.Map Name.Name Uses data Uses = Uses { _direct :: {-# UNPACK #-} !Int , _delayed :: {-# UNPACK #-} !Int } -- CANONICALIZE canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr canonicalize env (A.At region expression) = A.At region <$> case expression of Src.Str string -> Result.ok (Can.Str string) Src.Chr char -> Result.ok (Can.Chr char) Src.Int int -> Result.ok (Can.Int int) Src.Float float -> Result.ok (Can.Float float) Src.Var varType name -> case varType of Src.LowVar -> findVar region env name Src.CapVar -> toVarCtor name <$> Env.findCtor region env name Src.VarQual varType prefix name -> case varType of Src.LowVar -> findVarQual region env prefix name Src.CapVar -> toVarCtor name <$> Env.findCtorQual region env prefix name Src.List exprs -> Can.List <$> traverse (canonicalize env) exprs Src.Op op -> do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op return (Can.VarOperator op home name annotation) Src.Negate expr -> Can.Negate <$> canonicalize env expr Src.Binops ops final -> A.toValue <$> canonicalizeBinops region env ops final Src.Lambda srcArgs body -> delayedUsage $ do (args, bindings) <- Pattern.verify Error.DPLambdaArgs $ traverse (Pattern.canonicalize env) srcArgs newEnv <- Env.addLocals bindings env (cbody, freeLocals) <- verifyBindings W.Pattern bindings (canonicalize newEnv body) return (Can.Lambda args cbody, freeLocals) Src.Call func args -> Can.Call <$> canonicalize env func <*> traverse (canonicalize env) args Src.If branches finally -> Can.If <$> traverse (canonicalizeIfBranch env) branches <*> canonicalize env finally Src.Let defs expr -> A.toValue <$> canonicalizeLet region env defs expr Src.Case expr branches -> Can.Case <$> canonicalize env expr <*> traverse (canonicalizeCaseBranch env) branches Src.Accessor field -> Result.ok $ Can.Accessor field Src.Access record field -> Can.Access <$> canonicalize env record <*> Result.ok field Src.Update (A.At reg name) fields -> let makeCanFields = Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields in Can.Update name <$> (A.At reg <$> findVar reg env name) <*> (sequenceA =<< makeCanFields) Src.Record fields -> do fieldDict <- Dups.checkFields fields Can.Record <$> traverse (canonicalize env) fieldDict Src.Unit -> Result.ok Can.Unit Src.Tuple a b cs -> Can.Tuple <$> canonicalize env a <*> canonicalize env b <*> canonicalizeTupleExtras region env cs Src.Shader src tipe -> Result.ok (Can.Shader src tipe) -- CANONICALIZE TUPLE EXTRAS canonicalizeTupleExtras :: A.Region -> Env.Env -> [Src.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr) canonicalizeTupleExtras region env extras = case extras of [] -> Result.ok Nothing [three] -> Just <$> canonicalize env three _ -> Result.throw (Error.TupleLargerThanThree region) -- CANONICALIZE IF BRANCH canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr) canonicalizeIfBranch env (condition, branch) = (,) <$> canonicalize env condition <*> canonicalize env branch -- CANONICALIZE CASE BRANCH canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch canonicalizeCaseBranch env (pattern, expr) = directUsage $ do (cpattern, bindings) <- Pattern.verify Error.DPCaseBranch $ Pattern.canonicalize env pattern newEnv <- Env.addLocals bindings env (cexpr, freeLocals) <- verifyBindings W.Pattern bindings (canonicalize newEnv expr) return (Can.CaseBranch cpattern cexpr, freeLocals) -- CANONICALIZE BINOPS canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr canonicalizeBinops overallRegion env ops final = let canonicalizeHelp (expr, A.At region op) = (,) <$> canonicalize env expr <*> Env.findBinop region env op in runBinopStepper overallRegion =<< ( More <$> traverse canonicalizeHelp ops <*> canonicalize env final ) data Step = Done Can.Expr | More [(Can.Expr, Env.Binop)] Can.Expr | Error Env.Binop Env.Binop runBinopStepper :: A.Region -> Step -> Result FreeLocals w Can.Expr runBinopStepper overallRegion step = case step of Done expr -> Result.ok expr More [] expr -> Result.ok expr More ( (expr, op) : rest ) final -> runBinopStepper overallRegion $ toBinopStep (toBinop op expr) op rest final Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) -> Result.throw (Error.Binop overallRegion op1 op2) toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step toBinopStep makeBinop rootOp@(Env.Binop _ _ _ _ rootAssociativity rootPrecedence) middle final = case middle of [] -> Done (makeBinop final) ( expr, op@(Env.Binop _ _ _ _ associativity precedence) ) : rest -> if precedence < rootPrecedence then More ((makeBinop expr, op) : rest) final else if precedence > rootPrecedence then case toBinopStep (toBinop op expr) op rest final of Done newLast -> Done (makeBinop newLast) More newMiddle newLast -> toBinopStep makeBinop rootOp newMiddle newLast Error a b -> Error a b else case (rootAssociativity, associativity) of (Binop.Left, Binop.Left) -> toBinopStep (\right -> toBinop op (makeBinop expr) right) op rest final (Binop.Right, Binop.Right) -> toBinopStep (\right -> makeBinop (toBinop op expr right)) op rest final (_, _) -> Error rootOp op toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr toBinop (Env.Binop op home name annotation _ _) left right = A.merge left right (Can.Binop op home name annotation left right) -- CANONICALIZE LET canonicalizeLet :: A.Region -> Env.Env -> [A.Located Src.Def] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr canonicalizeLet letRegion env defs body = directUsage $ do bindings <- Dups.detect (Error.DuplicatePattern Error.DPLetBinding) $ List.foldl' addBindings Dups.none defs newEnv <- Env.addLocals bindings env verifyBindings W.Def bindings $ do nodes <- foldM (addDefNodes newEnv) [] defs cbody <- canonicalize newEnv body detectCycles letRegion (Graph.stronglyConnComp nodes) cbody -- ADD BINDINGS addBindings :: Dups.Dict A.Region -> A.Located Src.Def -> Dups.Dict A.Region addBindings bindings (A.At _ def) = case def of Src.Define (A.At region name) _ _ _ -> Dups.insert name region region bindings Src.Destruct pattern _ -> addBindingsHelp bindings pattern addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region addBindingsHelp bindings (A.At region pattern) = case pattern of Src.PAnything -> bindings Src.PVar name -> Dups.insert name region region bindings Src.PRecord fields -> let addField dict (A.At fieldRegion name) = Dups.insert name fieldRegion fieldRegion dict in List.foldl' addField bindings fields Src.PUnit -> bindings Src.PTuple a b cs -> List.foldl' addBindingsHelp bindings (a:b:cs) Src.PCtor _ _ patterns -> List.foldl' addBindingsHelp bindings patterns Src.PCtorQual _ _ _ patterns -> List.foldl' addBindingsHelp bindings patterns Src.PList patterns -> List.foldl' addBindingsHelp bindings patterns Src.PCons hd tl -> addBindingsHelp (addBindingsHelp bindings hd) tl Src.PAlias aliasPattern (A.At nameRegion name) -> Dups.insert name nameRegion nameRegion $ addBindingsHelp bindings aliasPattern Src.PChr _ -> bindings Src.PStr _ -> bindings Src.PInt _ -> bindings -- BUILD BINDINGS GRAPH type Node = (Binding, Name.Name, [Name.Name]) data Binding = Define Can.Def | Edge (A.Located Name.Name) | Destruct Can.Pattern Can.Expr addDefNodes :: Env.Env -> [Node] -> A.Located Src.Def -> Result FreeLocals [W.Warning] [Node] addDefNodes env nodes (A.At _ def) = case def of Src.Define aname@(A.At _ name) srcArgs body maybeType -> case maybeType of Nothing -> do (args, argBindings) <- Pattern.verify (Error.DPFuncArgs name) $ traverse (Pattern.canonicalize env) srcArgs newEnv <- Env.addLocals argBindings env (cbody, freeLocals) <- verifyBindings W.Pattern argBindings (canonicalize newEnv body) let cdef = Can.Def aname args cbody let node = ( Define cdef, name, Map.keys freeLocals ) logLetLocals args freeLocals (node:nodes) Just tipe -> do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe ((args, resultType), argBindings) <- Pattern.verify (Error.DPFuncArgs name) $ gatherTypedArgs env name srcArgs ctipe Index.first [] newEnv <- Env.addLocals argBindings env (cbody, freeLocals) <- verifyBindings W.Pattern argBindings (canonicalize newEnv body) let cdef = Can.TypedDef aname freeVars args cbody resultType let node = ( Define cdef, name, Map.keys freeLocals ) logLetLocals args freeLocals (node:nodes) Src.Destruct pattern body -> do (cpattern, _bindings) <- Pattern.verify Error.DPDestruct $ Pattern.canonicalize env pattern Result.Result $ \fs ws bad good -> case canonicalize env body of Result.Result k -> k Map.empty ws (\freeLocals warnings errors -> bad (Map.unionWith combineUses freeLocals fs) warnings errors ) (\freeLocals warnings cbody -> let names = getPatternNames [] pattern name = Name.fromManyNames (map A.toValue names) node = ( Destruct cpattern cbody, name, Map.keys freeLocals ) in good (Map.unionWith combineUses fs freeLocals) warnings (List.foldl' (addEdge [name]) (node:nodes) names) ) logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value logLetLocals args letLocals value = Result.Result $ \freeLocals warnings _ good -> good ( Map.unionWith combineUses freeLocals $ case args of [] -> letLocals _ -> Map.map delayUse letLocals ) warnings value addEdge :: [Name.Name] -> [Node] -> A.Located Name.Name -> [Node] addEdge edges nodes aname@(A.At _ name) = (Edge aname, name, edges) : nodes getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name] getPatternNames names (A.At region pattern) = case pattern of Src.PAnything -> names Src.PVar name -> A.At region name : names Src.PRecord fields -> fields ++ names Src.PAlias ptrn name -> getPatternNames (name : names) ptrn Src.PUnit -> names Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs Src.PCtor _ _ args -> List.foldl' getPatternNames names args Src.PCtorQual _ _ _ args -> List.foldl' getPatternNames names args Src.PList patterns -> List.foldl' getPatternNames names patterns Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl Src.PChr _ -> names Src.PStr _ -> names Src.PInt _ -> names -- GATHER TYPED ARGS gatherTypedArgs :: Env.Env -> Name.Name -> [Src.Pattern] -> Can.Type -> Index.ZeroBased -> [(Can.Pattern, Can.Type)] -> Result Pattern.DupsDict w ([(Can.Pattern, Can.Type)], Can.Type) gatherTypedArgs env name srcArgs tipe index revTypedArgs = case srcArgs of [] -> return (reverse revTypedArgs, tipe) srcArg : otherSrcArgs -> case Type.iteratedDealias tipe of Can.TLambda argType resultType -> do arg <- Pattern.canonicalize env srcArg gatherTypedArgs env name otherSrcArgs resultType (Index.next index) $ (arg, argType) : revTypedArgs _ -> let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in Result.throw $ Error.AnnotationTooShort (A.mergeRegions start end) name index (length srcArgs) -- DETECT CYCLES detectCycles :: A.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr detectCycles letRegion sccs body = case sccs of [] -> Result.ok body scc : subSccs -> case scc of Graph.AcyclicSCC binding -> case binding of Define def -> A.At letRegion . Can.Let def <$> detectCycles letRegion subSccs body Edge _ -> detectCycles letRegion subSccs body Destruct pattern expr -> A.At letRegion . Can.LetDestruct pattern expr <$> detectCycles letRegion subSccs body Graph.CyclicSCC bindings -> A.At letRegion <$> (Can.LetRec <$> checkCycle bindings [] <*> detectCycles letRegion subSccs body ) checkCycle :: [Binding] -> [Can.Def] -> Result i w [Can.Def] checkCycle bindings defs = case bindings of [] -> Result.ok defs binding : otherBindings -> case binding of Define def@(Can.Def name args _) -> if null args then Result.throw (Error.RecursiveLet name (toNames otherBindings defs)) else checkCycle otherBindings (def:defs) Define def@(Can.TypedDef name _ args _ _) -> if null args then Result.throw (Error.RecursiveLet name (toNames otherBindings defs)) else checkCycle otherBindings (def:defs) Edge name -> Result.throw (Error.RecursiveLet name (toNames otherBindings defs)) Destruct _ _ -> -- a Destruct cannot appear in a cycle without any Edge values -- so we just keep going until we get to the edges checkCycle otherBindings defs toNames :: [Binding] -> [Can.Def] -> [Name.Name] toNames bindings revDefs = case bindings of [] -> reverse (map getDefName revDefs) binding : otherBindings -> case binding of Define def -> getDefName def : toNames otherBindings revDefs Edge (A.At _ name) -> name : toNames otherBindings revDefs Destruct _ _ -> toNames otherBindings revDefs getDefName :: Can.Def -> Name.Name getDefName def = case def of Can.Def (A.At _ name) _ _ -> name Can.TypedDef (A.At _ name) _ _ _ _ -> name -- LOG VARIABLE USES logVar :: Name.Name -> a -> Result FreeLocals w a logVar name value = Result.Result $ \freeLocals warnings _ good -> good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value {-# NOINLINE oneDirectUse #-} oneDirectUse :: Uses oneDirectUse = Uses 1 0 combineUses :: Uses -> Uses -> Uses combineUses (Uses a b) (Uses x y) = Uses (a + x) (b + y) delayUse :: Uses -> Uses delayUse (Uses direct delayed) = Uses 0 (direct + delayed) -- MANAGING BINDINGS verifyBindings :: W.Context -> Pattern.Bindings -> Result FreeLocals [W.Warning] value -> Result info [W.Warning] (value, FreeLocals) verifyBindings context bindings (Result.Result k) = Result.Result $ \info warnings bad good -> k Map.empty warnings (\_ warnings1 err -> bad info warnings1 err ) (\freeLocals warnings1 value -> let outerFreeLocals = Map.difference freeLocals bindings warnings2 = -- NOTE: Uses Map.size for O(1) lookup. This means there is -- no dictionary allocation unless a problem is detected. if Map.size bindings + Map.size outerFreeLocals == Map.size freeLocals then warnings1 else Map.foldlWithKey (addUnusedWarning context) warnings1 $ Map.difference bindings freeLocals in good info warnings2 (value, outerFreeLocals) ) addUnusedWarning :: W.Context -> [W.Warning] -> Name.Name -> A.Region -> [W.Warning] addUnusedWarning context warnings name region = W.UnusedVariable region context name : warnings directUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr directUsage (Result.Result k) = Result.Result $ \freeLocals warnings bad good -> k () warnings (\() ws es -> bad freeLocals ws es) (\() ws (value, newFreeLocals) -> good (Map.unionWith combineUses freeLocals newFreeLocals) ws value ) delayedUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr delayedUsage (Result.Result k) = Result.Result $ \freeLocals warnings bad good -> k () warnings (\() ws es -> bad freeLocals ws es) (\() ws (value, newFreeLocals) -> let delayedLocals = Map.map delayUse newFreeLocals in good (Map.unionWith combineUses freeLocals delayedLocals) ws value ) -- FIND VARIABLE findVar :: A.Region -> Env.Env -> Name.Name -> Result FreeLocals w Can.Expr_ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name = case Map.lookup name vs of Just var -> case var of Env.Local _ -> logVar name (Can.VarLocal name) Env.TopLevel _ -> logVar name (Can.VarTopLevel localHome name) Env.Foreign home annotation -> Result.ok $ if home == ModuleName.debug then Can.VarDebug localHome name annotation else Can.VarForeign home name annotation Env.Foreigns h hs -> Result.throw (Error.AmbiguousVar region Nothing name h hs) Nothing -> Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs)) findVarQual :: A.Region -> Env.Env -> Name.Name -> Name.Name -> Result FreeLocals w Can.Expr_ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name = case Map.lookup prefix qvs of Just qualified -> case Map.lookup name qualified of Just (Env.Specific home annotation) -> Result.ok $ if home == ModuleName.debug then Can.VarDebug localHome name annotation else Can.VarForeign home name annotation Just (Env.Ambiguous h hs) -> Result.throw (Error.AmbiguousVar region (Just prefix) name h hs) Nothing -> Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs)) Nothing -> if Name.isKernel prefix && Pkg.isKernel (ModuleName._package localHome) then Result.ok $ Can.VarKernel (Name.getKernel prefix) name else Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs)) toPossibleNames :: Map.Map Name.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames toPossibleNames exposed qualified = Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified) -- FIND CTOR toVarCtor :: Name.Name -> Env.Ctor -> Can.Expr_ toVarCtor name ctor = case ctor of Env.Ctor home typeName (Can.Union vars _ _ opts) index args -> let freeVars = Map.fromList (map (\v -> (v, ())) vars) result = Can.TType home typeName (map Can.TVar vars) tipe = foldr Can.TLambda result args in Can.VarCtor opts home name index (Can.Forall freeVars tipe) Env.RecordCtor home vars tipe -> let freeVars = Map.fromList (map (\v -> (v, ())) vars) in Can.VarCtor Can.Normal home name Index.first (Can.Forall freeVars tipe) ================================================ FILE: compiler/src/Canonicalize/Module.hs ================================================ module Canonicalize.Module ( canonicalize ) where import qualified Data.Graph as Graph import qualified Data.Map as Map import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Source as Src import qualified Canonicalize.Effects as Effects import qualified Canonicalize.Environment as Env import qualified Canonicalize.Environment.Dups as Dups import qualified Canonicalize.Environment.Foreign as Foreign import qualified Canonicalize.Environment.Local as Local import qualified Canonicalize.Expression as Expr import qualified Canonicalize.Pattern as Pattern import qualified Canonicalize.Type as Type import qualified Data.Index as Index import qualified Elm.Interface as I import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result import qualified Reporting.Warning as W -- RESULT type Result i w a = Result.Result i w Error.Error a -- MODULES canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) = do let home = ModuleName.Canonical pkg (Src.getName modul) let cbinops = Map.fromList (map canonicalizeBinop binops) (env, cunions, caliases) <- Local.add modul =<< Foreign.createInitialEnv home ifaces imports cvalues <- canonicalizeValues env values ceffects <- Effects.canonicalize env values cunions effects cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects -- CANONICALIZE BINOP canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop ) canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) = ( op, Can.Binop_ associativity precedence func ) -- DECLARATIONS / CYCLE DETECTION -- -- There are two phases of cycle detection: -- -- 1. Detect cycles using ALL dependencies => needed for type inference -- 2. Detect cycles using DIRECT dependencies => nonterminating recursion -- canonicalizeValues :: Env.Env -> [A.Located Src.Value] -> Result i [W.Warning] Can.Decls canonicalizeValues env values = do nodes <- traverse (toNodeOne env) values detectCycles (Graph.stronglyConnComp nodes) detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls detectCycles sccs = case sccs of [] -> Result.ok Can.SaveTheEnvironment scc : otherSccs -> case scc of Graph.AcyclicSCC (def, _, _) -> Can.Declare def <$> detectCycles otherSccs Graph.CyclicSCC subNodes -> do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes) case defs of [] -> detectCycles otherSccs d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def detectBadCycles scc = case scc of Graph.AcyclicSCC def -> Result.ok def Graph.CyclicSCC [] -> error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!" Graph.CyclicSCC (def:defs) -> let (A.At region name) = extractDefName def names = map (A.toValue . extractDefName) defs in Result.throw (Error.RecursiveDecl region name names) extractDefName :: Can.Def -> A.Located Name.Name extractDefName def = case def of Can.Def name _ _ -> name Can.TypedDef name _ _ _ _ -> name -- DECLARATIONS / CYCLE DETECTION SETUP -- -- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases. -- -- Phase one nodes track ALL dependencies. -- This allows us to find cyclic values for type inference. type NodeOne = (NodeTwo, Name.Name, [Name.Name]) -- Phase two nodes track DIRECT dependencies. -- This allows us to detect cycles that definitely do not terminate. type NodeTwo = (Can.Def, Name.Name, [Name.Name]) toNodeOne :: Env.Env -> A.Located Src.Value -> Result i [W.Warning] NodeOne toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) = case maybeType of Nothing -> do (args, argBindings) <- Pattern.verify (Error.DPFuncArgs name) $ traverse (Pattern.canonicalize env) srcArgs newEnv <- Env.addLocals argBindings env (cbody, freeLocals) <- Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body) let def = Can.Def aname args cbody return ( toNodeTwo name srcArgs def freeLocals , name , Map.keys freeLocals ) Just srcType -> do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType ((args,resultType), argBindings) <- Pattern.verify (Error.DPFuncArgs name) $ Expr.gatherTypedArgs env name srcArgs tipe Index.first [] newEnv <- Env.addLocals argBindings env (cbody, freeLocals) <- Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body) let def = Can.TypedDef aname freeVars args cbody resultType return ( toNodeTwo name srcArgs def freeLocals , name , Map.keys freeLocals ) toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo toNodeTwo name args def freeLocals = case args of [] -> (def, name, Map.foldrWithKey addDirects [] freeLocals) _ -> (def, name, []) addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name] addDirects name (Expr.Uses directUses _) directDeps = if directUses > 0 then name:directDeps else directDeps -- CANONICALIZE EXPORTS canonicalizeExports :: [A.Located Src.Value] -> Map.Map Name.Name union -> Map.Map Name.Name alias -> Map.Map Name.Name binop -> Can.Effects -> A.Located Src.Exposing -> Result i w Can.Exports canonicalizeExports values unions aliases binops effects (A.At region exposing) = case exposing of Src.Open -> Result.ok (Can.ExportEverything region) Src.Explicit exposeds -> do let names = Map.fromList (map valueToName values) infos <- traverse (checkExposed names unions aliases binops effects) exposeds Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos) valueToName :: A.Located Src.Value -> ( Name.Name, () ) valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) = ( name, () ) checkExposed :: Map.Map Name.Name value -> Map.Map Name.Name union -> Map.Map Name.Name alias -> Map.Map Name.Name binop -> Can.Effects -> Src.Exposed -> Result i w (Dups.Dict (A.Located Can.Export)) checkExposed values unions aliases binops effects exposed = case exposed of Src.Lower (A.At region name) -> if Map.member name values then ok name region Can.ExportValue else case checkPorts effects name of Nothing -> ok name region Can.ExportPort Just ports -> Result.throw $ Error.ExportNotFound region Error.BadVar name $ ports ++ Map.keys values Src.Operator region name -> if Map.member name binops then ok name region Can.ExportBinop else Result.throw $ Error.ExportNotFound region Error.BadOp name $ Map.keys binops Src.Upper (A.At region name) (Src.Public dotDotRegion) -> if Map.member name unions then ok name region Can.ExportUnionOpen else if Map.member name aliases then Result.throw $ Error.ExportOpenAlias dotDotRegion name else Result.throw $ Error.ExportNotFound region Error.BadType name $ Map.keys unions ++ Map.keys aliases Src.Upper (A.At region name) Src.Private -> if Map.member name unions then ok name region Can.ExportUnionClosed else if Map.member name aliases then ok name region Can.ExportAlias else Result.throw $ Error.ExportNotFound region Error.BadType name $ Map.keys unions ++ Map.keys aliases checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name] checkPorts effects name = case effects of Can.NoEffects -> Just [] Can.Ports ports -> if Map.member name ports then Nothing else Just (Map.keys ports) Can.Manager _ _ _ _ -> Just [] ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export)) ok name region export = Result.ok $ Dups.one name region (A.At region export) ================================================ FILE: compiler/src/Canonicalize/Pattern.hs ================================================ module Canonicalize.Pattern ( verify , Bindings , DupsDict , canonicalize ) where import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Source as Src import qualified Canonicalize.Environment as Env import qualified Canonicalize.Environment.Dups as Dups import qualified Data.Index as Index import qualified Elm.ModuleName as ModuleName import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result -- RESULTS type Result i w a = Result.Result i w Error.Error a type Bindings = Map.Map Name.Name A.Region -- VERIFY verify :: Error.DuplicatePatternContext -> Result DupsDict w a -> Result i w (a, Bindings) verify context (Result.Result k) = Result.Result $ \info warnings bad good -> k Dups.none warnings (\_ warnings1 errors -> bad info warnings1 errors ) (\bindings warnings1 value -> case Dups.detect (Error.DuplicatePattern context) bindings of Result.Result k1 -> k1 () () (\() () errs -> bad info warnings1 errs) (\() () dict -> good info warnings1 (value, dict)) ) -- CANONICALIZE type DupsDict = Dups.Dict A.Region canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern canonicalize env (A.At region pattern) = A.At region <$> case pattern of Src.PAnything -> Result.ok Can.PAnything Src.PVar name -> logVar name region (Can.PVar name) Src.PRecord fields -> logFields fields (Can.PRecord (map A.toValue fields)) Src.PUnit -> Result.ok Can.PUnit Src.PTuple a b cs -> Can.PTuple <$> canonicalize env a <*> canonicalize env b <*> canonicalizeTuple region env cs Src.PCtor nameRegion name patterns -> canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name Src.PCtorQual nameRegion home name patterns -> canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name Src.PList patterns -> Can.PList <$> canonicalizeList env patterns Src.PCons first rest -> Can.PCons <$> canonicalize env first <*> canonicalize env rest Src.PAlias ptrn (A.At reg name) -> do cpattern <- canonicalize env ptrn logVar name reg (Can.PAlias cpattern name) Src.PChr chr -> Result.ok (Can.PChr chr) Src.PStr str -> Result.ok (Can.PStr str) Src.PInt int -> Result.ok (Can.PInt int) canonicalizeCtor :: Env.Env -> A.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_ canonicalizeCtor env region name patterns ctor = case ctor of Env.Ctor home tipe union index args -> let toCanonicalArg argIndex argPattern argTipe = Can.PatternCtorArg argIndex argTipe <$> canonicalize env argPattern in do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args case verifiedList of Index.LengthMatch cargs -> if tipe == Name.bool && home == ModuleName.basics then Result.ok (Can.PBool union (name == Name.true)) else Result.ok (Can.PCtor home tipe union name index cargs) Index.LengthMismatch actualLength expectedLength -> Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength) Env.RecordCtor _ _ _ -> Result.throw (Error.PatternHasRecordCtor region name) canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern) canonicalizeTuple tupleRegion env extras = case extras of [] -> Result.ok Nothing [three] -> Just <$> canonicalize env three _ -> Result.throw $ Error.TupleLargerThanThree tupleRegion canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern] canonicalizeList env list = case list of [] -> Result.ok [] pattern : otherPatterns -> (:) <$> canonicalize env pattern <*> canonicalizeList env otherPatterns -- LOG BINDINGS logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a logVar name region value = Result.Result $ \bindings warnings _ ok -> ok (Dups.insert name region region bindings) warnings value logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a logFields fields value = let addField dict (A.At region name) = Dups.insert name region region dict in Result.Result $ \bindings warnings _ ok -> ok (List.foldl' addField bindings fields) warnings value ================================================ FILE: compiler/src/Canonicalize/Type.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Canonicalize.Type ( toAnnotation , canonicalize ) where import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Source as Src import qualified Canonicalize.Environment as Env import qualified Canonicalize.Environment.Dups as Dups import qualified Reporting.Annotation as A import qualified Reporting.Error.Canonicalize as Error import qualified Reporting.Result as Result -- RESULT type Result i w a = Result.Result i w Error.Error a -- TO ANNOTATION toAnnotation :: Env.Env -> Src.Type -> Result i w Can.Annotation toAnnotation env srcType = do tipe <- canonicalize env srcType Result.ok $ Can.Forall (addFreeVars Map.empty tipe) tipe -- CANONICALIZE TYPES canonicalize :: Env.Env -> Src.Type -> Result i w Can.Type canonicalize env (A.At typeRegion tipe) = case tipe of Src.TVar x -> Result.ok (Can.TVar x) Src.TType region name args -> canonicalizeType env typeRegion name args =<< Env.findType region env name Src.TTypeQual region home name args -> canonicalizeType env typeRegion name args =<< Env.findTypeQual region env home name Src.TLambda a b -> Can.TLambda <$> canonicalize env a <*> canonicalize env b Src.TRecord fields ext -> do cfields <- sequenceA =<< Dups.checkFields (canonicalizeFields env fields) return $ Can.TRecord cfields (fmap A.toValue ext) Src.TUnit -> Result.ok Can.TUnit Src.TTuple a b cs -> Can.TTuple <$> canonicalize env a <*> canonicalize env b <*> case cs of [] -> Result.ok Nothing [c] -> Just <$> canonicalize env c _ -> Result.throw $ Error.TupleLargerThanThree typeRegion canonicalizeFields :: Env.Env -> [(A.Located Name.Name, Src.Type)] -> [(A.Located Name.Name, Result i w Can.FieldType)] canonicalizeFields env fields = let len = fromIntegral (length fields) canonicalizeField index (name, srcType) = (name, Can.FieldType index <$> canonicalize env srcType) in zipWith canonicalizeField [0..len] fields -- CANONICALIZE TYPE canonicalizeType :: Env.Env -> A.Region -> Name.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type canonicalizeType env region name args info = do cargs <- traverse (canonicalize env) args case info of Env.Alias arity home argNames aliasedType -> checkArity arity region name args $ Can.TAlias home name (zip argNames cargs) (Can.Holey aliasedType) Env.Union arity home -> checkArity arity region name args $ Can.TType home name cargs checkArity :: Int -> A.Region -> Name.Name -> [A.Located arg] -> answer -> Result i w answer checkArity expected region name args answer = let actual = length args in if expected == actual then Result.ok answer else Result.throw (Error.BadArity region Error.TypeArity name expected actual) -- ADD FREE VARS addFreeVars :: Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name () addFreeVars freeVars tipe = case tipe of Can.TLambda arg result -> addFreeVars (addFreeVars freeVars result) arg Can.TVar var -> Map.insert var () freeVars Can.TType _ _ args -> List.foldl' addFreeVars freeVars args Can.TRecord fields Nothing -> Map.foldl addFieldFreeVars freeVars fields Can.TRecord fields (Just ext) -> Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields Can.TUnit -> freeVars Can.TTuple a b maybeC -> case maybeC of Nothing -> addFreeVars (addFreeVars freeVars a) b Just c -> addFreeVars (addFreeVars (addFreeVars freeVars a) b) c Can.TAlias _ _ args _ -> List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args addFieldFreeVars :: Map.Map Name.Name () -> Can.FieldType -> Map.Map Name.Name () addFieldFreeVars freeVars (Can.FieldType _ tipe) = addFreeVars freeVars tipe ================================================ FILE: compiler/src/Compile.hs ================================================ {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} module Compile ( Artifacts(..) , compile ) where import qualified Data.Map as Map import qualified Data.Name as Name import qualified AST.Source as Src import qualified AST.Canonical as Can import qualified AST.Optimized as Opt import qualified Canonicalize.Module as Canonicalize import qualified Elm.Interface as I import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Nitpick.PatternMatches as PatternMatches import qualified Optimize.Module as Optimize import qualified Reporting.Error as E import qualified Reporting.Result as R import qualified Reporting.Render.Type.Localizer as Localizer import qualified Type.Constrain.Module as Type import qualified Type.Solve as Type import System.IO.Unsafe (unsafePerformIO) -- COMPILE data Artifacts = Artifacts { _modul :: Can.Module , _types :: Map.Map Name.Name Can.Annotation , _graph :: Opt.LocalGraph } compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts compile pkg ifaces modul = do canonical <- canonicalize pkg ifaces modul annotations <- typeCheck modul canonical () <- nitpick canonical objects <- optimize modul annotations canonical return (Artifacts canonical annotations objects) -- PHASES canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module canonicalize pkg ifaces modul = case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of Right canonical -> Right canonical Left errors -> Left $ E.BadNames errors typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation) typeCheck modul canonical = case unsafePerformIO (Type.run =<< Type.constrain canonical) of Right annotations -> Right annotations Left errors -> Left (E.BadTypes (Localizer.fromModule modul) errors) nitpick :: Can.Module -> Either E.Error () nitpick canonical = case PatternMatches.check canonical of Right () -> Right () Left errors -> Left (E.BadPatterns errors) optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph optimize modul annotations canonical = case snd $ R.run $ Optimize.optimize annotations canonical of Right localGraph -> Right localGraph Left errors -> Left (E.BadMains (Localizer.fromModule modul) errors) ================================================ FILE: compiler/src/Data/Bag.hs ================================================ module Data.Bag ( Bag(..) , empty , one , append , map , toList , fromList ) where import Prelude hiding (map) import qualified Data.List as List -- BAGS data Bag a = Empty | One a | Two (Bag a) (Bag a) -- HELPERS empty :: Bag a empty = Empty one :: a -> Bag a one = One append :: Bag a -> Bag a -> Bag a append left right = case (left, right) of (other, Empty) -> other (Empty, other) -> other (_, _) -> Two left right -- MAP map :: (a -> b) -> Bag a -> Bag b map func bag = case bag of Empty -> Empty One a -> One (func a) Two left right -> Two (map func left) (map func right) -- TO LIST toList :: Bag a -> [a] toList bag = toListHelp bag [] toListHelp :: Bag a -> [a] -> [a] toListHelp bag list = case bag of Empty -> list One x -> x : list Two a b -> toListHelp a (toListHelp b list) -- FROM LIST fromList :: (a -> b) -> [a] -> Bag b fromList func list = case list of [] -> Empty first : rest -> List.foldl' (add func) (One (func first)) rest add :: (a -> b) -> Bag b -> a -> Bag b add func bag value = Two (One (func value)) bag ================================================ FILE: compiler/src/Data/Index.hs ================================================ module Data.Index ( ZeroBased , first , second , third , next , toMachine , toHuman , indexedMap , indexedTraverse , indexedForA , VerifiedList(..) , indexedZipWith , indexedZipWithA ) where import Control.Monad (liftM) import Data.Binary -- ZERO BASED newtype ZeroBased = ZeroBased Int deriving (Eq, Ord) first :: ZeroBased first = ZeroBased 0 second :: ZeroBased second = ZeroBased 1 third :: ZeroBased third = ZeroBased 2 {-# INLINE next #-} next :: ZeroBased -> ZeroBased next (ZeroBased i) = ZeroBased (i + 1) -- DESTRUCT toMachine :: ZeroBased -> Int toMachine (ZeroBased index) = index toHuman :: ZeroBased -> Int toHuman (ZeroBased index) = index + 1 -- INDEXED MAP {-# INLINE indexedMap #-} indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b] indexedMap func xs = zipWith func (map ZeroBased [0 .. length xs]) xs {-# INLINE indexedTraverse #-} indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b] indexedTraverse func xs = sequenceA (indexedMap func xs) {-# INLINE indexedForA #-} indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b] indexedForA xs func = sequenceA (indexedMap func xs) -- VERIFIED/INDEXED ZIP data VerifiedList a = LengthMatch [a] | LengthMismatch Int Int indexedZipWith :: (ZeroBased -> a -> b -> c) -> [a] -> [b] -> VerifiedList c indexedZipWith func listX listY = indexedZipWithHelp func 0 listX listY [] indexedZipWithHelp :: (ZeroBased -> a -> b -> c) -> Int -> [a] -> [b] -> [c] -> VerifiedList c indexedZipWithHelp func index listX listY revListZ = case (listX, listY) of ([], []) -> LengthMatch (reverse revListZ) (x:xs, y:ys) -> indexedZipWithHelp func (index + 1) xs ys $ func (ZeroBased index) x y : revListZ (_, _) -> LengthMismatch (index + length listX) (index + length listY) indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c) indexedZipWithA func listX listY = case indexedZipWith func listX listY of LengthMatch xs -> LengthMatch <$> sequenceA xs LengthMismatch x y -> pure (LengthMismatch x y) -- BINARY instance Binary ZeroBased where get = liftM ZeroBased get put (ZeroBased n) = put n ================================================ FILE: compiler/src/Data/Map/Utils.hs ================================================ module Data.Map.Utils ( fromKeys , fromKeysA , fromValues , any ) where import Prelude hiding (any) import qualified Data.Map as Map import Data.Map.Internal (Map(..)) -- FROM KEYS fromKeys :: (Ord k) => (k -> v) -> [k] -> Map.Map k v fromKeys toValue keys = Map.fromList $ map (\k -> (k, toValue k)) keys fromKeysA :: (Applicative f, Ord k) => (k -> f v) -> [k] -> f (Map.Map k v) fromKeysA toValue keys = Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v fromValues toKey values = Map.fromList $ map (\v -> (toKey v, v)) values -- ANY {-# INLINE any #-} any :: (v -> Bool) -> Map.Map k v -> Bool any isGood = go where go Tip = False go (Bin _ _ v l r) = isGood v || go l || go r ================================================ FILE: compiler/src/Data/Name.hs ================================================ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-} module Data.Name ( Name -- , toChars , toElmString , toBuilder -- , fromPtr , fromChars -- , getKernel , hasDot , splitDots , isKernel , isNumberType , isComparableType , isAppendableType , isCompappendType , fromVarIndex , fromWords , fromManyNames , fromTypeVariable , fromTypeVariableScheme , sepBy -- , int, float, bool, char, string , maybe, result, list, array, dict, tuple, jsArray , task, router, cmd, sub, platform, virtualDom , shader, debug, debugger, bitwise, basics , utils, negate, true, false, value , node, program, _main, _Main, dollar, identity , replModule, replValueToPrint ) where import Prelude hiding (length, maybe, negate) import Control.Exception (assert) import qualified Data.Binary as Binary import qualified Data.ByteString.Builder.Internal as B import qualified Data.Coerce as Coerce import qualified Data.List as List import qualified Data.String as Chars import qualified Data.Utf8 as Utf8 import GHC.Exts (Int(I#), Ptr, isTrue#) import GHC.ST (ST(ST), runST) import GHC.Prim import GHC.Word (Word8(W8#)) import qualified Elm.String as ES -- NAME type Name = Utf8.Utf8 ELM_NAME data ELM_NAME -- INSTANCES instance Chars.IsString (Utf8.Utf8 ELM_NAME) where fromString = Utf8.fromChars instance Binary.Binary (Utf8.Utf8 ELM_NAME) where get = Utf8.getUnder256 put = Utf8.putUnder256 -- TO toChars :: Name -> [Char] toChars = Utf8.toChars toElmString :: Name -> ES.String toElmString = Coerce.coerce {-# INLINE toBuilder #-} toBuilder :: Name -> B.Builder toBuilder = Utf8.toBuilder -- FROM fromPtr :: Ptr Word8 -> Ptr Word8 -> Name fromPtr = Utf8.fromPtr fromChars :: [Char] -> Name fromChars = Utf8.fromChars -- HAS DOT hasDot :: Name -> Bool hasDot name = Utf8.contains 0x2E {- . -} name splitDots :: Name -> [Name] splitDots name = Utf8.split 0x2E {- . -} name -- GET KERNEL getKernel :: Name -> Name getKernel name@(Utf8.Utf8 ba#) = assert (isKernel name) ( runST ( let !size# = sizeofByteArray# ba# -# 11# in ST $ \s -> case newByteArray# size# s of (# s, mba# #) -> case copyByteArray# ba# 11# mba# 0# size# s of s -> case unsafeFreezeByteArray# mba# s of (# s, ba# #) -> (# s, Utf8.Utf8 ba# #) ) ) -- STARTS WITH isKernel :: Name -> Bool isKernel = Utf8.startsWith prefix_kernel isNumberType :: Name -> Bool isNumberType = Utf8.startsWith prefix_number isComparableType :: Name -> Bool isComparableType = Utf8.startsWith prefix_comparable isAppendableType :: Name -> Bool isAppendableType = Utf8.startsWith prefix_appendable isCompappendType :: Name -> Bool isCompappendType = Utf8.startsWith prefix_compappend {-# NOINLINE prefix_kernel #-} prefix_kernel :: Name prefix_kernel = fromChars "Elm.Kernel." {-# NOINLINE prefix_number #-} prefix_number :: Name prefix_number = fromChars "number" {-# NOINLINE prefix_comparable #-} prefix_comparable :: Name prefix_comparable = fromChars "comparable" {-# NOINLINE prefix_appendable #-} prefix_appendable :: Name prefix_appendable = fromChars "appendable" {-# NOINLINE prefix_compappend #-} prefix_compappend :: Name prefix_compappend = fromChars "compappend" -- FROM VAR INDEX fromVarIndex :: Int -> Name fromVarIndex n = runST ( do let !size = 2 + getIndexSize n mba <- newByteArray size writeWord8 mba 0 0x5F {- _ -} writeWord8 mba 1 0x76 {- v -} writeDigitsAtEnd mba size n freeze mba ) {-# INLINE getIndexSize #-} getIndexSize :: Int -> Int getIndexSize n | n < 10 = 1 | n < 100 = 2 | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float) writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s () writeDigitsAtEnd !mba !oldOffset !n = do let (q,r) = quotRem n 10 let !newOffset = oldOffset - 1 writeWord8 mba newOffset (0x30 + fromIntegral r) if q <= 0 then return () else writeDigitsAtEnd mba newOffset q -- FROM TYPE VARIABLE fromTypeVariable :: Name -> Int -> Name fromTypeVariable name@(Utf8.Utf8 ba#) index = if index <= 0 then name else let len# = sizeofByteArray# ba# end# = word8ToWord# (indexWord8Array# ba# (len# -# 1#)) in if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then runST ( do let !size = I# len# + 1 + getIndexSize index mba <- newByteArray size copyToMBA name mba writeWord8 mba (I# len#) 0x5F {- _ -} writeDigitsAtEnd mba size index freeze mba ) else runST ( do let !size = I# len# + getIndexSize index mba <- newByteArray size copyToMBA name mba writeDigitsAtEnd mba size index freeze mba ) -- FROM TYPE VARIABLE SCHEME fromTypeVariableScheme :: Int -> Name fromTypeVariableScheme scheme = runST ( if scheme < 26 then do mba <- newByteArray 1 writeWord8 mba 0 (0x61 + fromIntegral scheme) freeze mba else do let (extra, letter) = quotRem scheme 26 let !size = 1 + getIndexSize extra mba <- newByteArray size writeWord8 mba 0 (0x61 + fromIntegral letter) writeDigitsAtEnd mba size extra freeze mba ) -- FROM MANY NAMES -- -- Creating a unique name by combining all the subnames can create names -- longer than 256 bytes relatively easily. So instead, the first given name -- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo) -- -- This should be a unique name since 0.19 disallows shadowing. It would not -- be possible for multiple top-level cycles to include values with the same -- name, so the important thing is to make the cycle name distinct from the -- normal name. Same logic for destructuring patterns like (x,y) fromManyNames :: [Name] -> Name fromManyNames names = case names of [] -> blank -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...) -- but maybe unused patterns should be stripped out instead Utf8.Utf8 ba# : _ -> let len# = sizeofByteArray# ba# in runST ( ST $ \s -> case newByteArray# (len# +# 3#) s of (# s, mba# #) -> case writeWord8Array# mba# 0# (wordToWord8# 0x5F##) {-_-} s of s -> case writeWord8Array# mba# 1# (wordToWord8# 0x4D##) {-M-} s of s -> case writeWord8Array# mba# 2# (wordToWord8# 0x24##) {-$-} s of s -> case copyByteArray# ba# 0# mba# 3# len# s of s -> case unsafeFreezeByteArray# mba# s of (# s, ba# #) -> (# s, Utf8.Utf8 ba# #) ) {-# NOINLINE blank #-} blank :: Name blank = fromWords [0x5F,0x4D,0x24] {-_M$-} -- FROM WORDS fromWords :: [Word8] -> Name fromWords words = runST ( do mba <- newByteArray (List.length words) writeWords mba 0 words freeze mba ) writeWords :: MBA s -> Int -> [Word8] -> ST s () writeWords !mba !i words = case words of [] -> return () w:ws -> do writeWord8 mba i w writeWords mba (i+1) ws -- SEP BY sepBy :: Word8 -> Name -> Name -> Name sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) = let !len1# = sizeofByteArray# ba1# !len2# = sizeofByteArray# ba2# in runST ( ST $ \s -> case newByteArray# (len1# +# len2# +# 1#) s of (# s, mba# #) -> case copyByteArray# ba1# 0# mba# 0# len1# s of s -> case writeWord8Array# mba# len1# sep# s of s -> case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of s -> case unsafeFreezeByteArray# mba# s of (# s, ba# #) -> (# s, Utf8.Utf8 ba# #) ) -- PRIMITIVES data MBA s = MBA# (MutableByteArray# s) {-# INLINE newByteArray #-} newByteArray :: Int -> ST s (MBA s) newByteArray (I# len#) = ST $ \s -> case newByteArray# len# s of (# s, mba# #) -> (# s, MBA# mba# #) {-# INLINE freeze #-} freeze :: MBA s -> ST s Name freeze (MBA# mba#) = ST $ \s -> case unsafeFreezeByteArray# mba# s of (# s, ba# #) -> (# s, Utf8.Utf8 ba# #) {-# INLINE writeWord8 #-} writeWord8 :: MBA s -> Int -> Word8 -> ST s () writeWord8 (MBA# mba#) (I# offset#) (W8# w#) = ST $ \s -> case writeWord8Array# mba# offset# w# s of s -> (# s, () #) {-# INLINE copyToMBA #-} copyToMBA :: Name -> MBA s -> ST s () copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) = ST $ \s -> case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of s -> (# s, () #) -- COMMON NAMES {-# NOINLINE int #-} int :: Name int = fromChars "Int" {-# NOINLINE float #-} float :: Name float = fromChars "Float" {-# NOINLINE bool #-} bool :: Name bool = fromChars "Bool" {-# NOINLINE char #-} char :: Name char = fromChars "Char" {-# NOINLINE string #-} string :: Name string = fromChars "String" {-# NOINLINE maybe #-} maybe :: Name maybe = fromChars "Maybe" {-# NOINLINE result #-} result :: Name result = fromChars "Result" {-# NOINLINE list #-} list :: Name list = fromChars "List" {-# NOINLINE array #-} array :: Name array = fromChars "Array" {-# NOINLINE dict #-} dict :: Name dict = fromChars "Dict" {-# NOINLINE tuple #-} tuple :: Name tuple = fromChars "Tuple" {-# NOINLINE jsArray #-} jsArray :: Name jsArray = fromChars "JsArray" {-# NOINLINE task #-} task :: Name task = fromChars "Task" {-# NOINLINE router #-} router :: Name router = fromChars "Router" {-# NOINLINE cmd #-} cmd :: Name cmd = fromChars "Cmd" {-# NOINLINE sub #-} sub :: Name sub = fromChars "Sub" {-# NOINLINE platform #-} platform :: Name platform = fromChars "Platform" {-# NOINLINE virtualDom #-} virtualDom :: Name virtualDom = fromChars "VirtualDom" {-# NOINLINE shader #-} shader :: Name shader = fromChars "Shader" {-# NOINLINE debug #-} debug :: Name debug = fromChars "Debug" {-# NOINLINE debugger #-} debugger :: Name debugger = fromChars "Debugger" {-# NOINLINE bitwise #-} bitwise :: Name bitwise = fromChars "Bitwise" {-# NOINLINE basics #-} basics :: Name basics = fromChars "Basics" {-# NOINLINE utils #-} utils :: Name utils = fromChars "Utils" {-# NOINLINE negate #-} negate :: Name negate = fromChars "negate" {-# NOINLINE true #-} true :: Name true = fromChars "True" {-# NOINLINE false #-} false :: Name false = fromChars "False" {-# NOINLINE value #-} value :: Name value = fromChars "Value" {-# NOINLINE node #-} node :: Name node = fromChars "Node" {-# NOINLINE program #-} program :: Name program = fromChars "Program" {-# NOINLINE _main #-} _main :: Name _main = fromChars "main" {-# NOINLINE _Main #-} _Main :: Name _Main = fromChars "Main" {-# NOINLINE dollar #-} dollar :: Name dollar = fromChars "$" {-# NOINLINE identity #-} identity :: Name identity = fromChars "identity" {-# NOINLINE replModule #-} replModule :: Name replModule = fromChars "Elm_Repl" {-# NOINLINE replValueToPrint #-} replValueToPrint :: Name replValueToPrint = fromChars "repl_input_value_" ================================================ FILE: compiler/src/Data/NonEmptyList.hs ================================================ module Data.NonEmptyList ( List(..) , singleton , toList , sortBy ) where import Control.Monad (liftM2) import Data.Binary (Binary, get, put) import qualified Data.List as List -- LIST data List a = List a [a] singleton :: a -> List a singleton a = List a [] toList :: List a -> [a] toList (List x xs) = x:xs -- INSTANCES instance Functor List where fmap func (List x xs) = List (func x) (map func xs) instance Traversable List where traverse func (List x xs) = List <$> func x <*> traverse func xs instance Foldable List where foldr step state (List x xs) = step x (foldr step state xs) foldl step state (List x xs) = foldl step (step state x) xs foldl1 step (List x xs) = foldl step x xs -- SORT BY sortBy :: (Ord b) => (a -> b) -> List a -> List a sortBy toRank (List x xs) = let comparison a b = compare (toRank a) (toRank b) in case List.sortBy comparison xs of [] -> List x [] y:ys -> case comparison x y of LT -> List x (y:ys) EQ -> List x (y:ys) GT -> List y (List.insertBy comparison x ys) -- BINARY instance (Binary a) => Binary (List a) where put (List x xs) = put x >> put xs get = liftM2 List get get ================================================ FILE: compiler/src/Data/OneOrMore.hs ================================================ module Data.OneOrMore ( OneOrMore(..) , one , more , map , destruct , getFirstTwo ) where import Prelude hiding (map) -- ONE OR MORE data OneOrMore a = One a | More (OneOrMore a) (OneOrMore a) one :: a -> OneOrMore a one = One more :: OneOrMore a -> OneOrMore a -> OneOrMore a more = More -- MAP map :: (a -> b) -> OneOrMore a -> OneOrMore b map func oneOrMore = case oneOrMore of One value -> One (func value) More left right -> More (map func left) (map func right) -- DESTRUCT destruct :: (a -> [a] -> b) -> OneOrMore a -> b destruct func oneOrMore = destructLeft func oneOrMore [] destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b destructLeft func oneOrMore xs = case oneOrMore of One x -> func x xs More a b -> destructLeft func a (destructRight b xs) destructRight :: OneOrMore a -> [a] -> [a] destructRight oneOrMore xs = case oneOrMore of One x -> x : xs More a b -> destructRight a (destructRight b xs) -- GET FIRST TWO getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a) getFirstTwo left right = case left of One x -> (x, getFirstOne right) More lleft lright -> getFirstTwo lleft lright getFirstOne :: OneOrMore a -> a getFirstOne oneOrMore = case oneOrMore of One x -> x More left _ -> getFirstOne left ================================================ FILE: compiler/src/Data/Utf8.hs ================================================ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-} module Data.Utf8 ( Utf8(..) , isEmpty , empty , size , contains , startsWith , startsWithChar , endsWithWord8 , split , join -- , getUnder256 , putUnder256 -- , getVeryLong , putVeryLong -- , toChars , toBuilder , toEscapedBuilder -- , fromPtr , fromSnippet , fromChars -- , MBA , newByteArray , copyFromPtr , writeWord8 , freeze ) where import Prelude hiding (String, all, any, concat) import Data.Binary (Get, get, getWord8, Put, put, putWord8) import Data.Binary.Put (putBuilder) import Data.Binary.Get.Internal (readN) import Data.Bits ((.&.), shiftR) import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Builder.Internal as B import qualified Data.Char as Char import qualified Data.List as List import Foreign.ForeignPtr (touchForeignPtr) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.Ptr (minusPtr, plusPtr) import GHC.Exts (Int(I#), Ptr(Ptr), Char(C#), isTrue#) import GHC.IO import GHC.ST (ST(ST), runST) import GHC.Prim import GHC.Word (Word8(W8#)) import qualified Parse.Primitives as P -- UTF-8 data Utf8 tipe = Utf8 ByteArray# -- EMPTY {-# NOINLINE empty #-} empty :: Utf8 t empty = runST (freeze =<< newByteArray 0) isEmpty :: Utf8 t -> Bool isEmpty (Utf8 ba#) = isTrue# (sizeofByteArray# ba# ==# 0#) -- SIZE size :: Utf8 t -> Int size (Utf8 ba#) = I# (sizeofByteArray# ba#) -- CONTAINS contains :: Word8 -> Utf8 t -> Bool contains (W8# word#) (Utf8 ba#) = containsHelp word# ba# 0# (sizeofByteArray# ba#) containsHelp :: Word8# -> ByteArray# -> Int# -> Int# -> Bool containsHelp word# ba# !offset# len# = if isTrue# (offset# <# len#) then if isTrue# (eqWord8# word# (indexWord8Array# ba# offset#)) then True else containsHelp word# ba# (offset# +# 1#) len# else False -- STARTS WITH {-# INLINE startsWith #-} startsWith :: Utf8 t -> Utf8 t -> Bool startsWith (Utf8 ba1#) (Utf8 ba2#) = let !len1# = sizeofByteArray# ba1# !len2# = sizeofByteArray# ba2# in isTrue# (len1# <=# len2#) && isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#) -- STARTS WITH CHAR startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool startsWithChar isGood bytes@(Utf8 ba#) = if isEmpty bytes then False else let !w# = word8ToWord# (indexWord8Array# ba# 0#) !char | isTrue# (ltWord# w# 0xC0##) = C# (chr# (word2Int# w#)) | isTrue# (ltWord# w# 0xE0##) = chr2 ba# 0# w# | isTrue# (ltWord# w# 0xF0##) = chr3 ba# 0# w# | True = chr4 ba# 0# w# in isGood char -- ENDS WITH WORD endsWithWord8 :: Word8 -> Utf8 t -> Bool endsWithWord8 (W8# w#) (Utf8 ba#) = let len# = sizeofByteArray# ba# in isTrue# (len# ># 0#) && isTrue# (eqWord8# w# (indexWord8Array# ba# (len# -# 1#))) -- SPLIT split :: Word8 -> Utf8 t -> [Utf8 t] split (W8# divider#) str@(Utf8 ba#) = splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) []) splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t] splitHelp str start offsets = case offsets of [] -> [ unsafeSlice str start (size str) ] offset : offsets -> unsafeSlice str start offset : splitHelp str (offset + 1) offsets findDividers :: Word8# -> ByteArray# -> Int# -> Int# -> [Int] -> [Int] findDividers divider# ba# !offset# len# revOffsets = if isTrue# (offset# <# len#) then findDividers divider# ba# (offset# +# 1#) len# $ if isTrue# (eqWord8# divider# (indexWord8Array# ba# offset#)) then I# offset# : revOffsets else revOffsets else reverse revOffsets unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t unsafeSlice str start end = let !len = end - start in if len == 0 then empty else runST $ do mba <- newByteArray len copy str start mba 0 len freeze mba -- JOIN join :: Word8 -> [Utf8 t] -> Utf8 t join sep strings = case strings of [] -> empty str:strs -> runST $ do let !len = List.foldl' (\w s -> w + 1 + size s) (size str) strs mba <- newByteArray len joinHelp sep mba 0 str strs freeze mba joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s () joinHelp sep mba offset str strings = let !len = size str in case strings of [] -> copy str 0 mba offset len s:ss -> do copy str 0 mba offset len let !dotOffset = offset + len writeWord8 mba dotOffset sep let !newOffset = dotOffset + 1 joinHelp sep mba newOffset s ss -- EQUAL instance Eq (Utf8 t) where (==) (Utf8 ba1#) (Utf8 ba2#) = let !len1# = sizeofByteArray# ba1# !len2# = sizeofByteArray# ba2# in isTrue# (len1# ==# len2#) && isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#) -- COMPARE -- -- TODO: is it fine to sort by length and only compare bytes on length ties? -- instance Ord (Utf8 t) where compare (Utf8 ba1#) (Utf8 ba2#) = let !len1# = sizeofByteArray# ba1# !len2# = sizeofByteArray# ba2# !len# = if isTrue# (len1# <# len2#) then len1# else len2# !cmp# = compareByteArrays# ba1# 0# ba2# 0# len# in case () of _ | isTrue# (cmp# <# 0#) -> LT | isTrue# (cmp# ># 0#) -> GT | isTrue# (len1# <# len2#) -> LT | isTrue# (len1# ># len2#) -> GT | True -> EQ -- FROM STRING fromChars :: [Char] -> Utf8 t fromChars chars = runST ( do mba <- newByteArray (sum (map getWidth chars)) writeChars mba 0 chars ) writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t) writeChars !mba !offset chars = case chars of [] -> freeze mba char : chars | n < 0x80 -> do writeWord8 mba (offset ) (fromIntegral n) writeChars mba (offset + 1) chars | n < 0x800 -> do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0)) writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80)) writeChars mba (offset + 2) chars | n < 0x10000 -> do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0)) writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80)) writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80)) writeChars mba (offset + 3) chars | otherwise -> do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0)) writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80)) writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80)) writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80)) writeChars mba (offset + 4) chars where n = Char.ord char {-# INLINE getWidth #-} getWidth :: Char -> Int getWidth char | code < 0x80 = 1 | code < 0x800 = 2 | code < 0x10000 = 3 | otherwise = 4 where code = Char.ord char -- TO CHARS toChars :: Utf8 t -> [Char] toChars (Utf8 ba#) = toCharsHelp ba# 0# (sizeofByteArray# ba#) toCharsHelp :: ByteArray# -> Int# -> Int# -> [Char] toCharsHelp ba# offset# len# = if isTrue# (offset# >=# len#) then [] else let !w# = word8ToWord# (indexWord8Array# ba# offset#) !(# char, width# #) | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #) | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #) | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #) | True = (# chr4 ba# offset# w#, 4# #) !newOffset# = offset# +# width# in char : toCharsHelp ba# newOffset# len# {-# INLINE chr2 #-} chr2 :: ByteArray# -> Int# -> Word# -> Char chr2 ba# offset# firstWord# = let !i1# = word2Int# firstWord# !i2# = word2Int# (word8ToWord# (indexWord8Array# ba# (offset# +# 1#))) !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6# !c2# = i2# -# 0x80# in C# (chr# (c1# +# c2#)) {-# INLINE chr3 #-} chr3 :: ByteArray# -> Int# -> Word# -> Char chr3 ba# offset# firstWord# = let !i1# = word2Int# firstWord# !i2# = word2Int# (word8ToWord# (indexWord8Array# ba# (offset# +# 1#))) !i3# = word2Int# (word8ToWord# (indexWord8Array# ba# (offset# +# 2#))) !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12# !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6# !c3# = i3# -# 0x80# in C# (chr# (c1# +# c2# +# c3#)) {-# INLINE chr4 #-} chr4 :: ByteArray# -> Int# -> Word# -> Char chr4 ba# offset# firstWord# = let !i1# = word2Int# firstWord# !i2# = word2Int# (word8ToWord# (indexWord8Array# ba# (offset# +# 1#))) !i3# = word2Int# (word8ToWord# (indexWord8Array# ba# (offset# +# 2#))) !i4# = word2Int# (word8ToWord# (indexWord8Array# ba# (offset# +# 3#))) !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18# !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12# !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6# !c4# = i4# -# 0x80# in C# (chr# (c1# +# c2# +# c3# +# c4#)) -- TO BUILDER {-# INLINE toBuilder #-} toBuilder :: Utf8 t -> B.Builder toBuilder = \bytes -> B.builder (toBuilderHelp bytes) {-# INLINE toBuilderHelp #-} toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a toBuilderHelp !bytes@(Utf8 ba#) k = go 0 (I# (sizeofByteArray# ba#)) where go !offset !end !(B.BufferRange bOffset bEnd) = let !bLen = minusPtr bEnd bOffset !len = end - offset in if len <= bLen then do copyToPtr bytes offset bOffset len let !br' = B.BufferRange (plusPtr bOffset len) bEnd k br' else do copyToPtr bytes offset bOffset bLen let !offset' = offset + bLen return $ B.bufferFull 1 bEnd (go offset' end) -- TO ESCAPED BUILDER {-# INLINE toEscapedBuilder #-} toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder toEscapedBuilder before after = \name -> B.builder (toEscapedBuilderHelp before after name) {-# INLINE toEscapedBuilderHelp #-} toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a toEscapedBuilderHelp before after !name@(Utf8 ba#) k = go 0 (I# (sizeofByteArray# ba#)) where go !offset !len !(B.BufferRange bOffset bEnd) = let !bLen = minusPtr bEnd bOffset in if len <= bLen then do -- PERF test if writing word-by-word is faster copyToPtr name offset bOffset len escape before after bOffset name offset len 0 let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd k newBufferRange else do copyToPtr name offset bOffset bLen escape before after bOffset name offset bLen 0 let !newOffset = offset + bLen let !newLength = len - bLen return $ B.bufferFull 1 bEnd (go newOffset newLength) escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO () escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) = if isTrue# (i# <# len#) then if isTrue# (eqWord8# before# (indexWord8Array# ba# (offset# +# i#))) then do writeWordToPtr ptr i after escape before after ptr name offset len (i + 1) else do escape before after ptr name offset len (i + 1) else return () -- FROM PTR fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t fromPtr pos end = unsafeDupablePerformIO (stToIO ( do let !len = minusPtr end pos mba <- newByteArray len copyFromPtr pos mba 0 len freeze mba )) -- FROM SNIPPET fromSnippet :: P.Snippet -> Utf8 t fromSnippet (P.Snippet fptr off len _ _) = unsafeDupablePerformIO (stToIO ( do mba <- newByteArray len let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off copyFromPtr pos mba 0 len freeze mba )) -- BINARY putUnder256 :: Utf8 t -> Put putUnder256 bytes = do putWord8 (fromIntegral (size bytes)) putBuilder (toBuilder bytes) getUnder256 :: Get (Utf8 t) getUnder256 = do word <- getWord8 let !n = fromIntegral word readN n (copyFromByteString n) putVeryLong :: Utf8 t -> Put putVeryLong bytes = do put (size bytes) putBuilder (toBuilder bytes) getVeryLong :: Get (Utf8 t) getVeryLong = do n <- get if n > 0 then readN n (copyFromByteString n) else return empty -- COPY FROM BYTESTRING {-# INLINE copyFromByteString #-} copyFromByteString :: Int -> B.ByteString -> Utf8 t copyFromByteString len (B.PS fptr offset _) = unsafeDupablePerformIO ( do mba <- stToIO (newByteArray len) stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len) touchForeignPtr fptr stToIO (freeze mba) ) -- PRIMITIVES data MBA s = MBA# (MutableByteArray# s) newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive newByteArray (I# len#) = ST $ \s -> case newByteArray# len# s of (# s, mba# #) -> (# s, MBA# mba# #) freeze :: MBA s -> ST s (Utf8 t) freeze (MBA# mba#) = ST $ \s -> case unsafeFreezeByteArray# mba# s of (# s, ba# #) -> (# s, Utf8 ba# #) copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s () copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) = ST $ \s -> case copyByteArray# ba# offset# mba# i# len# s of s -> (# s, () #) copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld () copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) = ST $ \s -> case copyAddrToByteArray# src# mba# offset# len# s of s -> (# s, () #) copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO () copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) = IO $ \s -> case copyByteArrayToAddr# ba# offset# mba# len# s of s -> (# s, () #) {-# INLINE writeWord8 #-} writeWord8 :: MBA s -> Int -> Word8 -> ST s () writeWord8 (MBA# mba#) (I# offset#) (W8# w#) = ST $ \s -> case writeWord8Array# mba# offset# w# s of s -> (# s, () #) {-# INLINE writeWordToPtr #-} writeWordToPtr :: Ptr a -> Int -> Word8 -> IO () writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) = IO $ \s -> case writeWord8OffAddr# addr# offset# word# s of s -> (# s, () #) ================================================ FILE: compiler/src/Elm/Compiler/Imports.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Elm.Compiler.Imports ( defaults ) where import qualified Data.Name as Name import qualified AST.Source as Src import qualified Elm.ModuleName as ModuleName import qualified Reporting.Annotation as A -- DEFAULTS defaults :: [Src.Import] defaults = [ import_ ModuleName.basics Nothing Src.Open , import_ ModuleName.debug Nothing closed , import_ ModuleName.list Nothing (operator "::") , import_ ModuleName.maybe Nothing (typeOpen Name.maybe) , import_ ModuleName.result Nothing (typeOpen Name.result) , import_ ModuleName.string Nothing (typeClosed Name.string) , import_ ModuleName.char Nothing (typeClosed Name.char) , import_ ModuleName.tuple Nothing closed , import_ ModuleName.platform Nothing (typeClosed Name.program) , import_ ModuleName.cmd (Just Name.cmd) (typeClosed Name.cmd) , import_ ModuleName.sub (Just Name.sub) (typeClosed Name.sub) ] import_ :: ModuleName.Canonical -> Maybe Name.Name -> Src.Exposing -> Src.Import import_ (ModuleName.Canonical _ name) maybeAlias exposing = Src.Import (A.At A.zero name) maybeAlias exposing -- EXPOSING closed :: Src.Exposing closed = Src.Explicit [] typeOpen :: Name.Name -> Src.Exposing typeOpen name = Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ] typeClosed :: Name.Name -> Src.Exposing typeClosed name = Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ] operator :: Name.Name -> Src.Exposing operator op = Src.Explicit [ Src.Operator A.zero op ] ================================================ FILE: compiler/src/Elm/Compiler/Type/Extract.hs ================================================ {-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-} module Elm.Compiler.Type.Extract ( fromAnnotation , fromType , Types(..) , mergeMany , merge , fromInterface , fromDependencyInterface , fromMsg ) where import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Name as Name import qualified Data.Set as Set import qualified AST.Canonical as Can import qualified AST.Optimized as Opt import qualified AST.Utils.Type as Type import qualified Elm.Compiler.Type as T import qualified Elm.Interface as I import qualified Elm.ModuleName as ModuleName -- EXTRACTION fromAnnotation :: Can.Annotation -> T.Type fromAnnotation (Can.Forall _ astType) = fromType astType fromType :: Can.Type -> T.Type fromType astType = snd (run (extract astType)) extract :: Can.Type -> Extractor T.Type extract astType = case astType of Can.TLambda arg result -> T.Lambda <$> extract arg <*> extract result Can.TVar x -> pure (T.Var x) Can.TType home name args -> addUnion (Opt.Global home name) (T.Type (toPublicName home name)) <*> traverse extract args Can.TRecord fields ext -> do efields <- traverse (traverse extract) (Can.fieldsToList fields) pure (T.Record efields ext) Can.TUnit -> pure T.Unit Can.TTuple a b maybeC -> T.Tuple <$> extract a <*> extract b <*> traverse extract (Maybe.maybeToList maybeC) Can.TAlias home name args aliasType -> do addAlias (Opt.Global home name) () _ <- extract (Type.dealias args aliasType) T.Type (toPublicName home name) <$> traverse (extract . snd) args toPublicName :: ModuleName.Canonical -> Name.Name -> Name.Name toPublicName (ModuleName.Canonical _ home) name = Name.sepBy 0x2E {- . -} home name -- TRANSITIVELY AVAILABLE TYPES newtype Types = Types (Map.Map ModuleName.Canonical Types_) -- PERF profile Opt.Global representation -- current representation needs less allocation -- but maybe the lookup is much worse data Types_ = Types_ { _union_info :: Map.Map Name.Name Can.Union , _alias_info :: Map.Map Name.Name Can.Alias } mergeMany :: [Types] -> Types mergeMany listOfTypes = case listOfTypes of [] -> Types Map.empty t:ts -> foldr merge t ts merge :: Types -> Types -> Types merge (Types types1) (Types types2) = Types (Map.union types1 types2) fromInterface :: ModuleName.Raw -> I.Interface -> Types fromInterface name (I.Interface pkg _ unions aliases _) = Types $ Map.singleton (ModuleName.Canonical pkg name) $ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases) fromDependencyInterface :: ModuleName.Canonical -> I.DependencyInterface -> Types fromDependencyInterface home di = Types $ Map.singleton home $ case di of I.Public (I.Interface _ _ unions aliases _) -> Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases) I.Private _ unions aliases -> Types_ unions aliases -- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES fromMsg :: Types -> Can.Type -> T.DebugMetadata fromMsg types message = let (msgDeps, msgType) = run (extract message) (aliases, unions) = extractTransitive types noDeps msgDeps in T.DebugMetadata msgType aliases unions extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] ) extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) = let aliases = Set.difference nextAliases seenAliases unions = Set.difference nextUnions seenUnions in if Set.null aliases && Set.null unions then ( [], [] ) else let (newDeps, result) = run $ (,) <$> traverse (extractAlias types) (Set.toList aliases) <*> traverse (extractUnion types) (Set.toList unions) oldDeps = Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions) remainingResult = extractTransitive types oldDeps newDeps in mappend result remainingResult extractAlias :: Types -> Opt.Global -> Extractor T.Alias extractAlias (Types dict) (Opt.Global home name) = let (Can.Alias args aliasType) = _alias_info (dict ! home) ! name in T.Alias (toPublicName home name) args <$> extract aliasType extractUnion :: Types -> Opt.Global -> Extractor T.Union extractUnion (Types dict) (Opt.Global home name) = if name == Name.list && home == ModuleName.list then return $ T.Union (toPublicName home name) ["a"] [] else let pname = toPublicName home name (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name in T.Union pname vars <$> traverse extractCtor ctors extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type]) extractCtor (Can.Ctor ctor _ _ args) = (,) ctor <$> traverse extract args -- DEPS data Deps = Deps { _aliases :: Set.Set Opt.Global , _unions :: Set.Set Opt.Global } {-# NOINLINE noDeps #-} noDeps :: Deps noDeps = Deps Set.empty Set.empty -- EXTRACTOR newtype Extractor a = Extractor ( forall result. Set.Set Opt.Global -> Set.Set Opt.Global -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result) -> result ) run :: Extractor a -> (Deps, a) run (Extractor k) = k Set.empty Set.empty $ \aliases unions value -> ( Deps aliases unions, value ) addAlias :: Opt.Global -> a -> Extractor a addAlias alias value = Extractor $ \aliases unions ok -> ok (Set.insert alias aliases) unions value addUnion :: Opt.Global -> a -> Extractor a addUnion union value = Extractor $ \aliases unions ok -> ok aliases (Set.insert union unions) value instance Functor Extractor where fmap func (Extractor k) = Extractor $ \aliases unions ok -> let ok1 a1 u1 value = ok a1 u1 (func value) in k aliases unions ok1 instance Applicative Extractor where pure value = Extractor $ \aliases unions ok -> ok aliases unions value (<*>) (Extractor kf) (Extractor kv) = Extractor $ \aliases unions ok -> let ok1 a1 u1 func = let ok2 a2 u2 value = ok a2 u2 (func value) in kv a1 u1 ok2 in kf aliases unions ok1 instance Monad Extractor where return = pure (>>=) (Extractor ka) callback = Extractor $ \aliases unions ok -> let ok1 a1 u1 value = case callback value of Extractor kb -> kb a1 u1 ok in ka aliases unions ok1 ================================================ FILE: compiler/src/Elm/Compiler/Type.hs ================================================ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# LANGUAGE OverloadedStrings #-} module Elm.Compiler.Type ( Type(..) , RT.Context(..) , toDoc , DebugMetadata(..) , Alias(..) , Union(..) , encode , decoder , encodeMetadata ) where import qualified Data.Name as Name import qualified AST.Source as Src 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 Parse.Type as Type import qualified Reporting.Annotation as A import qualified Reporting.Doc as D import qualified Reporting.Render.Type as RT import qualified Reporting.Render.Type.Localizer as L -- TYPES data Type = Lambda Type Type | Var Name.Name | Type Name.Name [Type] | Record [(Name.Name, Type)] (Maybe Name.Name) | Unit | Tuple Type Type [Type] data DebugMetadata = DebugMetadata { _message :: Type , _aliases :: [Alias] , _unions :: [Union] } data Alias = Alias Name.Name [Name.Name] Type data Union = Union Name.Name [Name.Name] [(Name.Name, [Type])] -- TO DOC toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc toDoc localizer context tipe = case tipe of Lambda _ _ -> let a:b:cs = map (toDoc localizer RT.Func) (collectLambdas tipe) in RT.lambda context a b cs Var name -> D.fromName name Unit -> "()" Tuple a b cs -> RT.tuple (toDoc localizer RT.None a) (toDoc localizer RT.None b) (map (toDoc localizer RT.None) cs) Type name args -> RT.apply context (D.fromName name) (map (toDoc localizer RT.App) args) Record fields ext -> RT.record (map (entryToDoc localizer) fields) (fmap D.fromName ext) entryToDoc :: L.Localizer -> (Name.Name, Type) -> (D.Doc, D.Doc) entryToDoc localizer (field, fieldType) = ( D.fromName field, toDoc localizer RT.None fieldType ) collectLambdas :: Type -> [Type] collectLambdas tipe = case tipe of Lambda arg body -> arg : collectLambdas body _ -> [tipe] -- JSON for TYPE encode :: Type -> E.Value encode tipe = E.chars $ D.toLine (toDoc L.empty RT.None tipe) decoder :: D.Decoder () Type decoder = let parser = P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression) in D.customString parser (\_ _ -> ()) fromRawType :: Src.Type -> Type fromRawType (A.At _ astType) = case astType of Src.TLambda t1 t2 -> Lambda (fromRawType t1) (fromRawType t2) Src.TVar x -> Var x Src.TUnit -> Unit Src.TTuple a b cs -> Tuple (fromRawType a) (fromRawType b) (map fromRawType cs) Src.TType _ name args -> Type name (map fromRawType args) Src.TTypeQual _ _ name args -> Type name (map fromRawType args) Src.TRecord fields ext -> let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in Record (map fromField fields) (fmap A.toValue ext) -- JSON for PROGRAM encodeMetadata :: DebugMetadata -> E.Value encodeMetadata (DebugMetadata msg aliases unions) = E.object [ "message" ==> encode msg , "aliases" ==> E.object (map toTypeAliasField aliases) , "unions" ==> E.object (map toCustomTypeField unions) ] toTypeAliasField :: Alias -> ( Json.String, E.Value ) toTypeAliasField (Alias name args tipe) = ( Json.fromName name , E.object [ "args" ==> E.list E.name args , "type" ==> encode tipe ] ) toCustomTypeField :: Union -> ( Json.String, E.Value ) toCustomTypeField (Union name args constructors) = ( Json.fromName name , E.object [ "args" ==> E.list E.name args , "tags" ==> E.object (map toVariantObject constructors) ] ) toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value ) toVariantObject (name, args) = ( Json.fromName name, E.list encode args ) ================================================ FILE: compiler/src/Elm/Constraint.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Elm.Constraint ( Constraint , exactly , anything , toChars , satisfies , check , intersect , goodElm , defaultElm , untilNextMajor , untilNextMinor , expand -- , Error(..) , decoder , encode ) where import Control.Monad (liftM4) import Data.Binary (Binary, get, put, getWord8, putWord8) import qualified Elm.Version as V import qualified Json.Decode as D import qualified Json.Encode as E import qualified Parse.Primitives as P import Parse.Primitives (Row, Col) -- CONSTRAINTS data Constraint = Range V.Version Op Op V.Version deriving (Eq) data Op = Less | LessOrEqual deriving (Eq) -- COMMON CONSTRAINTS exactly :: V.Version -> Constraint exactly version = Range version LessOrEqual LessOrEqual version anything :: Constraint anything = Range V.one LessOrEqual LessOrEqual V.max -- TO CHARS toChars :: Constraint -> [Char] toChars constraint = case constraint of Range lower lowerOp upperOp upper -> V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper opToChars :: Op -> [Char] opToChars op = case op of Less -> " < " LessOrEqual -> " <= " -- IS SATISFIED satisfies :: Constraint -> V.Version -> Bool satisfies constraint version = case constraint of Range lower lowerOp upperOp upper -> isLess lowerOp lower version && isLess upperOp version upper isLess :: (Ord a) => Op -> (a -> a -> Bool) isLess op = case op of Less -> (<) LessOrEqual -> (<=) check :: Constraint -> V.Version -> Ordering check constraint version = case constraint of Range lower lowerOp upperOp upper -> if not (isLess lowerOp lower version) then LT else if not (isLess upperOp version upper) then GT else EQ -- INTERSECT intersect :: Constraint -> Constraint -> Maybe Constraint intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) = let (newLo, newLop) = case compare lo lo_ of LT -> (lo_, lop_) EQ -> (lo, if elem Less [lop,lop_] then Less else LessOrEqual) GT -> (lo, lop) (newHi, newHop) = case compare hi hi_ of LT -> (hi, hop) EQ -> (hi, if elem Less [hop, hop_] then Less else LessOrEqual) GT -> (hi_, hop_) in if newLo <= newHi then Just (Range newLo newLop newHop newHi) else Nothing -- ELM CONSTRAINT goodElm :: Constraint -> Bool goodElm constraint = satisfies constraint V.compiler defaultElm :: Constraint defaultElm = if V._major V.compiler > 0 then untilNextMajor V.compiler else untilNextMinor V.compiler -- CREATE CONSTRAINTS untilNextMajor :: V.Version -> Constraint untilNextMajor version = Range version LessOrEqual Less (V.bumpMajor version) untilNextMinor :: V.Version -> Constraint untilNextMinor version = Range version LessOrEqual Less (V.bumpMinor version) expand :: Constraint -> V.Version -> Constraint expand constraint@(Range lower lowerOp upperOp upper) version | version < lower = Range version LessOrEqual upperOp upper | version > upper = Range lower lowerOp Less (V.bumpMajor version) | otherwise = constraint -- JSON encode :: Constraint -> E.Value encode constraint = E.chars (toChars constraint) decoder :: D.Decoder Error Constraint decoder = D.customString parser BadFormat -- BINARY instance Binary Constraint where get = liftM4 Range get get get get put (Range a b c d) = put a >> put b >> put c >> put d instance Binary Op where put op = case op of Less -> putWord8 0 LessOrEqual -> putWord8 1 get = do n <- getWord8 case n of 0 -> return Less 1 -> return LessOrEqual _ -> fail "binary encoding of Op was corrupted" -- PARSER data Error = BadFormat Row Col | InvalidRange V.Version V.Version parser :: P.Parser Error Constraint parser = do lower <- parseVersion P.word1 0x20 {- -} BadFormat loOp <- parseOp P.word1 0x20 {- -} BadFormat P.word1 0x76 {-v-} BadFormat P.word1 0x20 {- -} BadFormat hiOp <- parseOp P.word1 0x20 {- -} BadFormat higher <- parseVersion P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr -> if lower < higher then eok (Range lower loOp hiOp higher) state else eerr row col (\_ _ -> InvalidRange lower higher) parseVersion :: P.Parser Error V.Version parseVersion = P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser parseOp :: P.Parser Error Op parseOp = do P.word1 0x3C {-<-} BadFormat P.oneOfWithFallback [ do P.word1 0x3D {-=-} BadFormat return LessOrEqual ] Less ================================================ FILE: compiler/src/Elm/Docs.hs ================================================ {-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-} module Elm.Docs ( Documentation , Module(..) , fromModule , Union(..) , Alias(..) , Value(..) , Binop(..) , Binop.Associativity(..) , Binop.Precedence(..) , Error(..) , decoder , encode ) where import qualified Data.Coerce as Coerce import qualified Data.List as List import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Map.Merge.Strict as Map import qualified Data.Name as Name import qualified Data.NonEmptyList as NE import qualified Data.OneOrMore as OneOrMore import Data.Word (Word8) import Foreign.Ptr (Ptr, plusPtr) import qualified AST.Canonical as Can import qualified AST.Source as Src import qualified AST.Utils.Binop as Binop import qualified Elm.Compiler.Type as Type import qualified Elm.Compiler.Type.Extract as Extract import qualified Elm.ModuleName as ModuleName import qualified Json.Decode as D import qualified Json.Encode as E import Json.Encode ((==>)) import qualified Json.String as Json import Parse.Primitives (Row, Col, word1) import qualified Parse.Primitives as P import qualified Parse.Space as Space import qualified Parse.Symbol as Symbol import qualified Parse.Variable as Var import qualified Reporting.Annotation as A import qualified Reporting.Error.Docs as E import qualified Reporting.Result as Result -- DOCUMENTATION type Documentation = Map.Map Name.Name Module data Module = Module { _name :: Name.Name , _comment :: Comment , _unions :: Map.Map Name.Name Union , _aliases :: Map.Map Name.Name Alias , _values :: Map.Map Name.Name Value , _binops :: Map.Map Name.Name Binop } type Comment = Json.String data Alias = Alias Comment [Name.Name] Type.Type data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])] data Value = Value Comment Type.Type data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence -- JSON encode :: Documentation -> E.Value encode docs = E.list encodeModule (Map.elems docs) encodeModule :: Module -> E.Value encodeModule (Module name comment unions aliases values binops) = E.object $ [ "name" ==> ModuleName.encode name , "comment" ==> E.string comment , "unions" ==> E.list encodeUnion (Map.toList unions) , "aliases" ==> E.list encodeAlias (Map.toList aliases) , "values" ==> E.list encodeValue (Map.toList values) , "binops" ==> E.list encodeBinop (Map.toList binops) ] data Error = BadAssociativity | BadModuleName | BadType decoder :: D.Decoder Error Documentation decoder = toDict <$> D.list moduleDecoder toDict :: [Module] -> Documentation toDict modules = Map.fromList (map toDictHelp modules) toDictHelp :: Module -> (Name.Name, Module) toDictHelp modul@(Module name _ _ _ _ _) = (name, modul) moduleDecoder :: D.Decoder Error Module moduleDecoder = Module <$> D.field "name" moduleNameDecoder <*> D.field "comment" D.string <*> D.field "unions" (dictDecoder union) <*> D.field "aliases" (dictDecoder alias) <*> D.field "values" (dictDecoder value) <*> D.field "binops" (dictDecoder binop) dictDecoder :: D.Decoder Error a -> D.Decoder Error (Map.Map Name.Name a) dictDecoder entryDecoder = Map.fromList <$> D.list (named entryDecoder) named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a) named entryDecoder = (,) <$> D.field "name" nameDecoder <*> entryDecoder nameDecoder :: D.Decoder e Name.Name nameDecoder = fmap Coerce.coerce D.string moduleNameDecoder :: D.Decoder Error ModuleName.Raw moduleNameDecoder = D.mapError (const BadModuleName) ModuleName.decoder typeDecoder :: D.Decoder Error Type.Type typeDecoder = D.mapError (const BadType) Type.decoder -- UNION JSON encodeUnion :: (Name.Name, Union) -> E.Value encodeUnion (name, Union comment args cases) = E.object [ "name" ==> E.name name , "comment" ==> E.string comment , "args" ==> E.list E.name args , "cases" ==> E.list encodeCase cases ] union :: D.Decoder Error Union union = Union <$> D.field "comment" D.string <*> D.field "args" (D.list nameDecoder) <*> D.field "cases" (D.list caseDecoder) encodeCase :: ( Name.Name, [Type.Type] ) -> E.Value encodeCase ( tag, args ) = E.list id [ E.name tag, E.list Type.encode args ] caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] ) caseDecoder = D.pair nameDecoder (D.list typeDecoder) -- ALIAS JSON encodeAlias :: (Name.Name, Alias) -> E.Value encodeAlias ( name, Alias comment args tipe) = E.object [ "name" ==> E.name name , "comment" ==> E.string comment , "args" ==> E.list E.name args , "type" ==> Type.encode tipe ] alias :: D.Decoder Error Alias alias = Alias <$> D.field "comment" D.string <*> D.field "args" (D.list nameDecoder) <*> D.field "type" typeDecoder -- VALUE JSON encodeValue :: (Name.Name, Value) -> E.Value encodeValue (name, Value comment tipe) = E.object [ "name" ==> E.name name , "comment" ==> E.string comment , "type" ==> Type.encode tipe ] value :: D.Decoder Error Value value = Value <$> D.field "comment" D.string <*> D.field "type" typeDecoder -- BINOP JSON encodeBinop :: (Name.Name, Binop) -> E.Value encodeBinop (name, Binop comment tipe assoc prec) = E.object [ "name" ==> E.name name , "comment" ==> E.string comment , "type" ==> Type.encode tipe , "associativity" ==> encodeAssoc assoc , "precedence" ==> encodePrec prec ] binop :: D.Decoder Error Binop binop = Binop <$> D.field "comment" D.string <*> D.field "type" typeDecoder <*> D.field "associativity" assocDecoder <*> D.field "precedence" precDecoder -- ASSOCIATIVITY JSON encodeAssoc :: Binop.Associativity -> E.Value encodeAssoc assoc = case assoc of Binop.Left -> E.chars "left" Binop.Non -> E.chars "non" Binop.Right -> E.chars "right" assocDecoder :: D.Decoder Error Binop.Associativity assocDecoder = let left = Json.fromChars "left" non = Json.fromChars "non" right = Json.fromChars "right" in do str <- D.string if | str == left -> return Binop.Left | str == non -> return Binop.Non | str == right -> return Binop.Right | otherwise -> D.failure BadAssociativity -- PRECEDENCE JSON encodePrec :: Binop.Precedence -> E.Value encodePrec (Binop.Precedence n) = E.int n precDecoder :: D.Decoder Error Binop.Precedence precDecoder = Binop.Precedence <$> D.int -- FROM MODULE fromModule :: Can.Module -> Either E.Error Module fromModule modul@(Can.Module _ exports docs _ _ _ _ _) = case exports of Can.ExportEverything region -> Left (E.ImplicitExposing region) Can.Export exportDict -> case docs of Src.NoDocs region -> Left (E.NoDocs region) Src.YesDocs overview comments -> do names <- parseOverview overview checkNames exportDict names checkDefs exportDict overview (Map.fromList comments) modul -- PARSE OVERVIEW parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name] parseOverview (Src.Comment snippet) = case P.fromSnippet (chompOverview []) E.BadEnd snippet of Left err -> Left (E.SyntaxProblem err) Right names -> Right names type Parser a = P.Parser E.SyntaxProblem a chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name] chompOverview names = do isDocs <- chompUntilDocs if isDocs then do Space.chomp E.Space chompOverview =<< chompDocs names else return names chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name] chompDocs names = do name <- P.addLocation $ P.oneOf E.Name [ Var.lower E.Name , Var.upper E.Name , chompOperator ] Space.chomp E.Space P.oneOfWithFallback [ do pos <- P.getPosition Space.checkIndent pos E.Comma word1 0x2C {-,-} E.Comma Space.chomp E.Space chompDocs (name:names) ] (name:names) chompOperator :: Parser Name.Name chompOperator = do word1 0x28 {-(-} E.Op op <- Symbol.operator E.Op E.OpBad word1 0x29 {-)-} E.Op return op -- TODO add rule that @docs must be after newline in 0.20 -- chompUntilDocs :: Parser Bool chompUntilDocs = P.Parser $ \(P.State src pos end indent row col) cok _ _ _ -> let (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col !newState = P.State src newPos end indent newRow newCol in cok isDocs newState untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #) untilDocs pos end row col = if pos >= end then (# False, pos, row, col #) else let !word = P.unsafeIndex pos in if word == 0x0A {-\n-} then untilDocs (plusPtr pos 1) end (row + 1) 1 else let !pos5 = plusPtr pos 5 in if pos5 <= end && P.unsafeIndex ( pos ) == 0x40 {-@-} && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-} && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-} && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-} && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-} && Var.getInnerWidth pos5 end == 0 then (# True, pos5, row, col + 5 #) else let !newPos = plusPtr pos (P.getCharWidth word) in untilDocs newPos end row (col + 1) -- CHECK NAMES checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error () checkNames exports names = let docs = List.foldl' addName Map.empty names loneDoc = Map.traverseMissing onlyInDocs loneExport = Map.traverseMissing onlyInExports checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r) in case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of (_, Right _) -> Right () (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es)) type DocNameRegions = Map.Map Name.Name (OneOrMore.OneOrMore A.Region) addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions addName dict (A.At region name) = Map.insertWith OneOrMore.more name (OneOrMore.one region) dict isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region isUnique name regions = case regions of OneOrMore.One region -> Result.ok region OneOrMore.More left right -> let (r1, r2) = OneOrMore.getFirstTwo left right in Result.throw (E.NameDuplicate name r1 r2) onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a onlyInDocs name regions = do region <- isUnique name regions Result.throw $ E.NameOnlyInDocs name region onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a onlyInExports name (A.At region _) = Result.throw $ E.NameOnlyInExports name region -- CHECK DEFS checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) = let types = gatherTypes decls Map.empty info = Info comments types unions aliases infixes effects in case Result.run (Map.traverseWithKey (checkExport info) exportDict) of (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems) (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters emptyModule :: ModuleName.Canonical -> Src.Comment -> Module emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) = Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty data Info = Info { _iComments :: Map.Map Name.Name Src.Comment , _iValues :: Map.Map Name.Name (Either A.Region Can.Type) , _iUnions :: Map.Map Name.Name Can.Union , _iAliases :: Map.Map Name.Name Can.Alias , _iBinops :: Map.Map Name.Name Can.Binop , _iEffects :: Can.Effects } checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module) checkExport info name (A.At region export) = case export of Can.ExportValue -> do tipe <- getType name info comment <- getComment region name info Result.ok $ \m -> m { _values = Map.insert name (Value comment tipe) (_values m) } Can.ExportBinop -> do let (Can.Binop_ assoc prec realName) = _iBinops info ! name tipe <- getType realName info comment <- getComment region realName info Result.ok $ \m -> m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) } Can.ExportAlias -> do let (Can.Alias tvars tipe) = _iAliases info ! name comment <- getComment region name info Result.ok $ \m -> m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) } Can.ExportUnionOpen -> do let (Can.Union tvars ctors _ _) = _iUnions info ! name comment <- getComment region name info Result.ok $ \m -> m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) } Can.ExportUnionClosed -> do let (Can.Union tvars _ _ _) = _iUnions info ! name comment <- getComment region name info Result.ok $ \m -> m { _unions = Map.insert name (Union comment tvars []) (_unions m) } Can.ExportPort -> do tipe <- getType name info comment <- getComment region name info Result.ok $ \m -> m { _values = Map.insert name (Value comment tipe) (_values m) } getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment getComment region name info = case Map.lookup name (_iComments info) of Nothing -> Result.throw (E.NoComment name region) Just (Src.Comment snippet) -> Result.ok (Json.fromComment snippet) getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type getType name info = case _iValues info ! name of Left region -> Result.throw (E.NoAnnotation name region) Right tipe -> Result.ok (Extract.fromType tipe) dector :: Can.Ctor -> (Name.Name, [Type.Type]) dector (Can.Ctor name _ _ args) = ( name, map Extract.fromType args ) -- GATHER TYPES type Types = Map.Map Name.Name (Either A.Region Can.Type) gatherTypes :: Can.Decls -> Types -> Types gatherTypes decls types = case decls of Can.Declare def subDecls -> gatherTypes subDecls (addDef types def) Can.DeclareRec def defs subDecls -> gatherTypes subDecls (List.foldl' addDef (addDef types def) defs) Can.SaveTheEnvironment -> types addDef :: Types -> Can.Def -> Types addDef types def = case def of Can.Def (A.At region name) _ _ -> Map.insert name (Left region) types Can.TypedDef (A.At _ name) _ typedArgs _ resultType -> let tipe = foldr Can.TLambda resultType (map snd typedArgs) in Map.insert name (Right tipe) types ================================================ FILE: compiler/src/Elm/Float.hs ================================================ {-# LANGUAGE EmptyDataDecls, FlexibleInstances #-} module Elm.Float ( Float , fromPtr , toBuilder ) where import Prelude hiding (Float) import Data.Binary (Binary, get, put) import qualified Data.ByteString.Builder as B import qualified Data.Utf8 as Utf8 import Data.Word (Word8) import Foreign.Ptr (Ptr) -- FLOATS type Float = Utf8.Utf8 ELM_FLOAT data ELM_FLOAT -- HELPERS fromPtr :: Ptr Word8 -> Ptr Word8 -> Float fromPtr = Utf8.fromPtr {-# INLINE toBuilder #-} toBuilder :: Float -> B.Builder toBuilder = Utf8.toBuilder -- BINARY instance Binary (Utf8.Utf8 ELM_FLOAT) where get = Utf8.getUnder256 put = Utf8.putUnder256 ================================================ FILE: compiler/src/Elm/Interface.hs ================================================ module Elm.Interface ( Interface(..) , Union(..) , Alias(..) , Binop(..) , fromModule , toPublicUnion , toPublicAlias , DependencyInterface(..) , public , private , privatize , extractUnion , extractAlias ) where import Control.Monad (liftM, liftM3, liftM4, liftM5) import Data.Binary import Data.Map.Strict ((!)) import qualified Data.Map.Strict as Map import qualified Data.Map.Merge.Strict as Map import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Utils.Binop as Binop import qualified Elm.Package as Pkg import qualified Reporting.Annotation as A -- INTERFACE data Interface = Interface { _home :: Pkg.Name , _values :: Map.Map Name.Name Can.Annotation , _unions :: Map.Map Name.Name Union , _aliases :: Map.Map Name.Name Alias , _binops :: Map.Map Name.Name Binop } deriving (Eq) data Union = OpenUnion Can.Union | ClosedUnion Can.Union | PrivateUnion Can.Union deriving (Eq) data Alias = PublicAlias Can.Alias | PrivateAlias Can.Alias deriving (Eq) data Binop = Binop { _op_name :: Name.Name , _op_annotation :: Can.Annotation , _op_associativity :: Binop.Associativity , _op_precedence :: Binop.Precedence } deriving (Eq) -- FROM MODULE fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations = Interface { _home = home , _values = restrict exports annotations , _unions = restrictUnions exports unions , _aliases = restrictAliases exports aliases , _binops = restrict exports (Map.map (toOp annotations) binops) } restrict :: Can.Exports -> Map.Map Name.Name a -> Map.Map Name.Name a restrict exports dict = case exports of Can.ExportEverything _ -> dict Can.Export explicitExports -> Map.intersection dict explicitExports toOp :: Map.Map Name.Name Can.Annotation -> Can.Binop -> Binop toOp types (Can.Binop_ associativity precedence name) = Binop name (types ! name) associativity precedence restrictUnions :: Can.Exports -> Map.Map Name.Name Can.Union -> Map.Map Name.Name Union restrictUnions exports unions = case exports of Can.ExportEverything _ -> Map.map OpenUnion unions Can.Export explicitExports -> Map.merge onLeft onRight onBoth explicitExports unions where onLeft = Map.dropMissing onRight = Map.mapMissing (\_ union -> PrivateUnion union) onBoth = Map.zipWithMatched $ \_ (A.At _ export) union -> case export of Can.ExportUnionOpen -> OpenUnion union Can.ExportUnionClosed -> ClosedUnion union _ -> error "impossible exports discovered in restrictUnions" restrictAliases :: Can.Exports -> Map.Map Name.Name Can.Alias -> Map.Map Name.Name Alias restrictAliases exports aliases = case exports of Can.ExportEverything _ -> Map.map PublicAlias aliases Can.Export explicitExports -> Map.merge onLeft onRight onBoth explicitExports aliases where onLeft = Map.dropMissing onRight = Map.mapMissing (\_ a -> PrivateAlias a) onBoth = Map.zipWithMatched (\_ _ a -> PublicAlias a) -- TO PUBLIC toPublicUnion :: Union -> Maybe Can.Union toPublicUnion iUnion = case iUnion of OpenUnion union -> Just union ClosedUnion (Can.Union vars _ _ opts) -> Just (Can.Union vars [] 0 opts) PrivateUnion _ -> Nothing toPublicAlias :: Alias -> Maybe Can.Alias toPublicAlias iAlias = case iAlias of PublicAlias alias -> Just alias PrivateAlias _ -> Nothing -- DEPENDENCY INTERFACE data DependencyInterface = Public Interface | Private Pkg.Name (Map.Map Name.Name Can.Union) (Map.Map Name.Name Can.Alias) public :: Interface -> DependencyInterface public = Public private :: Interface -> DependencyInterface private (Interface pkg _ unions aliases _) = Private pkg (Map.map extractUnion unions) (Map.map extractAlias aliases) extractUnion :: Union -> Can.Union extractUnion iUnion = case iUnion of OpenUnion union -> union ClosedUnion union -> union PrivateUnion union -> union extractAlias :: Alias -> Can.Alias extractAlias iAlias = case iAlias of PublicAlias alias -> alias PrivateAlias alias -> alias privatize :: DependencyInterface -> DependencyInterface privatize di = case di of Public i -> private i Private _ _ _ -> di -- BINARY instance Binary Interface where get = liftM5 Interface get get get get get put (Interface a b c d e) = put a >> put b >> put c >> put d >> put e instance Binary Union where put union = case union of OpenUnion u -> putWord8 0 >> put u ClosedUnion u -> putWord8 1 >> put u PrivateUnion u -> putWord8 2 >> put u get = do n <- getWord8 case n of 0 -> liftM OpenUnion get 1 -> liftM ClosedUnion get 2 -> liftM PrivateUnion get _ -> fail "binary encoding of Union was corrupted" instance Binary Alias where put union = case union of PublicAlias a -> putWord8 0 >> put a PrivateAlias a -> putWord8 1 >> put a get = do n <- getWord8 case n of 0 -> liftM PublicAlias get 1 -> liftM PrivateAlias get _ -> fail "binary encoding of Alias was corrupted" instance Binary Binop where get = liftM4 Binop get get get get put (Binop a b c d) = put a >> put b >> put c >> put d instance Binary DependencyInterface where put union = case union of Public a -> putWord8 0 >> put a Private a b c -> putWord8 1 >> put a >> put b >> put c get = do n <- getWord8 case n of 0 -> liftM Public get 1 -> liftM3 Private get get get _ -> fail "binary encoding of DependencyInterface was corrupted" ================================================ FILE: compiler/src/Elm/Kernel.hs ================================================ {-# LANGUAGE BangPatterns, EmptyDataDecls, OverloadedStrings, UnboxedTuples #-} module Elm.Kernel ( Content(..) , Chunk(..) , fromByteString , countFields ) where import Control.Monad (liftM, liftM2) import Data.Binary (Binary, get, put, getWord8, putWord8) import qualified Data.ByteString.Internal as B import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Name as Name import Data.Word (Word8) import Foreign.Ptr (Ptr, plusPtr, minusPtr) import Foreign.ForeignPtr (ForeignPtr) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import qualified AST.Source as Src import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Parse.Module as Module import qualified Parse.Space as Space import qualified Parse.Variable as Var import Parse.Primitives hiding (fromByteString) import qualified Parse.Primitives as P import qualified Reporting.Annotation as A -- CHUNK data Chunk = JS B.ByteString | ElmVar ModuleName.Canonical Name.Name | JsVar Name.Name Name.Name | ElmField Name.Name | JsField Int | JsEnum Int | Debug | Prod -- COUNT FIELDS countFields :: [Chunk] -> Map.Map Name.Name Int countFields chunks = foldr addField Map.empty chunks addField :: Chunk -> Map.Map Name.Name Int -> Map.Map Name.Name Int addField chunk fields = case chunk of JS _ -> fields ElmVar _ _ -> fields JsVar _ _ -> fields ElmField f -> Map.insertWith (+) f 1 fields JsField _ -> fields JsEnum _ -> fields Debug -> fields Prod -> fields -- FROM FILE data Content = Content [Src.Import] [Chunk] type Foreigns = Map.Map ModuleName.Raw Pkg.Name fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content fromByteString pkg foreigns bytes = case P.fromByteString (parser pkg foreigns) toError bytes of Right content -> Just content Left () -> Nothing parser :: Pkg.Name -> Foreigns -> Parser () Content parser pkg foreigns = do word2 0x2F 0x2A {-/*-} toError Space.chomp ignoreError Space.checkFreshLine toError imports <- specialize ignoreError (Module.chompImports []) word2 0x2A 0x2F {-*/-} toError chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty return (Content imports chunks) toError :: Row -> Col -> () toError _ _ = () ignoreError :: a -> Row -> Col -> () ignoreError _ _ _ = () -- PARSE CHUNKS parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk] parseChunks vtable enums fields = P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> let (# chunks, newPos, newRow, newCol #) = chompChunks vtable enums fields src pos end row col pos [] in if newPos == end then cok chunks (P.State src newPos end indent newRow newCol) else cerr row col toError chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #) chompChunks vs es fs src pos end row col lastPos revChunks = if pos >= end then let !js = toByteString src lastPos end in (# reverse (JS js : revChunks), pos, row, col #) else let !word = unsafeIndex pos in if word == 0x5F {-_-} then let !pos1 = plusPtr pos 1 !pos3 = plusPtr pos 3 in if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then let !js = toByteString src lastPos pos in chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks) else chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks else if word == 0x0A {-\n-} then chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks else let !newPos = plusPtr pos (getCharWidth word) in chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString toByteString src pos end = let !off = minusPtr pos (unsafeForeignPtrToPtr src) !len = minusPtr end pos in B.PS src off len -- relies on external checks in chompChunks chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #) chompTag vs es fs src pos end row col revChunks = let (# newPos, newCol #) = Var.chompInnerChars pos end col !tagPos = plusPtr pos (-1) !word = unsafeIndex tagPos in if word == 0x24 {-$-} then let !name = Name.fromPtr pos newPos in chompChunks vs es fs src newPos end row newCol newPos $ ElmField name : revChunks else let !name = Name.fromPtr tagPos newPos in if 0x30 {-0-} <= word && word <= 0x39 {-9-} then let (enum, newEnums) = lookupEnum (word - 0x30) name es in chompChunks vs newEnums fs src newPos end row newCol newPos $ JsEnum enum : revChunks else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then let (field, newFields) = lookupField name fs in chompChunks vs es newFields src newPos end row newCol newPos $ JsField field : revChunks else if name == "DEBUG" then chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks) else if name == "PROD" then chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks) else case Map.lookup name vs of Just chunk -> chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks) Nothing -> (# revChunks, pos, row, col #) -- FIELDS type Fields = Map.Map Name.Name Int lookupField :: Name.Name -> Fields -> (Int, Fields) lookupField name fields = case Map.lookup name fields of Just n -> ( n, fields ) Nothing -> let n = Map.size fields in ( n, Map.insert name n fields ) -- ENUMS type Enums = Map.Map Word8 (Map.Map Name.Name Int) lookupEnum :: Word8 -> Name.Name -> Enums -> (Int, Enums) lookupEnum word var allEnums = let enums = Map.findWithDefault Map.empty word allEnums in case Map.lookup var enums of Just n -> ( n, allEnums ) Nothing -> let n = Map.size enums in ( n, Map.insert word (Map.insert var n enums) allEnums ) -- PROCESS IMPORTS type VarTable = Map.Map Name.Name Chunk toVarTable :: Pkg.Name -> Foreigns -> [Src.Import] -> VarTable toVarTable pkg foreigns imports = List.foldl' (addImport pkg foreigns) Map.empty imports addImport :: Pkg.Name -> Foreigns -> VarTable -> Src.Import -> VarTable addImport pkg foreigns vtable (Src.Import (A.At _ importName) maybeAlias exposing) = if Name.isKernel importName then case maybeAlias of Just _ -> error ("cannot use `as` with kernel import of: " ++ Name.toChars importName) Nothing -> let home = Name.getKernel importName add table name = Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table in List.foldl' add vtable (toNames exposing) else let home = ModuleName.Canonical (Map.findWithDefault pkg importName foreigns) importName prefix = toPrefix importName maybeAlias add table name = Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) table in List.foldl' add vtable (toNames exposing) toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name toPrefix home maybeAlias = case maybeAlias of Just alias -> alias Nothing -> if Name.hasDot home then error ("kernel imports with dots need an alias: " ++ show (Name.toChars home)) else home toNames :: Src.Exposing -> [Name.Name] toNames exposing = case exposing of Src.Open -> error "cannot have `exposing (..)` in kernel code." Src.Explicit exposedList -> map toName exposedList toName :: Src.Exposed -> Name.Name toName exposed = case exposed of Src.Lower (A.At _ name) -> name Src.Upper (A.At _ name) Src.Private -> name Src.Upper _ (Src.Public _) -> error "cannot have Maybe(..) syntax in kernel code header" Src.Operator _ _ -> error "cannot use binops in kernel code" -- BINARY instance Binary Chunk where put chunk = case chunk of JS a -> putWord8 0 >> put a ElmVar a b -> putWord8 1 >> put a >> put b JsVar a b -> putWord8 2 >> put a >> put b ElmField a -> putWord8 3 >> put a JsField a -> putWord8 4 >> put a JsEnum a -> putWord8 5 >> put a Debug -> putWord8 6 Prod -> putWord8 7 get = do word <- getWord8 case word of 0 -> liftM JS get 1 -> liftM2 ElmVar get get 2 -> liftM2 JsVar get get 3 -> liftM ElmField get 4 -> liftM JsField get 5 -> liftM JsEnum get 6 -> return Debug 7 -> return Prod _ -> error "problem deserializing Elm.Kernel.Chunk" ================================================ FILE: compiler/src/Elm/Licenses.hs ================================================ {-# LANGUAGE OverloadedStrings #-} module Elm.Licenses ( License , bsd3 , encode , decoder ) where import qualified Data.Map as Map import qualified Data.Utf8 as Utf8 import qualified Json.Decode as D import qualified Json.Encode as E import qualified Json.String as Json import qualified Reporting.Suggest as Suggest -- LICENCES newtype License = License Json.String bsd3 :: License bsd3 = License (Json.fromChars "BSD-3-Clause") encode :: License -> E.Value encode (License code) = E.string code decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License decoder toError = do str <- D.string case check str of Right license -> return license Left suggestions -> D.failure (toError str suggestions) -- CHECK check :: Json.String -> Either [Json.String] License check givenCode = if Map.member givenCode osiApprovedSpdxLicenses then Right (License givenCode) else let pairs = map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses) ++ Map.toList osiApprovedSpdxLicenses in Left $ map fst $ take 4 $ Suggest.sort (Utf8.toChars givenCode) snd pairs -- LIST OF LICENCES (==>) :: [Char] -> [Char] -> (Json.String, [Char]) (==>) code fullName = ( Json.fromChars code, fullName ) -- -- OSI approved licenses in SPDX format. -- -- osiApprovedSpdxLicenses :: Map.Map Json.String [Char] osiApprovedSpdxLicenses = Map.fromList [ "0BSD" ==> "BSD Zero Clause License" , "AAL" ==> "Attribution Assurance License" , "AFL-1.1" ==> "Academic Free License v1.1" , "AFL-1.2" ==> "Academic Free License v1.2" , "AFL-2.0" ==> "Academic Free License v2.0" , "AFL-2.1" ==> "Academic Free License v2.1" , "AFL-3.0" ==> "Academic Free License v3.0" , "AGPL-3.0" ==> "GNU Affero General Public License v3.0" , "Apache-1.1" ==> "Apache License 1.1" , "Apache-2.0" ==> "Apache License 2.0" , "APL-1.0" ==> "Adaptive Public License 1.0" , "APSL-1.0" ==> "Apple Public Source License 1.0" , "APSL-1.1" ==> "Apple Public Source License 1.1" , "APSL-1.2" ==> "Apple Public Source License 1.2" , "APSL-2.0" ==> "Apple Public Source License 2.0" , "Artistic-1.0" ==> "Artistic License 1.0" , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8" , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)" , "Artistic-2.0" ==> "Artistic License 2.0" , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License" , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License" , "BSL-1.0" ==> "Boost Software License 1.0" , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1" , "CDDL-1.0" ==> "Common Development and Distribution License 1.0" , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1" , "CNRI-Python" ==> "CNRI Python License" , "CPAL-1.0" ==> "Common Public Attribution License 1.0" , "CPL-1.0" ==> "Common Public License 1.0" , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0" , "ECL-1.0" ==> "Educational Community License v1.0" , "ECL-2.0" ==> "Educational Community License v2.0" , "EFL-1.0" ==> "Eiffel Forum License v1.0" , "EFL-2.0" ==> "Eiffel Forum License v2.0" , "Entessa" ==> "Entessa Public License v1.0" , "EPL-1.0" ==> "Eclipse Public License 1.0" , "EUDatagrid" ==> "EU DataGrid Software License" , "EUPL-1.1" ==> "European Union Public License 1.1" , "Fair" ==> "Fair License" , "Frameworx-1.0" ==> "Frameworx Open License 1.0" , "GPL-2.0" ==> "GNU General Public License v2.0 only" , "GPL-3.0" ==> "GNU General Public License v3.0 only" , "HPND" ==> "Historic Permission Notice and Disclaimer" , "Intel" ==> "Intel Open Source License" , "IPA" ==> "IPA Font License" , "IPL-1.0" ==> "IBM Public License v1.0" , "ISC" ==> "ISC License" , "LGPL-2.0" ==> "GNU Library General Public License v2 only" , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only" , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only" , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1" , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1" , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1" , "LPL-1.0" ==> "Lucent Public License Version 1.0" , "LPL-1.02" ==> "Lucent Public License v1.02" , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c" , "MirOS" ==> "MirOS Licence" , "MIT" ==> "MIT License" , "Motosoto" ==> "Motosoto License" , "MPL-1.0" ==> "Mozilla Public License 1.0" , "MPL-1.1" ==> "Mozilla Public License 1.1" , "MPL-2.0" ==> "Mozilla Public License 2.0" , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)" , "MS-PL" ==> "Microsoft Public License" , "MS-RL" ==> "Microsoft Reciprocal License" , "Multics" ==> "Multics License" , "NASA-1.3" ==> "NASA Open Source Agreement 1.3" , "Naumen" ==> "Naumen Public License" , "NCSA" ==> "University of Illinois/NCSA Open Source License" , "NGPL" ==> "Nethack General Public License" , "Nokia" ==> "Nokia Open Source License" , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0" , "NTP" ==> "NTP License" , "OCLC-2.0" ==> "OCLC Research Public License 2.0" , "OFL-1.1" ==> "SIL Open Font License 1.1" , "OGTSL" ==> "Open Group Test Suite License" , "OSET-PL-2.1" ==> "OSET Public License version 2.1" , "OSL-1.0" ==> "Open Software License 1.0" , "OSL-2.0" ==> "Open Software License 2.0" , "OSL-2.1" ==> "Open Software License 2.1" , "OSL-3.0" ==> "Open Software License 3.0" , "PHP-3.0" ==> "PHP License v3.0" , "PostgreSQL" ==> "PostgreSQL License" , "Python-2.0" ==> "Python License 2.0" , "QPL-1.0" ==> "Q Public License 1.0" , "RPL-1.1" ==> "Reciprocal Public License 1.1" , "RPL-1.5" ==> "Reciprocal Public License 1.5" , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0" , "RSCPL" ==> "Ricoh Source Code Public License" , "SimPL-2.0" ==> "Simple Public License 2.0" , "SISSL" ==> "Sun Industry Standards Source License v1.1" , "Sleepycat" ==> "Sleepycat License" , "SPL-1.0" ==> "Sun Public License v1.0" , "UPL-1.0" ==> "Universal Permissive License v1.0" , "VSL-1.0" ==> "Vovida Software License v1.0" , "W3C" ==> "W3C Software Notice and License (2002-12-31)" , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0" , "Xnet" ==> "X.Net License" , "Zlib" ==> "zlib License" , "ZPL-2.0" ==> "Zope Public License 2.0" ] ================================================ FILE: compiler/src/Elm/Magnitude.hs ================================================ module Elm.Magnitude ( Magnitude(..) , toChars ) where -- MAGNITUDE data Magnitude = PATCH | MINOR | MAJOR deriving (Eq, Ord) toChars :: Magnitude -> String toChars magnitude = case magnitude of PATCH -> "PATCH" MINOR -> "MINOR" MAJOR -> "MAJOR" ================================================ FILE: compiler/src/Elm/ModuleName.hs ================================================ {-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-} module Elm.ModuleName ( Raw , toChars , toFilePath , toHyphenPath -- , encode , decoder , parser -- , Canonical(..) , basics, char, string , maybe, result, list, array, dict, tuple , platform, cmd, sub , debug , virtualDom , jsonDecode, jsonEncode , webgl, texture, vector2, vector3, vector4, matrix4 ) where import Control.Monad (liftM2) import Data.Binary (Binary(..)) import qualified Data.Name as Name import qualified Data.Utf8 as Utf8 import Data.Word (Word8) import Foreign.Ptr (Ptr, plusPtr, minusPtr) import Prelude hiding (maybe) import qualified System.FilePath as FP import qualified Elm.Package as Pkg import qualified Json.Decode as D import qualified Json.Encode as E import qualified Parse.Variable as Var import qualified Parse.Primitives as P import Parse.Primitives (Row, Col) -- RAW type Raw = Name.Name toChars :: Raw -> String toChars = Name.toChars toFilePath :: Raw -> FilePath toFilePath name = map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name) toHyphenPath :: Raw -> FilePath toHyphenPath name = map (\c -> if c == '.' then '-' else c) (Name.toChars name) -- JSON encode :: Raw -> E.Value encode = E.name decoder :: D.Decoder (Row, Col) Raw decoder = D.customString parser (,) -- PARSER parser :: P.Parser (Row, Col) Raw parser = P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> let (# isGood, newPos, newCol #) = chompStart pos end col in if isGood && minusPtr newPos pos < 256 then let !newState = P.State src newPos end indent row newCol in cok (Utf8.fromPtr pos newPos) newState else if col == newCol then eerr row newCol (,) else cerr row newCol (,) chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #) chompStart pos end col = let !width = Var.getUpperWidth pos end in if width == 0 then (# False, pos, col #) else chompInner (plusPtr pos width) end (col + 1) chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #) chompInner pos end col = if pos >= end then (# True, pos, col #) else let !word = P.unsafeIndex pos !width = Var.getInnerWidthHelp pos end word in if width == 0 then if word == 0x2E {-.-} then chompStart (plusPtr pos 1) end (col + 1) else (# True, pos, col #) else chompInner (plusPtr pos width) end (col + 1) -- CANONICAL data Canonical = Canonical { _package :: !Pkg.Name , _module :: !Name.Name } -- INSTANCES instance Eq Canonical where (==) (Canonical pkg1 name1) (Canonical pkg2 name2) = name1 == name2 && pkg1 == pkg2 instance Ord Canonical where compare (Canonical pkg1 name1) (Canonical pkg2 name2) = case compare name1 name2 of LT -> LT EQ -> compare pkg1 pkg2 GT -> GT instance Binary Canonical where put (Canonical a b) = put a >> put b get = liftM2 Canonical get get -- CORE {-# NOINLINE basics #-} basics :: Canonical basics = Canonical Pkg.core Name.basics {-# NOINLINE char #-} char :: Canonical char = Canonical Pkg.core Name.char {-# NOINLINE string #-} string :: Canonical string = Canonical Pkg.core Name.string {-# NOINLINE maybe #-} maybe :: Canonical maybe = Canonical Pkg.core Name.maybe {-# NOINLINE result #-} result :: Canonical result = Canonical Pkg.core Name.result {-# NOINLINE list #-} list :: Canonical list = Canonical Pkg.core Name.list {-# NOINLINE array #-} array :: Canonical array = Canonical Pkg.core Name.array {-# NOINLINE dict #-} dict :: Canonical dict = Canonical Pkg.core Name.dict {-# NOINLINE tuple #-} tuple :: Canonical tuple = Canonical Pkg.core Name.tuple {-# NOINLINE platform #-} platform :: Canonical platform = Canonical Pkg.core Name.platform {-# NOINLINE cmd #-} cmd :: Canonical cmd = Canonical Pkg.core "Platform.Cmd" {-# NOINLINE sub #-} sub :: Canonical sub = Canonical Pkg.core "Platform.Sub" {-# NOINLINE debug #-} debug :: Canonical debug = Canonical Pkg.core Name.debug -- HTML {-# NOINLINE virtualDom #-} virtualDom :: Canonical virtualDom = Canonical Pkg.virtualDom Name.virtualDom -- JSON {-# NOINLINE jsonDecode #-} jsonDecode :: Canonical jsonDecode = Canonical Pkg.json "Json.Decode" {-# NOINLINE jsonEncode #-} jsonEncode :: Canonical jsonEncode = Canonical Pkg.json "Json.Encode" -- WEBGL {-# NOINLINE webgl #-} webgl :: Canonical webgl = Canonical Pkg.webgl "WebGL" {-# NOINLINE texture #-} texture :: Canonical texture = Canonical Pkg.webgl "WebGL.Texture" {-# NOINLINE vector2 #-} vector2 :: Canonical vector2 = Canonical Pkg.linearAlgebra "Math.Vector2" {-# NOINLINE vector3 #-} vector3 :: Canonical vector3 = Canonical Pkg.linearAlgebra "Math.Vector3" {-# NOINLINE vector4 #-} vector4 :: Canonical vector4 = Canonical Pkg.linearAlgebra "Math.Vector4" {-# NOINLINE matrix4 #-} matrix4 :: Canonical matrix4 = Canonical Pkg.linearAlgebra "Math.Matrix4" ================================================ FILE: compiler/src/Elm/Package.hs ================================================ {-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-} module Elm.Package ( Name(..) , Author , Project , Canonical(..) , isKernel , toChars , toUrl , toFilePath , toJsonString -- , dummyName, kernel, core , browser, virtualDom, html , json, http, url , webgl, linearAlgebra -- , suggestions , nearbyNames -- , decoder , encode , keyDecoder -- , parser ) where import Control.Monad (liftM2) import Data.Binary (Binary, get, put) import qualified Data.Coerce as Coerce import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Name as Name import qualified Data.Utf8 as Utf8 import Data.Word (Word8) import Foreign.Ptr (Ptr, plusPtr, minusPtr) import System.FilePath (()) import qualified Elm.Version as V import qualified Json.Decode as D import qualified Json.Encode as E import qualified Json.String as Json import qualified Parse.Primitives as P import Parse.Primitives (Row, Col) import qualified Reporting.Suggest as Suggest -- PACKGE NAMES data Name = Name { _author :: !Author , _project :: !Project } deriving (Ord) type Author = Utf8.Utf8 AUTHOR type Project = Utf8.Utf8 PROJECT data AUTHOR data PROJECT data Canonical = Canonical { _name :: !Name , _version :: !V.Version } deriving (Ord) -- HELPERS isKernel :: Name -> Bool isKernel (Name author _) = author == elm || author == elm_explorations toChars :: Name -> String toChars (Name author project) = Utf8.toChars author <> "/" <> Utf8.toChars project toUrl :: Name -> String toUrl (Name author project) = Utf8.toChars author ++ "/" ++ Utf8.toChars project toFilePath :: Name -> FilePath toFilePath (Name author project) = Utf8.toChars author Utf8.toChars project toJsonString :: Name -> Json.String toJsonString (Name author project) = Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ] -- COMMON PACKAGE NAMES toName :: Author -> [Char] -> Name toName author project = Name author (Utf8.fromChars project) {-# NOINLINE dummyName #-} dummyName :: Name dummyName = toName (Utf8.fromChars "author") "project" {-# NOINLINE kernel #-} kernel :: Name kernel = toName elm "kernel" {-# NOINLINE core #-} core :: Name core = toName elm "core" {-# NOINLINE browser #-} browser :: Name browser = toName elm "browser" {-# NOINLINE virtualDom #-} virtualDom :: Name virtualDom = toName elm "virtual-dom" {-# NOINLINE html #-} html :: Name html = toName elm "html" {-# NOINLINE json #-} json :: Name json = toName elm "json" {-# NOINLINE http #-} http :: Name http = toName elm "http" {-# NOINLINE url #-} url :: Name url = toName elm "url" {-# NOINLINE webgl #-} webgl :: Name webgl = toName elm_explorations "webgl" {-# NOINLINE linearAlgebra #-} linearAlgebra :: Name linearAlgebra = toName elm_explorations "linear-algebra" {-# NOINLINE elm #-} elm :: Author elm = Utf8.fromChars "elm" {-# NOINLINE elm_explorations #-} elm_explorations :: Author elm_explorations = Utf8.fromChars "elm-explorations" -- PACKAGE SUGGESTIONS suggestions :: Map.Map Name.Name Name suggestions = let random = toName elm "random" time = toName elm "time" file = toName elm "file" in Map.fromList [ "Browser" ==> browser , "File" ==> file , "File.Download" ==> file , "File.Select" ==> file , "Html" ==> html , "Html.Attributes" ==> html , "Html.Events" ==> html , "Http" ==> http , "Json.Decode" ==> json , "Json.Encode" ==> json , "Random" ==> random , "Time" ==> time , "Url.Parser" ==> url , "Url" ==> url ] (==>) :: [Char] -> Name -> (Name.Name, Name) (==>) moduleName package = ( Utf8.fromChars moduleName, package ) -- NEARBY NAMES nearbyNames :: Name -> [Name] -> [Name] nearbyNames (Name author1 project1) possibleNames = let authorDist = authorDistance (Utf8.toChars author1) projectDist = projectDistance (Utf8.toChars project1) nameDistance (Name author2 project2) = authorDist author2 + projectDist project2 in take 4 $ List.sortOn nameDistance possibleNames authorDistance :: [Char] -> Author -> Int authorDistance given possibility = if possibility == elm || possibility == elm_explorations then 0 else abs (Suggest.distance given (Utf8.toChars possibility)) projectDistance :: [Char] -> Project -> Int projectDistance given possibility = abs (Suggest.distance given (Utf8.toChars possibility)) -- INSTANCES instance Eq Name where (==) (Name author1 project1) (Name author2 project2) = project1 == project2 && author1 == author2 instance Eq Canonical where (==) (Canonical package1 version1) (Canonical package2 version2) = version1 == version2 && package1 == package2 -- BINARY instance Binary Name where -- PERF try storing as a Word16 get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256 put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b instance Binary Canonical where get = liftM2 Canonical get get put (Canonical a b) = put a >> put b -- JSON decoder :: D.Decoder (Row, Col) Name decoder = D.customString parser (,) encode :: Name -> E.Value encode name = E.chars (toChars name) keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name keyDecoder toError = let keyParser = P.specialize (\(r,c) _ _ -> toError r c) parser in D.KeyDecoder keyParser toError -- PARSER parser :: P.Parser (Row, Col) Name parser = do author <- parseName isAlphaOrDigit isAlphaOrDigit P.word1 0x2F {-/-} (,) project <- parseName isLower isLowerOrDigit return (Name author project) parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t) parseName isGoodStart isGoodInner = P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> if pos >= end then eerr row col (,) else let !word = P.unsafeIndex pos in if not (isGoodStart word) then eerr row col (,) else let (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False !len = fromIntegral (minusPtr newPos pos) !newCol = col + len in if isGood && len < 256 then let !newState = P.State src newPos end indent row newCol in cok (Utf8.fromPtr pos newPos) newState else cerr row newCol (,) isLower :: Word8 -> Bool isLower word = 0x61 {-a-} <= word && word <= 0x7A {-z-} isLowerOrDigit :: Word8 -> Bool isLowerOrDigit word = 0x61 {-a-} <= word && word <= 0x7A {-z-} || 0x30 {-0-} <= word && word <= 0x39 {-9-} isAlphaOrDigit :: Word8 -> Bool isAlphaOrDigit word = 0x61 {-a-} <= word && word <= 0x7A {-z-} || 0x41 {-A-} <= word && word <= 0x5A {-Z-} || 0x30 {-0-} <= word && word <= 0x39 {-9-} chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #) chompName isGoodChar pos end prevWasDash = if pos >= end then (# not prevWasDash, pos #) else let !word = P.unsafeIndex pos in if isGoodChar word then chompName isGoodChar (plusPtr pos 1) end False else if word == 0x2D {---} then if prevWasDash then (# False, pos #) else chompName isGoodChar (plusPtr pos 1) end True else (# True, pos #) ================================================ FILE: compiler/src/Elm/String.hs ================================================ {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} {-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-} module Elm.String ( String , toChars , toBuilder , Chunk(..) , fromChunks ) where import Prelude hiding (String) import Data.Binary (Binary, get, put) import Data.Bits ((.&.), shiftR) import qualified Data.ByteString.Builder as B import qualified Data.Utf8 as Utf8 import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8) import GHC.Exts (RealWorld, Ptr) import GHC.IO (stToIO, unsafeDupablePerformIO) import GHC.ST (ST) import GHC.Word (Word8) -- STRINGS type String = Utf8.Utf8 ELM_STRING data ELM_STRING -- HELPERS toChars :: String -> [Char] toChars = Utf8.toChars {-# INLINE toBuilder #-} toBuilder :: String -> B.Builder toBuilder = Utf8.toBuilder -- FROM CHUNKS data Chunk = Slice (Ptr Word8) Int | Escape Word8 | CodePoint Int fromChunks :: [Chunk] -> String fromChunks chunks = unsafeDupablePerformIO (stToIO ( do let !len = sum (map chunkToWidth chunks) mba <- newByteArray len writeChunks mba 0 chunks freeze mba )) chunkToWidth :: Chunk -> Int chunkToWidth chunk = case chunk of Slice _ len -> len Escape _ -> 2 CodePoint c -> if c < 0xFFFF then 6 else 12 writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld () writeChunks mba offset chunks = case chunks of [] -> return () chunk : chunks -> case chunk of Slice ptr len -> do copyFromPtr ptr mba offset len let !newOffset = offset + len writeChunks mba newOffset chunks Escape word -> do writeWord8 mba offset 0x5C {- \ -} writeWord8 mba (offset + 1) word let !newOffset = offset + 2 writeChunks mba newOffset chunks CodePoint code -> if code < 0xFFFF then do writeCode mba offset code let !newOffset = offset + 6 writeChunks mba newOffset chunks else do let (hi,lo) = divMod (code - 0x10000) 0x400 writeCode mba (offset ) (hi + 0xD800) writeCode mba (offset + 6) (lo + 0xDC00) let !newOffset = offset + 12 writeChunks mba newOffset chunks writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld () writeCode mba offset code = do writeWord8 mba offset 0x5C {- \ -} writeWord8 mba (offset + 1) 0x75 {- u -} writeHex mba (offset + 2) (shiftR code 12) writeHex mba (offset + 3) (shiftR code 8) writeHex mba (offset + 4) (shiftR code 4) writeHex mba (offset + 5) code writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld () writeHex mba !offset !bits = do let !n = fromIntegral bits .&. 0x0F writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n) -- BINARY instance Binary (Utf8.Utf8 ELM_STRING) where get = Utf8.getVeryLong put = Utf8.putVeryLong ================================================ FILE: compiler/src/Elm/Version.hs ================================================ {-# LANGUAGE BangPatterns, UnboxedTuples #-} module Elm.Version ( Version(..) , one , max , compiler , bumpPatch , bumpMinor , bumpMajor , toChars -- , decoder , encode -- , parser ) where import Prelude hiding (max) import Control.Monad (liftM3) import Data.Binary (Binary, get, put, getWord8, putWord8) import qualified Data.Version as Version import Data.Word (Word8, Word16) import Foreign.Ptr (Ptr, plusPtr, minusPtr) import qualified Paths_elm import qualified Json.Decode as D import qualified Json.Encode as E import qualified Parse.Primitives as P import Parse.Primitives (Row, Col) -- VERSION data Version = Version { _major :: {-# UNPACK #-} !Word16 , _minor :: {-# UNPACK #-} !Word16 , _patch :: {-# UNPACK #-} !Word16 } deriving (Eq, Ord) one :: Version one = Version 1 0 0 max :: Version max = Version maxBound 0 0 compiler :: Version compiler = case map fromIntegral (Version.versionBranch Paths_elm.version) of major : minor : patch : _ -> Version major minor patch [major, minor] -> Version major minor 0 [major] -> Version major 0 0 [] -> error "could not detect version of elm-compiler you are using" -- BUMP bumpPatch :: Version -> Version bumpPatch (Version major minor patch) = Version major minor (patch + 1) bumpMinor :: Version -> Version bumpMinor (Version major minor _patch) = Version major (minor + 1) 0 bumpMajor :: Version -> Version bumpMajor (Version major _minor _patch) = Version (major + 1) 0 0 -- TO CHARS toChars :: Version -> [Char] toChars (Version major minor patch) = show major ++ '.' : show minor ++ '.' : show patch -- JSON decoder :: D.Decoder (Row, Col) Version decoder = D.customString parser (,) encode :: Version -> E.Value encode version = E.chars (toChars version) -- BINARY instance Binary Version where get = do word <- getWord8 if word == 255 then liftM3 Version get get get else do minor <- getWord8 patch <- getWord8 return (Version (fromIntegral word) (fromIntegral minor) (fromIntegral patch)) put (Version major minor patch) = if major < 255 && minor < 256 && patch < 256 then do putWord8 (fromIntegral major) putWord8 (fromIntegral minor) putWord8 (fromIntegral patch) else do putWord8 255 put major put minor put patch -- PARSER parser :: P.Parser (Row, Col) Version parser = do major <- numberParser P.word1 0x2E {-.-} (,) minor <- numberParser P.word1 0x2E {-.-} (,) patch <- numberParser return (Version major minor patch) numberParser :: P.Parser (Row, Col) Word16 numberParser = P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr -> if pos >= end then eerr row col (,) else let !word = P.unsafeIndex pos in if word == 0x30 {-0-} then let !newState = P.State src (plusPtr pos 1) end indent row (col + 1) in cok 0 newState else if isDigit word then let (# total, newPos #) = chompWord16 (plusPtr pos 1) end (fromIntegral (word - 0x30)) !newState = P.State src newPos end indent row (col + fromIntegral (minusPtr newPos pos)) in cok total newState else eerr row col (,) chompWord16 :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Word16, Ptr Word8 #) chompWord16 pos end total = if pos >= end then (# total, pos #) else let !word = P.unsafeIndex pos in if isDigit word then chompWord16 (plusPtr pos 1) end (10 * total + fromIntegral (word - 0x30)) else (# total, pos #) isDigit :: Word8 -> Bool isDigit word = 0x30 {-0-} <= word && word <= 0x39 {-9-} ================================================ FILE: compiler/src/Generate/Html.hs ================================================ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Generate.Html ( sandwich ) where import qualified Data.ByteString.Builder as B import qualified Data.Name as Name import Text.RawString.QQ (r) -- SANDWICH sandwich :: Name.Name -> B.Builder -> B.Builder sandwich moduleName javascript = let name = Name.toBuilder moduleName in [r| |] <> name <> [r| 





|]


================================================
FILE: compiler/src/Generate/JavaScript/Builder.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Generate.JavaScript.Builder
  ( stmtToBuilder
  , exprToBuilder
  , Expr(..), LValue(..)
  , Stmt(..), Case(..)
  , InfixOp(..), PrefixOp(..)
  )
  where

-- Based on the language-ecmascript package.
-- https://hackage.haskell.org/package/language-ecmascript
-- They did the hard work of reading the spec to figure out
-- how all the types should fit together.

import Prelude hiding (lines)
import qualified Data.List as List
import qualified Data.ByteString as BS
import Data.ByteString.Builder as B
import qualified Generate.JavaScript.Name as Name
import Generate.JavaScript.Name (Name)
import qualified Json.Encode as Json



-- EXPRESSIONS


-- NOTE: I tried making this create a B.Builder directly.
--
-- The hope was that it'd allocate less and speed things up, but it seemed
-- to be neutral for perf.
--
-- The downside is that Generate.JavaScript.Expression inspects the
-- structure of Expr and Stmt on some occassions to try to strip out
-- unnecessary closures. I think these closures are already avoided
-- by other logic in code gen these days, but I am not 100% certain.
--
-- For this to be worth it, I think it would be necessary to avoid
-- returning tuples when generating expressions.
--
data Expr
  = String Builder
  | Float Builder
  | Int Int
  | Bool Bool
  | Null
  | Json Json.Value
  | Array [Expr]
  | Object [(Name, Expr)]
  | Ref Name
  | Access Expr Name -- foo.bar
  | Index  Expr Expr -- foo[bar]
  | Prefix PrefixOp Expr
  | Infix InfixOp Expr Expr
  | If Expr Expr Expr
  | Assign LValue Expr
  | Call Expr [Expr]
  | Function (Maybe Name) [Name] [Stmt]


data LValue
  = LRef Name
  | LDot Expr Name
  | LBracket Expr Expr



-- STATEMENTS


data Stmt
  = Block [Stmt]
  | EmptyStmt
  | ExprStmt Expr
  | IfStmt Expr Stmt Stmt
  | Switch Expr [Case]
  | While Expr Stmt
  | Break (Maybe Name)
  | Continue (Maybe Name)
  | Labelled Name Stmt
  | Try Stmt Name Stmt
  | Throw Expr
  | Return Expr
  | Var Name Expr
  | Vars [(Name, Expr)]
  | FunctionStmt Name [Name] [Stmt]


data Case
  = Case Expr [Stmt]
  | Default [Stmt]



-- OPERATORS


data InfixOp
  = OpAdd -- +
  | OpSub -- -
  | OpMul -- *
  | OpDiv -- /
  | OpMod -- %
  | OpEq -- ===
  | OpNe -- !==
  | OpLt -- <
  | OpLe -- <=
  | OpGt -- >
  | OpGe -- >=
  | OpAnd -- &&
  | OpOr  -- ||
  | OpBitwiseAnd -- &
  | OpBitwiseXor -- ^
  | OpBitwiseOr  -- |
  | OpLShift     -- <<
  | OpSpRShift   -- >>
  | OpZfRShift   -- >>>


data PrefixOp
  = PrefixNot        -- !
  | PrefixNegate     -- -
  | PrefixComplement -- ~



-- ENCODE


stmtToBuilder :: Stmt -> Builder
stmtToBuilder stmts =
  fromStmt levelZero stmts


exprToBuilder :: Expr -> Builder
exprToBuilder expr =
  snd $ fromExpr levelZero Whatever expr



-- INDENT LEVEL


data Level =
  Level Builder Level


levelZero :: Level
levelZero =
  Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))


makeLevel :: Int -> BS.ByteString -> Level
makeLevel level oldTabs =
  let
    tabs =
      if level <= BS.length oldTabs
      then oldTabs
      else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
  in
  Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)



-- HELPERS


commaSep :: [Builder] -> Builder
commaSep builders =
  mconcat (List.intersperse ", " builders)


commaNewlineSep :: Level -> [Builder] -> Builder
commaNewlineSep (Level _ (Level deeperIndent _)) builders =
  mconcat (List.intersperse (",\n" <> deeperIndent) builders)



-- STATEMENTS


fromStmtBlock :: Level -> [Stmt] -> Builder
fromStmtBlock level stmts =
  mconcat (map (fromStmt level) stmts)


fromStmt :: Level -> Stmt -> Builder
fromStmt level@(Level indent nextLevel) statement =
  case statement of
    Block stmts ->
      fromStmtBlock level stmts

    EmptyStmt ->
      mempty

    ExprStmt expr ->
      indent <> snd (fromExpr level Whatever expr) <> ";\n"

    IfStmt condition thenStmt elseStmt ->
      mconcat
        [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
        , fromStmt nextLevel thenStmt
        , indent, "} else {\n"
        , fromStmt nextLevel elseStmt
        , indent, "}\n"
        ]

    Switch expr clauses ->
      mconcat
        [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
        , mconcat (map (fromClause nextLevel) clauses)
        , indent, "}\n"
        ]

    While expr stmt ->
      mconcat
        [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
        , fromStmt nextLevel stmt
        , indent, "}\n"
        ]

    Break Nothing ->
      indent <> "break;\n"

    Break (Just label) ->
      indent <> "break " <> Name.toBuilder label <> ";\n"

    Continue Nothing ->
      indent <> "continue;\n"

    Continue (Just label) ->
      indent <> "continue " <> Name.toBuilder label <> ";\n"

    Labelled label stmt ->
      mconcat
        [ indent, Name.toBuilder label, ":\n"
        , fromStmt level stmt
        ]

    Try tryStmt errorName catchStmt ->
      mconcat
        [ indent, "try {\n"
        , fromStmt nextLevel tryStmt
        , indent, "} catch (", Name.toBuilder errorName, ") {\n"
        , fromStmt nextLevel catchStmt
        , indent, "}\n"
        ]

    Throw expr ->
      indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"

    Return expr ->
      indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"

    Var name expr ->
      indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"

    Vars [] ->
      mempty

    Vars vars ->
      indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"

    FunctionStmt name args stmts ->
      indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
      <>
          fromStmtBlock nextLevel stmts
      <>
      indent <> "}\n"



-- SWITCH CLAUSES


fromClause :: Level -> Case -> Builder
fromClause level@(Level indent nextLevel) clause =
  case clause of
    Case expr stmts ->
      indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
      <> fromStmtBlock nextLevel stmts

    Default stmts ->
      indent <> "default:\n"
      <> fromStmtBlock nextLevel stmts



-- VAR DECLS


varToBuilder :: Level -> (Name, Expr) -> Builder
varToBuilder level (name, expr) =
  Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)



-- EXPRESSIONS


data Lines = One | Many deriving (Eq)


merge :: Lines -> Lines -> Lines
merge a b =
  if a == Many || b == Many then Many else One


linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
linesMap func xs =
  let
    pairs = map func xs
  in
  ( any ((==) Many . fst) pairs
  , map snd pairs
  )


data Grouping = Atomic | Whatever


parensFor :: Grouping -> Builder -> Builder
parensFor grouping builder =
  case grouping of
    Atomic ->
      "(" <> builder <> ")"

    Whatever ->
      builder


fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
  case expression of
    String string ->
      ( One, "'" <> string <> "'" )

    Float float ->
      ( One, float )

    Int n ->
      ( One, B.intDec n )

    Bool bool ->
      ( One, if bool then "true" else "false" )

    Null ->
      ( One, "null" )

    Json json ->
      ( One, Json.encodeUgly json )

    Array exprs ->
      (,) Many $
        let
          (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
        in
        if anyMany then
          "[\n"
          <> deeperIndent
          <> commaNewlineSep level builders
          <> "\n" <> indent <> "]"
        else
          "[" <> commaSep builders <> "]"

    Object fields ->
      (,) Many $
        let
          (anyMany, builders) = linesMap (fromField nextLevel) fields
        in
        if anyMany then
          "{\n"
          <> deeperIndent
          <> commaNewlineSep level builders
          <> "\n" <> indent <> "}"
        else
          "{" <> commaSep builders <> "}"

    Ref name ->
      ( One, Name.toBuilder name )

    Access expr field ->
      makeDot level expr field

    Index expr bracketedExpr ->
      makeBracketed level expr bracketedExpr

    Prefix op expr ->
      let
        (lines, builder) = fromExpr level Atomic expr
      in
      ( lines
      , parensFor grouping (fromPrefix op <> builder)
      )

    Infix op leftExpr rightExpr ->
      let
        (leftLines , left ) = fromExpr level Atomic leftExpr
        (rightLines, right) = fromExpr level Atomic rightExpr
      in
      ( merge leftLines rightLines
      , parensFor grouping (left <> fromInfix op <> right)
      )

    If condExpr thenExpr elseExpr ->
      let
        condB = snd (fromExpr level Atomic condExpr)
        thenB = snd (fromExpr level Atomic thenExpr)
        elseB = snd (fromExpr level Atomic elseExpr)
      in
      ( Many
      , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
      )

    Assign lValue expr ->
      let
        (leftLines , left ) = fromLValue level lValue
        (rightLines, right) = fromExpr level Whatever expr
      in
      ( merge leftLines rightLines
      , parensFor grouping (left <> " = " <> right)
      )

    Call function args ->
      (,) Many $
        let
          (_      , funcB) = fromExpr level Atomic function
          (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
        in
        if anyMany then
          funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
        else
          funcB <> "(" <> commaSep argsB <> ")"

    Function maybeName args stmts ->
      (,) Many $
        "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
        <>
            fromStmtBlock nextLevel stmts
        <>
        indent <> "}"



-- FIELDS


fromField :: Level -> (Name, Expr) -> (Lines, Builder)
fromField level (field, expr) =
  let
    (lines, builder) = fromExpr level Whatever expr
  in
  ( lines
  , Name.toBuilder field <> ": " <> builder
  )



-- VALUES


fromLValue :: Level -> LValue -> (Lines, Builder)
fromLValue level lValue =
  case lValue of
    LRef name ->
      (One, Name.toBuilder name)

    LDot expr field ->
      makeDot level expr field

    LBracket expr bracketedExpr ->
      makeBracketed level expr bracketedExpr


makeDot :: Level -> Expr -> Name -> (Lines, Builder)
makeDot level expr field =
  let
    (lines, builder) = fromExpr level Atomic expr
  in
  (lines, builder <> "." <> Name.toBuilder field)


makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
makeBracketed level expr bracketedExpr =
  let
    (lines         , builder         ) = fromExpr level Atomic expr
    (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
  in
  ( merge lines bracketedLines
  , builder <> "[" <> bracketedBuilder <> "]"
  )



-- OPERATORS


fromPrefix :: PrefixOp -> Builder
fromPrefix op =
  case op of
    PrefixNot        -> "!"
    PrefixNegate     -> "-"
    PrefixComplement -> "~"


fromInfix :: InfixOp -> Builder
fromInfix op =
  case op of
    OpAdd        -> " + "
    OpSub        -> " - "
    OpMul        -> " * "
    OpDiv        -> " / "
    OpMod        -> " % "
    OpEq         -> " === "
    OpNe         -> " !== "
    OpLt         -> " < "
    OpLe         -> " <= "
    OpGt         -> " > "
    OpGe         -> " >= "
    OpAnd        -> " && "
    OpOr         -> " || "
    OpBitwiseAnd -> " & "
    OpBitwiseXor -> " ^ "
    OpBitwiseOr  -> " | "
    OpLShift     -> " << "
    OpSpRShift   -> " >> "
    OpZfRShift   -> " >>> "


================================================
FILE: compiler/src/Generate/JavaScript/Expression.hs
================================================
{-# OPTIONS_GHC -fno-warn-x-partial #-}
{-# LANGUAGE OverloadedStrings #-}
module Generate.JavaScript.Expression
  ( generate
  , generateCtor
  , generateField
  , generateTailDef
  , generateMain
  , Code
  , codeToExpr
  , codeToStmtList
  )
  where


import qualified Data.IntMap as IntMap
import qualified Data.List as List
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.Set as Set
import qualified Data.Utf8 as Utf8

import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified AST.Utils.Shader as Shader
import qualified Data.Index as Index
import qualified Elm.Compiler.Type as Type
import qualified Elm.Compiler.Type.Extract as Extract
import qualified Elm.Version as V
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified Generate.JavaScript.Builder as JS
import qualified Generate.JavaScript.Name as JsName
import qualified Generate.Mode as Mode
import qualified Json.Encode as Encode
import Json.Encode ((==>))
import qualified Optimize.DecisionTree as DT
import qualified Reporting.Annotation as A



-- EXPRESSIONS


generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr
generateJsExpr mode expression =
  codeToExpr (generate mode expression)


generate :: Mode.Mode -> Opt.Expr -> Code
generate mode expression =
  case expression of
    Opt.Bool bool ->
      JsExpr $ JS.Bool bool

    Opt.Chr char ->
      JsExpr $
        case mode of
          Mode.Dev _ ->
            JS.Call toChar [ JS.String (Utf8.toBuilder char) ]

          Mode.Prod _ ->
            JS.String (Utf8.toBuilder char)

    Opt.Str string ->
      JsExpr $ JS.String (Utf8.toBuilder string)

    Opt.Int int ->
      JsExpr $ JS.Int int

    Opt.Float float ->
      JsExpr $ JS.Float (Utf8.toBuilder float)

    Opt.VarLocal name ->
      JsExpr $ JS.Ref (JsName.fromLocal name)

    Opt.VarGlobal (Opt.Global home name) ->
      JsExpr $ JS.Ref (JsName.fromGlobal home name)

    Opt.VarEnum (Opt.Global home name) index ->
      case mode of
        Mode.Dev _ ->
          JsExpr $ JS.Ref (JsName.fromGlobal home name)

        Mode.Prod _ ->
          JsExpr $ JS.Int (Index.toMachine index)

    Opt.VarBox (Opt.Global home name) ->
      JsExpr $ JS.Ref $
        case mode of
          Mode.Dev _ -> JsName.fromGlobal home name
          Mode.Prod _ -> JsName.fromGlobal ModuleName.basics Name.identity

    Opt.VarCycle home name ->
      JsExpr $ JS.Call (JS.Ref (JsName.fromCycle home name)) []

    Opt.VarDebug name home region unhandledValueName ->
      JsExpr $ generateDebug name home region unhandledValueName

    Opt.VarKernel home name ->
      JsExpr $ JS.Ref (JsName.fromKernel home name)

    Opt.List entries ->
      case entries of
        [] ->
          JsExpr $ JS.Ref (JsName.fromKernel Name.list "Nil")

        _ ->
          JsExpr $
            JS.Call
              (JS.Ref (JsName.fromKernel Name.list "fromArray"))
              [ JS.Array $ map (generateJsExpr mode) entries
              ]

    Opt.Function args body ->
      generateFunction (map JsName.fromLocal args) (generate mode body)

    Opt.Call func args ->
      JsExpr $ generateCall mode func args

    Opt.TailCall name args ->
      JsBlock $ generateTailCall mode name args

    Opt.If branches final ->
      generateIf mode branches final

    Opt.Let def body ->
      JsBlock $
        generateDef mode def : codeToStmtList (generate mode body)

    Opt.Destruct (Opt.Destructor name path) body ->
      let
        pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
      in
      JsBlock $ pathDef : codeToStmtList (generate mode body)

    Opt.Case label root decider jumps ->
      JsBlock $ generateCase mode label root decider jumps

    Opt.Accessor field ->
      JsExpr $ JS.Function Nothing [JsName.dollar]
        [ JS.Return $
            JS.Access (JS.Ref JsName.dollar) (generateField mode field)
        ]

    Opt.Access record field ->
      JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field)

    Opt.Update record fields ->
      JsExpr $
        JS.Call (JS.Ref (JsName.fromKernel Name.utils "update"))
          [ generateJsExpr mode record
          , generateRecord mode fields
          ]

    Opt.Record fields ->
      JsExpr $ generateRecord mode fields

    Opt.Unit ->
      case mode of
        Mode.Dev _ ->
          JsExpr $ JS.Ref (JsName.fromKernel Name.utils "Tuple0")

        Mode.Prod _ ->
          JsExpr $ JS.Int 0

    Opt.Tuple a b maybeC ->
      JsExpr $
        case maybeC of
          Nothing ->
            JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple2"))
              [ generateJsExpr mode a
              , generateJsExpr mode b
              ]

          Just c ->
            JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple3"))
              [ generateJsExpr mode a
              , generateJsExpr mode b
              , generateJsExpr mode c
              ]

    Opt.Shader src attributes uniforms ->
      let
        toTranlation field =
          ( JsName.fromLocal field
          , JS.String (JsName.toBuilder (generateField mode field))
          )

        toTranslationObject fields =
          JS.Object (map toTranlation (Set.toList fields))
      in
      JsExpr $ JS.Object $
        [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
        , ( JsName.fromLocal "attributes", toTranslationObject attributes )
        , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
        ]



-- CODE CHUNKS


data Code
    = JsExpr JS.Expr
    | JsBlock [JS.Stmt]


codeToExpr :: Code -> JS.Expr
codeToExpr code =
  case code of
    JsExpr expr ->
      expr

    JsBlock [ JS.Return expr ] ->
      expr

    JsBlock stmts ->
      JS.Call (JS.Function Nothing [] stmts) []


codeToStmtList :: Code -> [JS.Stmt]
codeToStmtList code =
  case code of
    JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
        stmts

    JsExpr expr ->
        [ JS.Return expr ]

    JsBlock stmts ->
        stmts


codeToStmt :: Code -> JS.Stmt
codeToStmt code =
  case code of
    JsExpr (JS.Call (JS.Function Nothing [] stmts) []) ->
        JS.Block stmts

    JsExpr expr ->
        JS.Return expr

    JsBlock [stmt] ->
        stmt

    JsBlock stmts ->
        JS.Block stmts



-- CHARS


{-# NOINLINE toChar #-}
toChar :: JS.Expr
toChar =
  JS.Ref (JsName.fromKernel Name.utils "chr")



-- CTOR


generateCtor :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code
generateCtor mode (Opt.Global home name) index arity =
  let
    argNames =
      Index.indexedMap (\i _ -> JsName.fromIndex i) [1 .. arity]

    ctorTag =
      case mode of
        Mode.Dev _ -> JS.String (Name.toBuilder name)
        Mode.Prod _ -> JS.Int (ctorToInt home name index)
  in
  generateFunction argNames $ JsExpr $ JS.Object $
    (JsName.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames


ctorToInt :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Int
ctorToInt home name index =
  if home == ModuleName.dict && name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin" then
    0 - Index.toHuman index
  else
    Index.toMachine index



-- RECORDS


generateRecord :: Mode.Mode -> Map.Map Name.Name Opt.Expr -> JS.Expr
generateRecord mode fields =
  let
    toPair (field, value) =
      (generateField mode field, generateJsExpr mode value)
  in
  JS.Object (map toPair (Map.toList fields))


generateField :: Mode.Mode -> Name.Name -> JsName.Name
generateField mode name =
  case mode of
    Mode.Dev _ ->
      JsName.fromLocal name

    Mode.Prod fields ->
      fields ! name




-- DEBUG


generateDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Maybe Name.Name -> JS.Expr
generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =
  if name /= "todo" then
    JS.Ref (JsName.fromGlobal ModuleName.debug name)
  else
    case unhandledValueName of
      Nothing ->
        JS.Call (JS.Ref (JsName.fromKernel Name.debug "todo")) $
          [ JS.String (Name.toBuilder home)
          , regionToJsExpr region
          ]

      Just valueName ->
        JS.Call (JS.Ref (JsName.fromKernel Name.debug "todoCase")) $
          [ JS.String (Name.toBuilder home)
          , regionToJsExpr region
          , JS.Ref (JsName.fromLocal valueName)
          ]


regionToJsExpr :: A.Region -> JS.Expr
regionToJsExpr (A.Region start end) =
  JS.Object
    [ ( JsName.fromLocal "start", positionToJsExpr start )
    , ( JsName.fromLocal "end", positionToJsExpr end )
    ]


positionToJsExpr :: A.Position -> JS.Expr
positionToJsExpr (A.Position line column) =
  JS.Object
    [ ( JsName.fromLocal "line", JS.Int (fromIntegral line) )
    , ( JsName.fromLocal "column", JS.Int (fromIntegral column) )
    ]



-- FUNCTION


generateFunction :: [JsName.Name] -> Code -> Code
generateFunction args body =
  case IntMap.lookup (length args) funcHelpers of
    Just helper ->
      JsExpr $
        JS.Call helper
          [ JS.Function Nothing args $
              codeToStmtList body
          ]

    Nothing ->
      let
        addArg arg code =
          JsExpr $ JS.Function Nothing [arg] $
            codeToStmtList code
      in
      foldr addArg body args


{-# NOINLINE funcHelpers #-}
funcHelpers :: IntMap.IntMap JS.Expr
funcHelpers =
  IntMap.fromList $
    map (\n -> (n, JS.Ref (JsName.makeF n))) [2..9]



-- CALLS


generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
generateCall mode func args =
  case func of
    Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->
      generateCoreCall mode global args

    Opt.VarBox _ ->
      case mode of
        Mode.Dev _ ->
          generateCallHelp mode func args

        Mode.Prod _ ->
          case args of
            [arg] ->
              generateJsExpr mode arg

            _ ->
              generateCallHelp mode func args

    _ ->
      generateCallHelp mode func args


generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
generateCallHelp mode func args =
  generateNormalCall
    (generateJsExpr mode func)
    (map (generateJsExpr mode) args)


generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
generateGlobalCall home name args =
  generateNormalCall (JS.Ref (JsName.fromGlobal home name)) args


generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr
generateNormalCall func args =
  case IntMap.lookup (length args) callHelpers of
    Just helper ->
      JS.Call helper (func:args)

    Nothing ->
      List.foldl' (\f a -> JS.Call f [a]) func args


{-# NOINLINE callHelpers #-}
callHelpers :: IntMap.IntMap JS.Expr
callHelpers =
  IntMap.fromList $
    map (\n -> (n, JS.Ref (JsName.makeA n))) [2..9]



-- CORE CALLS


generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr
generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =
  if moduleName == Name.basics then
    generateBasicsCall mode home name args

  else if moduleName == Name.bitwise then
    generateBitwiseCall home name (map (generateJsExpr mode) args)

  else if moduleName == Name.tuple then
    generateTupleCall home name (map (generateJsExpr mode) args)

  else if moduleName == Name.jsArray then
    generateJsArrayCall home name (map (generateJsExpr mode) args)

  else
    generateGlobalCall home name (map (generateJsExpr mode) args)


generateTupleCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
generateTupleCall home name args =
  case args of
    [value] ->
      case name of
        "first"  -> JS.Access value (JsName.fromLocal "a")
        "second" -> JS.Access value (JsName.fromLocal "b")
        _        -> generateGlobalCall home name args

    _ ->
      generateGlobalCall home name args


generateJsArrayCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
generateJsArrayCall home name args =
  case args of
    [entry]        | name == "singleton" -> JS.Array [entry]
    [index, array] | name == "unsafeGet" -> JS.Index array index
    _                                    -> generateGlobalCall home name args


generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr
generateBitwiseCall home name args =
  case args of
    [arg] ->
      case name of
        "complement" -> JS.Prefix JS.PrefixComplement arg
        _            -> generateGlobalCall home name args

    [left,right] ->
      case name of
        "and"            -> JS.Infix JS.OpBitwiseAnd left right
        "or"             -> JS.Infix JS.OpBitwiseOr  left right
        "xor"            -> JS.Infix JS.OpBitwiseXor left right
        "shiftLeftBy"    -> JS.Infix JS.OpLShift     right left
        "shiftRightBy"   -> JS.Infix JS.OpSpRShift   right left
        "shiftRightZfBy" -> JS.Infix JS.OpZfRShift   right left
        _                -> generateGlobalCall home name args

    _ ->
      generateGlobalCall home name args


generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr
generateBasicsCall mode home name args =
  case args of
    [elmArg] ->
      let arg = generateJsExpr mode elmArg in
      case name of
        "not"      -> JS.Prefix JS.PrefixNot arg
        "negate"   -> JS.Prefix JS.PrefixNegate arg
        "toFloat"  -> arg
        "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
        _          -> generateGlobalCall home name [arg]

    [elmLeft, elmRight] ->
      case name of
        -- NOTE: removed "composeL" and "composeR" because of this issue:
        -- https://github.com/elm/compiler/issues/1722
        "append"   -> append mode elmLeft elmRight
        "apL"      -> generateJsExpr mode $ apply elmLeft elmRight
        "apR"      -> generateJsExpr mode $ apply elmRight elmLeft
        _ ->
          let
            left = generateJsExpr mode elmLeft
            right = generateJsExpr mode elmRight
          in
          case name of
            "add"  -> JS.Infix JS.OpAdd left right
            "sub"  -> JS.Infix JS.OpSub left right
            "mul"  -> JS.Infix JS.OpMul left right
            "fdiv" -> JS.Infix JS.OpDiv left right
            "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
            "eq"   -> equal left right
            "neq"  -> notEqual left right
            "lt"   -> cmp JS.OpLt JS.OpLt   0  left right
            "gt"   -> cmp JS.OpGt JS.OpGt   0  left right
            "le"   -> cmp JS.OpLe JS.OpLt   1  left right
            "ge"   -> cmp JS.OpGe JS.OpGt (-1) left right
            "or"   -> JS.Infix JS.OpOr  left right
            "and"  -> JS.Infix JS.OpAnd left right
            "xor"  -> JS.Infix JS.OpNe  left right
            "remainderBy" -> JS.Infix JS.OpMod right left
            _      -> generateGlobalCall home name [left, right]

    _ ->
      generateGlobalCall home name (map (generateJsExpr mode) args)


equal :: JS.Expr -> JS.Expr -> JS.Expr
equal left right =
  if isLiteral left || isLiteral right then
    strictEq left right
  else
    JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]


notEqual :: JS.Expr -> JS.Expr -> JS.Expr
notEqual left right =
  if isLiteral left || isLiteral right then
    strictNEq left right
  else
    JS.Prefix JS.PrefixNot $
      JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]


cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
cmp idealOp backupOp backupInt left right =
  if isLiteral left || isLiteral right then
    JS.Infix idealOp left right
  else
    JS.Infix backupOp
      (JS.Call (JS.Ref (JsName.fromKernel Name.utils "cmp")) [left, right])
      (JS.Int backupInt)


isLiteral :: JS.Expr -> Bool
isLiteral expr =
  case expr of
    JS.String _ ->
      True

    JS.Float _ ->
      True

    JS.Int _ ->
      True

    JS.Bool _ ->
      True

    _ ->
      False


apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
apply func value =
  case func of
    Opt.Accessor field ->
      Opt.Access value field

    Opt.Call f args ->
      Opt.Call f (args ++ [value])

    _ ->
      Opt.Call func [value]


append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr
append mode left right =
  let seqs = generateJsExpr mode left : toSeqs mode right in
  if any isStringLiteral seqs then
    foldr1 (JS.Infix JS.OpAdd) seqs
  else
    foldr1 jsAppend seqs


jsAppend :: JS.Expr -> JS.Expr -> JS.Expr
jsAppend a b =
  JS.Call (JS.Ref (JsName.fromKernel Name.utils "ap")) [a, b]


toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr]
toSeqs mode expr =
  case expr of
    Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]
      | home == ModuleName.basics ->
          generateJsExpr mode left : toSeqs mode right

    _ ->
      [generateJsExpr mode expr]


isStringLiteral :: JS.Expr -> Bool
isStringLiteral expr =
  case expr of
    JS.String _ ->
      True

    _ ->
      False



-- SIMPLIFY INFIX OPERATORS


strictEq :: JS.Expr -> JS.Expr -> JS.Expr
strictEq left right =
  case left of
    JS.Int 0 ->
      JS.Prefix JS.PrefixNot right

    JS.Bool bool ->
      if bool then right else JS.Prefix JS.PrefixNot right

    _ ->
      case right of
        JS.Int 0 ->
          JS.Prefix JS.PrefixNot left

        JS.Bool bool ->
          if bool then left else JS.Prefix JS.PrefixNot left

        _ ->
          JS.Infix JS.OpEq left right


strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
strictNEq left right =
  case left of
    JS.Int 0 ->
      JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)

    JS.Bool bool ->
      if bool then JS.Prefix JS.PrefixNot right else right

    _ ->
      case right of
        JS.Int 0 ->
          JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)

        JS.Bool bool ->
          if bool then JS.Prefix JS.PrefixNot left else left

        _ ->
          JS.Infix JS.OpNe left right



-- TAIL CALL


-- TODO check if JS minifiers collapse unnecessary temporary variables
--
generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stmt]
generateTailCall mode name args =
  let
    toTempVars (argName, arg) =
      ( JsName.makeTemp argName, generateJsExpr mode arg )

    toRealVars (argName, _) =
      JS.ExprStmt $
        JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
  in
  JS.Vars (map toTempVars args)
  : map toRealVars args
  ++ [ JS.Continue (Just (JsName.fromLocal name)) ]



-- DEFINITIONS


generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
generateDef mode def =
  case def of
    Opt.Def name body ->
      JS.Var (JsName.fromLocal name) (generateJsExpr mode body)

    Opt.TailDef name argNames body ->
      JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))


generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
generateTailDef mode name argNames body =
  generateFunction (map JsName.fromLocal argNames) $ JsBlock $
    [ JS.Labelled (JsName.fromLocal name) $
        JS.While (JS.Bool True) $
          codeToStmt $ generate mode body
    ]



-- PATHS


generatePath :: Mode.Mode -> Opt.Path -> JS.Expr
generatePath mode path =
  case path of
    Opt.Index index subPath ->
      JS.Access (generatePath mode subPath) (JsName.fromIndex index)

    Opt.Root name ->
      JS.Ref (JsName.fromLocal name)

    Opt.Field field subPath ->
      JS.Access (generatePath mode subPath) (generateField mode field)

    Opt.Unbox subPath ->
      case mode of
        Mode.Dev _ ->
          JS.Access (generatePath mode subPath) (JsName.fromIndex Index.first)

        Mode.Prod _ ->
          generatePath mode subPath



-- GENERATE IFS


generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code
generateIf mode givenBranches givenFinal =
  let
    (branches, final) =
      crushIfs givenBranches givenFinal

    convertBranch (condition, expr) =
      ( generateJsExpr mode condition
      , generate mode expr
      )

    branchExprs = map convertBranch branches
    finalCode = generate mode final
  in
  if isBlock finalCode || any (isBlock . snd) branchExprs then
    JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
  else
    JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs


addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
addExprIf (condition, branch) final =
  JS.If condition (codeToExpr branch) final


addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
addStmtIf (condition, branch) final =
  JS.IfStmt condition (codeToStmt branch) final


isBlock :: Code -> Bool
isBlock code =
  case code of
    JsBlock _ -> True
    JsExpr _ -> False


crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
crushIfs branches final =
  crushIfsHelp [] branches final


crushIfsHelp
    :: [(Opt.Expr, Opt.Expr)]
    -> [(Opt.Expr, Opt.Expr)]
    -> Opt.Expr
    -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
crushIfsHelp visitedBranches unvisitedBranches final =
  case unvisitedBranches of
    [] ->
        case final of
          Opt.If subBranches subFinal ->
              crushIfsHelp visitedBranches subBranches subFinal

          _ ->
              (reverse visitedBranches, final)

    visiting : unvisited ->
        crushIfsHelp (visiting : visitedBranches) unvisited final



-- CASE EXPRESSIONS


generateCase :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]
generateCase mode label root decider jumps =
  foldr (goto mode label) (generateDecider mode label root decider) jumps


goto :: Mode.Mode -> Name.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
goto mode label (index, branch) stmts =
  let
    labeledDeciderStmt =
      JS.Labelled
        (JsName.makeLabel label index)
        (JS.While (JS.Bool True) (JS.Block stmts))
  in
  labeledDeciderStmt : codeToStmtList (generate mode branch)


generateDecider :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
generateDecider mode label root decisionTree =
  case decisionTree of
    Opt.Leaf (Opt.Inline branch) ->
      codeToStmtList (generate mode branch)

    Opt.Leaf (Opt.Jump index) ->
      [ JS.Break (Just (JsName.makeLabel label index)) ]

    Opt.Chain testChain success failure ->
      [ JS.IfStmt
          (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
          (JS.Block $ generateDecider mode label root success)
          (JS.Block $ generateDecider mode label root failure)
      ]

    Opt.FanOut path edges fallback ->
      [ JS.Switch
          (generateCaseTest mode root path (fst (head edges)))
          ( foldr
              (\edge cases -> generateCaseBranch mode label root edge : cases)
              [ JS.Default (generateDecider mode label root fallback) ]
              edges
          )
      ]


generateIfTest :: Mode.Mode -> Name.Name -> (DT.Path, DT.Test) -> JS.Expr
generateIfTest mode root (path, test) =
  let
    value = pathToJsExpr mode root path
  in
  case test of
    DT.IsCtor home name index _ opts ->
      let
        tag =
          case mode of
            Mode.Dev _ -> JS.Access value JsName.dollar
            Mode.Prod _ ->
              case opts of
                Can.Normal -> JS.Access value JsName.dollar
                Can.Enum   -> value
                Can.Unbox  -> value
      in
      strictEq tag $
        case mode of
          Mode.Dev _ -> JS.String (Name.toBuilder name)
          Mode.Prod _ -> JS.Int (ctorToInt home name index)

    DT.IsBool True ->
      value

    DT.IsBool False ->
      JS.Prefix JS.PrefixNot value

    DT.IsInt int ->
      strictEq value (JS.Int int)

    DT.IsChr char ->
      strictEq (JS.String (Utf8.toBuilder char)) $
        case mode of
          Mode.Dev _ -> JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []
          Mode.Prod _ -> value

    DT.IsStr string ->
      strictEq value (JS.String (Utf8.toBuilder string))

    DT.IsCons ->
      JS.Access value (JsName.fromLocal "b")

    DT.IsNil ->
      JS.Prefix JS.PrefixNot $
        JS.Access value (JsName.fromLocal "b")

    DT.IsTuple ->
      error "COMPILER BUG - there should never be tests on a tuple"



generateCaseBranch :: Mode.Mode -> Name.Name -> Name.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case
generateCaseBranch mode label root (test, subTree) =
  JS.Case
    (generateCaseValue mode test)
    (generateDecider mode label root subTree)


generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr
generateCaseValue mode test =
  case test of
    DT.IsCtor home name index _ _ ->
      case mode of
        Mode.Dev _ -> JS.String (Name.toBuilder name)
        Mode.Prod _ -> JS.Int (ctorToInt home name index)

    DT.IsInt int ->
      JS.Int int

    DT.IsChr char ->
      JS.String (Utf8.toBuilder char)

    DT.IsStr string ->
      JS.String (Utf8.toBuilder string)

    DT.IsBool _ ->
      error "COMPILER BUG - there should never be three tests on a boolean"

    DT.IsCons ->
      error "COMPILER BUG - there should never be three tests on a list"

    DT.IsNil ->
      error "COMPILER BUG - there should never be three tests on a list"

    DT.IsTuple ->
      error "COMPILER BUG - there should never be three tests on a tuple"


generateCaseTest :: Mode.Mode -> Name.Name -> DT.Path -> DT.Test -> JS.Expr
generateCaseTest mode root path exampleTest =
  let
    value = pathToJsExpr mode root path
  in
  case exampleTest of
    DT.IsCtor home name _ _ opts ->
      if name == Name.bool && home == ModuleName.basics then
        value
      else
        case mode of
          Mode.Dev _ ->
            JS.Access value JsName.dollar

          Mode.Prod _ ->
            case opts of
              Can.Normal ->
                JS.Access value JsName.dollar

              Can.Enum ->
                value

              Can.Unbox ->
                value

    DT.IsInt _ ->
      value

    DT.IsStr _ ->
      value

    DT.IsChr _ ->
      case mode of
        Mode.Dev _ ->
          JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []

        Mode.Prod _ ->
          value

    DT.IsBool _ ->
      error "COMPILER BUG - there should never be three tests on a list"

    DT.IsCons ->
      error "COMPILER BUG - there should never be three tests on a list"

    DT.IsNil ->
      error "COMPILER BUG - there should never be three tests on a list"

    DT.IsTuple ->
      error "COMPILER BUG - there should never be three tests on a list"



-- PATTERN PATHS


pathToJsExpr :: Mode.Mode -> Name.Name -> DT.Path -> JS.Expr
pathToJsExpr mode root path =
  case path of
    DT.Index index subPath ->
      JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex index)

    DT.Unbox subPath ->
      case mode of
        Mode.Dev _ ->
          JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex Index.first)

        Mode.Prod _ ->
          pathToJsExpr mode root subPath

    DT.Empty ->
      JS.Ref (JsName.fromLocal root)



-- GENERATE MAIN


generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr
generateMain mode home main =
  case main of
    Opt.Static ->
      JS.Ref (JsName.fromKernel Name.virtualDom "init")
        # JS.Ref (JsName.fromGlobal home "main")
        # JS.Int 0
        # JS.Int 0

    Opt.Dynamic msgType decoder ->
      JS.Ref (JsName.fromGlobal home "main")
        # generateJsExpr mode decoder
        # toDebugMetadata mode msgType


(#) :: JS.Expr -> JS.Expr -> JS.Expr
(#) func arg =
  JS.Call func [arg]


toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr
toDebugMetadata mode msgType =
  case mode of
    Mode.Prod _ ->
      JS.Int 0

    Mode.Dev Nothing ->
      JS.Int 0

    Mode.Dev (Just interfaces) ->
      JS.Json $ Encode.object $
        [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
        , "types"    ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)
        ]


================================================
FILE: compiler/src/Generate/JavaScript/Functions.hs
================================================
{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
module Generate.JavaScript.Functions
  ( functions
  )
  where


import qualified Data.ByteString.Builder as B
import Text.RawString.QQ (r)



-- FUNCTIONS


functions :: B.Builder
functions = [r|

function F(arity, fun, wrapper) {
  wrapper.a = arity;
  wrapper.f = fun;
  return wrapper;
}

function F2(fun) {
  return F(2, fun, function(a) { return function(b) { return fun(a,b); }; })
}
function F3(fun) {
  return F(3, fun, function(a) {
    return function(b) { return function(c) { return fun(a, b, c); }; };
  });
}
function F4(fun) {
  return F(4, fun, function(a) { return function(b) { return function(c) {
    return function(d) { return fun(a, b, c, d); }; }; };
  });
}
function F5(fun) {
  return F(5, fun, function(a) { return function(b) { return function(c) {
    return function(d) { return function(e) { return fun(a, b, c, d, e); }; }; }; };
  });
}
function F6(fun) {
  return F(6, fun, function(a) { return function(b) { return function(c) {
    return function(d) { return function(e) { return function(f) {
    return fun(a, b, c, d, e, f); }; }; }; }; };
  });
}
function F7(fun) {
  return F(7, fun, function(a) { return function(b) { return function(c) {
    return function(d) { return function(e) { return function(f) {
    return function(g) { return fun(a, b, c, d, e, f, g); }; }; }; }; }; };
  });
}
function F8(fun) {
  return F(8, fun, function(a) { return function(b) { return function(c) {
    return function(d) { return function(e) { return function(f) {
    return function(g) { return function(h) {
    return fun(a, b, c, d, e, f, g, h); }; }; }; }; }; }; };
  });
}
function F9(fun) {
  return F(9, fun, function(a) { return function(b) { return function(c) {
    return function(d) { return function(e) { return function(f) {
    return function(g) { return function(h) { return function(i) {
    return fun(a, b, c, d, e, f, g, h, i); }; }; }; }; }; }; }; };
  });
}

function A2(fun, a, b) {
  return fun.a === 2 ? fun.f(a, b) : fun(a)(b);
}
function A3(fun, a, b, c) {
  return fun.a === 3 ? fun.f(a, b, c) : fun(a)(b)(c);
}
function A4(fun, a, b, c, d) {
  return fun.a === 4 ? fun.f(a, b, c, d) : fun(a)(b)(c)(d);
}
function A5(fun, a, b, c, d, e) {
  return fun.a === 5 ? fun.f(a, b, c, d, e) : fun(a)(b)(c)(d)(e);
}
function A6(fun, a, b, c, d, e, f) {
  return fun.a === 6 ? fun.f(a, b, c, d, e, f) : fun(a)(b)(c)(d)(e)(f);
}
function A7(fun, a, b, c, d, e, f, g) {
  return fun.a === 7 ? fun.f(a, b, c, d, e, f, g) : fun(a)(b)(c)(d)(e)(f)(g);
}
function A8(fun, a, b, c, d, e, f, g, h) {
  return fun.a === 8 ? fun.f(a, b, c, d, e, f, g, h) : fun(a)(b)(c)(d)(e)(f)(g)(h);
}
function A9(fun, a, b, c, d, e, f, g, h, i) {
  return fun.a === 9 ? fun.f(a, b, c, d, e, f, g, h, i) : fun(a)(b)(c)(d)(e)(f)(g)(h)(i);
}

|]


================================================
FILE: compiler/src/Generate/JavaScript/Name.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Generate.JavaScript.Name
  ( Name
  , toBuilder
  , fromIndex
  , fromInt
  , fromLocal
  , fromGlobal
  , fromCycle
  , fromKernel
  , makeF
  , makeA
  , makeLabel
  , makeTemp
  , dollar
  )
  where


import qualified Data.ByteString.Builder as B
import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.Set as Set
import qualified Data.Utf8 as Utf8
import Data.Word (Word8)

import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg



-- NAME


newtype Name =
  Name { toBuilder :: B.Builder }



-- CONSTRUCTORS


fromIndex :: Index.ZeroBased -> Name
fromIndex index =
  fromInt (Index.toMachine index)


fromInt :: Int -> Name
fromInt n =
  Name (Name.toBuilder (intToAscii n))


fromLocal :: Name.Name -> Name
fromLocal name =
  if Set.member name reservedNames then
    Name ("_" <> Name.toBuilder name)
  else
    Name (Name.toBuilder name)


fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
fromGlobal home name =
  Name $ homeToBuilder home <> usd <> Name.toBuilder name


fromCycle :: ModuleName.Canonical -> Name.Name -> Name
fromCycle home name =
  Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name


fromKernel :: Name.Name -> Name.Name -> Name
fromKernel home name =
  Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)


{-# INLINE homeToBuilder #-}
homeToBuilder :: ModuleName.Canonical -> B.Builder
homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) =
  usd <>
  Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
  <> usd <>
  Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
  <> usd <>
  Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home



-- TEMPORARY NAMES


makeF :: Int -> Name
makeF n =
  Name ("F" <> B.intDec n)


makeA :: Int -> Name
makeA n =
  Name ("A" <> B.intDec n)


makeLabel :: Name.Name -> Int -> Name
makeLabel name index =
  Name (Name.toBuilder name <> usd <> B.intDec index)


makeTemp :: Name.Name -> Name
makeTemp name =
  Name ("$temp$" <> Name.toBuilder name)


dollar :: Name
dollar =
  Name usd


usd :: B.Builder
usd =
  Name.toBuilder Name.dollar



-- RESERVED NAMES


{-# NOINLINE reservedNames #-}
reservedNames :: Set.Set Name.Name
reservedNames =
  Set.union jsReservedWords elmReservedWords


jsReservedWords :: Set.Set Name.Name
jsReservedWords =
  Set.fromList
    [ "do", "if", "in"
    , "NaN", "int", "for", "new", "try", "var", "let"
    , "null", "true", "eval", "byte", "char", "goto", "long", "case", "else", "this", "void", "with", "enum"
    , "false", "final", "float", "short", "break", "catch", "throw", "while", "class", "const", "super", "yield"
    , "double", "native", "throws", "delete", "return", "switch", "typeof", "export", "import", "public", "static"
    , "boolean", "default", "finally", "extends", "package", "private"
    , "Infinity", "abstract", "volatile", "function", "continue", "debugger", "function"
    , "undefined", "arguments", "transient", "interface", "protected"
    , "instanceof", "implements"
    , "synchronized"
    ]


elmReservedWords :: Set.Set Name.Name
elmReservedWords =
  Set.fromList
    [ "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"
    , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"
    ]



-- INT TO ASCII


intToAscii :: Int -> Name.Name
intToAscii n =
  if n < 53 then -- skip $ as a standalone name
    Name.fromWords [toByte n]

  else
    intToAsciiHelp 2 (numStartBytes * numInnerBytes) allBadFields (n - 53)


intToAsciiHelp :: Int -> Int -> [BadFields] -> Int -> Name.Name
intToAsciiHelp width blockSize badFields n =
  case badFields of
    [] ->
      if n < blockSize then
        unsafeIntToAscii width [] n
      else
        intToAsciiHelp (width + 1) (blockSize * numInnerBytes) [] (n - blockSize)

    BadFields renamings : biggerBadFields ->
      let availableSize = blockSize - Map.size renamings in
      if n < availableSize then
        let name = unsafeIntToAscii width [] n in
        Map.findWithDefault name name renamings
      else
        intToAsciiHelp (width + 1) (blockSize * numInnerBytes) biggerBadFields (n - availableSize)



-- UNSAFE INT TO ASCII


unsafeIntToAscii :: Int -> [Word8] -> Int -> Name.Name
unsafeIntToAscii width bytes n =
  if width <= 1 then
    Name.fromWords (toByte n : bytes)
  else
    let
      (quotient, remainder) =
        quotRem n numInnerBytes
    in
    unsafeIntToAscii (width - 1) (toByte remainder : bytes) quotient



-- ASCII BYTES


numStartBytes :: Int
numStartBytes =
  54


numInnerBytes :: Int
numInnerBytes =
  64


toByte :: Int -> Word8
toByte n
  | n < 26  = fromIntegral (97 + n     ) {- lower -}
  | n < 52  = fromIntegral (65 + n - 26) {- upper -}
  | n == 52 = 95 {- _ -}
  | n == 53 = 36 {- $ -}
  | n < 64  = fromIntegral (48 + n - 54) {- digit -}
  | True    = error $ "cannot convert int " ++ show n ++ " to ASCII"



-- BAD FIELDS


newtype BadFields =
  BadFields { _renamings :: Renamings }


type Renamings =
  Map.Map Name.Name Name.Name


allBadFields :: [BadFields]
allBadFields =
  let
    add keyword dict =
      Map.alter (Just . addRenaming keyword) (Utf8.size keyword) dict
  in
    Map.elems $ Set.foldr add Map.empty jsReservedWords


addRenaming :: Name.Name -> Maybe BadFields -> BadFields
addRenaming keyword maybeBadFields =
  let
    width = Utf8.size keyword
    maxName = numStartBytes * numInnerBytes ^ (width - 1) - 1
  in
  case maybeBadFields of
    Nothing ->
      BadFields $ Map.singleton keyword (unsafeIntToAscii width [] maxName)

    Just (BadFields renamings) ->
      BadFields $ Map.insert keyword (unsafeIntToAscii width [] (maxName - Map.size renamings)) renamings


================================================
FILE: compiler/src/Generate/JavaScript.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Generate.JavaScript
  ( generate
  , generateForRepl
  , generateForReplEndpoint
  )
  where


import Prelude hiding (cycle, print)
import qualified Data.ByteString.Builder as B
import qualified Data.List as List
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.Set as Set
import qualified Data.Utf8 as Utf8

import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified Data.Index as Index
import qualified Elm.Kernel as K
import qualified Elm.ModuleName as ModuleName
import qualified Generate.JavaScript.Builder as JS
import qualified Generate.JavaScript.Expression as Expr
import qualified Generate.JavaScript.Functions as Functions
import qualified Generate.JavaScript.Name as JsName
import qualified Generate.Mode as Mode
import qualified Reporting.Doc as D
import qualified Reporting.Render.Type as RT
import qualified Reporting.Render.Type.Localizer as L



-- GENERATE


type Graph = Map.Map Opt.Global Opt.Node
type Mains = Map.Map ModuleName.Canonical Opt.Main


generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder
generate mode (Opt.GlobalGraph graph _) mains =
  let
    state = Map.foldrWithKey (addMain mode graph) emptyState mains
  in
  "(function(scope){\n'use strict';"
  <> Functions.functions
  <> perfNote mode
  <> stateToBuilder state
  <> toMainExports mode mains
  <> "}(this));"


addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State
addMain mode graph home _ state =
  addGlobal mode graph state (Opt.Global home "main")


perfNote :: Mode.Mode -> B.Builder
perfNote mode =
  case mode of
    Mode.Prod _ ->
      ""

    Mode.Dev Nothing ->
      "console.warn('Compiled in DEV mode. Follow the advice at "
      <> B.stringUtf8 (D.makeNakedLink "optimize")
      <> " for better performance and smaller assets.');"

    Mode.Dev (Just _) ->
      "console.warn('Compiled in DEBUG mode. Follow the advice at "
      <> B.stringUtf8 (D.makeNakedLink "optimize")
      <> " for better performance and smaller assets.');"



-- GENERATE FOR REPL


generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =
  let
    mode = Mode.Dev Nothing
    debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
    evalState = addGlobal mode graph debugState (Opt.Global home name)
  in
  "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
  <> Functions.functions
  <> stateToBuilder evalState
  <> print ansi localizer home name tipe


print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder
print ansi localizer home name tipe =
  let
    value = JsName.toBuilder (JsName.fromGlobal home name)
    toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
    tipeDoc = RT.canToDoc localizer RT.None tipe
    bool = if ansi then "true" else "false"
  in
  "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
  \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
  \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
  \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
  \    _print('\\n    : ' + _type.split('\\n').join('\\n      '));\n\
  \} else {\n\
  \    _print(' : ' + _type);\n\
  \}\n"



-- GENERATE FOR REPL ENDPOINT


generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
  let
    name = maybe Name.replValueToPrint id maybeName
    mode = Mode.Dev Nothing
    debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
    evalState = addGlobal mode graph debugState (Opt.Global home name)
  in
  Functions.functions
  <> stateToBuilder evalState
  <> postMessage localizer home maybeName tipe


postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
postMessage localizer home maybeName tipe =
  let
    name = maybe Name.replValueToPrint id maybeName
    value = JsName.toBuilder (JsName.fromGlobal home name)
    toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
    tipeDoc = RT.canToDoc localizer RT.None tipe
    toName n = "\"" <> Name.toBuilder n <> "\""
  in
  "self.postMessage({\n\
  \  name: " <> maybe "null" toName maybeName <> ",\n\
  \  value: " <> toString <> "(true, " <> value <> "),\n\
  \  type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
  \});\n"



-- GRAPH TRAVERSAL STATE


data State =
  State
    { _revKernels :: [B.Builder]
    , _revBuilders :: [B.Builder]
    , _seenGlobals :: Set.Set Opt.Global
    }


emptyState :: State
emptyState =
  State mempty [] Set.empty


stateToBuilder :: State -> B.Builder
stateToBuilder (State revKernels revBuilders _) =
  prependBuilders revKernels (prependBuilders revBuilders mempty)


prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
prependBuilders revBuilders monolith =
  List.foldl' (\m b -> b <> m) monolith revBuilders



-- ADD DEPENDENCIES


addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
addGlobal mode graph state@(State revKernels builders seen) global =
  if Set.member global seen then
    state
  else
    addGlobalHelp mode graph global $
      State revKernels builders (Set.insert global seen)


addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
addGlobalHelp mode graph global state =
  let
    addDeps deps someState =
      Set.foldl' (addGlobal mode graph) someState deps
  in
  case graph ! global of
    Opt.Define expr deps ->
      addStmt (addDeps deps state) (
        var global (Expr.generate mode expr)
      )

    Opt.DefineTailFunc argNames body deps ->
      addStmt (addDeps deps state) (
        let (Opt.Global _ name) = global in
        var global (Expr.generateTailDef mode name argNames body)
      )

    Opt.Ctor index arity ->
      addStmt state (
        var global (Expr.generateCtor mode global index arity)
      )

    Opt.Link linkedGlobal ->
      addGlobal mode graph state linkedGlobal

    Opt.Cycle names values functions deps ->
      addStmt (addDeps deps state) (
        generateCycle mode global names values functions
      )

    Opt.Manager effectsType ->
      generateManager mode graph global effectsType state

    Opt.Kernel chunks deps ->
      if isDebugger global && not (Mode.isDebug mode) then
        state
      else
        addKernel (addDeps deps state) (generateKernel mode chunks)

    Opt.Enum index ->
      addStmt state (
        generateEnum mode global index
      )

    Opt.Box ->
      addStmt (addGlobal mode graph state identity) (
        generateBox mode global
      )

    Opt.PortIncoming decoder deps ->
      addStmt (addDeps deps state) (
        generatePort mode global "incomingPort" decoder
      )

    Opt.PortOutgoing encoder deps ->
      addStmt (addDeps deps state) (
        generatePort mode global "outgoingPort" encoder
      )


addStmt :: State -> JS.Stmt -> State
addStmt state stmt =
  addBuilder state (JS.stmtToBuilder stmt)


addBuilder :: State -> B.Builder -> State
addBuilder (State revKernels revBuilders seen) builder =
  State revKernels (builder:revBuilders) seen


addKernel :: State -> B.Builder -> State
addKernel (State revKernels revBuilders seen) kernel =
  State (kernel:revKernels) revBuilders seen


var :: Opt.Global -> Expr.Code -> JS.Stmt
var (Opt.Global home name) code =
  JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)


isDebugger :: Opt.Global -> Bool
isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
  home == Name.debugger



-- GENERATE CYCLES


generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
generateCycle mode (Opt.Global home _) names values functions =
  JS.Block
    [ JS.Block $ map (generateCycleFunc mode home) functions
    , JS.Block $ map (generateSafeCycle mode home) values
    , case map (generateRealCycle home) values of
        [] ->
          JS.EmptyStmt

        realBlock@(_:_) ->
            case mode of
              Mode.Prod _ ->
                JS.Block realBlock

              Mode.Dev _ ->
                JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $
                  "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
                  <> drawCycle names
                  <> "\\n\\nThese errors are very tricky, so read "
                  <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
                  <> " to learn how to fix it!"
    ]


generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
generateCycleFunc mode home def =
  case def of
    Opt.Def name expr ->
      JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))

    Opt.TailDef name args expr ->
      JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))


generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
generateSafeCycle mode home (name, expr) =
  JS.FunctionStmt (JsName.fromCycle home name) [] $
    Expr.codeToStmtList (Expr.generate mode expr)


generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
generateRealCycle home (name, _) =
  let
    safeName = JsName.fromCycle home name
    realName = JsName.fromGlobal home name
  in
  JS.Block
    [ JS.Var realName (JS.Call (JS.Ref safeName) [])
    , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
        JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
    ]


drawCycle :: [Name.Name] -> B.Builder
drawCycle names =
  let
    topLine       = "\\n  ┌─────┐"
    nameLine name = "\\n  │    " <> Name.toBuilder name
    midLine       = "\\n  │     ↓"
    bottomLine    = "\\n  └─────┘"
  in
  mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])



-- GENERATE KERNEL


generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder
generateKernel mode chunks =
  List.foldr (addChunk mode) mempty chunks


addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
addChunk mode chunk builder =
  case chunk of
    K.JS javascript ->
      B.byteString javascript <> builder

    K.ElmVar home name ->
      JsName.toBuilder (JsName.fromGlobal home name) <> builder

    K.JsVar home name ->
      JsName.toBuilder (JsName.fromKernel home name) <> builder

    K.ElmField name ->
      JsName.toBuilder (Expr.generateField mode name) <> builder

    K.JsField int ->
      JsName.toBuilder (JsName.fromInt int) <> builder

    K.JsEnum int ->
      B.intDec int <> builder

    K.Debug ->
      case mode of
        Mode.Dev _ ->
          builder

        Mode.Prod _ ->
          "_UNUSED" <> builder

    K.Prod ->
      case mode of
        Mode.Dev _ ->
          "_UNUSED" <> builder

        Mode.Prod _ ->
          builder



-- GENERATE ENUM


generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
generateEnum mode global@(Opt.Global home name) index =
  JS.Var (JsName.fromGlobal home name) $
    case mode of
      Mode.Dev _ ->
        Expr.codeToExpr (Expr.generateCtor mode global index 0)

      Mode.Prod _ ->
        JS.Int (Index.toMachine index)



-- GENERATE BOX


generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
generateBox mode global@(Opt.Global home name) =
  JS.Var (JsName.fromGlobal home name) $
    case mode of
      Mode.Dev _ ->
        Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)

      Mode.Prod _ ->
        JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)


{-# NOINLINE identity #-}
identity :: Opt.Global
identity =
  Opt.Global ModuleName.basics Name.identity



-- GENERATE PORTS


generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
generatePort mode (Opt.Global home name) makePort converter =
  JS.Var (JsName.fromGlobal home name) $
    JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
      [ JS.String (Name.toBuilder name)
      , Expr.codeToExpr (Expr.generate mode converter)
      ]



-- GENERATE MANAGER


generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
  let
    managerLVar =
      JS.LBracket
        (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
        (JS.String (Name.toBuilder moduleName))

    (deps, args, stmts) =
      generateManagerHelp home effectsType

    createManager =
      JS.ExprStmt $ JS.Assign managerLVar $
        JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
  in
  addStmt (List.foldl' (addGlobal mode graph) state deps) $
    JS.Block (createManager : stmts)


generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
generateLeaf home@(ModuleName.Canonical _ moduleName) name =
  JS.Var (JsName.fromGlobal home name) $
    JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]



{-# NOINLINE leaf #-}
leaf :: JS.Expr
leaf =
  JS.Ref (JsName.fromKernel Name.platform "leaf")


generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
generateManagerHelp home effectsType =
  let
    dep name = Opt.Global home name
    ref name = JS.Ref (JsName.fromGlobal home name)
  in
  case effectsType of
    Opt.Cmd ->
      ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
      , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
      , [ generateLeaf home "command" ]
      )

    Opt.Sub ->
      ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
      , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
      , [ generateLeaf home "subscription" ]
      )

    Opt.Fx ->
      ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
      , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
      , [ generateLeaf home "command"
        , generateLeaf home "subscription"
        ]
      )



-- MAIN EXPORTS


toMainExports :: Mode.Mode -> Mains -> B.Builder
toMainExports mode mains =
  let
    export = JsName.fromKernel Name.platform "export"
    exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
  in
  JsName.toBuilder export <> "(" <> exports <> ");"


generateExports :: Mode.Mode -> Trie -> B.Builder
generateExports mode (Trie maybeMain subs) =
  let
    starter end =
      case maybeMain of
        Nothing ->
          "{"

        Just (home, main) ->
          "{'init':"
          <> JS.exprToBuilder (Expr.generateMain mode home main)
          <> end
    in
    case Map.toList subs of
      [] ->
        starter "" <> "}"

      (name, subTrie) : otherSubTries ->
        starter "," <>
        "'" <> Utf8.toBuilder name <> "':"
        <> generateExports mode subTrie
        <> List.foldl' (addSubTrie mode) "}" otherSubTries


addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
addSubTrie mode end (name, trie) =
  ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end



-- BUILD TRIES


data Trie =
  Trie
    { _main :: Maybe (ModuleName.Canonical, Opt.Main)
    , _subs :: Map.Map Name.Name Trie
    }


emptyTrie :: Trie
emptyTrie =
  Trie Nothing Map.empty


addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
  merge trie $ segmentsToTrie home (Name.splitDots moduleName) main


segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
segmentsToTrie home segments main =
  case segments of
    [] ->
      Trie (Just (home, main)) Map.empty

    segment : otherSegments ->
      Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))


merge :: Trie -> Trie -> Trie
merge (Trie main1 subs1) (Trie main2 subs2) =
  Trie
    (checkedMerge main1 main2)
    (Map.unionWith merge subs1 subs2)


checkedMerge :: Maybe a -> Maybe a -> Maybe a
checkedMerge a b =
  case (a, b) of
    (Nothing, main) ->
      main

    (main, Nothing) ->
      main

    (Just _, Just _) ->
      error "cannot have two modules with the same name"


================================================
FILE: compiler/src/Generate/Mode.hs
================================================
module Generate.Mode
  ( Mode(..)
  , isDebug
  , ShortFieldNames
  , shortenFieldNames
  )
  where


import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Name as Name

import qualified AST.Optimized as Opt
import qualified Elm.Compiler.Type.Extract as Extract
import qualified Generate.JavaScript.Name as JsName



-- MODE


data Mode
  = Dev (Maybe Extract.Types)
  | Prod ShortFieldNames


isDebug :: Mode -> Bool
isDebug mode =
  case mode of
    Dev mi -> Maybe.isJust mi
    Prod _ -> False



-- SHORTEN FIELD NAMES


type ShortFieldNames =
  Map.Map Name.Name JsName.Name


shortenFieldNames :: Opt.GlobalGraph -> ShortFieldNames
shortenFieldNames (Opt.GlobalGraph _ frequencies) =
  Map.foldr addToShortNames Map.empty $
    Map.foldrWithKey addToBuckets Map.empty frequencies


addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
addToBuckets field frequency buckets =
  Map.insertWith (++) frequency [field] buckets


addToShortNames :: [Name.Name] -> ShortFieldNames -> ShortFieldNames
addToShortNames fields shortNames =
  List.foldl' addField shortNames fields


addField :: ShortFieldNames -> Name.Name -> ShortFieldNames
addField shortNames field =
  let rename = JsName.fromInt (Map.size shortNames) in
  Map.insert field rename shortNames


================================================
FILE: compiler/src/Json/Decode.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}
module Json.Decode
  ( fromByteString
  , Decoder
  , string
  , customString
  , bool
  , int
  , list
  , nonEmptyList
  , pair
  --
  , KeyDecoder(..)
  , dict
  , pairs
  , field
  --
  , oneOf
  , failure
  , mapError
  --
  , Error(..)
  , Problem(..)
  , DecodeExpectation(..)
  , ParseError(..)
  , StringProblem(..)
  )
  where


import qualified Data.ByteString.Internal as B
import qualified Data.Map as Map
import qualified Data.NonEmptyList as NE
import Data.Word (Word8)
import Foreign.Ptr (Ptr, plusPtr, minusPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

import qualified Json.String as Json
import qualified Parse.Keyword as K
import qualified Parse.Primitives as P
import Parse.Primitives (Row, Col)
import qualified Reporting.Annotation as A



-- RUNNERS


fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
fromByteString (Decoder decode) src =
  case P.fromByteString pFile BadEnd src of
    Right ast ->
      decode ast Right (Left . DecodeProblem src)

    Left problem ->
      Left (ParseProblem src problem)



-- DECODERS


newtype Decoder x a =
  Decoder
  (
    forall b.
      AST
      -> (a -> b)
      -> (Problem x -> b)
      -> b
  )



-- ERRORS


data Error x
  = DecodeProblem B.ByteString (Problem x)
  | ParseProblem B.ByteString ParseError



-- DECODE PROBLEMS


data Problem x
  = Field B.ByteString (Problem x)
  | Index Int (Problem x)
  | OneOf (Problem x) [Problem x]
  | Failure A.Region x
  | Expecting A.Region DecodeExpectation


data DecodeExpectation
  = TObject
  | TArray
  | TString
  | TBool
  | TInt
  | TObjectWith B.ByteString
  | TArrayPair Int



-- INSTANCES


instance Functor (Decoder x) where
  {-# INLINE fmap #-}
  fmap func (Decoder decodeA) =
    Decoder $ \ast ok err ->
      let
        ok' a = ok (func a)
      in
      decodeA ast ok' err


instance Applicative (Decoder x) where
  {-# INLINE pure #-}
  pure a =
    Decoder $ \_ ok _ ->
      ok a

  {-# INLINE (<*>) #-}
  (<*>) (Decoder decodeFunc) (Decoder decodeArg) =
    Decoder $ \ast ok err ->
      let
        okF func =
          let
            okA arg = ok (func arg)
          in
          decodeArg ast okA err
      in
      decodeFunc ast okF err


instance Monad (Decoder x) where
  {-# INLINE (>>=) #-}
  (>>=) (Decoder decodeA) callback =
    Decoder $ \ast ok err ->
      let
        ok' a =
          case callback a of
            Decoder decodeB -> decodeB ast ok err
      in
      decodeA ast ok' err



-- STRINGS


string :: Decoder x Json.String
string =
  Decoder $ \(A.At region ast) ok err ->
    case ast of
      String snippet ->
        ok (Json.fromSnippet snippet)

      _ ->
        err (Expecting region TString)


customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
customString parser toBadEnd =
  Decoder $ \(A.At region ast) ok err ->
    case ast of
      String snippet ->
        case P.fromSnippet parser toBadEnd snippet of
          Right a -> ok a
          Left  x -> err (Failure region x)

      _ ->
        err (Expecting region TString)



-- BOOL


bool :: Decoder x Bool
bool =
  Decoder $ \(A.At region ast) ok err ->
    case ast of
      TRUE ->
        ok True

      FALSE ->
        ok False

      _ ->
        err (Expecting region TBool)



-- INT


int :: Decoder x Int
int =
  Decoder $ \(A.At region ast) ok err ->
    case ast of
      Int n ->
        ok n

      _ ->
        err (Expecting region TInt)



-- LISTS


list :: Decoder x a -> Decoder x [a]
list decoder =
  Decoder $ \(A.At region ast) ok err ->
    case ast of
      Array asts ->
        listHelp decoder ok err 0 asts []

      _ ->
        err (Expecting region TArray)


listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
listHelp decoder@(Decoder decodeA) ok err !i asts revs =
  case asts of
    [] ->
      ok (reverse revs)

    ast:asts ->
      let
        ok' value = listHelp decoder ok err (i+1) asts (value:revs)
        err' prob = err (Index i prob)
      in
      decodeA ast ok' err'



-- NON-EMPTY LISTS


nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
nonEmptyList decoder x =
  do  values <- list decoder
      case values of
        v:vs -> return (NE.List v vs)
        []   -> failure x



-- PAIR


pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
pair (Decoder decodeA) (Decoder decodeB) =
  Decoder $ \(A.At region ast) ok err ->
    case ast of
      Array vs ->
        case vs of
          [astA,astB] ->
            let
              err0 e = err (Index 0 e)
              ok0 a =
                let
                  err1 e = err (Index 1 e)
                  ok1 b = ok (a,b)
                in
                decodeB astB ok1 err1
            in
            decodeA astA ok0 err0

          _ ->
            err (Expecting region (TArrayPair (length vs)))

      _ ->
        err (Expecting region TArray)



-- OBJECTS


data KeyDecoder x a =
  KeyDecoder (P.Parser x a) (Row -> Col -> x)


dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
dict keyDecoder valueDecoder =
  Map.fromList <$> pairs keyDecoder valueDecoder


pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
pairs keyDecoder valueDecoder =
  Decoder $ \(A.At region ast) ok err ->
    case ast of
      Object kvs ->
        pairsHelp keyDecoder valueDecoder ok err kvs []

      _ ->
        err (Expecting region TObject)


pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
  case kvs of
    [] ->
      ok (reverse revs)

    (snippet, ast) : kvs ->
      case P.fromSnippet keyParser toBadEnd snippet of
        Left x ->
          err (Failure (snippetToRegion snippet) x)

        Right key ->
          let
            ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
            err' prob =
              let (P.Snippet fptr off len _ _) = snippet in
              err (Field (B.PS fptr off len) prob)
          in
          decodeA ast ok' err'


snippetToRegion :: P.Snippet -> A.Region
snippetToRegion (P.Snippet _ _ len row col) =
  A.Region (A.Position row col) (A.Position row (col + fromIntegral len))



-- FIELDS


field :: B.ByteString -> Decoder x a -> Decoder x a
field key (Decoder decodeA) =
  Decoder $ \(A.At region ast) ok err ->
    case ast of
      Object kvs ->
        case findField key kvs of
          Just value ->
            let
              err' prob =
                err (Field key prob)
            in
            decodeA value ok err'

          Nothing ->
            err (Expecting region (TObjectWith key))

      _ ->
        err (Expecting region TObject)


findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
findField key pairs =
  case pairs of
    [] ->
      Nothing

    (P.Snippet fptr off len _ _, value) : remainingPairs ->
      if key == B.PS fptr off len
      then Just value
      else findField key remainingPairs



-- ONE OF


oneOf :: [Decoder x a] -> Decoder x a
oneOf decoders =
  Decoder $ \ast ok err ->
    case decoders of
      Decoder decodeA : decoders ->
        let
          err' e =
            oneOfHelp ast ok err decoders e []
        in
        decodeA ast ok err'

      [] ->
        error "Ran into (Json.Decode.oneOf [])"


oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
oneOfHelp ast ok err decoders p ps =
  case decoders of
    Decoder decodeA : decoders ->
      let
        err' p' =
          oneOfHelp ast ok err decoders p' (p:ps)
      in
      decodeA ast ok err'

    [] ->
      err (oneOfError [] p ps)


oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
oneOfError problems prob ps =
  case ps of
    [] ->
      OneOf prob problems

    p:ps ->
      oneOfError (prob:problems) p ps



-- FAILURE


failure :: x -> Decoder x a
failure x =
  Decoder $ \(A.At region _) _ err ->
    err (Failure region x)



-- ERRORS


mapError :: (x -> y) -> Decoder x a -> Decoder y a
mapError func (Decoder decodeA) =
  Decoder $ \ast ok err ->
    let
      err' prob = err (mapErrorHelp func prob)
    in
    decodeA ast ok err'


mapErrorHelp :: (x -> y) -> Problem x -> Problem y
mapErrorHelp func problem =
  case problem of
    Field k p     -> Field k (mapErrorHelp func p)
    Index i p     -> Index i (mapErrorHelp func p)
    OneOf p ps    -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
    Failure r x   -> Failure r (func x)
    Expecting r e -> Expecting r e



-- AST


type AST =
  A.Located AST_


data AST_
  = Array [AST]
  | Object [(P.Snippet, AST)]
  | String P.Snippet
  | Int Int
  | TRUE
  | FALSE
  | NULL



-- PARSE


type Parser a =
  P.Parser ParseError a


data ParseError
  = Start Row Col
  | ObjectField Row Col
  | ObjectColon Row Col
  | ObjectEnd Row Col
  | ArrayEnd Row Col
  | StringProblem StringProblem Row Col
  | NoLeadingZeros Row Col
  | NoFloats Row Col
  | BadEnd Row Col

--  PIndex Int ParseError Row Col
--  PField Json.String ParseError Row Col


data StringProblem
  = BadStringEnd
  | BadStringControlChar
  | BadStringEscapeChar
  | BadStringEscapeHex



-- PARSE AST


pFile :: Parser AST
pFile =
  do  spaces
      value <- pValue
      spaces
      return value


pValue :: Parser AST
pValue =
  P.addLocation $
  P.oneOf Start
    [ String <$> pString Start
    , pObject
    , pArray
    , pInt
    , K.k4 0x74 0x72 0x75 0x65      Start >> return TRUE
    , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
    , K.k4 0x6E 0x75 0x6C 0x6C      Start >> return NULL
    ]



-- OBJECT


pObject :: Parser AST_
pObject =
  do  P.word1 0x7B {- { -} Start
      spaces
      P.oneOf ObjectField
        [ do  entry <- pField
              spaces
              pObjectHelp [entry]
        , do  P.word1 0x7D {-}-} ObjectEnd
              return (Object [])
        ]


pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
pObjectHelp revEntries =
  P.oneOf ObjectEnd
    [
      do  P.word1 0x2C {-,-} ObjectEnd
          spaces
          entry <- pField
          spaces
          pObjectHelp (entry:revEntries)
    ,
      do  P.word1 0x7D {-}-} ObjectEnd
          return (Object (reverse revEntries))
    ]


pField :: Parser (P.Snippet, AST)
pField =
  do  key <- pString ObjectField
      spaces
      P.word1 0x3A {-:-} ObjectColon
      spaces
      value <- pValue
      return (key, value)



-- ARRAY


pArray :: Parser AST_
pArray =
  do  P.word1 0x5B {-[-} Start
      spaces
      P.oneOf Start
        [ do  entry <- pValue
              spaces
              pArrayHelp 1 [entry]
        , do  P.word1 0x5D {-]-} ArrayEnd
              return (Array [])
        ]


pArrayHelp :: Int -> [AST] -> Parser AST_
pArrayHelp !len revEntries =
  P.oneOf ArrayEnd
    [
      do  P.word1 0x2C {-,-} ArrayEnd
          spaces
          entry <- pValue
          spaces
          pArrayHelp (len + 1) (entry:revEntries)
    ,
      do  P.word1 0x5D {-]-} ArrayEnd
          return (Array (reverse revEntries))
    ]



-- STRING


pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
pString start =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    if pos < end && P.unsafeIndex pos == 0x22 {-"-} then

      let
        !pos1 = plusPtr pos 1
        !col1 = col + 1

        (# status, newPos, newRow, newCol #) =
          pStringHelp pos1 end row col1
      in
      case status of
        GoodString ->
          let
            !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
            !len = minusPtr newPos pos1 - 1
            !snp = P.Snippet src off len row col1
            !newState = P.State src newPos end indent newRow newCol
          in
          cok snp newState

        BadString problem ->
          cerr newRow newCol (StringProblem problem)

    else
      eerr row col start


data StringStatus
  = GoodString
  | BadString StringProblem


pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
pStringHelp pos end row col =
  if pos >= end then
    (# BadString BadStringEnd, pos, row, col #)

  else
    case P.unsafeIndex pos of
      0x22 {-"-} ->
        (# GoodString, plusPtr pos 1, row, col + 1 #)

      0x0A {-\n-} ->
        (# BadString BadStringEnd, pos, row, col #)

      0x5C {-\-} ->
        let !pos1 = plusPtr pos 1 in
        if pos1 >= end then
          (# BadString BadStringEnd, pos1, row + 1, col #)
        else
          case P.unsafeIndex pos1 of
            0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
            0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
            0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
            0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
            0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
            0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
            0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
            0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
            0x75 {-u-} ->
              let !pos6 = plusPtr pos 6 in
              if pos6 <= end
                && isHex (P.unsafeIndex (plusPtr pos 2))
                && isHex (P.unsafeIndex (plusPtr pos 3))
                && isHex (P.unsafeIndex (plusPtr pos 4))
                && isHex (P.unsafeIndex (plusPtr pos 5))
              then
                pStringHelp pos6 end row (col + 6)
              else
                (# BadString BadStringEscapeHex, pos, row, col #)

            _ ->
              (# BadString BadStringEscapeChar, pos, row, col #)

      word ->
        if word < 0x20 then
          (# BadString BadStringControlChar, pos, row, col #)
        else
          let !newPos = plusPtr pos (P.getCharWidth word) in
          pStringHelp newPos end row (col + 1)


isHex :: Word8 -> Bool
isHex word =
     0x30 {-0-} <= word && word <= 0x39 {-9-}
  || 0x61 {-a-} <= word && word <= 0x66 {-f-}
  || 0x41 {-A-} <= word && word <= 0x46 {-F-}



-- SPACES


spaces :: Parser ()
spaces =
  P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
    let
      (# newPos, newRow, newCol #) =
        eatSpaces pos end row col
    in
    if pos == newPos then
      eok () state
    else
      let
        !newState =
          P.State src newPos end indent newRow newCol
      in
      cok () newState


eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
eatSpaces pos end row col =
  if pos >= end then
    (# pos, row, col #)

  else
    case P.unsafeIndex pos of
      0x20 {-  -} -> eatSpaces (plusPtr pos 1) end row (col + 1)
      0x09 {-\t-} -> eatSpaces (plusPtr pos 1) end row (col + 1)
      0x0A {-\n-} -> eatSpaces (plusPtr pos 1) end (row + 1) 1
      0x0D {-\r-} -> eatSpaces (plusPtr pos 1) end row col
      _ ->
        (# pos, row, col #)



-- INTS


pInt :: Parser AST_
pInt =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    if pos >= end then
      eerr row col Start

    else
      let !word = P.unsafeIndex pos in
      if not (isDecimalDigit word) then
        eerr row col Start

      else if word == 0x30 {-0-} then

        let
          !pos1 = plusPtr pos 1
          !newState = P.State src pos1 end indent row (col + 1)
        in
        if pos1 < end then
          let !word1 = P.unsafeIndex pos1 in
          if isDecimalDigit word1 then
            cerr row (col + 1) NoLeadingZeros
          else if word1 == 0x2E {-.-} then
            cerr row (col + 1) NoFloats
          else
            cok (Int 0) newState
        else
          cok (Int 0) newState

      else
        let
          (# status, n, newPos #) =
            chompInt (plusPtr pos 1) end (fromIntegral (word - 0x30 {-0-}))

          !len = fromIntegral (minusPtr newPos pos)
        in
        case status of
          GoodInt ->
            let
              !newState =
                P.State src newPos end indent row (col + len)
            in
            cok (Int n) newState

          BadIntEnd ->
            cerr row (col + len) NoFloats


data IntStatus = GoodInt | BadIntEnd


chompInt :: Ptr Word8 -> Ptr Word8 -> Int -> (# IntStatus, Int, Ptr Word8 #)
chompInt pos end n =
  if pos < end then
    let !word = P.unsafeIndex pos in
    if isDecimalDigit word then
      let !m = 10 * n + fromIntegral (word - 0x30 {-0-}) in
      chompInt (plusPtr pos 1) end m
    else if word == 0x2E {-.-} || word == 0x65 {-e-} || word == 0x45 {-E-} then
      (# BadIntEnd, n, pos #)
    else
      (# GoodInt, n, pos #)

  else
    (# GoodInt, n, pos #)


{-# INLINE isDecimalDigit #-}
isDecimalDigit :: Word8 -> Bool
isDecimalDigit word =
  word <= 0x39 {-9-} && word >= 0x30 {-0-}


================================================
FILE: compiler/src/Json/Encode.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Json.Encode
  ( write
  , encode
  , writeUgly
  , encodeUgly
  , Value(..)
  , array
  , object
  , string
  , name
  , chars
  , bool
  , int
  , number
  , null
  , dict
  , list
  , (==>)
  )
  where


import Prelude hiding (null)
import Control.Arrow ((***))
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Builder as B
import qualified Data.Map as Map
import qualified Data.Scientific as Sci
import qualified Data.Name as Name
import qualified Data.Utf8 as Utf8

import qualified File
import qualified Json.String as Json



-- VALUES


data Value
  = Array [Value]
  | Object [(Json.String, Value)]
  | String B.Builder
  | Boolean Bool
  | Integer Int
  | Number Sci.Scientific
  | Null


array :: [Value] -> Value
array =
  Array


object :: [(Json.String, Value)] -> Value
object =
  Object


string :: Json.String -> Value
string str =
  String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')


name :: Name.Name -> Value
name nm =
  String (B.char7 '"' <> Name.toBuilder nm <> B.char7 '"')


bool :: Bool -> Value
bool =
  Boolean


int :: Int -> Value
int =
  Integer


number :: Sci.Scientific -> Value
number =
  Number


null :: Value
null =
  Null


dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value
dict encodeKey encodeValue pairs =
  Object $ map (encodeKey *** encodeValue) (Map.toList pairs)


list :: (a -> Value) -> [a] -> Value
list encodeEntry entries =
  Array $ map encodeEntry entries



-- CHARS


chars :: [Char] -> Value -- PERF can this be done better? Look for examples.
chars chrs =
  String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')


escape :: [Char] -> [Char]
escape chrs =
  case chrs of
    [] ->
      []

    c:cs
      | c == '\r' -> '\\' : 'r'  : escape cs
      | c == '\n' -> '\\' : 'n'  : escape cs
      | c == '\"' -> '\\' : '"'  : escape cs
      | c == '\\' -> '\\' : '\\' : escape cs
      | otherwise -> c : escape cs



-- HELPERS


(==>) :: [Char] -> value -> (Json.String, value)
(==>) key value =
  (Json.fromChars key, value)



-- WRITE TO FILE


write :: FilePath -> Value -> IO ()
write path value =
  File.writeBuilder path (encode value <> "\n")


writeUgly :: FilePath -> Value -> IO ()
writeUgly path value =
  File.writeBuilder path (encodeUgly value)



-- ENCODE UGLY


encodeUgly :: Value -> B.Builder
encodeUgly value =
  case value of
    Array [] ->
      B.string7 "[]"

    Array (first : rest) ->
      let
        encodeEntry entry =
          B.char7 ',' <> encodeUgly entry
      in
        B.char7 '[' <> encodeUgly first <> mconcat (map encodeEntry rest) <> B.char7 ']'

    Object [] ->
      B.string7 "{}"

    Object (first : rest) ->
      let
        encodeEntry char (key, entry) =
          B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry
      in
        encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'

    String builder ->
      builder

    Boolean boolean ->
      B.string7 (if boolean then "true" else "false")

    Integer n ->
      B.intDec n

    Number scientific ->
      B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)

    Null ->
      "null"



-- ENCODE


encode :: Value -> B.Builder
encode value =
  encodeHelp "" value


encodeHelp :: BSC.ByteString -> Value -> B.Builder
encodeHelp indent value =
  case value of
    Array [] ->
      B.string7 "[]"

    Array (first : rest) ->
      encodeArray indent first rest

    Object [] ->
      B.string7 "{}"

    Object (first : rest) ->
      encodeObject indent first rest

    String builder ->
      builder

    Boolean boolean ->
      B.string7 (if boolean then "true" else "false")

    Integer n ->
      B.intDec n

    Number scientific ->
      B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)

    Null ->
      "null"



-- ENCODE ARRAY


encodeArray :: BSC.ByteString -> Value -> [Value] -> B.Builder
encodeArray =
  encodeSequence arrayOpen arrayClose encodeHelp


arrayOpen :: B.Builder
arrayOpen =
  B.string7 "[\n"


arrayClose :: B.Builder
arrayClose =
  B.char7 ']'



-- ENCODE OBJECT


encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder
encodeObject =
  encodeSequence objectOpen objectClose encodeField


objectOpen :: B.Builder
objectOpen =
  B.string7 "{\n"


objectClose :: B.Builder
objectClose =
  B.char7 '}'


encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder
encodeField indent (key, value) =
  B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value



-- ENCODE SEQUENCE


encodeSequence :: B.Builder -> B.Builder -> (BSC.ByteString -> a -> B.Builder) -> BSC.ByteString -> a -> [a] -> B.Builder
encodeSequence open close encodeEntry indent first rest =
  let
    newIndent =
      indent <> "    "

    newIndentBuilder =
      B.byteString newIndent

    closer =
      newline <> B.byteString indent <> close

    addValue field builder =
      commaNewline
      <> newIndentBuilder
      <> encodeEntry newIndent field
      <> builder
  in
    open
    <> newIndentBuilder
    <> encodeEntry newIndent first
    <> foldr addValue closer rest


commaNewline :: B.Builder
commaNewline =
  B.string7 ",\n"


newline :: B.Builder
newline =
  B.char7 '\n'


================================================
FILE: compiler/src/Json/String.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
{-# LANGUAGE BangPatterns, EmptyDataDecls #-}
module Json.String
  ( String
  , isEmpty
  --
  , fromPtr
  , fromName
  , fromChars
  , fromSnippet
  , fromComment
  --
  , toChars
  , toBuilder
  )
  where


import Prelude hiding (String)
import qualified Data.ByteString.Builder as B
import qualified Data.Coerce as Coerce
import qualified Data.Name as Name
import qualified Data.Utf8 as Utf8
import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
import Data.Word (Word8)
import Foreign.Ptr (Ptr, plusPtr, minusPtr)
import Foreign.ForeignPtr (withForeignPtr)
import GHC.Exts (RealWorld)
import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)
import GHC.ST (ST)

import qualified Parse.Primitives as P



-- JSON STRINGS


-- INVARIANT: any Json.String is appropriately escaped already
-- PERF: is this the right representation for Json.String? Maybe ByteString instead?
--
type String =
  Utf8.Utf8 JSON_STRING


data JSON_STRING


isEmpty :: String -> Bool
isEmpty =
  Utf8.isEmpty



-- FROM


fromPtr :: Ptr Word8 -> Ptr Word8 -> String
fromPtr =
  Utf8.fromPtr


fromChars :: [Char] -> String
fromChars =
  Utf8.fromChars


fromSnippet :: P.Snippet -> String
fromSnippet =
  Utf8.fromSnippet


fromName :: Name.Name -> String
fromName =
  Coerce.coerce



-- TO


toChars :: String -> [Char]
toChars =
  Utf8.toChars


{-# INLINE toBuilder #-}
toBuilder :: String -> B.Builder
toBuilder =
  Utf8.toBuilder



-- FROM COMMENT


fromComment :: P.Snippet -> String
fromComment (P.Snippet fptr off len _ _) =
  unsafePerformIO $ withForeignPtr fptr $ \ptr ->
    let
      !pos = plusPtr ptr off
      !end = plusPtr pos len
      !str = fromChunks (chompChunks pos end pos [])
    in
    return str


chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
chompChunks pos end start revChunks =
  if pos >= end then
    reverse (addSlice start end revChunks)
  else
    let
      !word = P.unsafeIndex pos
    in
    case word of
      0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
      0x22 {-"-}  -> chompEscape 0x22 {-"-} pos end start revChunks
      0x5C {-\-}  -> chompEscape 0x5C {-\-} pos end start revChunks
      0x0D {-\r-} ->
        let
          !newPos = plusPtr pos 1
        in
        chompChunks newPos end newPos (addSlice start pos revChunks)

      _ ->
        let
          !width = P.getCharWidth word
          !newPos = plusPtr pos width
        in
        chompChunks newPos end start revChunks


chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
chompEscape escape pos end start revChunks =
  let
    !pos1 = plusPtr pos 1
  in
  chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)


addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
addSlice start end revChunks =
  if start == end
    then revChunks
    else Slice start (minusPtr end start) : revChunks



-- FROM CHUNKS


data Chunk
  = Slice (Ptr Word8) Int
  | Escape Word8


fromChunks :: [Chunk] -> String
fromChunks chunks =
  unsafeDupablePerformIO (stToIO (
    do  let !len = sum (map chunkToWidth chunks)
        mba <- newByteArray len
        writeChunks mba 0 chunks
        freeze mba
  ))


chunkToWidth :: Chunk -> Int
chunkToWidth chunk =
  case chunk of
    Slice _ len -> len
    Escape _    -> 2


writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
writeChunks mba offset chunks =
  case chunks of
    [] ->
      return ()

    chunk : chunks ->
      case chunk of
        Slice ptr len ->
          do  copyFromPtr ptr mba offset len
              let !newOffset = offset + len
              writeChunks mba newOffset chunks

        Escape word ->
          do  writeWord8 mba offset 0x5C {- \ -}
              writeWord8 mba (offset + 1) word
              let !newOffset = offset + 2
              writeChunks mba newOffset chunks


================================================
FILE: compiler/src/Nitpick/Debug.hs
================================================
module Nitpick.Debug
  ( hasDebugUses
  )
  where


import qualified Data.Map.Utils as Map

import qualified AST.Optimized as Opt



-- HAS DEBUG USES


hasDebugUses :: Opt.LocalGraph -> Bool
hasDebugUses (Opt.LocalGraph _ graph _) =
  Map.any nodeHasDebug graph


nodeHasDebug :: Opt.Node -> Bool
nodeHasDebug node =
  case node of
    Opt.Define expr _           -> hasDebug expr
    Opt.DefineTailFunc _ expr _ -> hasDebug expr
    Opt.Ctor _ _                -> False
    Opt.Enum _                  -> False
    Opt.Box                     -> False
    Opt.Link _                  -> False
    Opt.Cycle _ vs fs _         -> any (hasDebug . snd) vs || any defHasDebug fs
    Opt.Manager _               -> False
    Opt.Kernel _ _              -> False
    Opt.PortIncoming expr _     -> hasDebug expr
    Opt.PortOutgoing expr _     -> hasDebug expr


hasDebug :: Opt.Expr -> Bool
hasDebug expression =
  case expression of
    Opt.Bool _           -> False
    Opt.Chr _            -> False
    Opt.Str _            -> False
    Opt.Int _            -> False
    Opt.Float _          -> False
    Opt.VarLocal _       -> False
    Opt.VarGlobal _      -> False
    Opt.VarEnum _ _      -> False
    Opt.VarBox _         -> False
    Opt.VarCycle _ _     -> False
    Opt.VarDebug _ _ _ _ -> True
    Opt.VarKernel _ _    -> False
    Opt.List exprs       -> any hasDebug exprs
    Opt.Function _ expr  -> hasDebug expr
    Opt.Call e es        -> hasDebug e || any hasDebug es
    Opt.TailCall _ args  -> any (hasDebug . snd) args
    Opt.If conds finally -> any (\(c,e) -> hasDebug c || hasDebug e) conds || hasDebug finally
    Opt.Let def body     -> defHasDebug def || hasDebug body
    Opt.Destruct _ expr  -> hasDebug expr
    Opt.Case _ _ d jumps -> deciderHasDebug d || any (hasDebug . snd) jumps
    Opt.Accessor _       -> False
    Opt.Access r _       -> hasDebug r
    Opt.Update r fs      -> hasDebug r || any hasDebug fs
    Opt.Record fs        -> any hasDebug fs
    Opt.Unit             -> False
    Opt.Tuple a b c      -> hasDebug a || hasDebug b || maybe False hasDebug c
    Opt.Shader _ _ _     -> False


defHasDebug :: Opt.Def -> Bool
defHasDebug def =
  case def of
    Opt.Def _ expr       -> hasDebug expr
    Opt.TailDef _ _ expr -> hasDebug expr


deciderHasDebug :: Opt.Decider Opt.Choice -> Bool
deciderHasDebug decider =
  case decider of
    Opt.Leaf (Opt.Inline expr)  -> hasDebug expr
    Opt.Leaf (Opt.Jump _)       -> False
    Opt.Chain _ success failure -> deciderHasDebug success || deciderHasDebug failure
    Opt.FanOut _ tests fallback -> any (deciderHasDebug . snd) tests || deciderHasDebug fallback



-- TODO: FIND GLOBALLY UNUSED DEFINITIONS?
-- TODO: FIND PACKAGE USAGE STATS? (e.g. elm/core = 142, author/project = 2, etc.)


================================================
FILE: compiler/src/Nitpick/PatternMatches.hs
================================================
{-# OPTIONS_GHC -fno-warn-x-partial #-}
{-# LANGUAGE OverloadedStrings #-}
module Nitpick.PatternMatches
  ( check
  , Error(..)
  , Context(..)
  , Pattern(..)
  , Literal(..)
  )
  where


{- The algorithm used here comes from "Warnings for Pattern Matching"
by Luc Maranget. Check it out for more information!

http://moscova.inria.fr/~maranget/papers/warn/warn.pdf

-}

import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Name as Name
import qualified Data.NonEmptyList as NE

import qualified AST.Canonical as Can
import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Elm.String as ES
import qualified Reporting.Annotation as A



-- PATTERN


data Pattern
  = Anything
  | Literal Literal
  | Ctor Can.Union Name.Name [Pattern]


data Literal
  = Chr ES.String
  | Str ES.String
  | Int Int
  deriving (Eq)



-- CREATE SIMPLIFIED PATTERNS


simplify :: Can.Pattern -> Pattern
simplify (A.At _ pattern) =
  case pattern of
    Can.PAnything ->
      Anything

    Can.PVar _ ->
      Anything

    Can.PRecord _ ->
      Anything

    Can.PUnit ->
      Ctor unit unitName []

    Can.PTuple a b Nothing ->
      Ctor pair pairName [ simplify a, simplify b ]

    Can.PTuple a b (Just c) ->
      Ctor triple tripleName [ simplify a, simplify b, simplify c ]

    Can.PCtor _ _ union name _ args ->
      Ctor union name $
        map (\(Can.PatternCtorArg _ _ arg) -> simplify arg) args

    Can.PList entries ->
      foldr cons nil entries

    Can.PCons hd tl ->
      cons hd (simplify tl)

    Can.PAlias subPattern _ ->
      simplify subPattern

    Can.PInt int ->
      Literal (Int int)

    Can.PStr str ->
      Literal (Str str)

    Can.PChr chr ->
      Literal (Chr chr)

    Can.PBool union bool ->
      Ctor union (if bool then Name.true else Name.false) []


cons :: Can.Pattern -> Pattern -> Pattern
cons hd tl =
  Ctor list consName [ simplify hd, tl ]


{-# NOINLINE nil #-}
nil :: Pattern
nil =
  Ctor list nilName []



-- BUILT-IN UNIONS


{-# NOINLINE unit #-}
unit :: Can.Union
unit =
  let
    ctor =
      Can.Ctor unitName Index.first 0 []
  in
  Can.Union [] [ ctor ] 1 Can.Normal


{-# NOINLINE pair #-}
pair :: Can.Union
pair =
  let
    ctor =
      Can.Ctor pairName Index.first 2 [Can.TVar "a", Can.TVar "b"]
  in
  Can.Union ["a","b"] [ ctor ] 1 Can.Normal


{-# NOINLINE triple #-}
triple :: Can.Union
triple =
  let
    ctor =
      Can.Ctor tripleName Index.first 3 [Can.TVar "a", Can.TVar "b", Can.TVar "c"]
  in
  Can.Union ["a","b","c"] [ ctor ] 1 Can.Normal


{-# NOINLINE list #-}
list :: Can.Union
list =
  let
    nilCtor =
      Can.Ctor nilName Index.first 0 []

    consCtor =
      Can.Ctor consName Index.second 2
        [ Can.TVar "a"
        , Can.TType ModuleName.list Name.list [Can.TVar "a"]
        ]
  in
  Can.Union ["a"] [ nilCtor, consCtor ] 2 Can.Normal


{-# NOINLINE unitName #-}
unitName :: Name.Name
unitName = "#0"


{-# NOINLINE pairName #-}
pairName :: Name.Name
pairName = "#2"


{-# NOINLINE tripleName #-}
tripleName :: Name.Name
tripleName = "#3"


{-# NOINLINE consName #-}
consName :: Name.Name
consName = "::"


{-# NOINLINE nilName #-}
nilName :: Name.Name
nilName = "[]"



-- ERROR


data Error
  = Incomplete A.Region Context [Pattern]
  | Redundant A.Region A.Region Int


data Context
  = BadArg
  | BadDestruct
  | BadCase



-- CHECK


check :: Can.Module -> Either (NE.List Error) ()
check (Can.Module _ _ _ decls _ _ _ _) =
  case checkDecls decls [] of
    [] ->
      Right ()

    e:es ->
      Left (NE.List e es)



-- CHECK DECLS


checkDecls :: Can.Decls -> [Error] -> [Error]
checkDecls decls errors =
  case decls of
    Can.Declare def subDecls ->
      checkDef def $ checkDecls subDecls errors

    Can.DeclareRec def defs subDecls ->
      checkDef def (foldr checkDef (checkDecls subDecls errors) defs)

    Can.SaveTheEnvironment ->
      errors



-- CHECK DEFS


checkDef :: Can.Def -> [Error] -> [Error]
checkDef def errors =
  case def of
    Can.Def _ args body ->
      foldr checkArg (checkExpr body errors) args

    Can.TypedDef _ _ args body _ ->
      foldr checkTypedArg (checkExpr body errors) args


checkArg :: Can.Pattern -> [Error] -> [Error]
checkArg pattern@(A.At region _) errors =
  checkPatterns region BadArg [pattern] errors


checkTypedArg :: (Can.Pattern, tipe) -> [Error] -> [Error]
checkTypedArg (pattern@(A.At region _), _) errors =
  checkPatterns region BadArg [pattern] errors



-- CHECK EXPRESSIONS


checkExpr :: Can.Expr -> [Error] -> [Error]
checkExpr (A.At region expression) errors =
  case expression of
    Can.VarLocal _ ->
      errors

    Can.VarTopLevel _ _ ->
      errors

    Can.VarKernel _ _ ->
      errors

    Can.VarForeign _ _ _ ->
      errors

    Can.VarCtor _ _ _ _ _ ->
      errors

    Can.VarDebug _ _ _ ->
      errors

    Can.VarOperator _ _ _ _ ->
      errors

    Can.Chr _ ->
      errors

    Can.Str _ ->
      errors

    Can.Int _ ->
      errors

    Can.Float _ ->
      errors

    Can.List entries ->
      foldr checkExpr errors entries

    Can.Negate expr ->
      checkExpr expr errors

    Can.Binop _ _ _ _ left right ->
      checkExpr left $
        checkExpr right errors

    Can.Lambda args body ->
      foldr checkArg (checkExpr body errors) args

    Can.Call func args ->
      checkExpr func $ foldr checkExpr errors args

    Can.If branches finally ->
      foldr checkIfBranch (checkExpr finally errors) branches

    Can.Let def body ->
      checkDef def $ checkExpr body errors

    Can.LetRec defs body ->
      foldr checkDef (checkExpr body errors) defs

    Can.LetDestruct pattern@(A.At reg _) expr body ->
      checkPatterns reg BadDestruct [pattern] $
        checkExpr expr $ checkExpr body errors

    Can.Case expr branches ->
      checkExpr expr $ checkCases region branches errors

    Can.Accessor _ ->
      errors

    Can.Access record _ ->
      checkExpr record errors

    Can.Update _ record fields ->
      checkExpr record $ Map.foldr checkField errors fields

    Can.Record fields ->
      Map.foldr checkExpr errors fields

    Can.Unit ->
      errors

    Can.Tuple a b maybeC ->
      checkExpr a $
        checkExpr b $
          case maybeC of
            Nothing ->
              errors

            Just c ->
              checkExpr c errors

    Can.Shader _ _ ->
      errors



-- CHECK FIELD


checkField :: Can.FieldUpdate -> [Error] -> [Error]
checkField (Can.FieldUpdate _ expr) errors =
  checkExpr expr errors



-- CHECK IF BRANCH


checkIfBranch :: (Can.Expr, Can.Expr) -> [Error] -> [Error]
checkIfBranch (condition, branch) errs =
  checkExpr condition $ checkExpr branch errs



-- CHECK CASE EXPRESSION


checkCases :: A.Region -> [Can.CaseBranch] -> [Error] -> [Error]
checkCases region branches errors =
  let
    (patterns, newErrors) =
      foldr checkCaseBranch ([], errors) branches
  in
  checkPatterns region BadCase patterns newErrors


checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])
checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) =
  ( pattern:patterns
  , checkExpr expr errors
  )



-- CHECK PATTERNS


checkPatterns :: A.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]
checkPatterns region context patterns errors =
  case toNonRedundantRows region patterns of
    Left err ->
      err:errors

    Right matrix ->
      case isExhaustive matrix 1 of
        [] ->
          errors

        badPatterns ->
          Incomplete region context (map head badPatterns) : errors



-- EXHAUSTIVE PATTERNS


-- INVARIANTS:
--
--   The initial rows "matrix" are all of length 1
--   The initial count of items per row "n" is also 1
--   The resulting rows are examples of missing patterns
--
isExhaustive :: [[Pattern]] -> Int -> [[Pattern]]
isExhaustive matrix n =
  case matrix of
    [] ->
      [replicate n Anything]

    _ ->
      if n == 0 then
        []
      else
      let
        ctors = collectCtors matrix
        numSeen = Map.size ctors
      in
      if numSeen == 0 then
        (:) Anything
          <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)

      else
        let alts@(Can.Union _ altList numAlts _) = snd (Map.findMin ctors) in
        if numSeen < numAlts then
          (:)
            <$> Maybe.mapMaybe (isMissing alts ctors) altList
            <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1)

        else
          let
            isAltExhaustive (Can.Ctor name _ arity _) =
              recoverCtor alts name arity <$>
              isExhaustive
                (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
                (arity + n - 1)
          in
          concatMap isAltExhaustive altList


isMissing :: Can.Union -> Map.Map Name.Name a -> Can.Ctor -> Maybe Pattern
isMissing union ctors (Can.Ctor name _ arity _) =
  if Map.member name ctors then
    Nothing
  else
    Just (Ctor union name (replicate arity Anything))


recoverCtor :: Can.Union -> Name.Name -> Int -> [Pattern] -> [Pattern]
recoverCtor union name arity patterns =
  let
    (args, rest) =
      splitAt arity patterns
  in
  Ctor union name args : rest



-- REDUNDANT PATTERNS


-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
toNonRedundantRows :: A.Region -> [Can.Pattern] -> Either Error [[Pattern]]
toNonRedundantRows region patterns =
  toSimplifiedUsefulRows region [] patterns


-- INVARIANT: Produces a list of rows where (forall row. length row == 1)
toSimplifiedUsefulRows :: A.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]
toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =
  case uncheckedPatterns of
    [] ->
      Right checkedRows

    pattern@(A.At region _) : rest ->
      let nextRow = [simplify pattern] in
      if isUseful checkedRows nextRow then
        toSimplifiedUsefulRows overallRegion (nextRow : checkedRows) rest
      else
        Left (Redundant overallRegion region (length checkedRows + 1))


-- Check if a new row "vector" is useful given previous rows "matrix"
isUseful :: [[Pattern]] -> [Pattern] -> Bool
isUseful matrix vector =
  case matrix of
    [] ->
      -- No rows are the same as the new vector! The vector is useful!
      True

    _ ->
      case vector of
        [] ->
          -- There is nothing left in the new vector, but we still have
          -- rows that match the same things. This is not a useful vector!
          False

        firstPattern : patterns ->
          case firstPattern of
            Ctor _ name args ->
              -- keep checking rows that start with this Ctor or Anything
              isUseful
                (Maybe.mapMaybe (specializeRowByCtor name (length args)) matrix)
                (args ++ patterns)

            Anything ->
              -- check if all alts appear in matrix
              case isComplete matrix of
                No ->
                  -- This Anything is useful because some Ctors are missing.
                  -- But what if a previous row has an Anything?
                  -- If so, this one is not useful.
                  isUseful (Maybe.mapMaybe specializeRowByAnything matrix) patterns

                Yes alts ->
                  -- All Ctors are covered, so this Anything is not needed for any
                  -- of those. But what if some of those Ctors have subpatterns
                  -- that make them less general? If so, this actually is useful!
                  let
                    isUsefulAlt (Can.Ctor name _ arity _) =
                      isUseful
                        (Maybe.mapMaybe (specializeRowByCtor name arity) matrix)
                        (replicate arity Anything ++ patterns)
                  in
                    any isUsefulAlt alts

            Literal literal ->
              -- keep checking rows that start with this Literal or Anything
              isUseful
                (Maybe.mapMaybe (specializeRowByLiteral literal) matrix)
                patterns


-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)
specializeRowByCtor :: Name.Name -> Int -> [Pattern] -> Maybe [Pattern]
specializeRowByCtor ctorName arity row =
  case row of
    Ctor _ name args : patterns ->
      if name == ctorName then
        Just (args ++ patterns)
      else
        Nothing

    Anything : patterns ->
      Just (replicate arity Anything ++ patterns)

    Literal _ : _ ->
      error $
        "Compiler bug! After type checking, constructors and literals\
        \ should never align in pattern match exhaustiveness checks."

    [] ->
      error "Compiler error! Empty matrices should not get specialized."


-- INVARIANT: (length row == N) ==> (length result == N-1)
specializeRowByLiteral :: Literal -> [Pattern] -> Maybe [Pattern]
specializeRowByLiteral literal row =
  case row of
    Literal lit : patterns ->
      if lit == literal then
        Just patterns
      else
        Nothing

    Anything : patterns ->
      Just patterns

    Ctor _ _ _ : _ ->
      error $
        "Compiler bug! After type checking, constructors and literals\
        \ should never align in pattern match exhaustiveness checks."

    [] ->
      error "Compiler error! Empty matrices should not get specialized."


-- INVARIANT: (length row == N) ==> (length result == N-1)
specializeRowByAnything :: [Pattern] -> Maybe [Pattern]
specializeRowByAnything row =
  case row of
    [] ->
      Nothing

    Ctor _ _ _ : _ ->
      Nothing

    Anything : patterns ->
      Just patterns

    Literal _ : _ ->
      Nothing



-- ALL CONSTRUCTORS ARE PRESENT?


data Complete
  = Yes [Can.Ctor]
  | No


isComplete :: [[Pattern]] -> Complete
isComplete matrix =
  let
    ctors = collectCtors matrix
    numSeen = Map.size ctors
  in
    if numSeen == 0 then
      No
    else
      let (Can.Union _ alts numAlts _) = snd (Map.findMin ctors) in
      if numSeen == numAlts then Yes alts else No



-- COLLECT CTORS


collectCtors :: [[Pattern]] -> Map.Map Name.Name Can.Union
collectCtors matrix =
  List.foldl' collectCtorsHelp Map.empty matrix


collectCtorsHelp :: Map.Map Name.Name Can.Union -> [Pattern] -> Map.Map Name.Name Can.Union
collectCtorsHelp ctors row =
  case row of
    Ctor union name _ : _ ->
      Map.insert name union ctors

    _ ->
      ctors


================================================
FILE: compiler/src/Optimize/Case.hs
================================================
module Optimize.Case
  ( optimize
  )
  where


import Control.Arrow (second)
import qualified Data.Map as Map
import Data.Map ((!))
import qualified Data.Maybe as Maybe
import qualified Data.Name as Name

import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified Optimize.DecisionTree as DT



-- OPTIMIZE A CASE EXPRESSION


optimize :: Name.Name -> Name.Name -> [(Can.Pattern, Opt.Expr)] -> Opt.Expr
optimize temp root optBranches =
  let
    (patterns, indexedBranches) =
      unzip (zipWith indexify [0..] optBranches)

    decider = treeToDecider (DT.compile patterns)
    targetCounts = countTargets decider

    (choices, maybeJumps) =
        unzip (map (createChoices targetCounts) indexedBranches)
  in
  Opt.Case temp root
    (insertChoices (Map.fromList choices) decider)
    (Maybe.catMaybes maybeJumps)


indexify :: Int -> (a,b) -> ((a,Int), (Int,b))
indexify index (pattern, branch) =
    ( (pattern, index)
    , (index, branch)
    )



-- TREE TO DECIDER
--
-- Decision trees may have some redundancies, so we convert them to a Decider
-- which has special constructs to avoid code duplication when possible.


treeToDecider :: DT.DecisionTree -> Opt.Decider Int
treeToDecider tree =
  case tree of
    DT.Match target ->
        Opt.Leaf target

    -- zero options
    DT.Decision _ [] Nothing ->
        error "compiler bug, somehow created an empty decision tree"

    -- one option
    DT.Decision _ [(_, subTree)] Nothing ->
        treeToDecider subTree

    DT.Decision _ [] (Just subTree) ->
        treeToDecider subTree

    -- two options
    DT.Decision path [(test, successTree)] (Just failureTree) ->
        toChain path test successTree failureTree

    DT.Decision path [(test, successTree), (_, failureTree)] Nothing ->
        toChain path test successTree failureTree

    -- many options
    DT.Decision path edges Nothing ->
        let
          (necessaryTests, fallback) =
              (init edges, snd (last edges))
        in
          Opt.FanOut
            path
            (map (second treeToDecider) necessaryTests)
            (treeToDecider fallback)

    DT.Decision path edges (Just fallback) ->
        Opt.FanOut path (map (second treeToDecider) edges) (treeToDecider fallback)


toChain :: DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int
toChain path test successTree failureTree =
  let
    failure =
      treeToDecider failureTree
  in
    case treeToDecider successTree of
      Opt.Chain testChain success subFailure | failure == subFailure ->
          Opt.Chain ((path, test) : testChain) success failure

      success ->
          Opt.Chain [(path, test)] success failure



-- INSERT CHOICES
--
-- If a target appears exactly once in a Decider, the corresponding expression
-- can be inlined. Whether things are inlined or jumps is called a "choice".


countTargets :: Opt.Decider Int -> Map.Map Int Int
countTargets decisionTree =
  case decisionTree of
    Opt.Leaf target ->
        Map.singleton target 1

    Opt.Chain _ success failure ->
        Map.unionWith (+) (countTargets success) (countTargets failure)

    Opt.FanOut _ tests fallback ->
        Map.unionsWith (+) (map countTargets (fallback : map snd tests))


createChoices
    :: Map.Map Int Int
    -> (Int, Opt.Expr)
    -> ( (Int, Opt.Choice), Maybe (Int, Opt.Expr) )
createChoices targetCounts (target, branch) =
    if targetCounts ! target == 1 then
        ( (target, Opt.Inline branch)
        , Nothing
        )

    else
        ( (target, Opt.Jump target)
        , Just (target, branch)
        )


insertChoices
    :: Map.Map Int Opt.Choice
    -> Opt.Decider Int
    -> Opt.Decider Opt.Choice
insertChoices choiceDict decider =
  let
    go =
      insertChoices choiceDict
  in
    case decider of
      Opt.Leaf target ->
          Opt.Leaf (choiceDict ! target)

      Opt.Chain testChain success failure ->
          Opt.Chain testChain (go success) (go failure)

      Opt.FanOut path tests fallback ->
          Opt.FanOut path (map (second go) tests) (go fallback)



================================================
FILE: compiler/src/Optimize/DecisionTree.hs
================================================
{-# OPTIONS_GHC -fno-warn-x-partial #-}
{-# LANGUAGE OverloadedStrings #-}
module Optimize.DecisionTree
  ( DecisionTree(..)
  , compile
  , Path(..)
  , Test(..)
  )
  where


{- To learn more about how this works, definitely read through:

    "When Do Match-Compilation Heuristics Matter?"

by Kevin Scott and Norman Ramsey. The rough idea is that we start with a simple
list of patterns and expressions, and then turn that into a "decision tree"
that requires as few tests as possible to make it to a leaf. Read the paper, it
explains this extraordinarily well! We are currently using the same heuristics
as SML/NJ to get nice trees.
-}

import Control.Arrow (second)
import Control.Monad (liftM, liftM2, liftM5)
import Data.Binary
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Name as Name
import qualified Data.Set as Set

import qualified AST.Canonical as Can
import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Elm.String as ES
import qualified Reporting.Annotation as A



-- COMPILE CASES


{-| Users of this module will mainly interact with this function. It takes
some normal branches and gives out a decision tree that has "labels" at all
the leafs and a dictionary that maps these "labels" to the code that should
run.

If 2 or more leaves point to the same label, we need to do some tricks in JS to
make that work nicely. When is JS getting goto?! ;) That is outside the scope
of this module though.
-}
compile :: [(Can.Pattern, Int)] -> DecisionTree
compile rawBranches =
  let
    format (pattern, index) =
        Branch index [(Empty, pattern)]
  in
    toDecisionTree (map format rawBranches)



-- DECISION TREES


data DecisionTree
  = Match Int
  | Decision
      { _path :: Path
      , _edges :: [(Test, DecisionTree)]
      , _default :: Maybe DecisionTree
      }
  deriving (Eq)


data Test
  = IsCtor ModuleName.Canonical Name.Name Index.ZeroBased Int Can.CtorOpts
  | IsCons
  | IsNil
  | IsTuple
  | IsInt Int
  | IsChr ES.String
  | IsStr ES.String
  | IsBool Bool
  deriving (Eq, Ord)


data Path
  = Index Index.ZeroBased Path
  | Unbox Path
  | Empty
  deriving (Eq)



-- ACTUALLY BUILD DECISION TREES


data Branch =
  Branch
    { _goal :: Int
    , _patterns :: [(Path, Can.Pattern)]
    }


toDecisionTree :: [Branch] -> DecisionTree
toDecisionTree rawBranches =
  let
    branches =
        map flattenPatterns rawBranches
  in
  case checkForMatch branches of
    Just goal ->
        Match goal

    Nothing ->
        let
          path =
              pickPath branches

          (edges, fallback) =
              gatherEdges branches path

          decisionEdges =
              map (second toDecisionTree) edges
        in
          case (decisionEdges, fallback) of
            ([(_tag, decisionTree)], []) ->
                decisionTree

            (_, []) ->
                Decision path decisionEdges Nothing

            ([], _ : _) ->
                toDecisionTree fallback

            (_, _) ->
                Decision path decisionEdges (Just (toDecisionTree fallback))


isComplete :: [Test] -> Bool
isComplete tests =
  case head tests of
    IsCtor _ _ _ numAlts _ ->
      numAlts == length tests

    IsCons ->
      length tests == 2

    IsNil ->
      length tests == 2

    IsTuple ->
      True

    IsChr _ ->
      False

    IsStr _ ->
      False

    IsInt _ ->
      False

    IsBool _ ->
      length tests == 2



-- FLATTEN PATTERNS


{-| Flatten type aliases and use the VariantDict to figure out when a tag is
the only variant so we can skip doing any tests on it.
-}
flattenPatterns :: Branch -> Branch
flattenPatterns (Branch goal pathPatterns) =
  Branch goal (foldr flatten [] pathPatterns)


flatten :: (Path, Can.Pattern) -> [(Path, Can.Pattern)] -> [(Path, Can.Pattern)]
flatten pathPattern@(path, A.At region pattern) otherPathPatterns =
  case pattern of
    Can.PVar _ ->
      pathPattern : otherPathPatterns

    Can.PAnything ->
      pathPattern : otherPathPatterns

    Can.PCtor _ _ (Can.Union _ _ numAlts _) _ _ ctorArgs ->
      if numAlts == 1 then
        case map dearg ctorArgs of
          [arg] ->
            flatten (Unbox path, arg) otherPathPatterns

          args ->
            foldr flatten otherPathPatterns (subPositions path args)
      else
        pathPattern : otherPathPatterns

    Can.PTuple a b maybeC ->
      flatten (Index Index.first path, a) $
      flatten (Index Index.second path, b) $
        case maybeC of
          Nothing ->
            otherPathPatterns

          Just c ->
            flatten (Index Index.third path, c) otherPathPatterns

    Can.PUnit ->
      otherPathPatterns

    Can.PAlias realPattern alias ->
      flatten (path, realPattern) $
        (path, A.At region (Can.PVar alias)) : otherPathPatterns

    Can.PRecord _ ->
      pathPattern : otherPathPatterns

    Can.PList _ ->
      pathPattern : otherPathPatterns

    Can.PCons _ _ ->
      pathPattern : otherPathPatterns

    Can.PChr _ ->
      pathPattern : otherPathPatterns

    Can.PStr _ ->
      pathPattern : otherPathPatterns

    Can.PInt _ ->
      pathPattern : otherPathPatterns

    Can.PBool _ _ ->
      pathPattern : otherPathPatterns


subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]
subPositions path patterns =
  Index.indexedMap (\index pattern -> (Index index path, pattern)) patterns


dearg :: Can.PatternCtorArg -> Can.Pattern
dearg (Can.PatternCtorArg _ _ pattern) =
  pattern



-- SUCCESSFULLY MATCH


{-| If the first branch has no more "decision points" we can finally take that
path. If that is the case we give the resulting label and a mapping from free
variables to "how to get their value". So a pattern like (Just (x,_)) will give
us something like ("x" => value.0.0)
-}
checkForMatch :: [Branch] -> Maybe Int
checkForMatch branches =
  case branches of
    Branch goal patterns : _ | all (not . needsTests . snd) patterns ->
        Just goal

    _ ->
        Nothing



-- GATHER OUTGOING EDGES


gatherEdges :: [Branch] -> Path -> ([(Test, [Branch])], [Branch])
gatherEdges branches path =
  let
    relevantTests =
        testsAtPath path branches

    allEdges =
        map (edgesFor path branches) relevantTests

    fallbacks =
        if isComplete relevantTests then
          []
        else
          filter (isIrrelevantTo path) branches
  in
    ( allEdges, fallbacks )



-- FIND RELEVANT TESTS


testsAtPath :: Path -> [Branch] -> [Test]
testsAtPath selectedPath branches =
  let
    allTests =
      Maybe.mapMaybe (testAtPath selectedPath) branches

    skipVisited test curr@(uniqueTests, visitedTests) =
        if Set.member test visitedTests then
            curr
        else
            ( test : uniqueTests
            , Set.insert test visitedTests
            )
  in
  fst (foldr skipVisited ([], Set.empty) allTests)


testAtPath :: Path -> Branch -> Maybe Test
testAtPath selectedPath (Branch _ pathPatterns) =
  case List.lookup selectedPath pathPatterns of
    Nothing ->
      Nothing

    Just (A.At _ pattern) ->
      case pattern of
        Can.PCtor home _ (Can.Union _ _ numAlts opts) name index _ ->
            Just (IsCtor home name index numAlts opts)

        Can.PList ps ->
            Just (case ps of { [] -> IsNil ; _ -> IsCons })

        Can.PCons _ _ ->
            Just IsCons

        Can.PTuple _ _ _ ->
            Just IsTuple

        Can.PUnit ->
            Just IsTuple

        Can.PVar _ ->
            Nothing

        Can.PAnything ->
            Nothing

        Can.PInt int ->
            Just (IsInt int)

        Can.PStr str ->
            Just (IsStr str)

        Can.PChr chr ->
            Just (IsChr chr)

        Can.PBool _ bool ->
            Just (IsBool bool)

        Can.PRecord _ ->
            Nothing

        Can.PAlias _ _ ->
            error "aliases should never reach 'testAtPath' function"



-- BUILD EDGES


edgesFor :: Path -> [Branch] -> Test -> (Test, [Branch])
edgesFor path branches test =
  ( test
  , Maybe.mapMaybe (toRelevantBranch test path) branches
  )


toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch
toRelevantBranch test path branch@(Branch goal pathPatterns) =
  case extract path pathPatterns of
    Found start (A.At region pattern) end ->
        case pattern of
          Can.PCtor _ _ (Can.Union _ _ numAlts _) name _ ctorArgs ->
              case test of
                IsCtor _ testName _ _ _ | name == testName ->
                  Just $ Branch goal $
                    case map dearg ctorArgs of
                      [arg] | numAlts == 1 ->
                        start ++ [(Unbox path, arg)] ++ end

                      args ->
                        start ++ subPositions path args ++ end

                _ ->
                  Nothing

          Can.PList [] ->
              case test of
                IsNil ->
                  Just (Branch goal (start ++ end))

                _ ->
                  Nothing

          Can.PList (hd:tl) ->
              case test of
                IsCons ->
                  let tl' = A.At region (Can.PList tl) in
                  Just (Branch goal (start ++ subPositions path [ hd, tl' ] ++ end))

                _ ->
                  Nothing

          Can.PCons hd tl ->
              case test of
                IsCons ->
                  Just (Branch goal (start ++ subPositions path [hd,tl] ++ end))

                _ ->
                  Nothing

          Can.PChr chr ->
              case test of
                IsChr testChr | chr == testChr ->
                  Just (Branch goal (start ++ end))
                _ ->
                  Nothing

          Can.PStr str ->
              case test of
                IsStr testStr | str == testStr ->
                  Just (Branch goal (start ++ end))

                _ ->
                  Nothing

          Can.PInt int ->
              case test of
                IsInt testInt | int == testInt ->
                  Just (Branch goal (start ++ end))

                _ ->
                  Nothing

          Can.PBool _ bool ->
              case test of
                IsBool testBool | bool == testBool ->
                  Just (Branch goal (start ++ end))

                _ ->
                  Nothing

          Can.PUnit ->
              Just (Branch goal (start ++ end))

          Can.PTuple a b maybeC ->
              Just (Branch goal (start ++ subPositions path (a : b : Maybe.maybeToList maybeC) ++ end))

          Can.PVar _ ->
              Just branch

          Can.PAnything ->
              Just branch

          Can.PRecord _ ->
              Just branch

          Can.PAlias _ _ ->
              Just branch

    NotFound ->
        Just branch


data Extract
  = NotFound
  | Found [(Path, Can.Pattern)] Can.Pattern [(Path, Can.Pattern)]


extract :: Path -> [(Path, Can.Pattern)] -> Extract
extract selectedPath pathPatterns =
  case pathPatterns of
    [] ->
        NotFound

    first@(path, pattern) : rest ->
        if path == selectedPath then
            Found [] pattern rest

        else
            case extract selectedPath rest of
              NotFound ->
                  NotFound

              Found start foundPattern end ->
                  Found (first : start) foundPattern end



-- FIND IRRELEVANT BRANCHES


isIrrelevantTo :: Path -> Branch -> Bool
isIrrelevantTo selectedPath (Branch _ pathPatterns) =
  case List.lookup selectedPath pathPatterns of
    Nothing ->
        True

    Just pattern ->
        not (needsTests pattern)


needsTests :: Can.Pattern -> Bool
needsTests (A.At _ pattern) =
  case pattern of
    Can.PVar _            -> False
    Can.PAnything         -> False
    Can.PRecord _         -> False
    Can.PCtor _ _ _ _ _ _ -> True
    Can.PList _           -> True
    Can.PCons _ _         -> True
    Can.PUnit             -> True
    Can.PTuple _ _ _      -> True
    Can.PChr _            -> True
    Can.PStr _            -> True
    Can.PInt _            -> True
    Can.PBool _ _         -> True
    Can.PAlias _ _ ->
        error "aliases should never reach 'isIrrelevantTo' function"




-- PICK A PATH


pickPath :: [Branch] -> Path
pickPath branches =
  let
    allPaths =
      Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
  in
    case bests (addWeights (smallDefaults branches) allPaths) of
      [path] ->
          path

      tiedPaths ->
          head (bests (addWeights (smallBranchingFactor branches) tiedPaths))


isChoicePath :: (Path, Can.Pattern) -> Maybe Path
isChoicePath (path, pattern) =
  if needsTests pattern then
      Just path
  else
      Nothing


addWeights :: (Path -> Int) -> [Path] -> [(Path, Int)]
addWeights toWeight paths =
  map (\path -> (path, toWeight path)) paths


bests :: [(Path, Int)] -> [Path]
bests allPaths =
  case allPaths of
    [] ->
      error "Cannot choose the best of zero paths. This should never happen."

    (headPath, headWeight) : weightedPaths ->
      let
        gatherMinimum acc@(minWeight, paths) (path, weight) =
          if weight == minWeight then
            (minWeight, path : paths)

          else if weight < minWeight then
            (weight, [path])

          else
            acc
      in
        snd (List.foldl' gatherMinimum (headWeight, [headPath]) weightedPaths)



-- PATH PICKING HEURISTICS


smallDefaults :: [Branch] -> Path -> Int
smallDefaults branches path =
  length (filter (isIrrelevantTo path) branches)


smallBranchingFactor :: [Branch] -> Path -> Int
smallBranchingFactor branches path =
  let
    (edges, fallback) =
      gatherEdges branches path
  in
    length edges + (if null fallback then 0 else 1)



-- BINARY


instance Binary Test where
  put test =
    case test of
      IsCtor a b c d e -> putWord8 0 >> put a >> put b >> put c >> put d >> put e
      IsCons           -> putWord8 1
      IsNil            -> putWord8 2
      IsTuple          -> putWord8 3
      IsChr a          -> putWord8 4 >> put a
      IsStr a          -> putWord8 5 >> put a
      IsInt a          -> putWord8 6 >> put a
      IsBool a         -> putWord8 7 >> put a

  get =
    do  word <- getWord8
        case word of
          0 -> liftM5 IsCtor get get get get get
          1 -> pure   IsCons
          2 -> pure   IsNil
          3 -> pure   IsTuple
          4 -> liftM  IsChr get
          5 -> liftM  IsStr get
          6 -> liftM  IsInt get
          7 -> liftM  IsBool get
          _ -> fail "problem getting DecisionTree.Test binary"


instance Binary Path where
  put path =
    case path of
      Index a b -> putWord8 0 >> put a >> put b
      Unbox a   -> putWord8 1 >> put a
      Empty     -> putWord8 2

  get =
    do  word <- getWord8
        case word of
          0 -> liftM2 Index get get
          1 -> liftM Unbox get
          2 -> pure Empty
          _ -> fail "problem getting DecisionTree.Path binary"


================================================
FILE: compiler/src/Optimize/Expression.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Optimize.Expression
  ( optimize
  , destructArgs
  , optimizePotentialTailCall
  )
  where


import Prelude hiding (cycle)
import Control.Monad (foldM)
import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.Set as Set

import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified AST.Utils.Shader as Shader
import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Optimize.Case as Case
import qualified Optimize.Names as Names
import qualified Reporting.Annotation as A



-- OPTIMIZE


type Cycle =
  Set.Set Name.Name


optimize :: Cycle -> Can.Expr -> Names.Tracker Opt.Expr
optimize cycle (A.At region expression) =
  case expression of
    Can.VarLocal name ->
      pure (Opt.VarLocal name)

    Can.VarTopLevel home name ->
      if Set.member name cycle then
        pure (Opt.VarCycle home name)
      else
        Names.registerGlobal home name

    Can.VarKernel home name ->
      Names.registerKernel home (Opt.VarKernel home name)

    Can.VarForeign home name _ ->
      Names.registerGlobal home name

    Can.VarCtor opts home name index _ ->
      Names.registerCtor home name index opts

    Can.VarDebug home name _ ->
      Names.registerDebug name home region

    Can.VarOperator _ home name _ ->
      Names.registerGlobal home name

    Can.Chr chr ->
      Names.registerKernel Name.utils (Opt.Chr chr)

    Can.Str str ->
      pure (Opt.Str str)

    Can.Int int ->
      pure (Opt.Int int)

    Can.Float float ->
      pure (Opt.Float float)

    Can.List entries ->
      Names.registerKernel Name.list Opt.List
        <*> traverse (optimize cycle) entries

    Can.Negate expr ->
      do  func <- Names.registerGlobal ModuleName.basics Name.negate
          arg <- optimize cycle expr
          pure $ Opt.Call func [arg]

    Can.Binop _ home name _ left right ->
      do  optFunc <- Names.registerGlobal home name
          optLeft <- optimize cycle left
          optRight <- optimize cycle right
          return (Opt.Call optFunc [optLeft, optRight])

    Can.Lambda args body ->
      do  (argNames, destructors) <- destructArgs args
          obody <- optimize cycle body
          pure $ Opt.Function argNames (foldr Opt.Destruct obody destructors)

    Can.Call func args ->
      Opt.Call
        <$> optimize cycle func
        <*> traverse (optimize cycle) args

    Can.If branches finally ->
      let
        optimizeBranch (condition, branch) =
          (,)
            <$> optimize cycle condition
            <*> optimize cycle branch
      in
      Opt.If
        <$> traverse optimizeBranch branches
        <*> optimize cycle finally

    Can.Let def body ->
      optimizeDef cycle def =<< optimize cycle body

    Can.LetRec defs body ->
      case defs of
        [def] ->
          Opt.Let
            <$> optimizePotentialTailCallDef cycle def
            <*> optimize cycle body

        _ ->
          do  obody <- optimize cycle body
              foldM (\bod def -> optimizeDef cycle def bod) obody defs

    Can.LetDestruct pattern expr body ->
      do  (name, destructs) <- destruct pattern
          oexpr <- optimize cycle expr
          obody <- optimize cycle body
          pure $
            Opt.Let (Opt.Def name oexpr) (foldr Opt.Destruct obody destructs)

    Can.Case expr branches ->
      let
        optimizeBranch root (Can.CaseBranch pattern branch) =
          do  destructors <- destructCase root pattern
              obranch <- optimize cycle branch
              pure (pattern, foldr Opt.Destruct obranch destructors)
      in
      do  temp <- Names.generate
          oexpr <- optimize cycle expr
          case oexpr of
            Opt.VarLocal root ->
              Case.optimize temp root <$> traverse (optimizeBranch root) branches

            _ ->
              do  obranches <- traverse (optimizeBranch temp) branches
                  return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches)

    Can.Accessor field ->
      Names.registerField field (Opt.Accessor field)

    Can.Access record (A.At _ field) ->
      do  optRecord <- optimize cycle record
          Names.registerField field (Opt.Access optRecord field)

    Can.Update _ record updates ->
      Names.registerFieldDict updates Opt.Update
        <*> optimize cycle record
        <*> traverse (optimizeUpdate cycle) updates

    Can.Record fields ->
      Names.registerFieldDict fields Opt.Record
        <*> traverse (optimize cycle) fields

    Can.Unit ->
      Names.registerKernel Name.utils Opt.Unit

    Can.Tuple a b maybeC ->
      Names.registerKernel Name.utils Opt.Tuple
        <*> optimize cycle a
        <*> optimize cycle b
        <*> traverse (optimize cycle) maybeC

    Can.Shader src (Shader.Types attributes uniforms _varyings) ->
      pure (Opt.Shader src (Map.keysSet attributes) (Map.keysSet uniforms))



-- UPDATE


optimizeUpdate :: Cycle -> Can.FieldUpdate -> Names.Tracker Opt.Expr
optimizeUpdate cycle (Can.FieldUpdate _ expr) =
  optimize cycle expr



-- DEFINITION


optimizeDef :: Cycle -> Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr
optimizeDef cycle def body =
  case def of
    Can.Def (A.At _ name) args expr ->
      optimizeDefHelp cycle name args expr body

    Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
      optimizeDefHelp cycle name (map fst typedArgs) expr body


optimizeDefHelp :: Cycle -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr
optimizeDefHelp cycle name args expr body =
  do  oexpr <- optimize cycle expr
      case args of
        [] ->
          pure $ Opt.Let (Opt.Def name oexpr) body

        _ ->
          do  (argNames, destructors) <- destructArgs args
              let ofunc = Opt.Function argNames (foldr Opt.Destruct oexpr destructors)
              pure $ Opt.Let (Opt.Def name ofunc) body



-- DESTRUCTURING


destructArgs :: [Can.Pattern] -> Names.Tracker ([Name.Name], [Opt.Destructor])
destructArgs args =
  do  (argNames, destructorLists) <- unzip <$> traverse destruct args
      return (argNames, concat destructorLists)


destructCase :: Name.Name -> Can.Pattern -> Names.Tracker [Opt.Destructor]
destructCase rootName pattern =
  reverse <$> destructHelp (Opt.Root rootName) pattern []


destruct :: Can.Pattern -> Names.Tracker (Name.Name, [Opt.Destructor])
destruct pattern@(A.At _ ptrn) =
  case ptrn of
    Can.PVar name ->
      pure (name, [])

    Can.PAlias subPattern name ->
      do  revDs <- destructHelp (Opt.Root name) subPattern []
          pure (name, reverse revDs)

    _ ->
      do  name <- Names.generate
          revDs <- destructHelp (Opt.Root name) pattern []
          pure (name, reverse revDs)


destructHelp :: Opt.Path -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor]
destructHelp path (A.At region pattern) revDs =
  case pattern of
    Can.PAnything ->
      pure revDs

    Can.PVar name ->
      pure (Opt.Destructor name path : revDs)

    Can.PRecord fields ->
      let
        toDestruct name =
          Opt.Destructor name (Opt.Field name path)
      in
      Names.registerFieldList fields (map toDestruct fields ++ revDs)

    Can.PAlias subPattern name ->
      destructHelp (Opt.Root name) subPattern $
        Opt.Destructor name path : revDs

    Can.PUnit ->
      pure revDs

    Can.PTuple a b Nothing ->
      destructTwo path a b revDs

    Can.PTuple a b (Just c) ->
      case path of
        Opt.Root _ ->
          destructHelp (Opt.Index Index.third path) c =<<
            destructHelp (Opt.Index Index.second path) b =<<
              destructHelp (Opt.Index Index.first path) a revDs

        _ ->
          do  name <- Names.generate
              let newRoot = Opt.Root name
              destructHelp (Opt.Index Index.third newRoot) c =<<
                destructHelp (Opt.Index Index.second newRoot) b =<<
                  destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path : revDs)

    Can.PList [] ->
      pure revDs

    Can.PList (hd:tl) ->
      destructTwo path hd (A.At region (Can.PList tl)) revDs

    Can.PCons hd tl ->
      destructTwo path hd tl revDs

    Can.PChr _ ->
      pure revDs

    Can.PStr _ ->
      pure revDs

    Can.PInt _ ->
      pure revDs

    Can.PBool _ _ ->
      pure revDs

    Can.PCtor _ _ (Can.Union _ _ _ opts) _ _ args ->
      case args of
        [Can.PatternCtorArg _ _ arg] ->
          case opts of
            Can.Normal -> destructHelp (Opt.Index Index.first path) arg revDs
            Can.Unbox  -> destructHelp (Opt.Unbox path) arg revDs
            Can.Enum   -> destructHelp (Opt.Index Index.first path) arg revDs

        _ ->
          case path of
            Opt.Root _ ->
              foldM (destructCtorArg path) revDs args

            _ ->
              do  name <- Names.generate
                  foldM (destructCtorArg (Opt.Root name)) (Opt.Destructor name path : revDs) args


destructTwo :: Opt.Path -> Can.Pattern -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor]
destructTwo path a b revDs =
  case path of
    Opt.Root _ ->
      destructHelp (Opt.Index Index.second path) b =<<
        destructHelp (Opt.Index Index.first path) a revDs

    _ ->
      do  name <- Names.generate
          let newRoot = Opt.Root name
          destructHelp (Opt.Index Index.second newRoot) b =<<
            destructHelp (Opt.Index Index.first newRoot) a (Opt.Destructor name path : revDs)


destructCtorArg :: Opt.Path -> [Opt.Destructor] -> Can.PatternCtorArg -> Names.Tracker [Opt.Destructor]
destructCtorArg path revDs (Can.PatternCtorArg index _ arg) =
  destructHelp (Opt.Index index path) arg revDs



-- TAIL CALL


optimizePotentialTailCallDef :: Cycle -> Can.Def -> Names.Tracker Opt.Def
optimizePotentialTailCallDef cycle def =
  case def of
    Can.Def (A.At _ name) args expr ->
      optimizePotentialTailCall cycle name args expr

    Can.TypedDef (A.At _ name) _ typedArgs expr _ ->
      optimizePotentialTailCall cycle name (map fst typedArgs) expr


optimizePotentialTailCall :: Cycle -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker Opt.Def
optimizePotentialTailCall cycle name args expr =
  do  (argNames, destructors) <- destructArgs args
      toTailDef name argNames destructors <$>
        optimizeTail cycle name argNames expr


optimizeTail :: Cycle -> Name.Name -> [Name.Name] -> Can.Expr -> Names.Tracker Opt.Expr
optimizeTail cycle rootName argNames locExpr@(A.At _ expression) =
  case expression of
    Can.Call func args ->
      do  oargs <- traverse (optimize cycle) args

          let isMatchingName =
                case A.toValue func of
                  Can.VarLocal      name -> rootName == name
                  Can.VarTopLevel _ name -> rootName == name
                  _                      -> False

          if isMatchingName
            then
              case Index.indexedZipWith (\_ a b -> (a,b)) argNames oargs of
                Index.LengthMatch pairs ->
                  pure $ Opt.TailCall rootName pairs

                Index.LengthMismatch _ _ ->
                  do  ofunc <- optimize cycle func
                      pure $ Opt.Call ofunc oargs
            else
              do  ofunc <- optimize cycle func
                  pure $ Opt.Call ofunc oargs

    Can.If branches finally ->
      let
        optimizeBranch (condition, branch) =
          (,)
            <$> optimize cycle condition
            <*> optimizeTail cycle rootName argNames branch
      in
      Opt.If
        <$> traverse optimizeBranch branches
        <*> optimizeTail cycle rootName argNames finally

    Can.Let def body ->
      optimizeDef cycle def =<< optimizeTail cycle rootName argNames body

    Can.LetRec defs body ->
      case defs of
        [def] ->
          Opt.Let
            <$> optimizePotentialTailCallDef cycle def
            <*> optimizeTail cycle rootName argNames body

        _ ->
          do  obody <- optimizeTail cycle rootName argNames body
              foldM (\bod def -> optimizeDef cycle def bod) obody defs

    Can.LetDestruct pattern expr body ->
      do  (dname, destructors) <- destruct pattern
          oexpr <- optimize cycle expr
          obody <- optimizeTail cycle rootName argNames body
          pure $
            Opt.Let (Opt.Def dname oexpr) (foldr Opt.Destruct obody destructors)

    Can.Case expr branches ->
      let
        optimizeBranch root (Can.CaseBranch pattern branch) =
          do  destructors <- destructCase root pattern
              obranch <- optimizeTail cycle rootName argNames branch
              pure (pattern, foldr Opt.Destruct obranch destructors)
      in
      do  temp <- Names.generate
          oexpr <- optimize cycle expr
          case oexpr of
            Opt.VarLocal root ->
              Case.optimize temp root <$> traverse (optimizeBranch root) branches

            _ ->
              do  obranches <- traverse (optimizeBranch temp) branches
                  return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches)

    _ ->
      optimize cycle locExpr



-- DETECT TAIL CALLS


toTailDef :: Name.Name -> [Name.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def
toTailDef name argNames destructors body =
  if hasTailCall body then
    Opt.TailDef name argNames (foldr Opt.Destruct body destructors)
  else
    Opt.Def name (Opt.Function argNames (foldr Opt.Destruct body destructors))


hasTailCall :: Opt.Expr -> Bool
hasTailCall expression =
  case expression of
    Opt.TailCall _ _ ->
      True

    Opt.If branches finally ->
      hasTailCall finally || any (hasTailCall . snd) branches

    Opt.Let _ body ->
      hasTailCall body

    Opt.Destruct _ body ->
      hasTailCall body

    Opt.Case _ _ decider jumps ->
      decidecHasTailCall decider || any (hasTailCall . snd) jumps

    _ ->
      False


decidecHasTailCall :: Opt.Decider Opt.Choice -> Bool
decidecHasTailCall decider =
  case decider of
    Opt.Leaf choice ->
      case choice of
        Opt.Inline expr ->
          hasTailCall expr

        Opt.Jump _ ->
          False

    Opt.Chain _ success failure ->
      decidecHasTailCall success || decidecHasTailCall failure

    Opt.FanOut _ tests fallback ->
      decidecHasTailCall fallback || any (decidecHasTailCall . snd) tests


================================================
FILE: compiler/src/Optimize/Module.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Optimize.Module
  ( optimize
  )
  where


import Prelude hiding (cycle)
import Control.Monad (foldM)
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 Data.Map ((!))

import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified AST.Utils.Type as Type
import qualified Canonicalize.Effects as Effects
import qualified Elm.ModuleName as ModuleName
import qualified Optimize.Expression as Expr
import qualified Optimize.Names as Names
import qualified Optimize.Port as Port
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Main as E
import qualified Reporting.Result as Result
import qualified Reporting.Warning as W



-- OPTIMIZE


type Result i w a =
  Result.Result i w E.Error a


type Annotations =
  Map.Map Name.Name Can.Annotation


optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph
optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =
  addDecls home annotations decls $
    addEffects home effects $
      addUnions home unions $
        addAliases home aliases $
          Opt.LocalGraph Nothing Map.empty Map.empty



-- UNION


type Nodes =
  Map.Map Opt.Global Opt.Node


addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph
addUnions home unions (Opt.LocalGraph main nodes fields) =
  Opt.LocalGraph main (Map.foldr (addUnion home) nodes unions) fields


addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
addUnion home (Can.Union _ ctors _ opts) nodes =
  List.foldl' (addCtorNode home opts) nodes ctors


addCtorNode :: ModuleName.Canonical -> Can.CtorOpts -> Nodes -> Can.Ctor -> Nodes
addCtorNode home opts nodes (Can.Ctor name index numArgs _) =
  let
    node =
      case opts of
        Can.Normal -> Opt.Ctor index numArgs
        Can.Unbox -> Opt.Box
        Can.Enum -> Opt.Enum index
  in
  Map.insert (Opt.Global home name) node nodes



-- ALIAS


addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph
addAliases home aliases graph =
  Map.foldrWithKey (addAlias home) graph aliases


addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph
addAlias home name (Can.Alias _ tipe) graph@(Opt.LocalGraph main nodes fieldCounts) =
  case tipe of
    Can.TRecord fields Nothing ->
      let
        function =
          Opt.Function (map fst (Can.fieldsToList fields)) $ Opt.Record $
            Map.mapWithKey (\field _ -> Opt.VarLocal field) fields

        node =
          Opt.Define function Set.empty
      in
      Opt.LocalGraph
        main
        (Map.insert (Opt.Global home name) node nodes)
        (Map.foldrWithKey addRecordCtorField fieldCounts fields)

    _ ->
      graph


addRecordCtorField :: Name.Name -> Can.FieldType -> Map.Map Name.Name Int -> Map.Map Name.Name Int
addRecordCtorField name _ fields =
  Map.insertWith (+) name 1 fields



-- ADD EFFECTS


addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.LocalGraph -> Opt.LocalGraph
addEffects home effects graph@(Opt.LocalGraph main nodes fields) =
  case effects of
    Can.NoEffects ->
      graph

    Can.Ports ports ->
      Map.foldrWithKey (addPort home) graph ports

    Can.Manager _ _ _ manager ->
      let
        fx = Opt.Global home "$fx$"
        cmd = Opt.Global home "command"
        sub = Opt.Global home "subscription"
        link = Opt.Link fx
        newNodes =
          case manager of
            Can.Cmd _ ->
              Map.insert cmd link $
              Map.insert fx (Opt.Manager Opt.Cmd) nodes

            Can.Sub _ ->
              Map.insert sub link $
              Map.insert fx (Opt.Manager Opt.Sub) nodes

            Can.Fx _ _ ->
              Map.insert cmd link $
              Map.insert sub link $
              Map.insert fx (Opt.Manager Opt.Fx) nodes
      in
      Opt.LocalGraph main newNodes fields


addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.LocalGraph -> Opt.LocalGraph
addPort home name port_ graph =
  case port_ of
    Can.Incoming _ payloadType _ ->
      let
        (deps, fields, decoder) = Names.run (Port.toDecoder payloadType)
        node = Opt.PortIncoming decoder deps
      in
      addToGraph (Opt.Global home name) node fields graph

    Can.Outgoing _ payloadType _ ->
      let
        (deps, fields, encoder) = Names.run (Port.toEncoder payloadType)
        node = Opt.PortOutgoing encoder deps
      in
      addToGraph (Opt.Global home name) node fields graph



-- HELPER


addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph
addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =
  Opt.LocalGraph
    main
    (Map.insert name node nodes)
    (Map.unionWith (+) fields fieldCounts)



-- ADD DECLS


addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
addDecls home annotations decls graph =
  case decls of
    Can.Declare def subDecls ->
      addDecls home annotations subDecls =<< addDef home annotations def graph

    Can.DeclareRec d ds subDecls ->
      let defs = d:ds in
      case findMain defs of
        Nothing ->
          addDecls home annotations subDecls (addRecDefs home defs graph)

        Just region ->
          Result.throw $ E.BadCycle region (defToName d) (map defToName ds)

    Can.SaveTheEnvironment ->
      Result.ok graph


findMain :: [Can.Def] -> Maybe A.Region
findMain defs =
  case defs of
    [] ->
      Nothing

    def:rest ->
      case def of
        Can.Def (A.At region name) _ _ ->
          if name == Name._main then Just region else findMain rest

        Can.TypedDef (A.At region name) _ _ _ _ ->
          if name == Name._main then Just region else findMain rest


defToName :: Can.Def -> Name.Name
defToName def =
  case def of
    Can.Def (A.At _ name) _ _          -> name
    Can.TypedDef (A.At _ name) _ _ _ _ -> name



-- ADD DEFS


addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
addDef home annotations def graph =
  case def of
    Can.Def (A.At region name) args body ->
      do  let (Can.Forall _ tipe) = annotations ! name
          Result.warn $ W.MissingTypeAnnotation region name tipe
          addDefHelp region annotations home name args body graph

    Can.TypedDef (A.At region name) _ typedArgs body _ ->
      addDefHelp region annotations home name (map fst typedArgs) body graph


addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
  if name /= Name._main then
    Result.ok (addDefNode home name args body Set.empty graph)
  else
    let
      (Can.Forall _ tipe) = annotations ! name

      addMain (deps, fields, main) =
        addDefNode home name args body deps $
          Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts)
    in
    case Type.deepDealias tipe of
      Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->
          Result.ok $ addMain $ Names.run $
            Names.registerKernel Name.virtualDom Opt.Static

      Can.TType hm nm [flags, _, message] | hm == ModuleName.platform && nm == Name.program ->
          case Effects.checkPayload flags of
            Right () ->
              Result.ok $ addMain $ Names.run $
                Opt.Dynamic message <$> Port.toFlagsDecoder flags

            Left (subType, invalidPayload) ->
              Result.throw (E.BadFlags region subType invalidPayload)

      _ ->
          Result.throw (E.BadType region tipe)


addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph
addDefNode home name args body mainDeps graph =
  let
    (deps, fields, def) =
      Names.run $
        case args of
          [] ->
            Expr.optimize Set.empty body

          _ ->
            do  (argNames, destructors) <- Expr.destructArgs args
                obody <- Expr.optimize Set.empty body
                pure $ Opt.Function argNames $
                  foldr Opt.Destruct obody destructors
  in
  addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph



-- ADD RECURSIVE DEFS


data State =
  State
    { _values :: [(Name.Name, Opt.Expr)]
    , _functions :: [Opt.Def]
    }


addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.LocalGraph -> Opt.LocalGraph
addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) =
  let
    names = reverse (map toName defs)
    cycleName = Opt.Global home (Name.fromManyNames names)
    cycle = foldr addValueName Set.empty defs
    links = foldr (addLink home (Opt.Link cycleName)) Map.empty defs

    (deps, fields, State values funcs) =
      Names.run $
        foldM (addRecDef cycle) (State [] []) defs
  in
  Opt.LocalGraph
    main
    (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
    (Map.unionWith (+) fields fieldCounts)


toName :: Can.Def -> Name.Name
toName def =
  case def of
    Can.Def      (A.At _ name) _ _     -> name
    Can.TypedDef (A.At _ name) _ _ _ _ -> name


addValueName :: Can.Def -> Set.Set Name.Name -> Set.Set Name.Name
addValueName def names =
  case def of
    Can.Def      (A.At _ name)   args _   -> if null args then Set.insert name names else names
    Can.TypedDef (A.At _ name) _ args _ _ -> if null args then Set.insert name names else names


addLink :: ModuleName.Canonical -> Opt.Node -> Can.Def -> Map.Map Opt.Global Opt.Node -> Map.Map Opt.Global Opt.Node
addLink home link def links =
  case def of
    Can.Def (A.At _ name) _ _ ->
      Map.insert (Opt.Global home name) link links

    Can.TypedDef (A.At _ name) _ _ _ _ ->
      Map.insert (Opt.Global home name) link links



-- ADD RECURSIVE DEFS


addRecDef :: Set.Set Name.Name -> State -> Can.Def -> Names.Tracker State
addRecDef cycle state def =
  case def of
    Can.Def (A.At _ name) args body ->
      addRecDefHelp cycle state name args body

    Can.TypedDef (A.At _ name) _ args body _ ->
      addRecDefHelp cycle state name (map fst args) body


addRecDefHelp :: Set.Set Name.Name -> State -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker State
addRecDefHelp cycle (State values funcs) name args body =
  case args of
    [] ->
      do  obody <- Expr.optimize cycle body
          pure $ State ((name, obody) : values) funcs

    _:_ ->
      do  odef <- Expr.optimizePotentialTailCall cycle name args body
          pure $ State values (odef : funcs)


================================================
FILE: compiler/src/Optimize/Names.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module Optimize.Names
  ( Tracker
  , run
  , generate
  , registerKernel
  , registerGlobal
  , registerDebug
  , registerCtor
  , registerField
  , registerFieldDict
  , registerFieldList
  )
  where


import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.Set as Set

import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Reporting.Annotation as A



-- GENERATOR


newtype Tracker a =
  Tracker (
    forall r.
      Int
      -> Set.Set Opt.Global
      -> Map.Map Name.Name Int
      -> (Int -> Set.Set Opt.Global -> Map.Map Name.Name Int -> a -> r)
      -> r
  )


run :: Tracker a -> (Set.Set Opt.Global, Map.Map Name.Name Int, a)
run (Tracker k) =
  k 0 Set.empty Map.empty
    (\_uid deps fields value -> (deps, fields, value))


generate :: Tracker Name.Name
generate =
  Tracker $ \uid deps fields ok ->
    ok (uid + 1) deps fields (Name.fromVarIndex uid)


registerKernel :: Name.Name -> a -> Tracker a
registerKernel home value =
  Tracker $ \uid deps fields ok ->
    ok uid (Set.insert (Opt.toKernelGlobal home) deps) fields value


registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr
registerGlobal home name =
  Tracker $ \uid deps fields ok ->
    let global = Opt.Global home name in
    ok uid (Set.insert global deps) fields (Opt.VarGlobal global)


registerDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Tracker Opt.Expr
registerDebug name home region =
  Tracker $ \uid deps fields ok ->
    let global = Opt.Global ModuleName.debug name in
    ok uid (Set.insert global deps) fields (Opt.VarDebug name home region Nothing)


registerCtor :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr
registerCtor home name index opts =
  Tracker $ \uid deps fields ok ->
    let
      global = Opt.Global home name
      newDeps = Set.insert global deps
    in
    case opts of
      Can.Normal ->
        ok uid newDeps fields (Opt.VarGlobal global)

      Can.Enum ->
        ok uid newDeps fields $
          case name of
            "True"  | home == ModuleName.basics -> Opt.Bool True
            "False" | home == ModuleName.basics -> Opt.Bool False
            _ -> Opt.VarEnum global index

      Can.Unbox ->
        ok uid (Set.insert identity newDeps) fields (Opt.VarBox global)


identity :: Opt.Global
identity =
  Opt.Global ModuleName.basics Name.identity


registerField :: Name.Name -> a -> Tracker a
registerField name value =
  Tracker $ \uid d fields ok ->
    ok uid d (Map.insertWith (+) name 1 fields) value


registerFieldDict :: Map.Map Name.Name v -> a -> Tracker a
registerFieldDict newFields value =
  Tracker $ \uid d fields ok ->
    ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value


toOne :: a -> Int
toOne _ = 1


registerFieldList :: [Name.Name] -> a -> Tracker a
registerFieldList names value =
  Tracker $ \uid deps fields ok ->
    ok uid deps (foldr addOne fields names) value


addOne :: Name.Name -> Map.Map Name.Name Int -> Map.Map Name.Name Int
addOne name fields =
  Map.insertWith (+) name 1 fields



-- INSTANCES


instance Functor Tracker where
  fmap func (Tracker kv) =
    Tracker $ \n d f ok ->
      let
        ok1 n1 d1 f1 value =
          ok n1 d1 f1 (func value)
      in
      kv n d f ok1


instance Applicative Tracker where
  {-# INLINE pure #-}
  pure value =
    Tracker $ \n d f ok -> ok n d f value

  (<*>) (Tracker kf) (Tracker kv) =
    Tracker $ \n d f ok ->
      let
        ok1 n1 d1 f1 func =
          let
            ok2 n2 d2 f2 value =
              ok n2 d2 f2 (func value)
          in
          kv n1 d1 f1 ok2
      in
      kf n d f ok1


instance Monad Tracker where
  return = pure

  (>>=) (Tracker k) callback =
    Tracker $ \n d f ok ->
      let
        ok1 n1 d1 f1 a =
          case callback a of
            Tracker kb -> kb n1 d1 f1 ok
      in
      k n d f ok1


================================================
FILE: compiler/src/Optimize/Port.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Optimize.Port
  ( toEncoder
  , toFlagsDecoder
  , toDecoder
  )
  where


import Prelude hiding (maybe, null)
import Control.Monad (foldM)
import qualified Data.Map as Map
import qualified Data.Name as Name

import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified AST.Utils.Type as Type
import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Optimize.Names as Names



-- ENCODE


toEncoder :: Can.Type -> Names.Tracker Opt.Expr
toEncoder tipe =
  case tipe of
    Can.TAlias _ _ args alias ->
      toEncoder (Type.dealias args alias)

    Can.TLambda _ _ ->
      error "toEncoder: function"

    Can.TVar _ ->
      error "toEncoder: type variable"

    Can.TUnit ->
      Opt.Function [Name.dollar] <$> encode "null"

    Can.TTuple a b c ->
      encodeTuple a b c

    Can.TType _ name args ->
      case args of
        []
          | name == Name.float  -> encode "float"
          | name == Name.int    -> encode "int"
          | name == Name.bool   -> encode "bool"
          | name == Name.string -> encode "string"
          | name == Name.value  -> Names.registerGlobal ModuleName.basics Name.identity

        [arg]
          | name == Name.maybe -> encodeMaybe arg
          | name == Name.list  -> encodeList arg
          | name == Name.array -> encodeArray arg

        _ ->
          error "toEncoder: bad custom type"

    Can.TRecord _ (Just _) ->
      error "toEncoder: bad record"

    Can.TRecord fields Nothing ->
      let
        encodeField (name, Can.FieldType _ fieldType) =
          do  encoder <- toEncoder fieldType
              let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
              return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing
      in
      do  object <- encode "object"
          keyValuePairs <- traverse encodeField (Map.toList fields)
          Names.registerFieldDict fields $
            Opt.Function [Name.dollar] (Opt.Call object [Opt.List keyValuePairs])



-- ENCODE HELPERS


encodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
encodeMaybe tipe =
  do  null <- encode "null"
      encoder <- toEncoder tipe
      destruct <- Names.registerGlobal ModuleName.maybe "destruct"
      return $ Opt.Function [Name.dollar] $
        Opt.Call destruct [ null, encoder, Opt.VarLocal Name.dollar ]


encodeList :: Can.Type -> Names.Tracker Opt.Expr
encodeList tipe =
  do  list <- encode "list"
      encoder <- toEncoder tipe
      return $ Opt.Call list [ encoder ]


encodeArray :: Can.Type -> Names.Tracker Opt.Expr
encodeArray tipe =
  do  array <- encode "array"
      encoder <- toEncoder tipe
      return $ Opt.Call array [ encoder ]


encodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
encodeTuple a b maybeC =
  let
    let_ arg index body =
      Opt.Destruct (Opt.Destructor arg (Opt.Index index (Opt.Root Name.dollar))) body

    encodeArg arg tipe =
      do  encoder <- toEncoder tipe
          return $ Opt.Call encoder [ Opt.VarLocal arg ]
  in
  do  list <- encode "list"
      identity <- Names.registerGlobal ModuleName.basics Name.identity
      arg1 <- encodeArg "a" a
      arg2 <- encodeArg "b" b

      case maybeC of
        Nothing ->
          return $ Opt.Function [Name.dollar] $
            let_ "a" Index.first $
            let_ "b" Index.second $
              Opt.Call list [ identity, Opt.List [ arg1, arg2 ] ]

        Just c ->
          do  arg3 <- encodeArg "c" c
              return $ Opt.Function [Name.dollar] $
                let_ "a" Index.first $
                let_ "b" Index.second $
                let_ "c" Index.third $
                  Opt.Call list [ identity, Opt.List [ arg1, arg2, arg3 ] ]



-- FLAGS DECODER


toFlagsDecoder :: Can.Type -> Names.Tracker Opt.Expr
toFlagsDecoder tipe =
  case tipe of
    Can.TUnit ->
      do  succeed <- decode "succeed"
          return $ Opt.Call succeed [ Opt.Unit ]

    _ ->
      toDecoder tipe



-- DECODE


toDecoder :: Can.Type -> Names.Tracker Opt.Expr
toDecoder tipe =
  case tipe of
    Can.TLambda _ _ ->
      error "functions should not be allowed through input ports"

    Can.TVar _ ->
      error "type variables should not be allowed through input ports"

    Can.TAlias _ _ args alias ->
      toDecoder (Type.dealias args alias)

    Can.TUnit ->
      decodeTuple0

    Can.TTuple a b c ->
      decodeTuple a b c

    Can.TType _ name args ->
      case args of
        []
          | name == Name.float  -> decode "float"
          | name == Name.int    -> decode "int"
          | name == Name.bool   -> decode "bool"
          | name == Name.string -> decode "string"
          | name == Name.value  -> decode "value"

        [arg]
          | name == Name.maybe -> decodeMaybe arg
          | name == Name.list  -> decodeList arg
          | name == Name.array -> decodeArray arg

        _ ->
          error "toDecoder: bad type"

    Can.TRecord _ (Just _) ->
      error "toDecoder: bad record"

    Can.TRecord fields Nothing ->
      decodeRecord fields



-- DECODE MAYBE


decodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
decodeMaybe tipe =
  do  nothing <- Names.registerGlobal ModuleName.maybe "Nothing"
      just    <- Names.registerGlobal ModuleName.maybe "Just"

      oneOf <- decode "oneOf"
      null  <- decode "null"
      map_  <- decode "map"

      subDecoder <- toDecoder tipe

      return $
        Opt.Call oneOf
          [ Opt.List
              [ Opt.Call null [ nothing ]
              , Opt.Call map_ [ just, subDecoder ]
              ]
          ]


-- DECODE LIST


decodeList :: Can.Type -> Names.Tracker Opt.Expr
decodeList tipe =
  do  list <- decode "list"
      decoder <- toDecoder tipe
      return $ Opt.Call list [ decoder ]



-- DECODE ARRAY


decodeArray :: Can.Type -> Names.Tracker Opt.Expr
decodeArray tipe =
  do  array <- decode "array"
      decoder <- toDecoder tipe
      return $ Opt.Call array [ decoder ]



-- DECODE TUPLES


decodeTuple0 :: Names.Tracker Opt.Expr
decodeTuple0 =
  do  null <- decode "null"
      return (Opt.Call null [ Opt.Unit ])


decodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
decodeTuple a b maybeC =
  do  succeed <- decode "succeed"
      case maybeC of
        Nothing ->
          let tuple = Opt.Tuple (toLocal 0) (toLocal 1) Nothing in
          indexAndThen 0 a =<<
            indexAndThen 1 b (Opt.Call succeed [tuple])

        Just c ->
          let tuple = Opt.Tuple (toLocal 0) (toLocal 1) (Just (toLocal 2)) in
          indexAndThen 0 a =<<
            indexAndThen 1 b =<<
              indexAndThen 2 c (Opt.Call succeed [tuple])


toLocal :: Int -> Opt.Expr
toLocal index =
  Opt.VarLocal (Name.fromVarIndex index)


indexAndThen :: Int -> Can.Type -> Opt.Expr -> Names.Tracker Opt.Expr
indexAndThen i tipe decoder =
  do  andThen <- decode "andThen"
      index <- decode "index"
      typeDecoder <- toDecoder tipe
      return $
        Opt.Call andThen
          [ Opt.Function [Name.fromVarIndex i] decoder
          , Opt.Call index [ Opt.Int i, typeDecoder ]
          ]



-- DECODE RECORDS


decodeRecord :: Map.Map Name.Name Can.FieldType -> Names.Tracker Opt.Expr
decodeRecord fields =
  let
    toFieldExpr name _ =
      Opt.VarLocal name

    record =
      Opt.Record (Map.mapWithKey toFieldExpr fields)
  in
    do  succeed <- decode "succeed"
        foldM fieldAndThen (Opt.Call succeed [record]) =<<
          Names.registerFieldDict fields (Map.toList fields)


fieldAndThen :: Opt.Expr -> (Name.Name, Can.FieldType) -> Names.Tracker Opt.Expr
fieldAndThen decoder (key, Can.FieldType _ tipe) =
  do  andThen <- decode "andThen"
      field <- decode "field"
      typeDecoder <- toDecoder tipe
      return $
        Opt.Call andThen
          [ Opt.Function [key] decoder
          , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]
          ]



-- GLOBALS HELPERS


encode :: Name.Name -> Names.Tracker Opt.Expr
encode name =
  Names.registerGlobal ModuleName.jsonEncode name


decode :: Name.Name -> Names.Tracker Opt.Expr
decode name =
  Names.registerGlobal ModuleName.jsonDecode name


================================================
FILE: compiler/src/Parse/Declaration.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# LANGUAGE OverloadedStrings #-}
module Parse.Declaration
  ( Decl(..)
  , declaration
  , infix_
  )
  where


import qualified Data.Name as Name

import qualified AST.Source as Src
import qualified AST.Utils.Binop as Binop
import qualified Parse.Expression as Expr
import qualified Parse.Pattern as Pattern
import qualified Parse.Keyword as Keyword
import qualified Parse.Number as Number
import qualified Parse.Space as Space
import qualified Parse.Symbol as Symbol
import qualified Parse.Type as Type
import qualified Parse.Variable as Var
import Parse.Primitives hiding (State)
import qualified Parse.Primitives as P
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- DECLARATION


data Decl
  = Value (Maybe Src.Comment) (A.Located Src.Value)
  | Union (Maybe Src.Comment) (A.Located Src.Union)
  | Alias (Maybe Src.Comment) (A.Located Src.Alias)
  | Port (Maybe Src.Comment) Src.Port


declaration :: Space.Parser E.Decl Decl
declaration =
  do  maybeDocs <- chompDocComment
      start <- getPosition
      oneOf E.DeclStart
        [ typeDecl maybeDocs start
        , portDecl maybeDocs
        , valueDecl maybeDocs start
        ]



-- DOC COMMENT


chompDocComment :: Parser E.Decl (Maybe Src.Comment)
chompDocComment =
  oneOfWithFallback
    [
      do  docComment <- Space.docComment E.DeclStart E.DeclSpace
          Space.chomp E.DeclSpace
          Space.checkFreshLine E.DeclFreshLineAfterDocComment
          return (Just docComment)
    ]
    Nothing



-- DEFINITION and ANNOTATION


{-# INLINE valueDecl #-}
valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
valueDecl maybeDocs start =
  do  name <- Var.lower E.DeclStart
      end <- getPosition
      specialize (E.DeclDef name) $
        do  Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
            oneOf E.DeclDefEquals
              [
                do  word1 0x3A {-:-} E.DeclDefEquals
                    Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
                    (tipe, _) <- specialize E.DeclDefType Type.expression
                    Space.checkFreshLine E.DeclDefNameRepeat
                    defName <- chompMatchingName name
                    Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
                    chompDefArgsAndBody maybeDocs start defName (Just tipe) []
              ,
                chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing []
              ]


chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
chompDefArgsAndBody maybeDocs start name tipe revArgs =
  oneOf E.DeclDefEquals
    [ do  arg <- specialize E.DeclDefArg Pattern.term
          Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
          chompDefArgsAndBody maybeDocs start name tipe (arg : revArgs)
    , do  word1 0x3D {-=-} E.DeclDefEquals
          Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody
          (body, end) <- specialize E.DeclDefBody Expr.expression
          let value = Src.Value name (reverse revArgs) body tipe
          let avalue = A.at start end value
          return (Value maybeDocs avalue, end)
    ]


chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
chompMatchingName expectedName =
  let
    (P.Parser parserL) = Var.lower E.DeclDefNameRepeat
  in
  P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
    let
      cokL name newState@(P.State _ _ _ _ er ec) =
        if expectedName == name
        then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
        else cerr sr sc (E.DeclDefNameMatch name)

      eokL name newState@(P.State _ _ _ _ er ec) =
        if expectedName == name
        then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
        else eerr sr sc (E.DeclDefNameMatch name)
    in
    parserL state cokL eokL cerr eerr



-- TYPE DECLARATIONS


{-# INLINE typeDecl #-}
typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
typeDecl maybeDocs start =
  inContext E.DeclType (Keyword.type_ E.DeclStart) $
    do  Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
        oneOf E.DT_Name
          [
            inContext E.DT_Alias (Keyword.alias_ E.DT_Name) $
              do  Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
                  (name, args) <- chompAliasNameToEquals
                  (tipe, end) <- specialize E.AliasBody Type.expression
                  let alias = A.at start end (Src.Alias name args tipe)
                  return (Alias maybeDocs alias, end)
          ,
            specialize E.DT_Union $
              do  (name, args) <- chompCustomNameToEquals
                  (firstVariant, firstEnd) <- Type.variant
                  (variants, end) <- chompVariants [firstVariant] firstEnd
                  let union = A.at start end (Src.Union name args variants)
                  return (Union maybeDocs union, end)
          ]



-- TYPE ALIASES


chompAliasNameToEquals :: Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name])
chompAliasNameToEquals =
  do  name <- addLocation (Var.upper E.AliasName)
      Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
      chompAliasNameToEqualsHelp name []


chompAliasNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name])
chompAliasNameToEqualsHelp name args =
  oneOf E.AliasEquals
    [ do  arg <- addLocation (Var.lower E.AliasEquals)
          Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
          chompAliasNameToEqualsHelp name (arg:args)
    , do  word1 0x3D {-=-} E.AliasEquals
          Space.chompAndCheckIndent E.AliasSpace E.AliasIndentBody
          return ( name, reverse args )
    ]



-- CUSTOM TYPES


chompCustomNameToEquals :: Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])
chompCustomNameToEquals =
  do  name <- addLocation (Var.upper E.CT_Name)
      Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals
      chompCustomNameToEqualsHelp name []


chompCustomNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])
chompCustomNameToEqualsHelp name args =
  oneOf E.CT_Equals
    [ do  arg <- addLocation (Var.lower E.CT_Equals)
          Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals
          chompCustomNameToEqualsHelp name (arg:args)
    , do  word1 0x3D {-=-} E.CT_Equals
          Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals
          return ( name, reverse args )
    ]


chompVariants :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> Space.Parser E.CustomType [(A.Located Name.Name, [Src.Type])]
chompVariants variants end =
  oneOfWithFallback
    [ do  Space.checkIndent end E.CT_IndentBar
          word1 0x7C {-|-} E.CT_Bar
          Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar
          (variant, newEnd) <- Type.variant
          chompVariants (variant:variants) newEnd
    ]
    (reverse variants, end)



-- PORT


{-# INLINE portDecl #-}
portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl
portDecl maybeDocs =
  inContext E.Port (Keyword.port_ E.DeclStart) $
    do  Space.chompAndCheckIndent E.PortSpace E.PortIndentName
        name <- addLocation (Var.lower E.PortName)
        Space.chompAndCheckIndent E.PortSpace E.PortIndentColon
        word1 0x3A {-:-} E.PortColon
        Space.chompAndCheckIndent E.PortSpace E.PortIndentType
        (tipe, end) <- specialize E.PortType Type.expression
        return
          ( Port maybeDocs (Src.Port name tipe)
          , end
          )



-- INFIX


-- INVARIANT: always chomps to a freshline
--
infix_ :: Parser E.Module (A.Located Src.Infix)
infix_ =
  let
    err = E.Infix
    _err = \_ -> E.Infix
  in
  do  start <- getPosition
      Keyword.infix_ err
      Space.chompAndCheckIndent _err err
      associativity <-
        oneOf err
          [ Keyword.left_  err >> return Binop.Left
          , Keyword.right_ err >> return Binop.Right
          , Keyword.non_   err >> return Binop.Non
          ]
      Space.chompAndCheckIndent _err err
      precedence <- Number.precedence err
      Space.chompAndCheckIndent _err err
      word1 0x28 {-(-} err
      op <- Symbol.operator err _err
      word1 0x29 {-)-} err
      Space.chompAndCheckIndent _err err
      word1 0x3D {-=-} err
      Space.chompAndCheckIndent _err err
      name <- Var.lower err
      end <- getPosition
      Space.chomp _err
      Space.checkFreshLine err
      return (A.at start end (Src.Infix op associativity precedence name))


================================================
FILE: compiler/src/Parse/Expression.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# LANGUAGE OverloadedStrings #-}
module Parse.Expression
  ( expression
  )
  where


import qualified Data.Name as Name

import qualified AST.Source as Src
import qualified Parse.Keyword as Keyword
import qualified Parse.Number as Number
import qualified Parse.Pattern as Pattern
import qualified Parse.Shader as Shader
import qualified Parse.Space as Space
import qualified Parse.Symbol as Symbol
import qualified Parse.Type as Type
import qualified Parse.String as String
import qualified Parse.Variable as Var
import Parse.Primitives hiding (State)
import qualified Parse.Primitives as P
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- TERMS


term :: Parser E.Expr Src.Expr
term =
  do  start <- getPosition
      oneOf E.Start
        [ variable start >>= accessible start
        , string start
        , number start
        , Shader.shader start
        , list start
        , record start >>= accessible start
        , tuple start >>= accessible start
        , accessor start
        , character start
        ]


string :: A.Position -> Parser E.Expr Src.Expr
string start =
  do  str <- String.string E.Start E.String
      addEnd start (Src.Str str)


character :: A.Position -> Parser E.Expr Src.Expr
character start =
  do  chr <- String.character E.Start E.Char
      addEnd start (Src.Chr chr)


number :: A.Position -> Parser E.Expr Src.Expr
number start =
  do  nmbr <- Number.number E.Start E.Number
      addEnd start $
        case nmbr of
          Number.Int int -> Src.Int int
          Number.Float float -> Src.Float float


accessor :: A.Position -> Parser E.Expr Src.Expr
accessor start =
  do  word1 0x2E {-.-} E.Dot
      field <- Var.lower E.Access
      addEnd start (Src.Accessor field)


variable :: A.Position -> Parser E.Expr Src.Expr
variable start =
  do  var <- Var.foreignAlpha E.Start
      addEnd start var


accessible :: A.Position -> Src.Expr -> Parser E.Expr Src.Expr
accessible start expr =
  oneOfWithFallback
    [ do  word1 0x2E {-.-} E.Dot
          pos <- getPosition
          field <- Var.lower E.Access
          end <- getPosition
          accessible start $
            A.at start end (Src.Access expr (A.at pos end field))
    ]
    expr



-- LISTS


list :: A.Position -> Parser E.Expr Src.Expr
list start =
  inContext E.List (word1 0x5B {-[-} E.Start) $
    do  Space.chompAndCheckIndent E.ListSpace E.ListIndentOpen
        oneOf E.ListOpen
          [ do  (entry, end) <- specialize E.ListExpr expression
                Space.checkIndent end E.ListIndentEnd
                chompListEnd start [entry]
          , do  word1 0x5D {-]-} E.ListOpen
                addEnd start (Src.List [])
          ]


chompListEnd :: A.Position -> [Src.Expr] -> Parser E.List Src.Expr
chompListEnd start entries =
  oneOf E.ListEnd
    [ do  word1 0x2C {-,-} E.ListEnd
          Space.chompAndCheckIndent E.ListSpace E.ListIndentExpr
          (entry, end) <- specialize E.ListExpr expression
          Space.checkIndent end E.ListIndentEnd
          chompListEnd start (entry:entries)
    , do  word1 0x5D {-]-} E.ListEnd
          addEnd start (Src.List (reverse entries))
    ]



-- TUPLES


tuple :: A.Position -> Parser E.Expr Src.Expr
tuple start@(A.Position row col) =
  inContext E.Tuple (word1 0x28 {-(-} E.Start) $
    do  before <- getPosition
        Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
        after <- getPosition
        if before /= after
          then
            do  (entry, end) <- specialize E.TupleExpr expression
                Space.checkIndent end E.TupleIndentEnd
                chompTupleEnd start entry []
          else
            oneOf E.TupleIndentExpr1
              [
                do  op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
                    if op == "-"
                      then
                        oneOf E.TupleOperatorClose
                          [
                            do  word1 0x29 {-)-} E.TupleOperatorClose
                                addEnd start (Src.Op op)
                          ,
                            do  (entry, end) <-
                                  specialize E.TupleExpr $
                                    do  negatedExpr@(A.At (A.Region _ end) _) <- term
                                        Space.chomp E.Space
                                        let exprStart = A.Position row (col + 2)
                                        let expr = A.at exprStart end (Src.Negate negatedExpr)
                                        chompExprEnd exprStart (State [] expr [] end)
                                Space.checkIndent end E.TupleIndentEnd
                                chompTupleEnd start entry []
                          ]
                      else
                        do  word1 0x29 {-)-} E.TupleOperatorClose
                            addEnd start (Src.Op op)
              ,
                do  word1 0x29 {-)-} E.TupleIndentExpr1
                    addEnd start Src.Unit
              ,
                do  (entry, end) <- specialize E.TupleExpr expression
                    Space.checkIndent end E.TupleIndentEnd
                    chompTupleEnd start entry []
              ]


chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
chompTupleEnd start firstExpr revExprs =
  oneOf E.TupleEnd
    [ do  word1 0x2C {-,-} E.TupleEnd
          Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN
          (entry, end) <- specialize E.TupleExpr expression
          Space.checkIndent end E.TupleIndentEnd
          chompTupleEnd start firstExpr (entry : revExprs)
    , do  word1 0x29 {-)-} E.TupleEnd
          case reverse revExprs of
            [] ->
              return firstExpr

            secondExpr : otherExprs ->
              addEnd start (Src.Tuple firstExpr secondExpr otherExprs)
    ]



-- RECORDS


record :: A.Position -> Parser E.Expr Src.Expr
record start =
  inContext E.Record (word1 0x7B {- { -} E.Start) $
    do  Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen
        oneOf E.RecordOpen
          [ do  word1 0x7D {-}-} E.RecordOpen
                addEnd start (Src.Record [])
          , do  starter <- addLocation (Var.lower E.RecordField)
                Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
                oneOf E.RecordEquals
                  [ do  word1 0x7C {-|-} E.RecordEquals
                        Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
                        firstField <- chompField
                        fields <- chompFields [firstField]
                        addEnd start (Src.Update starter fields)
                  , do  word1 0x3D {-=-} E.RecordEquals
                        Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
                        (value, end) <- specialize E.RecordExpr expression
                        Space.checkIndent end E.RecordIndentEnd
                        fields <- chompFields [(starter, value)]
                        addEnd start (Src.Record fields)
                  ]
          ]


type Field = ( A.Located Name.Name, Src.Expr )


chompFields :: [Field] -> Parser E.Record [Field]
chompFields fields =
  oneOf E.RecordEnd
    [ do  word1 0x2C {-,-} E.RecordEnd
          Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
          f <- chompField
          chompFields (f : fields)
    , do  word1 0x7D {-}-} E.RecordEnd
          return (reverse fields)
    ]


chompField :: Parser E.Record Field
chompField =
  do  key <- addLocation (Var.lower E.RecordField)
      Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
      word1 0x3D {-=-} E.RecordEquals
      Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
      (value, end) <- specialize E.RecordExpr expression
      Space.checkIndent end E.RecordIndentEnd
      return (key, value)



-- EXPRESSIONS


expression :: Space.Parser E.Expr Src.Expr
expression =
  do  start <- getPosition
      oneOf E.Start
        [ let_ start
        , if_ start
        , case_ start
        , function start
        , do  expr <- possiblyNegativeTerm start
              end <- getPosition
              Space.chomp E.Space
              chompExprEnd start (State [] expr [] end)
        ]


data State =
  State
    { _ops  :: ![(Src.Expr, A.Located Name.Name)]
    , _expr :: !Src.Expr
    , _args :: ![Src.Expr]
    , _end  :: !A.Position
    }


chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr
chompExprEnd start (State ops expr args end) =
  oneOfWithFallback
    [ -- argument
      do  Space.checkIndent end E.Start
          arg <- term
          newEnd <- getPosition
          Space.chomp E.Space
          chompExprEnd start (State ops expr (arg:args) newEnd)

    , -- operator
      do  Space.checkIndent end E.Start
          op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
          Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
          newStart <- getPosition
          if "-" == opName && end /= opStart && opEnd == newStart
            then
              -- negative terms
              do  negatedExpr <- term
                  newEnd <- getPosition
                  Space.chomp E.Space
                  let arg = A.at opStart newEnd (Src.Negate negatedExpr)
                  chompExprEnd start (State ops expr (arg:args) newEnd)
            else
              let err = E.OperatorRight opName in
              oneOf err
                [ -- term
                  do  newExpr <- possiblyNegativeTerm newStart
                      newEnd <- getPosition
                      Space.chomp E.Space
                      let newOps = (toCall expr args, op) : ops
                      chompExprEnd start (State newOps newExpr [] newEnd)

                , -- final term
                  do  (newLast, newEnd) <-
                        oneOf err
                          [ let_ newStart
                          , case_ newStart
                          , if_ newStart
                          , function newStart
                          ]
                      let newOps = (toCall expr args, op) : ops
                      let finalExpr = Src.Binops (reverse newOps) newLast
                      return ( A.at start newEnd finalExpr, newEnd )
                ]

    ]
    -- done
    (
      case ops of
        [] ->
          ( toCall expr args
          , end
          )

        _ ->
          ( A.at start end (Src.Binops (reverse ops) (toCall expr args))
          , end
          )
    )


possiblyNegativeTerm :: A.Position -> Parser E.Expr Src.Expr
possiblyNegativeTerm start =
  oneOf E.Start
    [ do  word1 0x2D {---} E.Start
          expr <- term
          addEnd start (Src.Negate expr)
    , term
    ]


toCall :: Src.Expr -> [Src.Expr] -> Src.Expr
toCall func revArgs =
  case revArgs of
    [] ->
      func

    lastArg : _ ->
      A.merge func lastArg (Src.Call func (reverse revArgs))



-- IF EXPRESSION


if_ :: A.Position -> Space.Parser E.Expr Src.Expr
if_ start =
  inContext E.If (Keyword.if_ E.Start) $
    chompIfEnd start []


chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If Src.Expr
chompIfEnd start branches =
  do  Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition
      (condition, condEnd) <- specialize E.IfCondition expression
      Space.checkIndent condEnd E.IfIndentThen
      Keyword.then_ E.IfThen
      Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch
      (thenBranch, thenEnd) <- specialize E.IfThenBranch expression
      Space.checkIndent thenEnd E.IfIndentElse
      Keyword.else_ E.IfElse
      Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch
      let newBranches = (condition, thenBranch) : branches
      oneOf E.IfElseBranchStart
        [
          do  Keyword.if_ E.IfElseBranchStart
              chompIfEnd start newBranches
        ,
          do  (elseBranch, elseEnd) <- specialize E.IfElseBranch expression
              let ifExpr = Src.If (reverse newBranches) elseBranch
              return ( A.at start elseEnd ifExpr, elseEnd )
        ]



-- LAMBDA EXPRESSION


function :: A.Position -> Space.Parser E.Expr Src.Expr
function start =
  inContext E.Func (word1 0x5C {-\-} E.Start) $
    do  Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArg
        arg <- specialize E.FuncArg Pattern.term
        Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow
        revArgs <- chompArgs [arg]
        Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody
        (body, end) <- specialize E.FuncBody expression
        let funcExpr = Src.Lambda (reverse revArgs) body
        return (A.at start end funcExpr, end)


chompArgs :: [Src.Pattern] -> Parser E.Func [Src.Pattern]
chompArgs revArgs =
  oneOf E.FuncArrow
    [ do  arg <- specialize E.FuncArg Pattern.term
          Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow
          chompArgs (arg:revArgs)
    , do  word2 0x2D 0x3E {-->-} E.FuncArrow
          return revArgs
    ]



-- CASE EXPRESSIONS


case_ :: A.Position -> Space.Parser E.Expr Src.Expr
case_ start =
  inContext E.Case (Keyword.case_ E.Start) $
    do  Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr
        (expr, exprEnd) <- specialize E.CaseExpr expression
        Space.checkIndent exprEnd E.CaseIndentOf
        Keyword.of_ E.CaseOf
        Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern
        withIndent $
          do  (firstBranch, firstEnd) <- chompBranch
              (branches, end) <- chompCaseEnd [firstBranch] firstEnd
              return
                ( A.at start end (Src.Case expr branches)
                , end
                )


chompBranch :: Space.Parser E.Case (Src.Pattern, Src.Expr)
chompBranch =
  do  (pattern, patternEnd) <- specialize E.CasePattern Pattern.expression
      Space.checkIndent patternEnd E.CaseIndentArrow
      word2 0x2D 0x3E {-->-} E.CaseArrow
      Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch
      (branchExpr, end) <- specialize E.CaseBranch expression
      return ( (pattern, branchExpr), end )


chompCaseEnd :: [(Src.Pattern, Src.Expr)] -> A.Position -> Space.Parser E.Case [(Src.Pattern, Src.Expr)]
chompCaseEnd branches end =
  oneOfWithFallback
    [ do  Space.checkAligned E.CasePatternAlignment
          (branch, newEnd) <- chompBranch
          chompCaseEnd (branch:branches) newEnd
    ]
    (reverse branches, end)



-- LET EXPRESSION


let_ :: A.Position -> Space.Parser E.Expr Src.Expr
let_ start =
  inContext E.Let (Keyword.let_ E.Start) $
    do  (defs, defsEnd) <-
          withBacksetIndent 3 $
            do  Space.chompAndCheckIndent E.LetSpace E.LetIndentDef
                withIndent $
                  do  (def, end) <- chompLetDef
                      chompLetDefs [def] end

        Space.checkIndent defsEnd E.LetIndentIn
        Keyword.in_ E.LetIn
        Space.chompAndCheckIndent E.LetSpace E.LetIndentBody
        (body, end) <- specialize E.LetBody expression
        return
          ( A.at start end (Src.Let defs body)
          , end
          )


chompLetDefs :: [A.Located Src.Def] -> A.Position -> Space.Parser E.Let [A.Located Src.Def]
chompLetDefs revDefs end =
  oneOfWithFallback
    [ do  Space.checkAligned E.LetDefAlignment
          (def, newEnd) <- chompLetDef
          chompLetDefs (def:revDefs) newEnd
    ]
    (reverse revDefs, end)



-- LET DEFINITIONS


chompLetDef :: Space.Parser E.Let (A.Located Src.Def)
chompLetDef =
  oneOf E.LetDefName
    [ definition
    , destructure
    ]



-- DEFINITION


definition :: Space.Parser E.Let (A.Located Src.Def)
definition =
  do  aname@(A.At (A.Region start _) name) <- addLocation (Var.lower E.LetDefName)
      specialize (E.LetDef name) $
        do  Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
            oneOf E.DefEquals
              [
                do  word1 0x3A {-:-} E.DefEquals
                    Space.chompAndCheckIndent E.DefSpace E.DefIndentType
                    (tipe, _) <- specialize E.DefType Type.expression
                    Space.checkAligned E.DefAlignment
                    defName <- chompMatchingName name
                    Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
                    chompDefArgsAndBody start defName (Just tipe) []
              ,
                chompDefArgsAndBody start aname Nothing []
              ]


chompDefArgsAndBody :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.Def (A.Located Src.Def)
chompDefArgsAndBody start name tipe revArgs =
  oneOf E.DefEquals
    [ do  arg <- specialize E.DefArg Pattern.term
          Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
          chompDefArgsAndBody start name tipe (arg : revArgs)
    , do  word1 0x3D {-=-} E.DefEquals
          Space.chompAndCheckIndent E.DefSpace E.DefIndentBody
          (body, end) <- specialize E.DefBody expression
          return
            ( A.at start end (Src.Define name (reverse revArgs) body tipe)
            , end
            )
    ]


chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
chompMatchingName expectedName =
  let
    (P.Parser parserL) = Var.lower E.DefNameRepeat
  in
  P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
    let
      cokL name newState@(P.State _ _ _ _ er ec) =
        if expectedName == name
        then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
        else cerr sr sc (E.DefNameMatch name)

      eokL name newState@(P.State _ _ _ _ er ec) =
        if expectedName == name
        then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
        else eerr sr sc (E.DefNameMatch name)
    in
    parserL state cokL eokL cerr eerr




-- DESTRUCTURE


destructure :: Space.Parser E.Let (A.Located Src.Def)
destructure =
  specialize E.LetDestruct $
  do  start <- getPosition
      pattern <- specialize E.DestructPattern Pattern.term
      Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals
      word1 0x3D {-=-} E.DestructEquals
      Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody
      (expr, end) <- specialize E.DestructBody expression
      return ( A.at start end (Src.Destruct pattern expr), end )


================================================
FILE: compiler/src/Parse/Keyword.hs
================================================
{-# LANGUAGE BangPatterns #-}
module Parse.Keyword
  ( type_, alias_, port_
  , if_, then_, else_
  , case_, of_
  , let_, in_
  , infix_, left_, right_, non_
  , module_, import_, exposing_, as_
  , effect_, where_, command_, subscription_
  , k4, k5
  )
  where


import Foreign.Ptr (plusPtr)
import Data.Word (Word8)

import Parse.Primitives (Parser, Row, Col)
import qualified Parse.Variable as Var
import qualified Parse.Primitives as P



-- DECLARATIONS


type_ :: (Row -> Col -> x) -> Parser x ()
type_ tx = k4 0x74 0x79 0x70 0x65 tx

alias_ :: (Row -> Col -> x) -> Parser x ()
alias_ tx = k5 0x61 0x6C 0x69 0x61 0x73 tx

port_ :: (Row -> Col -> x) -> Parser x ()
port_ tx = k4 0x70 0x6F 0x72 0x74 tx



-- IF EXPRESSIONS


if_ :: (Row -> Col -> x) -> Parser x ()
if_ tx = k2 0x69 0x66 tx

then_ :: (Row -> Col -> x) -> Parser x ()
then_ tx = k4 0x74 0x68 0x65 0x6E tx

else_ :: (Row -> Col -> x) -> Parser x ()
else_ tx = k4 0x65 0x6C 0x73 0x65 tx



-- CASE EXPRESSIONS


case_ :: (Row -> Col -> x) -> Parser x ()
case_ tx = k4 0x63 0x61 0x73 0x65 tx

of_ :: (Row -> Col -> x) -> Parser x ()
of_ tx = k2 0x6F 0x66 tx



-- LET EXPRESSIONS


let_ :: (Row -> Col -> x) -> Parser x ()
let_ tx = k3 0x6C 0x65 0x74 tx

in_ :: (Row -> Col -> x) -> Parser x ()
in_ tx = k2 0x69 0x6E tx



-- INFIXES


infix_ :: (Row -> Col -> x) -> Parser x ()
infix_ tx = k5 0x69 0x6E 0x66 0x69 0x78 tx

left_ :: (Row -> Col -> x) -> Parser x ()
left_ tx = k4 0x6C 0x65 0x66 0x74 tx

right_ :: (Row -> Col -> x) -> Parser x ()
right_ tx = k5 0x72 0x69 0x67 0x68 0x74 tx

non_ :: (Row -> Col -> x) -> Parser x ()
non_ tx = k3 0x6E 0x6F 0x6E tx



-- IMPORTS


module_ :: (Row -> Col -> x) -> Parser x ()
module_ tx = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 tx

import_ :: (Row -> Col -> x) -> Parser x ()
import_ tx = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 tx

exposing_ :: (Row -> Col -> x) -> Parser x ()
exposing_ tx = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 tx

as_ :: (Row -> Col -> x) -> Parser x ()
as_ tx = k2 0x61 0x73 tx



-- EFFECTS


effect_ :: (Row -> Col -> x) -> Parser x ()
effect_ tx = k6 0x65 0x66 0x66 0x65 0x63 0x74 tx

where_ :: (Row -> Col -> x) -> Parser x ()
where_ tx = k5 0x77 0x68 0x65 0x72 0x65 tx

command_ :: (Row -> Col -> x) -> Parser x ()
command_ tx = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 tx

subscription_ :: (Row -> Col -> x) -> Parser x ()
subscription_ toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let !pos12 = plusPtr pos 12 in
    if pos12 <= end
      && P.unsafeIndex (        pos   ) == 0x73
      && P.unsafeIndex (plusPtr pos  1) == 0x75
      && P.unsafeIndex (plusPtr pos  2) == 0x62
      && P.unsafeIndex (plusPtr pos  3) == 0x73
      && P.unsafeIndex (plusPtr pos  4) == 0x63
      && P.unsafeIndex (plusPtr pos  5) == 0x72
      && P.unsafeIndex (plusPtr pos  6) == 0x69
      && P.unsafeIndex (plusPtr pos  7) == 0x70
      && P.unsafeIndex (plusPtr pos  8) == 0x74
      && P.unsafeIndex (plusPtr pos  9) == 0x69
      && P.unsafeIndex (plusPtr pos 10) == 0x6F
      && P.unsafeIndex (plusPtr pos 11) == 0x6E
      && Var.getInnerWidth pos12 end == 0
    then
      let !s = P.State src pos12 end indent row (col + 12) in cok () s
    else
      eerr row col toError



-- KEYWORDS


k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
k2 w1 w2 toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let !pos2 = plusPtr pos 2 in
    if pos2 <= end
      && P.unsafeIndex (        pos  ) == w1
      && P.unsafeIndex (plusPtr pos 1) == w2
      && Var.getInnerWidth pos2 end == 0
    then
      let !s = P.State src pos2 end indent row (col + 2) in cok () s
    else
      eerr row col toError


k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
k3 w1 w2 w3 toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let !pos3 = plusPtr pos 3 in
    if pos3 <= end
      && P.unsafeIndex (        pos  ) == w1
      && P.unsafeIndex (plusPtr pos 1) == w2
      && P.unsafeIndex (plusPtr pos 2) == w3
      && Var.getInnerWidth pos3 end == 0
    then
      let !s = P.State src pos3 end indent row (col + 3) in cok () s
    else
      eerr row col toError


k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
k4 w1 w2 w3 w4 toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let !pos4 = plusPtr pos 4 in
    if pos4 <= end
      && P.unsafeIndex (        pos  ) == w1
      && P.unsafeIndex (plusPtr pos 1) == w2
      && P.unsafeIndex (plusPtr pos 2) == w3
      && P.unsafeIndex (plusPtr pos 3) == w4
      && Var.getInnerWidth pos4 end == 0
    then
      let !s = P.State src pos4 end indent row (col + 4) in cok () s
    else
      eerr row col toError


k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
k5 w1 w2 w3 w4 w5 toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let !pos5 = plusPtr pos 5 in
    if pos5 <= end
      && P.unsafeIndex (        pos  ) == w1
      && P.unsafeIndex (plusPtr pos 1) == w2
      && P.unsafeIndex (plusPtr pos 2) == w3
      && P.unsafeIndex (plusPtr pos 3) == w4
      && P.unsafeIndex (plusPtr pos 4) == w5
      && Var.getInnerWidth pos5 end == 0
    then
      let !s = P.State src pos5 end indent row (col + 5) in cok () s
    else
      eerr row col toError


k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
k6 w1 w2 w3 w4 w5 w6 toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let !pos6 = plusPtr pos 6 in
    if pos6 <= end
      && P.unsafeIndex (        pos  ) == w1
      && P.unsafeIndex (plusPtr pos 1) == w2
      && P.unsafeIndex (plusPtr pos 2) == w3
      && P.unsafeIndex (plusPtr pos 3) == w4
      && P.unsafeIndex (plusPtr pos 4) == w5
      && P.unsafeIndex (plusPtr pos 5) == w6
      && Var.getInnerWidth pos6 end == 0
    then
      let !s = P.State src pos6 end indent row (col + 6) in cok () s
    else
      eerr row col toError


k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
k7 w1 w2 w3 w4 w5 w6 w7 toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let !pos7 = plusPtr pos 7 in
    if pos7 <= end
      && P.unsafeIndex (        pos  ) == w1
      && P.unsafeIndex (plusPtr pos 1) == w2
      && P.unsafeIndex (plusPtr pos 2) == w3
      && P.unsafeIndex (plusPtr pos 3) == w4
      && P.unsafeIndex (plusPtr pos 4) == w5
      && P.unsafeIndex (plusPtr pos 5) == w6
      && P.unsafeIndex (plusPtr pos 6) == w7
      && Var.getInnerWidth pos7 end == 0
    then
      let !s = P.State src pos7 end indent row (col + 7) in cok () s
    else
      eerr row col toError


k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let !pos8 = plusPtr pos 8 in
    if pos8 <= end
      && P.unsafeIndex (        pos  ) == w1
      && P.unsafeIndex (plusPtr pos 1) == w2
      && P.unsafeIndex (plusPtr pos 2) == w3
      && P.unsafeIndex (plusPtr pos 3) == w4
      && P.unsafeIndex (plusPtr pos 4) == w5
      && P.unsafeIndex (plusPtr pos 5) == w6
      && P.unsafeIndex (plusPtr pos 6) == w7
      && P.unsafeIndex (plusPtr pos 7) == w8
      && Var.getInnerWidth pos8 end == 0
    then
      let !s = P.State src pos8 end indent row (col + 8) in cok () s
    else
      eerr row col toError


================================================
FILE: compiler/src/Parse/Module.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Parse.Module
  ( fromByteString
  , ProjectType(..)
  , isKernel
  , chompImports
  , chompImport
  )
  where


import qualified Data.ByteString as BS
import qualified Data.Name as Name

import qualified AST.Source as Src
import qualified Elm.Compiler.Imports as Imports
import qualified Elm.Package as Pkg
import qualified Parse.Declaration as Decl
import qualified Parse.Keyword as Keyword
import qualified Parse.Space as Space
import qualified Parse.Symbol as Symbol
import qualified Parse.Variable as Var
import qualified Parse.Primitives as P
import Parse.Primitives hiding (State, fromByteString)
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- FROM BYTE STRING


fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module
fromByteString projectType source =
  case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of
    Right modul -> checkModule projectType modul
    Left err    -> Left (E.ParseError err)



-- PROJECT TYPE


data ProjectType
  = Package Pkg.Name
  | Application


isCore :: ProjectType -> Bool
isCore projectType =
  case projectType of
    Package pkg -> pkg == Pkg.core
    Application -> False


isKernel :: ProjectType -> Bool
isKernel projectType =
  case projectType of
    Package pkg -> Pkg.isKernel pkg
    Application -> False



-- MODULE


data Module =
  Module
    { _header :: Maybe Header
    , _imports :: [Src.Import]
    , _infixes :: [A.Located Src.Infix]
    , _decls :: [Decl.Decl]
    }


chompModule :: ProjectType -> Parser E.Module Module
chompModule projectType =
  do  header <- chompHeader
      imports <- chompImports (if isCore projectType then [] else Imports.defaults)
      infixes <- if isKernel projectType then chompInfixes [] else return []
      decls <- specialize E.Declarations $ chompDecls []
      return (Module header imports infixes decls)



-- CHECK MODULE


checkModule :: ProjectType -> Module -> Either E.Error Src.Module
checkModule projectType (Module maybeHeader imports infixes decls) =
  let
    (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
  in
  case maybeHeader of
    Just (Header name effects exports docs) ->
      Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
        <$> checkEffects projectType ports effects

    Nothing ->
      Right $
        Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $
          case ports of
            [] -> Src.NoEffects
            _:_ -> Src.Ports ports


checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects
checkEffects projectType ports effects =
  case effects of
    NoEffects region ->
      case ports of
        [] ->
          Right Src.NoEffects

        Src.Port name _ : _ ->
          case projectType of
            Package _   -> Left (E.NoPortsInPackage name)
            Application -> Left (E.UnexpectedPort region)

    Ports region ->
      case projectType of
        Package _ ->
          Left (E.NoPortModulesInPackage region)

        Application ->
          case ports of
            []  -> Left (E.NoPorts region)
            _:_ -> Right (Src.Ports ports)

    Manager region manager ->
      if isKernel projectType then
        case ports of
          []  -> Right (Src.Manager region manager)
          _:_ -> Left (E.UnexpectedPort region)
      else
        Left (E.NoEffectsOutsideKernel region)



categorizeDecls :: [A.Located Src.Value] -> [A.Located Src.Union] -> [A.Located Src.Alias] -> [Src.Port] -> [Decl.Decl] -> ( [A.Located Src.Value], [A.Located Src.Union], [A.Located Src.Alias], [Src.Port] )
categorizeDecls values unions aliases ports decls =
  case decls of
    [] ->
      (values, unions, aliases, ports)

    decl:otherDecls ->
      case decl of
        Decl.Value _ value -> categorizeDecls (value:values) unions aliases ports otherDecls
        Decl.Union _ union -> categorizeDecls values (union:unions) aliases ports otherDecls
        Decl.Alias _ alias -> categorizeDecls values unions (alias:aliases) ports otherDecls
        Decl.Port  _ port_ -> categorizeDecls values unions aliases (port_:ports) otherDecls



-- TO DOCS


toDocs :: Either A.Region Src.Comment -> [Decl.Decl] -> Src.Docs
toDocs comment decls =
  case comment of
    Right overview ->
      Src.YesDocs overview (getComments decls [])

    Left region ->
      Src.NoDocs region


getComments :: [Decl.Decl] -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]
getComments decls comments =
  case decls of
    [] ->
      comments

    decl:otherDecls ->
      case decl of
        Decl.Value c (A.At _ (Src.Value n _ _ _)) -> getComments otherDecls (addComment c n comments)
        Decl.Union c (A.At _ (Src.Union n _ _  )) -> getComments otherDecls (addComment c n comments)
        Decl.Alias c (A.At _ (Src.Alias n _ _  )) -> getComments otherDecls (addComment c n comments)
        Decl.Port  c         (Src.Port  n _    )  -> getComments otherDecls (addComment c n comments)


addComment :: Maybe Src.Comment -> A.Located Name.Name -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]
addComment maybeComment (A.At _ name) comments =
  case maybeComment of
    Just comment -> (name, comment) : comments
    Nothing      -> comments



-- FRESH LINES


freshLine :: (Row -> Col -> E.Module) -> Parser E.Module ()
freshLine toFreshLineError =
  do  Space.chomp E.ModuleSpace
      Space.checkFreshLine toFreshLineError



-- CHOMP DECLARATIONS


chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl]
chompDecls decls =
  do  (decl, _) <- Decl.declaration
      oneOfWithFallback
        [ do  Space.checkFreshLine E.DeclStart
              chompDecls (decl:decls)
        ]
        (reverse (decl:decls))


chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix]
chompInfixes infixes =
  oneOfWithFallback
    [ do  binop <- Decl.infix_
          chompInfixes (binop:infixes)
    ]
    infixes



-- MODULE DOC COMMENT


chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.Comment)
chompModuleDocCommentSpace =
  do  (A.At region ()) <- addLocation (freshLine E.FreshLine)
      oneOfWithFallback
        [
          do  docComment <- Space.docComment E.ImportStart E.ModuleSpace
              Space.chomp E.ModuleSpace
              Space.checkFreshLine E.FreshLine
              return (Right docComment)
        ]
        (Left region)



-- HEADER


data Header =
  Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.Comment)


data Effects
  = NoEffects A.Region
  | Ports A.Region
  | Manager A.Region Src.Manager


chompHeader :: Parser E.Module (Maybe Header)
chompHeader =
  do  freshLine E.FreshLine
      start <- getPosition
      oneOfWithFallback
        [
          -- module MyThing exposing (..)
          do  Keyword.module_ E.ModuleProblem
              effectEnd <- getPosition
              Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
              name <- addLocation (Var.moduleName E.ModuleName)
              Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
              Keyword.exposing_ E.ModuleProblem
              Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
              exports <- addLocation (specialize E.ModuleExposing exposing)
              comment <- chompModuleDocCommentSpace
              return $ Just $
                Header name (NoEffects (A.Region start effectEnd)) exports comment
        ,
          -- port module MyThing exposing (..)
          do  Keyword.port_ E.PortModuleProblem
              Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
              Keyword.module_ E.PortModuleProblem
              effectEnd <- getPosition
              Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
              name <- addLocation (Var.moduleName E.PortModuleName)
              Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
              Keyword.exposing_ E.PortModuleProblem
              Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
              exports <- addLocation (specialize E.PortModuleExposing exposing)
              comment <- chompModuleDocCommentSpace
              return $ Just $
                Header name (Ports (A.Region start effectEnd)) exports comment
        ,
          -- effect module MyThing where { command = MyCmd } exposing (..)
          do  Keyword.effect_ E.Effect
              Space.chompAndCheckIndent E.ModuleSpace E.Effect
              Keyword.module_ E.Effect
              effectEnd <- getPosition
              Space.chompAndCheckIndent E.ModuleSpace E.Effect
              name <- addLocation (Var.moduleName E.ModuleName)
              Space.chompAndCheckIndent E.ModuleSpace E.Effect
              Keyword.where_ E.Effect
              Space.chompAndCheckIndent E.ModuleSpace E.Effect
              manager <- chompManager
              Space.chompAndCheckIndent E.ModuleSpace E.Effect
              Keyword.exposing_ E.Effect
              Space.chompAndCheckIndent E.ModuleSpace E.Effect
              exports <- addLocation (specialize (const E.Effect) exposing)
              comment <- chompModuleDocCommentSpace
              return $ Just $
                Header name (Manager (A.Region start effectEnd) manager) exports comment
        ]
        -- default header
        Nothing


chompManager :: Parser E.Module Src.Manager
chompManager =
  do  word1 0x7B {- { -} E.Effect
      spaces_em
      oneOf E.Effect
        [ do  cmd <- chompCommand
              spaces_em
              oneOf E.Effect
                [ do  word1 0x7D {-}-} E.Effect
                      spaces_em
                      return (Src.Cmd cmd)
                , do  word1 0x2C {-,-} E.Effect
                      spaces_em
                      sub <- chompSubscription
                      spaces_em
                      word1 0x7D {-}-} E.Effect
                      spaces_em
                      return (Src.Fx cmd sub)
                ]
        , do  sub <- chompSubscription
              spaces_em
              oneOf E.Effect
                [ do  word1 0x7D {-}-} E.Effect
                      spaces_em
                      return (Src.Sub sub)
                , do  word1 0x2C {-,-} E.Effect
                      spaces_em
                      cmd <- chompCommand
                      spaces_em
                      word1 0x7D {-}-} E.Effect
                      spaces_em
                      return (Src.Fx cmd sub)
                ]
        ]


chompCommand :: Parser E.Module (A.Located Name.Name)
chompCommand =
  do  Keyword.command_ E.Effect
      spaces_em
      word1 0x3D {-=-} E.Effect
      spaces_em
      addLocation (Var.upper E.Effect)


chompSubscription :: Parser E.Module (A.Located Name.Name)
chompSubscription =
  do  Keyword.subscription_ E.Effect
      spaces_em
      word1 0x3D {-=-} E.Effect
      spaces_em
      addLocation (Var.upper E.Effect)


spaces_em :: Parser E.Module ()
spaces_em =
  Space.chompAndCheckIndent E.ModuleSpace E.Effect



-- IMPORTS


chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
chompImports is =
  oneOfWithFallback
    [ do  i <- chompImport
          chompImports (i:is)
    ]
    (reverse is)


chompImport :: Parser E.Module Src.Import
chompImport =
  do  Keyword.import_ E.ImportStart
      Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
      name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
      Space.chomp E.ModuleSpace
      oneOf E.ImportEnd
        [ do  Space.checkFreshLine E.ImportEnd
              return $ Src.Import name Nothing (Src.Explicit [])
        , do  Space.checkIndent end E.ImportEnd
              oneOf E.ImportAs
                [ chompAs name
                , chompExposing name Nothing
                ]
        ]


chompAs :: A.Located Name.Name -> Parser E.Module Src.Import
chompAs name =
  do  Keyword.as_ E.ImportAs
      Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
      alias <- Var.upper E.ImportAlias
      end <- getPosition
      Space.chomp E.ModuleSpace
      oneOf E.ImportEnd
        [ do  Space.checkFreshLine E.ImportEnd
              return $ Src.Import name (Just alias) (Src.Explicit [])
        , do  Space.checkIndent end E.ImportEnd
              chompExposing name (Just alias)
        ]


chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import
chompExposing name maybeAlias =
  do  Keyword.exposing_ E.ImportExposing
      Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
      exposed <- specialize E.ImportExposingList exposing
      freshLine E.ImportEnd
      return $ Src.Import name maybeAlias exposed



-- LISTING


exposing :: Parser E.Exposing Src.Exposing
exposing =
  do  word1 0x28 {-(-} E.ExposingStart
      Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
      oneOf E.ExposingValue
        [ do  word2 0x2E 0x2E {-..-} E.ExposingValue
              Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
              word1 0x29 {-)-} E.ExposingEnd
              return Src.Open
        , do  exposed <- chompExposed
              Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
              exposingHelp [exposed]
        ]


exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing
exposingHelp revExposed =
  oneOf E.ExposingEnd
    [ do  word1 0x2C {-,-} E.ExposingEnd
          Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
          exposed <- chompExposed
          Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
          exposingHelp (exposed:revExposed)
    , do  word1 0x29 {-)-} E.ExposingEnd
          return (Src.Explicit (reverse revExposed))
    ]


chompExposed :: Parser E.Exposing Src.Exposed
chompExposed =
  do  start <- getPosition
      oneOf E.ExposingValue
        [ do  name <- Var.lower E.ExposingValue
              end <- getPosition
              return $ Src.Lower $ A.at start end name
        , do  word1 0x28 {-(-} E.ExposingValue
              op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
              word1 0x29 {-)-} E.ExposingOperatorRightParen
              end <- getPosition
              return $ Src.Operator (A.Region start end) op
        , do  name <- Var.upper E.ExposingValue
              end <- getPosition
              Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
              Src.Upper (A.at start end name) <$> privacy
        ]


privacy :: Parser E.Exposing Src.Privacy
privacy =
  oneOfWithFallback
    [ do  word1 0x28 {-(-} E.ExposingTypePrivacy
          Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
          start <- getPosition
          word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy
          end <- getPosition
          Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
          word1 0x29 {-)-} E.ExposingTypePrivacy
          return $ Src.Public (A.Region start end)
    ]
    Src.Private


================================================
FILE: compiler/src/Parse/Number.hs
================================================
{-# LANGUAGE BangPatterns, UnboxedTuples #-}
module Parse.Number
  ( Number(..)
  , number
  , Outcome(..)
  , chompInt
  , chompHex
  , precedence
  )
  where


import Data.Word (Word8)
import Foreign.Ptr (Ptr, plusPtr, minusPtr)

import qualified AST.Utils.Binop as Binop
import qualified Elm.Float as EF
import Parse.Primitives (Parser, Row, Col)
import qualified Parse.Variable as Var
import qualified Parse.Primitives as P
import qualified Reporting.Error.Syntax as E



-- HELPERS


isDirtyEnd :: Ptr Word8 -> Ptr Word8 -> Word8 -> Bool
isDirtyEnd pos end word =
  Var.getInnerWidthHelp pos end word > 0


{-# INLINE isDecimalDigit #-}
isDecimalDigit :: Word8 -> Bool
isDecimalDigit word =
  word <= 0x39 {-9-} && word >= 0x30 {-0-}



-- NUMBERS


data Number
  = Int Int
  | Float EF.Float


number :: (Row -> Col -> x) -> (E.Number -> Row -> Col -> x) -> Parser x Number
number toExpectation toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    if pos >= end then
      eerr row col toExpectation

    else
      let !word = P.unsafeIndex pos in
      if not (isDecimalDigit word) then
        eerr row col toExpectation

      else
        let
          outcome =
            if word == 0x30 {-0-} then
              chompZero (plusPtr pos 1) end
            else
              chompInt (plusPtr pos 1) end (fromIntegral (word - 0x30 {-0-}))
        in
          case outcome of
            Err newPos problem ->
              let
                !newCol = col + fromIntegral (minusPtr newPos pos)
              in
              cerr row newCol (toError problem)

            OkInt newPos n ->
              let
                !newCol = col + fromIntegral (minusPtr newPos pos)
                !integer = Int n
                !newState = P.State src newPos end indent row newCol
              in
              cok integer newState

            OkFloat newPos ->
              let
                !newCol = col + fromIntegral (minusPtr newPos pos)
                !copy = EF.fromPtr pos newPos
                !float = Float copy
                !newState = P.State src newPos end indent row newCol
              in
              cok float newState



-- CHOMP OUTCOME


-- first Int is newPos
--
data Outcome
  = Err (Ptr Word8) E.Number
  | OkInt (Ptr Word8) Int
  | OkFloat (Ptr Word8)



-- CHOMP INT


chompInt :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome
chompInt !pos end !n =
  if pos >= end then

    OkInt pos n

  else

    let
      !word = P.unsafeIndex pos
    in
      if isDecimalDigit word then
        chompInt (plusPtr pos 1) end (10 * n + fromIntegral (word - 0x30 {-0-}))

      else if word == 0x2E {-.-} then
        chompFraction pos end n

      else if word == 0x65 {-e-} || word == 0x45 {-E-} then
        chompExponent (plusPtr pos 1) end

      else if isDirtyEnd pos end word then
        Err pos E.NumberEnd

      else
        OkInt pos n



-- CHOMP FRACTION


chompFraction :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome
chompFraction pos end n =
  let
    !pos1 = plusPtr pos 1
  in
  if pos1 >= end then
    Err pos (E.NumberDot n)

  else if isDecimalDigit (P.unsafeIndex pos1) then
    chompFractionHelp (plusPtr pos1 1) end

  else
    Err pos (E.NumberDot n)


chompFractionHelp :: Ptr Word8 -> Ptr Word8 -> Outcome
chompFractionHelp pos end =
  if pos >= end then
    OkFloat pos

  else
    let !word = P.unsafeIndex pos in
    if isDecimalDigit word then
      chompFractionHelp (plusPtr pos 1) end

    else if word == 0x65 {-e-} || word == 0x45 {-E-} then
      chompExponent (plusPtr pos 1) end

    else if isDirtyEnd pos end word then
      Err pos E.NumberEnd

    else
      OkFloat pos



-- CHOMP EXPONENT


chompExponent :: Ptr Word8 -> Ptr Word8 -> Outcome
chompExponent pos end =
  if pos >= end then
    Err pos E.NumberEnd

  else
    let !word = P.unsafeIndex pos in
    if isDecimalDigit word then
      chompExponentHelp (plusPtr pos 1) end

    else if word == 0x2B {-+-} || word == 0x2D {---} then

      let !pos1 = plusPtr pos 1 in
      if pos1 < end && isDecimalDigit (P.unsafeIndex pos1) then
        chompExponentHelp (plusPtr pos 2) end
      else
        Err pos E.NumberEnd

    else
      Err pos E.NumberEnd


chompExponentHelp :: Ptr Word8 -> Ptr Word8 -> Outcome
chompExponentHelp pos end =
  if pos >= end then
    OkFloat pos

  else if isDecimalDigit (P.unsafeIndex pos) then
    chompExponentHelp (plusPtr pos 1) end

  else
    OkFloat pos



-- CHOMP ZERO


chompZero :: Ptr Word8 -> Ptr Word8 -> Outcome
chompZero pos end =
  if pos >= end then
    OkInt pos 0

  else
    let !word = P.unsafeIndex pos in
    if word == 0x78 {-x-} then
      chompHexInt (plusPtr pos 1) end

    else if word == 0x2E {-.-} then
      chompFraction pos end 0

    else if isDecimalDigit word then
      Err pos E.NumberNoLeadingZero

    else if isDirtyEnd pos end word then
      Err pos E.NumberEnd

    else
      OkInt pos 0


chompHexInt :: Ptr Word8 -> Ptr Word8 -> Outcome
chompHexInt pos end =
  let (# newPos, answer #) = chompHex pos end in
  if answer < 0 then
    Err newPos E.NumberHexDigit
  else
    OkInt newPos answer



-- CHOMP HEX


-- Return -1 if it has NO digits
-- Return -2 if it has BAD digits

{-# INLINE chompHex #-}
chompHex :: Ptr Word8 -> Ptr Word8 -> (# Ptr Word8, Int #)
chompHex pos end =
  chompHexHelp pos end (-1) 0


chompHexHelp :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> (# Ptr Word8, Int #)
chompHexHelp pos end answer accumulator =
  if pos >= end then
    (# pos, answer #)
  else
    let
      !newAnswer =
        stepHex pos end (P.unsafeIndex pos) accumulator
    in
    if newAnswer < 0 then
      (# pos, if newAnswer == -1 then answer else -2 #)
    else
      chompHexHelp (plusPtr pos 1) end newAnswer newAnswer


{-# INLINE stepHex #-}
stepHex :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int -> Int
stepHex pos end word acc
  | 0x30 {-0-} <= word && word <= 0x39 {-9-} = 16 * acc + fromIntegral (word - 0x30 {-0-})
  | 0x61 {-a-} <= word && word <= 0x66 {-f-} = 16 * acc + 10 + fromIntegral (word - 0x61 {-a-})
  | 0x41 {-A-} <= word && word <= 0x46 {-F-} = 16 * acc + 10 + fromIntegral (word - 0x41 {-A-})
  | isDirtyEnd pos end word                  = -2
  | True                                     = -1



-- PRECEDENCE


precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence
precedence toExpectation =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    if pos >= end then
      eerr row col toExpectation

    else
      let !word = P.unsafeIndex pos in
      if isDecimalDigit word then
        cok
          (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))
          (P.State src (plusPtr pos 1) end indent row (col + 1))

      else
        eerr row col toExpectation


================================================
FILE: compiler/src/Parse/Pattern.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
module Parse.Pattern
  ( term
  , expression
  )
  where


import qualified Data.List as List
import qualified Data.Name as Name
import qualified Data.Utf8 as Utf8
import Foreign.Ptr (plusPtr)

import qualified AST.Source as Src
import qualified Parse.Keyword as Keyword
import qualified Parse.Number as Number
import qualified Parse.Space as Space
import qualified Parse.String as String
import qualified Parse.Variable as Var
import qualified Parse.Primitives as P
import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1, word2)
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- TERM


term :: Parser E.Pattern Src.Pattern
term =
  do  start <- getPosition
      oneOf E.PStart
        [ record start
        , tuple start
        , list start
        , termHelp start
        ]


termHelp :: A.Position -> Parser E.Pattern Src.Pattern
termHelp start =
  oneOf E.PStart
    [
      do  wildcard
          addEnd start Src.PAnything
    ,
      do  name <- Var.lower E.PStart
          addEnd start (Src.PVar name)
    ,
      do  upper <- Var.foreignUpper E.PStart
          end <- getPosition
          let region = A.Region start end
          return $ A.at start end $
            case upper of
              Var.Unqualified name ->
                Src.PCtor region name []

              Var.Qualified home name ->
                Src.PCtorQual region home name []
    ,
      do  number <- Number.number E.PStart E.PNumber
          end <- getPosition
          case number of
            Number.Int int ->
              return (A.at start end (Src.PInt int))

            Number.Float float ->
              P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ ->
                let
                  width = fromIntegral (Utf8.size float)
                in
                cerr row (col - width) (E.PFloat width)
    ,
      do  str <- String.string E.PStart E.PString
          addEnd start (Src.PStr str)
    ,
      do  chr <- String.character E.PStart E.PChar
          addEnd start (Src.PChr chr)
    ]



-- WILDCARD


wildcard :: Parser E.Pattern ()
wildcard =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
      eerr row col E.PStart
    else
      let
        !newPos = plusPtr pos 1
        !newCol = col + 1
      in
      if Var.getInnerWidth newPos end > 0 then
        let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol in
        cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col)))
      else
        let !newState = P.State src newPos end indent row newCol in
        cok () newState



-- RECORDS


record :: A.Position -> Parser E.Pattern Src.Pattern
record start =
  inContext E.PRecord (word1 0x7B {- { -} E.PStart) $
    do  Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentOpen
        oneOf E.PRecordOpen
          [ do  var <- addLocation (Var.lower E.PRecordField)
                Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
                recordHelp start [var]
          , do  word1 0x7D {-}-} E.PRecordEnd
                addEnd start (Src.PRecord [])
          ]


recordHelp :: A.Position -> [A.Located Name.Name] -> Parser E.PRecord Src.Pattern
recordHelp start vars =
  oneOf E.PRecordEnd
    [ do  word1 0x2C {-,-} E.PRecordEnd
          Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField
          var <- addLocation (Var.lower E.PRecordField)
          Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
          recordHelp start (var:vars)
    , do  word1 0x7D {-}-} E.PRecordEnd
          addEnd start (Src.PRecord (reverse vars))
    ]



-- TUPLES


tuple :: A.Position -> Parser E.Pattern Src.Pattern
tuple start =
  inContext E.PTuple (word1 0x28 {-(-} E.PStart) $
    do  Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1
        oneOf E.PTupleOpen
          [ do  (pattern, end) <- P.specialize E.PTupleExpr expression
                Space.checkIndent end E.PTupleIndentEnd
                tupleHelp start pattern []
          , do  word1 0x29 {-)-} E.PTupleEnd
                addEnd start Src.PUnit
          ]


tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.Pattern
tupleHelp start firstPattern revPatterns =
  oneOf E.PTupleEnd
    [ do  word1 0x2C {-,-} E.PTupleEnd
          Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN
          (pattern, end) <- P.specialize E.PTupleExpr expression
          Space.checkIndent end E.PTupleIndentEnd
          tupleHelp start firstPattern (pattern : revPatterns)
    , do  word1 0x29 {-)-} E.PTupleEnd
          case reverse revPatterns of
            [] ->
              return firstPattern

            secondPattern : otherPatterns ->
              addEnd start (Src.PTuple firstPattern secondPattern otherPatterns)
    ]



-- LIST


list :: A.Position -> Parser E.Pattern Src.Pattern
list start =
  inContext E.PList (word1 0x5B {-[-} E.PStart) $
    do  Space.chompAndCheckIndent E.PListSpace E.PListIndentOpen
        oneOf E.PListOpen
          [ do  (pattern, end) <- P.specialize E.PListExpr expression
                Space.checkIndent end E.PListIndentEnd
                listHelp start [pattern]
          , do  word1 0x5D {-]-} E.PListEnd
                addEnd start (Src.PList [])
          ]


listHelp :: A.Position -> [Src.Pattern] -> Parser E.PList Src.Pattern
listHelp start patterns =
  oneOf E.PListEnd
    [ do  word1 0x2C {-,-} E.PListEnd
          Space.chompAndCheckIndent E.PListSpace E.PListIndentExpr
          (pattern, end) <- P.specialize E.PListExpr expression
          Space.checkIndent end E.PListIndentEnd
          listHelp start (pattern:patterns)
    , do  word1 0x5D {-]-} E.PListEnd
          addEnd start (Src.PList (reverse patterns))
    ]



-- EXPRESSION


expression :: Space.Parser E.Pattern Src.Pattern
expression =
  do  start <- getPosition
      ePart <- exprPart
      exprHelp start [] ePart


exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern
exprHelp start revPatterns (pattern, end) =
  oneOfWithFallback
    [ do  Space.checkIndent end E.PIndentStart
          word2 0x3A 0x3A {-::-} E.PStart
          Space.chompAndCheckIndent E.PSpace E.PIndentStart
          ePart <- exprPart
          exprHelp start (pattern:revPatterns) ePart
    , do  Space.checkIndent end E.PIndentStart
          Keyword.as_ E.PStart
          Space.chompAndCheckIndent E.PSpace E.PIndentAlias
          nameStart <- getPosition
          name <- Var.lower E.PAlias
          newEnd <- getPosition
          Space.chomp E.PSpace
          let alias = A.at nameStart newEnd name
          return
            ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias)
            , newEnd
            )
    ]
    ( List.foldl' cons pattern revPatterns
    , end
    )


cons :: Src.Pattern -> Src.Pattern -> Src.Pattern
cons tl hd =
  A.merge hd tl (Src.PCons hd tl)



-- EXPRESSION PART


exprPart :: Space.Parser E.Pattern Src.Pattern
exprPart =
  oneOf E.PStart
    [
      do  start <- getPosition
          upper <- Var.foreignUpper E.PStart
          end <- getPosition
          exprTermHelp (A.Region start end) upper start []
    ,
      do  eterm@(A.At (A.Region _ end) _) <- term
          Space.chomp E.PSpace
          return (eterm, end)
    ]


exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [Src.Pattern] -> Space.Parser E.Pattern Src.Pattern
exprTermHelp region upper start revArgs =
  do  end <- getPosition
      Space.chomp E.PSpace
      oneOfWithFallback
        [ do  Space.checkIndent end E.PIndentStart
              arg <- term
              exprTermHelp region upper start (arg:revArgs)
        ]
        ( A.at start end $
            case upper of
              Var.Unqualified name ->
                Src.PCtor region name (reverse revArgs)

              Var.Qualified home name ->
                Src.PCtorQual region home name (reverse revArgs)
        , end
        )


================================================
FILE: compiler/src/Parse/Primitives.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
module Parse.Primitives
  ( fromByteString
  , Parser(..)
  , State(..)
  , Row
  , Col
  , oneOf, oneOfWithFallback
  , inContext, specialize
  , getPosition, getCol, addLocation, addEnd
  , getIndent, setIndent, withIndent, withBacksetIndent
  , word1, word2
  , unsafeIndex, isWord, getCharWidth
  , Snippet(..)
  , fromSnippet
  )
  where


import Prelude hiding (length)
import qualified Control.Applicative as Applicative (Applicative(..))
import qualified Data.ByteString.Internal as B
import Data.Word (Word8, Word16)
import Foreign.Ptr (Ptr, plusPtr)
import Foreign.Storable (peek)
import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

import qualified Reporting.Annotation as A



-- PARSER


newtype Parser x a =
  Parser (
    forall b.
      State
      -> (a -> State -> b)                       -- consumed ok
      -> (a -> State -> b)                       -- empty ok
      -> (Row -> Col -> (Row -> Col -> x) -> b)  -- consumed err
      -> (Row -> Col -> (Row -> Col -> x) -> b)  -- empty err
      -> b
  )


data State = -- PERF try taking some out to avoid allocation
  State
    { _src :: ForeignPtr Word8
    , _pos :: !(Ptr Word8)
    , _end :: !(Ptr Word8)
    , _indent :: !Word16
    , _row :: !Row
    , _col :: !Col
    }


type Row = Word16
type Col = Word16



-- FUNCTOR


instance Functor (Parser x) where
  {-# INLINE fmap #-}
  fmap f (Parser parser) =
    Parser $ \state cok eok cerr eerr ->
      let
        cok' a s = cok (f a) s
        eok' a s = eok (f a) s
      in
      parser state cok' eok' cerr eerr



-- APPLICATIVE


instance Applicative.Applicative (Parser x) where
  {-# INLINE pure #-}
  pure value =
    Parser $ \state _ eok _ _ ->
      eok value state

  {-# INLINE (<*>) #-}
  (<*>) (Parser parserFunc) (Parser parserArg) =
    Parser $ \state cok eok cerr eerr ->
      let
        cokF func s1 =
          let
            cokA arg s2 = cok (func arg) s2
          in
          parserArg s1 cokA cokA cerr cerr

        eokF func s1 =
          let
            cokA arg s2 = cok (func arg) s2
            eokA arg s2 = eok (func arg) s2
          in
          parserArg s1 cokA eokA cerr eerr
      in
      parserFunc state cokF eokF cerr eerr



-- ONE OF


{-# INLINE oneOf #-}
oneOf :: (Row -> Col -> x) -> [Parser x a] -> Parser x a
oneOf toError parsers =
  Parser $ \state cok eok cerr eerr ->
    oneOfHelp state cok eok cerr eerr toError parsers


oneOfHelp
  :: State
  -> (a -> State -> b)
  -> (a -> State -> b)
  -> (Row -> Col -> (Row -> Col -> x) -> b)
  -> (Row -> Col -> (Row -> Col -> x) -> b)
  -> (Row -> Col -> x)
  -> [Parser x a]
  -> b
oneOfHelp state cok eok cerr eerr toError parsers =
  case parsers of
    Parser parser : parsers ->
      let
        eerr' _ _ _ =
          oneOfHelp state cok eok cerr eerr toError parsers
      in
      parser state cok eok cerr eerr'

    [] ->
      let
        (State _ _ _ _ row col) = state
      in
      eerr row col toError



-- ONE OF WITH FALLBACK


{-# INLINE oneOfWithFallback #-}
oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- PERF is this function okay? Worried about allocation/laziness with fallback values.
oneOfWithFallback parsers fallback =
  Parser $ \state cok eok cerr _ ->
    oowfHelp state cok eok cerr parsers fallback


oowfHelp
  :: State
  -> (a -> State -> b)
  -> (a -> State -> b)
  -> (Row -> Col -> (Row -> Col -> x) -> b)
  -> [Parser x a]
  -> a
  -> b
oowfHelp state cok eok cerr parsers fallback =
  case parsers of
    [] ->
      eok fallback state

    Parser parser : parsers ->
      let
        eerr' _ _ _ =
          oowfHelp state cok eok cerr parsers fallback
      in
      parser state cok eok cerr eerr'



-- MONAD


instance Monad (Parser x) where
  {-# INLINE (>>=) #-}
  (Parser parserA) >>= callback =
    Parser $ \state cok eok cerr eerr ->
      let
        cok' a s =
          case callback a of
            Parser parserB -> parserB s cok cok cerr cerr

        eok' a s =
          case callback a of
            Parser parserB -> parserB s cok eok cerr eerr
      in
      parserA state cok' eok' cerr eerr



-- FROM BYTESTRING


fromByteString :: Parser x a -> (Row -> Col -> x) -> B.ByteString -> Either x a
fromByteString (Parser parser) toBadEnd (B.PS fptr offset length) =
  B.accursedUnutterablePerformIO $
    let
      toOk' = toOk toBadEnd
      !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset
      !end = plusPtr pos length
      !result = parser (State fptr pos end 0 1 1) toOk' toOk' toErr toErr
    in
    do  touchForeignPtr fptr
        return result


toOk :: (Row -> Col -> x) -> a -> State -> Either x a
toOk toBadEnd !a (State _ pos end _ row col) =
  if pos == end
  then Right a
  else Left (toBadEnd row col)


toErr :: Row -> Col -> (Row -> Col -> x) -> Either x a
toErr row col toError =
  Left (toError row col)



-- FROM SNIPPET


data Snippet =
  Snippet
    { _fptr   :: ForeignPtr Word8
    , _offset :: Int
    , _length :: Int
    , _offRow :: Row
    , _offCol :: Col
    }


fromSnippet :: Parser x a -> (Row -> Col -> x) -> Snippet -> Either x a
fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =
  B.accursedUnutterablePerformIO $
    let
      toOk' = toOk toBadEnd
      !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset
      !end = plusPtr pos length
      !result = parser (State fptr pos end 0 row col) toOk' toOk' toErr toErr
    in
    do  touchForeignPtr fptr
        return result



-- POSITION


getCol :: Parser x Word16
getCol =
  Parser $ \state@(State _ _ _ _ _ col) _ eok _ _ ->
    eok col state


{-# INLINE getPosition #-}
getPosition :: Parser x A.Position
getPosition =
  Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->
    eok (A.Position row col) state


addLocation :: Parser x a -> Parser x (A.Located a)
addLocation (Parser parser) =
  Parser $ \state@(State _ _ _ _ sr sc) cok eok cerr eerr ->
    let
      cok' a s@(State _ _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
      eok' a s@(State _ _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
    in
    parser state cok' eok' cerr eerr


addEnd :: A.Position -> a -> Parser x (A.Located a)
addEnd start value =
  Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->
    eok (A.at start (A.Position row col) value) state



-- INDENT


getIndent :: Parser x Word16
getIndent =
  Parser $ \state@(State _ _ _ indent _ _) _ eok _ _ ->
    eok indent state


setIndent :: Word16 -> Parser x ()
setIndent indent =
  Parser $ \(State src pos end _ row col) _ eok _ _ ->
    let
      !newState = State src pos end indent row col
    in
    eok () newState


withIndent :: Parser x a -> Parser x a
withIndent (Parser parser) =
  Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->
    let
      cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)
      eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)
    in
    parser (State src pos end col row col) cok' eok' cerr eerr


withBacksetIndent :: Word16 -> Parser x a -> Parser x a
withBacksetIndent backset (Parser parser) =
  Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->
    let
      cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)
      eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)
    in
    parser (State src pos end (col - backset) row col) cok' eok' cerr eerr



-- CONTEXT


inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a
inContext addContext (Parser parserStart) (Parser parserA) =
  Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->
    let
      cerrA r c tx = cerr row col (addContext (tx r c))
      eerrA r c tx = eerr row col (addContext (tx r c))

      cokS _ s = parserA s cok cok cerrA cerrA
      eokS _ s = parserA s cok eok cerrA eerrA
    in
    parserStart state cokS eokS cerr eerr


specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a
specialize addContext (Parser parser) =
  Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->
    let
      cerr' r c tx = cerr row col (addContext (tx r c))
      eerr' r c tx = eerr row col (addContext (tx r c))
    in
    parser state cok eok cerr' eerr'



-- SYMBOLS


word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()
word1 word toError =
  Parser $ \(State src pos end indent row col) cok _ _ eerr ->
    if pos < end && unsafeIndex pos == word then
      let !newState = State src (plusPtr pos 1) end indent row (col + 1) in
      cok () newState
    else
      eerr row col toError


word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
word2 w1 w2 toError =
  Parser $ \(State src pos end indent row col) cok _ _ eerr ->
    let
      !pos1 = plusPtr pos 1
    in
    if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then
      let !newState = State src (plusPtr pos 2) end indent row (col + 2) in
      cok () newState
    else
      eerr row col toError



-- LOW-LEVEL CHECKS


unsafeIndex :: Ptr Word8 -> Word8
unsafeIndex ptr =
  B.accursedUnutterablePerformIO (peek ptr)


{-# INLINE isWord #-}
isWord :: Ptr Word8 -> Ptr Word8 -> Word8 -> Bool
isWord pos end word =
  pos < end && unsafeIndex pos == word


getCharWidth :: Word8 -> Int
getCharWidth word
  | word < 0x80 = 1
  | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."
  | word < 0xe0 = 2
  | word < 0xf0 = 3
  | word < 0xf8 = 4
  | True        = error "Need UTF-8 encoded input. Ran into unrecognized bits."


================================================
FILE: compiler/src/Parse/Shader.hs
================================================
{-# LANGUAGE BangPatterns, UnboxedTuples #-}
module Parse.Shader
  ( shader
  )
  where


import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.UTF8 as BS_UTF8
import qualified Data.Map as Map
import qualified Data.Name as Name
import Data.Word (Word8)
import Foreign.Ptr (Ptr, plusPtr, minusPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import qualified Language.GLSL.Parser as GLP
import qualified Language.GLSL.Syntax as GLS
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Error as Parsec

import qualified AST.Source as Src
import qualified AST.Utils.Shader as Shader
import Parse.Primitives (Parser, Row, Col)
import qualified Parse.Primitives as P
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- SHADER


shader :: A.Position -> Parser E.Expr Src.Expr
shader start@(A.Position row col) =
  do  block <- parseBlock
      shdr <- parseGlsl row col block
      end <- P.getPosition
      return (A.at start end (Src.Shader (Shader.fromChars block) shdr))



-- BLOCK


parseBlock :: Parser E.Expr [Char]
parseBlock =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    let
      !pos6 = plusPtr pos 6
    in
    if pos6 <= end
      && P.unsafeIndex (        pos  ) == 0x5B {- [ -}
      && P.unsafeIndex (plusPtr pos 1) == 0x67 {- g -}
      && P.unsafeIndex (plusPtr pos 2) == 0x6C {- l -}
      && P.unsafeIndex (plusPtr pos 3) == 0x73 {- s -}
      && P.unsafeIndex (plusPtr pos 4) == 0x6C {- l -}
      && P.unsafeIndex (plusPtr pos 5) == 0x7C {- | -}
    then
      let
        (# status, newPos, newRow, newCol #) =
          eatShader pos6 end row (col + 6)
      in
      case status of
        Good ->
          let
            !off = minusPtr pos6 (unsafeForeignPtrToPtr src)
            !len = minusPtr newPos pos6
            !block = BS_UTF8.toString (B.PS src off len)
            !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2)
          in
          cok block newState

        Unending ->
          cerr row col E.EndlessShader

    else
      eerr row col E.Start


data Status
  = Good
  | Unending


eatShader :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
eatShader pos end row col =
  if pos >= end then
    (# Unending, pos, row, col #)

  else
    let !word = P.unsafeIndex pos in
    if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then
      (# Good, pos, row, col #)

    else if word == 0x0A {- \n -} then
      eatShader (plusPtr pos 1) end (row + 1) 1

    else
      let !newPos = plusPtr pos (P.getCharWidth word) in
      eatShader newPos end row (col + 1)



-- GLSL


parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types
parseGlsl startRow startCol src =
  case GLP.parse src of
    Right (GLS.TranslationUnit decls) ->
      return (foldr addInput emptyTypes (concatMap extractInputs decls))

    Left err ->
      let
        pos = Parsec.errorPos err
        row = fromIntegral (Parsec.sourceLine pos)
        col = fromIntegral (Parsec.sourceColumn pos)
        msg =
          Parsec.showErrorMessages
            "or"
            "unknown parse error"
            "expecting"
            "unexpected"
            "end of input"
            (Parsec.errorMessages err)
      in
      if row == 1
        then failure startRow (startCol + 6 + col) msg
        else failure (startRow + row - 1) col msg


failure :: Row -> Col -> [Char] -> Parser E.Expr a
failure row col msg =
  P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ ->
    cerr row col (E.ShaderProblem msg)



-- INPUTS


emptyTypes :: Shader.Types
emptyTypes =
  Shader.Types Map.empty Map.empty Map.empty


addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types
addInput (qual, tipe, name) glDecls =
  case qual of
    GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
    GLS.Uniform   -> glDecls { Shader._uniform = Map.insert (Name.fromChars name) tipe (Shader._uniform glDecls) }
    GLS.Varying   -> glDecls { Shader._varying = Map.insert (Name.fromChars name) tipe (Shader._varying glDecls) }
    _             -> error "Should never happen due to `extractInputs` function"


extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])]
extractInputs decl =
  case decl of
    GLS.Declaration
      (GLS.InitDeclaration
         (GLS.TypeDeclarator
            (GLS.FullType
               (Just (GLS.TypeQualSto qual))
               (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1))))
         [GLS.InitDecl name _mexpr2 _mexpr3]
      ) ->
        case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of
          False -> []
          True ->
              case tipe of
                GLS.Vec2 -> [(qual, Shader.V2, name)]
                GLS.Vec3 -> [(qual, Shader.V3, name)]
                GLS.Vec4 -> [(qual, Shader.V4, name)]
                GLS.Mat4 -> [(qual, Shader.M4, name)]
                GLS.Int -> [(qual, Shader.Int, name)]
                GLS.Float -> [(qual, Shader.Float, name)]
                GLS.Sampler2D -> [(qual, Shader.Texture, name)]
                _ -> []
    _ -> []




================================================
FILE: compiler/src/Parse/Space.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
module Parse.Space
  ( Parser
  --
  , chomp
  , chompAndCheckIndent
  --
  , checkIndent
  , checkAligned
  , checkFreshLine
  --
  , docComment
  )
  where


import Data.Word (Word8, Word16)
import Foreign.Ptr (Ptr, plusPtr, minusPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

import qualified AST.Source as Src
import Parse.Primitives (Row, Col)
import qualified Parse.Primitives as P
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- SPACE PARSING


type Parser x a =
  P.Parser x (a, A.Position)



-- CHOMP


chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x ()
chomp toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
    let
      (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
    in
    case status of
      Good ->
        let
          !newState = P.State src newPos end indent newRow newCol
        in
        cok () newState

      HasTab               -> cerr newRow newCol (toError E.HasTab)
      EndlessMultiComment  -> cerr newRow newCol (toError E.EndlessMultiComment)



-- CHECKS -- to be called right after a `chomp`


checkIndent :: A.Position -> (Row -> Col -> x) -> P.Parser x ()
checkIndent (A.Position endRow endCol) toError =
  P.Parser $ \state@(P.State _ _ _ indent _ col) _ eok _ eerr ->
    if col > indent && col > 1
    then eok () state
    else eerr endRow endCol toError


checkAligned :: (Word16 -> Row -> Col -> x) -> P.Parser x ()
checkAligned toError =
  P.Parser $ \state@(P.State _ _ _ indent row col) _ eok _ eerr ->
    if col == indent
    then eok () state
    else eerr row col (toError indent)


checkFreshLine :: (Row -> Col -> x) -> P.Parser x ()
checkFreshLine toError =
  P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
    if col == 1
    then eok () state
    else eerr row col toError



-- CHOMP AND CHECK


chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x ()
chompAndCheckIndent toSpaceError toIndentError =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
    let
      (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
    in
    case status of
      Good ->
        if newCol > indent && newCol > 1
        then

          let
            !newState = P.State src newPos end indent newRow newCol
          in
          cok () newState

        else
          cerr row col toIndentError

      HasTab               -> cerr newRow newCol (toSpaceError E.HasTab)
      EndlessMultiComment  -> cerr newRow newCol (toSpaceError E.EndlessMultiComment)



-- EAT SPACES


data Status
  = Good
  | HasTab
  | EndlessMultiComment


eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
eatSpaces pos end row col =
  if pos >= end then
    (# Good, pos, row, col #)

  else
    case P.unsafeIndex pos of
      0x20 {-   -} ->
        eatSpaces (plusPtr pos 1) end row (col + 1)

      0x0A {- \n -} ->
        eatSpaces (plusPtr pos 1) end (row + 1) 1

      0x7B {- { -} ->
        eatMultiComment pos end row col

      0x2D {- - -} ->
        let !pos1 = plusPtr pos 1 in
        if pos1 < end && P.unsafeIndex pos1 == 0x2D {- - -} then
          eatLineComment (plusPtr pos 2) end row (col + 2)
        else
          (# Good, pos, row, col #)

      0x0D {- \r -} ->
        eatSpaces (plusPtr pos 1) end row col

      0x09 {- \t -} ->
        (# HasTab, pos, row, col #)

      _ ->
        (# Good, pos, row, col #)



-- LINE COMMENTS


eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
eatLineComment pos end row col =
  if pos >= end then
    (# Good, pos, row, col #)

  else
    let !word = P.unsafeIndex pos in
    if word == 0x0A {- \n -} then
      eatSpaces (plusPtr pos 1) end (row + 1) 1
    else
      let !newPos = plusPtr pos (P.getCharWidth word) in
      eatLineComment newPos end row (col + 1)



-- MULTI COMMENTS


eatMultiComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
eatMultiComment pos end row col =
  let
    !pos1 = plusPtr pos 1
    !pos2 = plusPtr pos 2
  in
  if pos2 >= end then
    (# Good, pos, row, col #)

  else if P.unsafeIndex pos1 == 0x2D {- - -} then

    if P.unsafeIndex pos2 == 0x7C {- | -} then
      (# Good, pos, row, col #)
    else
      let
        (# status, newPos, newRow, newCol #) =
          eatMultiCommentHelp pos2 end row (col + 2) 1
      in
      case status of
        MultiGood    -> eatSpaces newPos end newRow newCol
        MultiTab     -> (# HasTab, newPos, newRow, newCol #)
        MultiEndless -> (# EndlessMultiComment, pos, row, col #)

  else
    (# Good, pos, row, col #)


data MultiStatus
  = MultiGood
  | MultiTab
  | MultiEndless


eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #)
eatMultiCommentHelp pos end row col openComments =
  if pos >= end then
    (# MultiEndless, pos, row, col #)

  else
    let !word = P.unsafeIndex pos in
    if word == 0x0A {- \n -} then
      eatMultiCommentHelp (plusPtr pos 1) end (row + 1) 1 openComments

    else if word == 0x09 {- \t -} then
      (# MultiTab, pos, row, col #)

    else if word == 0x2D {- - -} && P.isWord (plusPtr pos 1) end 0x7D {- } -} then
      if openComments == 1 then
        (# MultiGood, plusPtr pos 2, row, col + 2 #)
      else
        eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments - 1)

    else if word == 0x7B {- { -} && P.isWord (plusPtr pos 1) end 0x2D {- - -} then
      eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)

    else
      let !newPos = plusPtr pos (P.getCharWidth word) in
      eatMultiCommentHelp newPos end row (col + 1) openComments



-- DOCUMENTATION COMMENT


docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment
docComment toExpectation toSpaceError =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    let
      !pos3 = plusPtr pos 3
    in
    if pos3 <= end
      && P.unsafeIndex (        pos  ) == 0x7B {- { -}
      && P.unsafeIndex (plusPtr pos 1) == 0x2D {- - -}
      && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
    then
      let
        !col3 = col + 3

        (# status, newPos, newRow, newCol #) =
           eatMultiCommentHelp pos3 end row col3 1
      in
      case status of
        MultiGood ->
          let
            !off = minusPtr pos3 (unsafeForeignPtrToPtr src)
            !len = minusPtr newPos pos3 - 2
            !snippet = P.Snippet src off len row col3
            !comment = Src.Comment snippet
            !newState = P.State src newPos end indent newRow newCol
          in
          cok comment newState

        MultiTab -> cerr newRow newCol (toSpaceError E.HasTab)
        MultiEndless -> cerr row col (toSpaceError E.EndlessMultiComment)
    else
      eerr row col toExpectation


================================================
FILE: compiler/src/Parse/String.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
module Parse.String
  ( string
  , character
  )
  where


import qualified Data.Utf8 as Utf8
import Data.Word (Word8, Word16)
import Foreign.Ptr (Ptr, plusPtr, minusPtr)

import qualified Elm.String as ES
import Parse.Primitives (Parser, Row, Col)
import qualified Parse.Number as Number
import qualified Parse.Primitives as P
import qualified Reporting.Error.Syntax as E



-- CHARACTER


character :: (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x ES.String
character toExpectation toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    if pos >= end || P.unsafeIndex pos /= 0x27 {- ' -} then
      eerr row col toExpectation

    else
      case chompChar (plusPtr pos 1) end row (col + 1) 0 placeholder of
        Good newPos newCol numChars mostRecent ->
          if numChars /= 1 then
            cerr row col (toError (E.CharNotString (fromIntegral (newCol - col))))
          else
            let
              !newState = P.State src newPos end indent row newCol
              !char = ES.fromChunks [mostRecent]
            in
            cok char newState

        CharEndless newCol ->
          cerr row newCol (toError E.CharEndless)

        CharEscape r c escape ->
          cerr r c (toError (E.CharEscape escape))


data CharResult
  = Good (Ptr Word8) Col Word16 ES.Chunk
  | CharEndless Col
  | CharEscape Row Col E.Escape


chompChar :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> ES.Chunk -> CharResult
chompChar pos end row col numChars mostRecent =
  if pos >= end then
    CharEndless col

  else
    let
      !word = P.unsafeIndex pos
    in
      if word == 0x27 {- ' -} then
        Good (plusPtr pos 1) (col + 1) numChars mostRecent

      else if word == 0x0A {- \n -} then
        CharEndless col

      else if word == 0x22 {- " -} then
        chompChar (plusPtr pos 1) end row (col + 1) (numChars + 1) doubleQuote

      else if word == 0x5C {- \ -} then
        case eatEscape (plusPtr pos 1) end row col of
          EscapeNormal ->
            chompChar (plusPtr pos 2) end row (col + 2) (numChars + 1) (ES.Slice pos 2)

          EscapeUnicode delta code ->
            chompChar (plusPtr pos delta) end row (col + fromIntegral delta) (numChars + 1) (ES.CodePoint code)

          EscapeProblem r c badEscape ->
            CharEscape r c badEscape

          EscapeEndOfFile ->
            CharEndless col

      else
        let
          !width = P.getCharWidth word
          !newPos = plusPtr pos width
        in
        chompChar newPos end row (col + 1) (numChars + 1) (ES.Slice pos width)



-- STRINGS


string :: (Row -> Col -> x) -> (E.String -> Row -> Col -> x) -> Parser x ES.String
string toExpectation toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    if isDoubleQuote pos end then

      let
        !pos1 = plusPtr pos 1
      in
      case
        if isDoubleQuote pos1 end then
          let !pos2 = plusPtr pos 2 in
          if isDoubleQuote pos2 end then
            let
              !pos3 = plusPtr pos 3
              !col3 = col + 3
            in
            multiString pos3 end row col3 pos3 row col mempty
          else
            Ok pos2 row (col + 2) Utf8.empty
        else
          singleString pos1 end row (col + 1) pos1 mempty
      of
        Ok newPos newRow newCol utf8 ->
          let
            !newState =
              P.State src newPos end indent newRow newCol
          in
          cok utf8 newState

        Err r c x ->
          cerr r c (toError x)

    else
      eerr row col toExpectation


{-# INLINE isDoubleQuote #-}
isDoubleQuote :: Ptr Word8 -> Ptr Word8 -> Bool
isDoubleQuote pos end =
  pos < end && P.unsafeIndex pos == 0x22 {- " -}


data StringResult
  = Ok (Ptr Word8) Row Col !ES.String
  | Err Row Col E.String


finalize :: Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> ES.String
finalize start end revChunks =
  ES.fromChunks $ reverse $
    if start == end then
      revChunks
    else
      ES.Slice start (minusPtr end start) : revChunks


addEscape :: ES.Chunk -> Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> [ES.Chunk]
addEscape chunk start end revChunks =
  if start == end then
    chunk : revChunks
  else
    chunk : ES.Slice start (minusPtr end start) : revChunks



-- SINGLE STRINGS


singleString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [ES.Chunk] -> StringResult
singleString pos end row col initialPos revChunks =
  if pos >= end then
    Err row col E.StringEndless_Single

  else
    let
      !word = P.unsafeIndex pos
    in
      if word == 0x22 {- " -} then
        Ok (plusPtr pos 1) row (col + 1) $
          finalize initialPos pos revChunks

      else if word == 0x0A {- \n -} then
        Err row col E.StringEndless_Single

      else if word == 0x27 {- ' -} then
        let !newPos = plusPtr pos 1 in
        singleString newPos end row (col + 1) newPos $
          addEscape singleQuote initialPos pos revChunks

      else if word == 0x5C {- \ -} then
        case eatEscape (plusPtr pos 1) end row col of
          EscapeNormal ->
            singleString (plusPtr pos 2) end row (col + 2) initialPos revChunks

          EscapeUnicode delta code ->
            let !newPos = plusPtr pos delta in
            singleString newPos end row (col + fromIntegral delta) newPos $
              addEscape (ES.CodePoint code) initialPos pos revChunks

          EscapeProblem r c x ->
            Err r c (E.StringEscape x)

          EscapeEndOfFile ->
            Err row (col + 1) E.StringEndless_Single

      else
        let !newPos = plusPtr pos (P.getCharWidth word) in
        singleString newPos end row (col + 1) initialPos revChunks



-- MULTI STRINGS


multiString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> Row -> Col -> [ES.Chunk] -> StringResult
multiString pos end row col initialPos sr sc revChunks =
  if pos >= end then
    Err sr sc E.StringEndless_Multi

  else
    let !word = P.unsafeIndex pos in
    if word == 0x22 {- " -} && isDoubleQuote (plusPtr pos 1) end && isDoubleQuote (plusPtr pos 2) end then
      Ok (plusPtr pos 3) row (col + 3) $
        finalize initialPos pos revChunks

    else if word == 0x27 {- ' -} then
      let !pos1 = plusPtr pos 1 in
      multiString pos1 end row (col + 1) pos1 sr sc $
        addEscape singleQuote initialPos pos revChunks

    else if word == 0x0A {- \n -} then
      let !pos1 = plusPtr pos 1 in
      multiString pos1 end (row + 1) 1 pos1 sr sc $
        addEscape newline initialPos pos revChunks

    else if word == 0x0D {- \r -} then
      let !pos1 = plusPtr pos 1 in
      multiString pos1 end row col pos1 sr sc $
        addEscape carriageReturn initialPos pos revChunks

    else if word == 0x5C {- \ -} then
      case eatEscape (plusPtr pos 1) end row col of
        EscapeNormal ->
          multiString (plusPtr pos 2) end row (col + 2) initialPos sr sc revChunks

        EscapeUnicode delta code ->
          let !newPos = plusPtr pos delta in
          multiString newPos end row (col + fromIntegral delta) newPos sr sc $
            addEscape (ES.CodePoint code) initialPos pos revChunks

        EscapeProblem r c x ->
          Err r c (E.StringEscape x)

        EscapeEndOfFile ->
          Err sr sc E.StringEndless_Multi

    else
      let !newPos = plusPtr pos (P.getCharWidth word) in
      multiString newPos end row (col + 1) initialPos sr sc revChunks



-- ESCAPE CHARACTERS


data Escape
  = EscapeNormal
  | EscapeUnicode !Int !Int
  | EscapeEndOfFile
  | EscapeProblem Row Col E.Escape


eatEscape :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape
eatEscape pos end row col =
  if pos >= end then
    EscapeEndOfFile

  else
    case P.unsafeIndex pos of
      0x6E {- n -} -> EscapeNormal
      0x72 {- r -} -> EscapeNormal
      0x74 {- t -} -> EscapeNormal
      0x22 {- " -} -> EscapeNormal
      0x27 {- ' -} -> EscapeNormal
      0x5C {- \ -} -> EscapeNormal
      0x75 {- u -} -> eatUnicode (plusPtr pos 1) end row col
      _            -> EscapeProblem row col E.EscapeUnknown


eatUnicode :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape
eatUnicode pos end row col =
  if pos >= end || P.unsafeIndex pos /= 0x7B {- { -} then
    EscapeProblem row col (E.BadUnicodeFormat 2)
  else
    let
      !digitPos = plusPtr pos 1
      (# newPos, code #) = Number.chompHex digitPos end
      !numDigits = minusPtr newPos digitPos
    in
    if newPos >= end || P.unsafeIndex newPos /= 0x7D {- } -} then
      EscapeProblem row col $ E.BadUnicodeFormat (2 + fromIntegral (minusPtr newPos pos))

    else if code < 0 || 0x10FFFF < code then
      EscapeProblem row col $ E.BadUnicodeCode (3 + fromIntegral (minusPtr newPos pos))

    else if numDigits < 4 || 6 < numDigits then
      EscapeProblem row col $
        E.BadUnicodeLength
          (3 + fromIntegral (minusPtr newPos pos))
          numDigits
          code

    else
      EscapeUnicode (numDigits + 4) code


{-# NOINLINE singleQuote #-}
singleQuote :: ES.Chunk
singleQuote =
  ES.Escape 0x27 {-'-}


{-# NOINLINE doubleQuote #-}
doubleQuote :: ES.Chunk
doubleQuote =
  ES.Escape 0x22 {-"-}


{-# NOINLINE newline #-}
newline :: ES.Chunk
newline =
  ES.Escape 0x6E {-n-}


{-# NOINLINE carriageReturn #-}
carriageReturn :: ES.Chunk
carriageReturn =
  ES.Escape 0x72 {-r-}


{-# NOINLINE placeholder #-}
placeholder :: ES.Chunk
placeholder =
  ES.CodePoint 0xFFFD {-replacement character-}


================================================
FILE: compiler/src/Parse/Symbol.hs
================================================
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
module Parse.Symbol
  ( operator
  , BadOperator(..)
  , binopCharSet
  )
  where


import qualified Data.Char as Char
import qualified Data.IntSet as IntSet
import qualified Data.Name as Name
import qualified Data.Vector as Vector
import Foreign.Ptr (Ptr, plusPtr, minusPtr)
import GHC.Word (Word8)

import Parse.Primitives (Parser, Row, Col)
import qualified Parse.Primitives as P



-- OPERATOR


data BadOperator
  = BadDot
  | BadPipe
  | BadArrow
  | BadEquals
  | BadHasType


operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name
operator toExpectation toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    let !newPos = chompOps pos end in
    if pos == newPos then
      eerr row col toExpectation

    else
      case Name.fromPtr pos newPos of
        "."  -> eerr row col (toError BadDot)
        "|"  -> cerr row col (toError BadPipe)
        "->" -> cerr row col (toError BadArrow)
        "="  -> cerr row col (toError BadEquals)
        ":"  -> cerr row col (toError BadHasType)
        op   ->
          let
            !newCol = col + fromIntegral (minusPtr newPos pos)
            !newState = P.State src newPos end indent row newCol
          in
          cok op newState


chompOps :: Ptr Word8 -> Ptr Word8 -> Ptr Word8
chompOps pos end =
  if pos < end && isBinopCharHelp (P.unsafeIndex pos) then
    chompOps (plusPtr pos 1) end
  else
    pos


{-# INLINE isBinopCharHelp #-}
isBinopCharHelp :: Word8 -> Bool
isBinopCharHelp word =
  word < 128 && Vector.unsafeIndex binopCharVector (fromIntegral word)


{-# NOINLINE binopCharVector #-}
binopCharVector :: Vector.Vector Bool
binopCharVector =
  Vector.generate 128 (\i -> IntSet.member i binopCharSet)


{-# NOINLINE binopCharSet #-}
binopCharSet :: IntSet.IntSet
binopCharSet =
  IntSet.fromList (map Char.ord "+-/*=.<>:&|^?%!")


================================================
FILE: compiler/src/Parse/Type.hs
================================================
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# LANGUAGE OverloadedStrings #-}
module Parse.Type
  ( expression
  , variant
  )
  where


import qualified Data.Name as Name

import qualified AST.Source as Src
import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, specialize, oneOf, oneOfWithFallback, word1, word2)
import qualified Parse.Space as Space
import qualified Parse.Variable as Var
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- TYPE TERMS


term :: Parser E.Type Src.Type
term =
  do  start <- getPosition
      oneOf E.TStart
        [
          -- types with no arguments (Int, Float, etc.)
          do  upper <- Var.foreignUpper E.TStart
              end <- getPosition
              let region = A.Region start end
              return $ A.At region $
                case upper of
                  Var.Unqualified name ->
                    Src.TType region name []

                  Var.Qualified home name ->
                    Src.TTypeQual region home name []
        ,
          -- type variables
          do  var <- Var.lower E.TStart
              addEnd start (Src.TVar var)
        ,
          -- tuples
          inContext E.TTuple (word1 0x28 {-(-} E.TStart) $
            oneOf E.TTupleOpen
              [ do  word1 0x29 {-)-} E.TTupleOpen
                    addEnd start Src.TUnit
              , do  Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType1
                    (tipe, end) <- specialize E.TTupleType expression
                    Space.checkIndent end E.TTupleIndentEnd
                    chompTupleEnd start tipe []
              ]
        ,
          -- records
          inContext E.TRecord (word1 0x7B {- { -} E.TStart) $
            do  Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentOpen
                oneOf E.TRecordOpen
                  [ do  word1 0x7D {-}-} E.TRecordEnd
                        addEnd start (Src.TRecord [] Nothing)
                  , do  name <- addLocation (Var.lower E.TRecordField)
                        Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon
                        oneOf E.TRecordColon
                          [ do  word1 0x7C {-|-} E.TRecordColon
                                Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField
                                field <- chompField
                                fields <- chompRecordEnd [field]
                                addEnd start (Src.TRecord fields (Just name))
                          , do  word1 0x3A {-:-} E.TRecordColon
                                Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType
                                (tipe, end) <- specialize E.TRecordType expression
                                Space.checkIndent end E.TRecordIndentEnd
                                fields <- chompRecordEnd [(name, tipe)]
                                addEnd start (Src.TRecord fields Nothing)
                          ]
                  ]
        ]



-- TYPE EXPRESSIONS


expression :: Space.Parser E.Type Src.Type
expression =
  do  start <- getPosition
      term1@(tipe1, end1) <-
        oneOf E.TStart
          [ app start
          , do  eterm <- term
                end <- getPosition
                Space.chomp E.TSpace
                return (eterm, end)
          ]
      oneOfWithFallback
        [ do  Space.checkIndent end1 E.TIndentStart -- should never trigger
              word2 0x2D 0x3E {-->-} E.TStart -- could just be another type instead
              Space.chompAndCheckIndent E.TSpace E.TIndentStart
              (tipe2, end2) <- expression
              let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)
              return ( tipe, end2 )
        ]
        term1



-- TYPE CONSTRUCTORS


app :: A.Position -> Space.Parser E.Type Src.Type
app start =
  do  upper <- Var.foreignUpper E.TStart
      upperEnd <- getPosition
      Space.chomp E.TSpace
      (args, end) <- chompArgs [] upperEnd

      let region = A.Region start upperEnd
      let tipe =
            case upper of
              Var.Unqualified name ->
                Src.TType region name args

              Var.Qualified home name ->
                Src.TTypeQual region home name args

      return ( A.at start end tipe, end )


chompArgs :: [Src.Type] -> A.Position -> Space.Parser E.Type [Src.Type]
chompArgs args end =
  oneOfWithFallback
    [ do  Space.checkIndent end E.TIndentStart
          arg <- term
          newEnd <- getPosition
          Space.chomp E.TSpace
          chompArgs (arg:args) newEnd
    ]
    (reverse args, end)



-- TUPLES


chompTupleEnd :: A.Position -> Src.Type -> [Src.Type] -> Parser E.TTuple Src.Type
chompTupleEnd start firstType revTypes =
  oneOf E.TTupleEnd
    [ do  word1 0x2C {-,-} E.TTupleEnd
          Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentTypeN
          (tipe, end) <- specialize E.TTupleType expression
          Space.checkIndent end E.TTupleIndentEnd
          chompTupleEnd start firstType (tipe : revTypes)
    , do  word1 0x29 {-)-} E.TTupleEnd
          case reverse revTypes of
            [] ->
              return firstType

            secondType : otherTypes ->
              addEnd start (Src.TTuple firstType secondType otherTypes)
    ]



-- RECORD


type Field = ( A.Located Name.Name, Src.Type )


chompRecordEnd :: [Field] -> Parser E.TRecord [Field]
chompRecordEnd fields =
  oneOf E.TRecordEnd
    [ do  word1 0x2C {-,-} E.TRecordEnd
          Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField
          field <- chompField
          chompRecordEnd (field : fields)
    , do  word1 0x7D {-}-} E.TRecordEnd
          return (reverse fields)
    ]


chompField :: Parser E.TRecord Field
chompField =
  do  name <- addLocation (Var.lower E.TRecordField)
      Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon
      word1 0x3A {-:-} E.TRecordColon
      Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType
      (tipe, end) <- specialize E.TRecordType expression
      Space.checkIndent end E.TRecordIndentEnd
      return (name, tipe)



-- VARIANT


variant :: Space.Parser E.CustomType (A.Located Name.Name, [Src.Type])
variant =
  do  name@(A.At (A.Region _ nameEnd) _) <- addLocation (Var.upper E.CT_Variant)
      Space.chomp E.CT_Space
      (args, end) <- specialize E.CT_VariantArg (chompArgs [] nameEnd)
      return ( (name, args), end )


================================================
FILE: compiler/src/Parse/Variable.hs
================================================
{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
module Parse.Variable
  ( lower
  , upper
  , moduleName
  , Upper(..)
  , foreignUpper
  , foreignAlpha
  , chompInnerChars
  , getUpperWidth
  , getInnerWidth
  , getInnerWidthHelp
  , reservedWords
  )
  where


import qualified Data.Char as Char
import qualified Data.Name as Name
import qualified Data.Set as Set
import Data.Word (Word8)
import Foreign.Ptr (Ptr, plusPtr)
import GHC.Exts (Char(C#), Int#, (+#), (-#), chr#, uncheckedIShiftL#, word2Int#, word8ToWord#)
import GHC.Word (Word8(W8#))

import qualified AST.Source as Src
import Parse.Primitives (Parser, Row, Col, unsafeIndex)
import qualified Parse.Primitives as P



-- LOCAL UPPER


upper :: (Row -> Col -> x) -> Parser x Name.Name
upper toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let (# newPos, newCol #) = chompUpper pos end col in
    if pos == newPos then
      eerr row col toError
    else
      let !name = Name.fromPtr pos newPos in
      cok name (P.State src newPos end indent row newCol)



-- LOCAL LOWER


lower :: (Row -> Col -> x) -> Parser x Name.Name
lower toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let (# newPos, newCol #) = chompLower pos end col in
    if pos == newPos then
      eerr row col toError
    else
      let !name = Name.fromPtr pos newPos in
      if Set.member name reservedWords then
        eerr row col toError
      else
        let
          !newState =
            P.State src newPos end indent row newCol
        in
        cok name newState


{-# NOINLINE reservedWords #-}
reservedWords :: Set.Set Name.Name  -- PERF try using a trie instead
reservedWords =
  Set.fromList
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    ]



-- MODULE NAME


moduleName :: (Row -> Col -> x) -> Parser x Name.Name
moduleName toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    let
      (# pos1, col1 #) = chompUpper pos end col
    in
    if pos == pos1 then
      eerr row col toError
    else
      let
        (# status, newPos, newCol #) = moduleNameHelp pos1 end col1
      in
      case status of
        Good ->
          let
            !name = Name.fromPtr pos newPos
            !newState = P.State src newPos end indent row newCol
          in
          cok name newState

        Bad ->
          cerr row newCol toError


data ModuleNameStatus
  = Good
  | Bad


moduleNameHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# ModuleNameStatus, Ptr Word8, Col #)
moduleNameHelp pos end col =
  if isDot pos end then
    let
      !pos1 = plusPtr pos 1
      (# newPos, newCol #) = chompUpper pos1 end (col + 1)
    in
    if pos1 == newPos then
      (# Bad, newPos, newCol #)
    else
      moduleNameHelp newPos end newCol

  else
    (# Good, pos, col #)



-- FOREIGN UPPER


data Upper
  = Unqualified Name.Name
  | Qualified Name.Name Name.Name


foreignUpper :: (Row -> Col -> x) -> Parser x Upper
foreignUpper toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
    if upperStart == upperEnd then
      eerr row newCol toError
    else
      let
        !newState = P.State src upperEnd end indent row newCol
        !name = Name.fromPtr upperStart upperEnd
        !upperName =
          if upperStart == pos then
            Unqualified name
          else
            let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
            Qualified home name
      in
      cok upperName newState


foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
foreignUpperHelp pos end col =
  let
    (# newPos, newCol #) = chompUpper pos end col
  in
  if pos == newPos then
    (# pos, pos, col #)

  else if isDot newPos end then
    foreignUpperHelp (plusPtr newPos 1) end (newCol + 1)

  else
    (# pos, newPos, newCol #)



-- FOREIGN ALPHA


foreignAlpha :: (Row -> Col -> x) -> Parser x Src.Expr_
foreignAlpha toError =
  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
    let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
    if alphaStart == alphaEnd then
      eerr row newCol toError
    else
      let
        !newState = P.State src alphaEnd end indent row newCol
        !name = Name.fromPtr alphaStart alphaEnd
      in
      if alphaStart == pos then
        if Set.member name reservedWords then
          eerr row col toError
        else
          cok (Src.Var varType name) newState
      else
        let !home = Name.fromPtr pos (plusPtr alphaStart (-1)) in
        cok (Src.VarQual varType home name) newState


foreignAlphaHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col, Src.VarType #)
foreignAlphaHelp pos end col =
  let
    (# lowerPos, lowerCol #) = chompLower pos end col
  in
  if pos < lowerPos then
    (# pos, lowerPos, lowerCol, Src.LowVar #)

  else
    let
      (# upperPos, upperCol #) = chompUpper pos end col
    in
    if pos == upperPos then
      (# pos, pos, col, Src.CapVar #)

    else if isDot upperPos end then
      foreignAlphaHelp (plusPtr upperPos 1) end (upperCol + 1)

    else
      (# pos, upperPos, upperCol, Src.CapVar #)



---- CHAR CHOMPERS ----



-- DOTS


{-# INLINE isDot #-}
isDot :: Ptr Word8 -> Ptr Word8 -> Bool
isDot pos end =
  pos < end && unsafeIndex pos == 0x2e {- . -}



-- UPPER CHARS


chompUpper :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Col #)
chompUpper pos end col =
  let !width = getUpperWidth pos end in
  if width == 0 then
    (# pos, col #)
  else
    chompInnerChars (plusPtr pos width) end (col + 1)


{-# INLINE getUpperWidth #-}
getUpperWidth :: Ptr Word8 -> Ptr Word8 -> Int
getUpperWidth pos end =
  if pos < end then
    getUpperWidthHelp pos end (unsafeIndex pos)
  else
    0


{-# INLINE getUpperWidthHelp #-}
getUpperWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
getUpperWidthHelp pos _ word
  | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
  | word < 0xc0 = 0
  | word < 0xe0 = if Char.isUpper (chr2 pos word) then 2 else 0
  | word < 0xf0 = if Char.isUpper (chr3 pos word) then 3 else 0
  | word < 0xf8 = if Char.isUpper (chr4 pos word) then 4 else 0
  | True        = 0



-- LOWER CHARS


chompLower :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Col #)
chompLower pos end col =
  let !width = getLowerWidth pos end in
  if width == 0 then
    (# pos, col #)
  else
    chompInnerChars (plusPtr pos width) end (col + 1)


{-# INLINE getLowerWidth #-}
getLowerWidth :: Ptr Word8 -> Ptr Word8 -> Int
getLowerWidth pos end =
  if pos < end then
    getLowerWidthHelp pos end (unsafeIndex pos)
  else
    0


{-# INLINE getLowerWidthHelp #-}
getLowerWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
getLowerWidthHelp pos _ word
  | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
  | word < 0xc0 = 0
  | word < 0xe0 = if Char.isLower (chr2 pos word) then 2 else 0
  | word < 0xf0 = if Char.isLower (chr3 pos word) then 3 else 0
  | word < 0xf8 = if Char.isLower (chr4 pos word) then 4 else 0
  | True        = 0



-- INNER CHARS


chompInnerChars :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Col #)
chompInnerChars !pos end !col =
  let !width = getInnerWidth pos end in
  if width == 0 then
    (# pos, col #)
  else
    chompInnerChars (plusPtr pos width) end (col + 1)


getInnerWidth :: Ptr Word8 -> Ptr Word8 -> Int
getInnerWidth pos end =
  if pos < end then
    getInnerWidthHelp pos end (unsafeIndex pos)
  else
    0


{-# INLINE getInnerWidthHelp #-}
getInnerWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
getInnerWidthHelp pos _ word
  | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
  | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
  | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 1
  | word == 0x5F {- _ -} = 1
  | word < 0xc0 = 0
  | word < 0xe0 = if Char.isAlpha (chr2 pos word) then 2 else 0
  | word < 0xf0 = if Char.isAlpha (chr3 pos word) then 3 else 0
  | word < 0xf8 = if Char.isAlpha (chr4 pos word) then 4 else 0
  | True        = 0



-- EXTRACT CHARACTERS


{-# INLINE chr2 #-}
chr2 :: Ptr Word8 -> Word8 -> Char
chr2 pos firstWord =
  let
    !i1# = unpack firstWord
    !i2# = unpack (unsafeIndex (plusPtr pos 1))
    !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#
    !c2# = i2# -# 0x80#
  in
  C# (chr# (c1# +# c2#))


{-# INLINE chr3 #-}
chr3 :: Ptr Word8 -> Word8 -> Char
chr3 pos firstWord =
  let
    !i1# = unpack firstWord
    !i2# = unpack (unsafeIndex (plusPtr pos 1))
    !i3# = unpack (unsafeIndex (plusPtr pos 2))
    !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#
    !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#
    !c3# = i3# -# 0x80#
  in
  C# (chr# (c1# +# c2# +# c3#))


{-# INLINE chr4 #-}
chr4 :: Ptr Word8 -> Word8 -> Char
chr4 pos firstWord =
  let
    !i1# = unpack firstWord
    !i2# = unpack (unsafeIndex (plusPtr pos 1))
    !i3# = unpack (unsafeIndex (plusPtr pos 2))
    !i4# = unpack (unsafeIndex (plusPtr pos 3))
    !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
    !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
    !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
    !c4# = i4# -# 0x80#
  in
  C# (chr# (c1# +# c2# +# c3# +# c4#))


unpack :: Word8 -> Int#
unpack (W8# word#) =
  word2Int# (word8ToWord# word#)


================================================
FILE: compiler/src/Reporting/Annotation.hs
================================================
module Reporting.Annotation
  ( Located(..)
  , Position(..)
  , Region(..)
  , traverse
  , toValue
  , merge
  , at
  , toRegion
  , mergeRegions
  , zero
  , one
  )
  where


import Prelude hiding (traverse)
import Control.Monad (liftM2)
import Data.Binary (Binary, get, put)
import Data.Word (Word16)



-- LOCATED


data Located a =
  At Region a  -- PERF see if unpacking region is helpful


instance Functor Located where
  fmap f (At region a) =
    At region (f a)


traverse :: (Functor f) => (a -> f b) -> Located a -> f (Located b)
traverse func (At region value) =
  At region <$> func value


toValue :: Located a -> a
toValue (At _ value) =
  value


merge :: Located a -> Located b -> value -> Located value
merge (At r1 _) (At r2 _) value =
  At (mergeRegions r1 r2) value



-- POSITION


data Position =
  Position
    {-# UNPACK #-} !Word16
    {-# UNPACK #-} !Word16
  deriving (Eq)


at :: Position -> Position -> a -> Located a
at start end a =
  At (Region start end) a



-- REGION


data Region = Region Position Position
  deriving (Eq)


toRegion :: Located a -> Region
toRegion (At region _) =
  region


mergeRegions :: Region -> Region -> Region
mergeRegions (Region start _) (Region _ end) =
  Region start end


zero :: Region
zero =
  Region (Position 0 0) (Position 0 0)


one :: Region
one =
  Region (Position 1 1) (Position 1 1)


instance Binary Region where
  put (Region a b) = put a >> put b
  get = liftM2 Region get get


instance Binary Position where
  put (Position a b) = put a >> put b
  get = liftM2 Position get get


================================================
FILE: compiler/src/Reporting/Doc.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Doc
  ( P.Doc
  , (P.<+>), (<>)
  , P.align, P.cat, P.empty, P.fill, P.fillSep, P.hang
  , P.hcat, P.hsep, P.indent, P.sep, P.vcat
  , P.red, P.cyan, P.magenta, P.green, P.blue, P.black, P.yellow
  , P.dullred, P.dullcyan, P.dullyellow
  --
  , fromChars
  , fromName
  , fromVersion
  , fromPackage
  , fromInt
  --
  , toAnsi
  , toString
  , toLine
  --
  , encode
  --
  , stack
  , reflow
  , commaSep
  --
  , toSimpleNote
  , toFancyNote
  , toSimpleHint
  , toFancyHint
  --
  , link
  , fancyLink
  , reflowLink
  , makeLink
  , makeNakedLink
  --
  , args
  , moreArgs
  , ordinal
  , intToOrdinal
  , cycle
  )
  where


import Prelude hiding (cycle)
import qualified Data.List as List
import qualified Data.Name as Name
import qualified System.Console.ANSI.Types as Ansi
import qualified System.Info as Info
import System.IO (Handle)
import qualified Text.PrettyPrint.ANSI.Leijen as P

import qualified Data.Index as Index
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import Json.Encode ((==>))
import qualified Json.Encode as E
import qualified Json.String as Json



-- FROM


fromChars :: String -> P.Doc
fromChars =
  P.text


fromName :: Name.Name -> P.Doc
fromName name =
  P.text (Name.toChars name)


fromVersion :: V.Version -> P.Doc
fromVersion vsn =
  P.text (V.toChars vsn)


fromPackage :: Pkg.Name -> P.Doc
fromPackage pkg =
  P.text (Pkg.toChars pkg)


fromInt :: Int -> P.Doc
fromInt n =
  P.text (show n)



-- TO STRING


toAnsi :: Handle -> P.Doc -> IO ()
toAnsi handle doc =
  P.displayIO handle (P.renderPretty 1 80 doc)


toString :: P.Doc -> String
toString doc =
  P.displayS (P.renderPretty 1 80 (P.plain doc)) ""


toLine :: P.Doc -> String
toLine doc =
  P.displayS (P.renderPretty 1 (div maxBound 2) (P.plain doc)) ""



-- FORMATTING


stack :: [P.Doc] -> P.Doc
stack docs =
  P.vcat (List.intersperse "" docs)


reflow :: String -> P.Doc
reflow paragraph =
  P.fillSep (map P.text (words paragraph))


commaSep :: P.Doc -> (P.Doc -> P.Doc) -> [P.Doc] -> [P.Doc]
commaSep conjunction addStyle names =
  case names of
    [name] ->
      [ addStyle name ]

    [name1,name2] ->
      [ addStyle name1, conjunction, addStyle name2 ]

    _ ->
      map (\name -> addStyle name <> ",") (init names)
      ++
      [ conjunction
      , addStyle (last names)
      ]



-- NOTES


toSimpleNote :: String -> P.Doc
toSimpleNote message =
  toFancyNote (map P.text (words message))


toFancyNote :: [P.Doc] -> P.Doc
toFancyNote chunks =
  P.fillSep (P.underline "Note" <> ":" : chunks)



-- HINTS


toSimpleHint :: String -> P.Doc
toSimpleHint message =
  toFancyHint (map P.text (words message))


toFancyHint :: [P.Doc] -> P.Doc
toFancyHint chunks =
  P.fillSep (P.underline "Hint" <> ":" : chunks)



-- LINKS


link :: String -> String -> String -> String -> P.Doc
link word before fileName after =
  P.fillSep $
    (P.underline (P.text word) <> ":")
    : map P.text (words before)
    ++ P.text (makeLink fileName)
    : map P.text (words after)


fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc
fancyLink word before fileName after =
  P.fillSep $
    (P.underline (P.text word) <> ":") : before ++ P.text (makeLink fileName) : after


makeLink :: [Char] -> [Char]
makeLink fileName =
  " V.toChars V.compiler <> "/" <> fileName <> ">"


makeNakedLink :: [Char] -> [Char]
makeNakedLink fileName =
  "https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName


reflowLink :: [Char] -> [Char] -> [Char] -> P.Doc
reflowLink before fileName after =
  P.fillSep $
    map P.text (words before)
    ++ P.text (makeLink fileName)
    : map P.text (words after)



-- HELPERS


args :: Int -> String
args n =
  show n <> if n == 1 then " argument" else " arguments"


moreArgs :: Int -> String
moreArgs n =
  show n <> " more" <> if n == 1 then " argument" else " arguments"


ordinal :: Index.ZeroBased -> String
ordinal index =
  intToOrdinal (Index.toHuman index)


intToOrdinal :: Int -> String
intToOrdinal number =
  let
    remainder10 =
      number `mod` 10

    remainder100 =
      number `mod` 100

    ending
      | remainder100 `elem` [11..13] = "th"
      | remainder10 == 1             = "st"
      | remainder10 == 2             = "nd"
      | remainder10 == 3             = "rd"
      | otherwise                    = "th"
  in
    show number <> ending



cycle :: Int -> Name.Name -> [Name.Name] -> P.Doc
cycle indent name names =
  let
    toLn n = cycleLn <> P.dullyellow (fromName n)
  in
  P.indent indent $ P.vcat $
    cycleTop : List.intersperse cycleMid (toLn name : map toLn names) ++ [ cycleEnd ]


cycleTop, cycleLn, cycleMid, cycleEnd :: P.Doc
cycleTop = if isWindows then "+-----+" else "┌─────┐"
cycleLn  = if isWindows then "|    "   else "│    "
cycleMid = if isWindows then "|     |" else "│     ↓"
cycleEnd = if isWindows then "+-<---+" else "└─────┘"


isWindows :: Bool
isWindows =
  Info.os == "mingw32"



-- JSON


encode :: P.Doc -> E.Value
encode doc =
  E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc))


data Style =
  Style
    { _bold :: Bool
    , _underline :: Bool
    , _color :: Maybe Color
    }


noStyle :: Style
noStyle =
  Style False False Nothing


data Color
  = Red
  | RED
  | Magenta
  | MAGENTA
  | Yellow
  | YELLOW
  | Green
  | GREEN
  | Cyan
  | CYAN
  | Blue
  | BLUE
  | Black
  | BLACK
  | White
  | WHITE


toJsonHelp :: Style -> [String] -> P.SimpleDoc -> [E.Value]
toJsonHelp style revChunks simpleDoc =
  case simpleDoc of
    P.SFail ->
      error $
        "according to the main implementation, @SFail@ can not\
        \ appear uncaught in a rendered @SimpleDoc@"

    P.SEmpty ->
      [ encodeChunks style revChunks ]

    P.SChar char rest ->
      toJsonHelp style ([char] : revChunks) rest

    P.SText _ string rest ->
      toJsonHelp style (string : revChunks) rest

    P.SLine indent rest ->
      toJsonHelp style (replicate indent ' ' : "\n" : revChunks) rest

    P.SSGR sgrs rest ->
      encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest


sgrToStyle :: [Ansi.SGR] -> Style -> Style
sgrToStyle sgrs style@(Style bold underline color) =
  case sgrs of
    [] ->
      style

    sgr : rest ->
      sgrToStyle rest $
        case sgr of
          Ansi.Reset                         -> noStyle
          Ansi.SetConsoleIntensity i         -> Style (isBold i) underline color
          Ansi.SetItalicized _               -> style
          Ansi.SetUnderlining u              -> Style bold (isUnderline u) color
          Ansi.SetBlinkSpeed _               -> style
          Ansi.SetVisible _                  -> style
          Ansi.SetSwapForegroundBackground _ -> style
          Ansi.SetColor l i c                -> Style bold underline (toColor l i c)
          Ansi.SetRGBColor _ _               -> style
          Ansi.SetPaletteColor _ _           -> style
          Ansi.SetDefaultColor _             -> style


isBold :: Ansi.ConsoleIntensity -> Bool
isBold intensity =
  case intensity of
    Ansi.BoldIntensity -> True
    Ansi.FaintIntensity -> False
    Ansi.NormalIntensity -> False


isUnderline :: Ansi.Underlining -> Bool
isUnderline underlining =
  case underlining of
    Ansi.SingleUnderline -> True
    Ansi.DoubleUnderline -> False
    Ansi.NoUnderline -> False


toColor :: Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color
toColor layer intensity color =
  case layer of
    Ansi.Background ->
      Nothing

    Ansi.Foreground ->
      let
        pick dull vivid =
          case intensity of
            Ansi.Dull -> dull
            Ansi.Vivid -> vivid
      in
      Just $
        case color of
          Ansi.Red     -> pick Red     RED
          Ansi.Magenta -> pick Magenta MAGENTA
          Ansi.Yellow  -> pick Yellow  YELLOW
          Ansi.Green   -> pick Green   GREEN
          Ansi.Cyan    -> pick Cyan    CYAN
          Ansi.Blue    -> pick Blue    BLUE
          Ansi.White   -> pick White   WHITE
          Ansi.Black   -> pick Black   BLACK


encodeChunks :: Style -> [String] -> E.Value
encodeChunks (Style bold underline color) revChunks =
  let
    chars = concat (reverse revChunks)
  in
  case color of
    Nothing | not bold && not underline ->
      E.chars chars

    _ ->
      E.object
        [ "bold" ==> E.bool bold
        , "underline" ==> E.bool underline
        , "color" ==> maybe E.null encodeColor color
        , "string" ==> E.chars chars
        ]


encodeColor :: Color -> E.Value
encodeColor color =
  E.string $ Json.fromChars $
    case color of
      Red -> "red"
      RED -> "RED"
      Magenta -> "magenta"
      MAGENTA -> "MAGENTA"
      Yellow -> "yellow"
      YELLOW -> "YELLOW"
      Green -> "green"
      GREEN -> "GREEN"
      Cyan -> "cyan"
      CYAN -> "CYAN"
      Blue -> "blue"
      BLUE -> "BLUE"
      Black -> "black"
      BLACK -> "BLACK"
      White -> "white"
      WHITE -> "WHITE"


================================================
FILE: compiler/src/Reporting/Error/Canonicalize.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error.Canonicalize
  ( Error(..)
  , BadArityContext(..)
  , InvalidPayload(..)
  , PortProblem(..)
  , DuplicatePatternContext(..)
  , PossibleNames(..)
  , VarKind(..)
  , toReport
  )
  where


import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.OneOrMore as OneOrMore
import qualified Data.Set as Set

import qualified AST.Canonical as Can
import qualified AST.Source as Src
import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import Reporting.Doc (Doc, (<+>))
import qualified Reporting.Render.Code as Code
import qualified Reporting.Render.Type as RT
import qualified Reporting.Report as Report
import qualified Reporting.Suggest as Suggest



-- CANONICALIZATION ERRORS


data Error
  = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
  | AmbiguousVar A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
  | AmbiguousType A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
  | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
  | AmbiguousBinop A.Region Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
  | BadArity A.Region BadArityContext Name.Name Int Int
  | Binop A.Region Name.Name Name.Name
  | DuplicateDecl Name.Name A.Region A.Region
  | DuplicateType Name.Name A.Region A.Region
  | DuplicateCtor Name.Name A.Region A.Region
  | DuplicateBinop Name.Name A.Region A.Region
  | DuplicateField Name.Name A.Region A.Region
  | DuplicateAliasArg Name.Name Name.Name A.Region A.Region
  | DuplicateUnionArg Name.Name Name.Name A.Region A.Region
  | DuplicatePattern DuplicatePatternContext Name.Name A.Region A.Region
  | EffectNotFound A.Region Name.Name
  | EffectFunctionNotFound A.Region Name.Name
  | ExportDuplicate Name.Name A.Region A.Region
  | ExportNotFound A.Region VarKind Name.Name [Name.Name]
  | ExportOpenAlias A.Region Name.Name
  | ImportCtorByName A.Region Name.Name Name.Name
  | ImportNotFound A.Region Name.Name [ModuleName.Canonical]
  | ImportOpenAlias A.Region Name.Name
  | ImportExposingNotFound A.Region ModuleName.Canonical Name.Name [Name.Name]
  | NotFoundVar A.Region (Maybe Name.Name) Name.Name PossibleNames
  | NotFoundType A.Region (Maybe Name.Name) Name.Name PossibleNames
  | NotFoundVariant A.Region (Maybe Name.Name) Name.Name PossibleNames
  | NotFoundBinop A.Region Name.Name (Set.Set Name.Name)
  | PatternHasRecordCtor A.Region Name.Name
  | PortPayloadInvalid A.Region Name.Name Can.Type InvalidPayload
  | PortTypeInvalid A.Region Name.Name PortProblem
  | RecursiveAlias A.Region Name.Name [Name.Name] Src.Type [Name.Name]
  | RecursiveDecl A.Region Name.Name [Name.Name]
  | RecursiveLet (A.Located Name.Name) [Name.Name]
  | Shadowing Name.Name A.Region A.Region
  | TupleLargerThanThree A.Region
  | TypeVarsUnboundInUnion A.Region Name.Name [Name.Name] (Name.Name, A.Region) [(Name.Name, A.Region)]
  | TypeVarsMessedUpInAlias A.Region Name.Name [Name.Name] [(Name.Name, A.Region)] [(Name.Name, A.Region)]


data BadArityContext
  = TypeArity
  | PatternArity


data DuplicatePatternContext
  = DPLambdaArgs
  | DPFuncArgs Name.Name
  | DPCaseBranch
  | DPLetBinding
  | DPDestruct


data InvalidPayload
  = ExtendedRecord
  | Function
  | TypeVariable Name.Name
  | UnsupportedType Name.Name


data PortProblem
  = CmdNoArg
  | CmdExtraArgs Int
  | CmdBadMsg
  | SubBad
  | NotCmdOrSub


data PossibleNames =
  PossibleNames
    { _locals :: Set.Set Name.Name
    , _quals :: Map.Map Name.Name (Set.Set Name.Name)
    }



-- KIND


data VarKind
  = BadOp
  | BadVar
  | BadPattern
  | BadType


toKindInfo :: VarKind -> Name.Name -> ( Doc, Doc, Doc )
toKindInfo kind name =
  case kind of
    BadOp ->
      ( "an", "operator", "(" <> D.fromName name <> ")" )

    BadVar ->
      ( "a", "value", "`" <> D.fromName name <> "`" )

    BadPattern ->
      ( "a", "pattern", "`" <> D.fromName name <> "`" )

    BadType ->
      ( "a", "type", "`" <> D.fromName name <> "`" )



-- TO REPORT


toReport :: Code.Source -> Error -> Report.Report
toReport source err =
  case err of
    AnnotationTooShort region name index leftovers ->
      let
        numTypeArgs = Index.toMachine index
        numDefArgs = numTypeArgs + leftovers
      in
      Report.Report "BAD TYPE ANNOTATION" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "The type annotation for `" <> Name.toChars name <> "` says it can accept "
              <> D.args numTypeArgs <> ", but the definition says it has "
              <> D.args numDefArgs <> ":"
          ,
            D.reflow $
              "Is the type annotation missing something? Should some argument"
              <> (if leftovers == 1 then "" else "s")
              <> " be deleted? Maybe some parentheses are missing?"
          )

    AmbiguousVar region maybePrefix name h hs ->
      ambiguousName source region maybePrefix name h hs "variable"

    AmbiguousType region maybePrefix name h hs ->
      ambiguousName source region maybePrefix name h hs "type"

    AmbiguousVariant region maybePrefix name h hs ->
      ambiguousName source region maybePrefix name h hs "variant"

    AmbiguousBinop region name h hs ->
      ambiguousName source region Nothing name h hs "operator"

    BadArity region badArityContext name expected actual ->
      let
        thing =
          case badArityContext of
            TypeArity    -> "type"
            PatternArity -> "variant"
      in
      if actual < expected then
        Report.Report "TOO FEW ARGS" region [] $
          Code.toSnippet source region Nothing
            (
              D.reflow $
                "The `" <> Name.toChars name <> "` " <> thing <> " needs "
                <> D.args expected <> ", but I see " <> show actual <> " instead:"
            ,
              D.reflow $
                "What is missing? Are some parentheses misplaced?"
            )

      else
        Report.Report "TOO MANY ARGS" region [] $
          Code.toSnippet source region Nothing
            (
              D.reflow $
                "The `" <> Name.toChars name <> "` " <> thing <> " needs "
                <> D.args expected <> ", but I see " <> show actual <> " instead:"
            ,
              if actual - expected == 1 then
                "Which is the extra one? Maybe some parentheses are missing?"
              else
                "Which are the extra ones? Maybe some parentheses are missing?"
            )

    Binop region op1 op2 ->
      Report.Report "INFIX PROBLEM" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You cannot mix (" <> Name.toChars op1 <> ") and (" <> Name.toChars op2 <> ") without parentheses."
          ,
            D.reflow
              "I do not know how to group these expressions. Add parentheses for me!"
          )

    DuplicateDecl name r1 r2 ->
      nameClash source r1 r2 $
        "This file has multiple `" <> Name.toChars name <> "` declarations."

    DuplicateType name r1 r2 ->
      nameClash source r1 r2 $
        "This file defines multiple `" <> Name.toChars name <> "` types."

    DuplicateCtor name r1 r2 ->
      nameClash source r1 r2 $
        "This file defines multiple `" <> Name.toChars name <> "` type constructors."

    DuplicateBinop name r1 r2 ->
      nameClash source r1 r2 $
        "This file defines multiple (" <> Name.toChars name <> ") operators."

    DuplicateField name r1 r2 ->
      nameClash source r1 r2 $
        "This record has multiple `" <> Name.toChars name <> "` fields."

    DuplicateAliasArg typeName name r1 r2 ->
      nameClash source r1 r2 $
        "The `" <> Name.toChars typeName <> "` type alias has multiple `" <> Name.toChars name <> "` type variables."

    DuplicateUnionArg typeName name r1 r2 ->
      nameClash source r1 r2 $
        "The `" <> Name.toChars typeName <> "` type has multiple `" <> Name.toChars name <> "` type variables."

    DuplicatePattern context name r1 r2 ->
      nameClash source r1 r2 $
        case context of
          DPLambdaArgs ->
            "This anonymous function has multiple `" <> Name.toChars name <> "` arguments."

          DPFuncArgs funcName ->
            "The `" <> Name.toChars funcName <> "` function has multiple `" <> Name.toChars name <> "` arguments."

          DPCaseBranch ->
            "This `case` pattern has multiple `" <> Name.toChars name <> "` variables."

          DPLetBinding ->
            "This `let` expression defines `" <> Name.toChars name <> "` more than once!"

          DPDestruct ->
            "This pattern contains multiple `" <> Name.toChars name <> "` variables."

    EffectNotFound region name ->
      Report.Report "EFFECT PROBLEM" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You have declared that `" ++ Name.toChars name ++ "` is an effect type:"
          ,
            D.reflow $
              "But I cannot find a custom type named `" ++ Name.toChars name ++ "` in this file!"
          )

    EffectFunctionNotFound region name ->
      Report.Report "EFFECT PROBLEM" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "This kind of effect module must define a `" ++ Name.toChars name ++ "` function."
          ,
            D.reflow $
              "But I cannot find `" ++ Name.toChars name ++ "` in this file!"
          )


    ExportDuplicate name r1 r2 ->
      let
        messageThatEndsWithPunctuation =
          "You are trying to expose `" <> Name.toChars name <> "` multiple times!"
      in
      Report.Report "REDUNDANT EXPORT" r2 [] $
        Code.toPair source r1 r2
          (
            D.reflow messageThatEndsWithPunctuation
          ,
            "Remove one of them and you should be all set!"
          )
          (
            D.reflow (messageThatEndsWithPunctuation <> " Once here:")
          ,
            "And again right here:"
          ,
            "Remove one of them and you should be all set!"
          )

    ExportNotFound region kind rawName possibleNames ->
      let
        suggestions =
          map Name.toChars $ take 4 $
            Suggest.sort (Name.toChars rawName) Name.toChars possibleNames
      in
      Report.Report "UNKNOWN EXPORT" region suggestions $
        let (a, thing, name) = toKindInfo kind rawName in
        D.stack
          [ D.fillSep
              ["You","are","trying","to","expose",a,thing,"named"
              ,name,"but","I","cannot","find","its","definition."
              ]
          , case map D.fromChars suggestions of
              [] ->
                D.reflow $
                  "I do not see any super similar names in this file. Is the definition missing?"

              [alt] ->
                D.fillSep ["Maybe","you","want",D.dullyellow alt,"instead?"]

              alts ->
                D.stack
                  [ "These names seem close though:"
                  , D.indent 4 $ D.vcat $ map D.dullyellow alts
                  ]
          ]

    ExportOpenAlias region name ->
      Report.Report "BAD EXPORT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "The (..) syntax is for exposing variants of a custom type. It cannot be used with a type alias like `"
              ++ Name.toChars name ++ "` though."
          ,
            D.reflow $
              "Remove the (..) and you should be fine!"
          )

    ImportCtorByName region ctor tipe ->
      Report.Report "BAD IMPORT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You are trying to import the `" <> Name.toChars ctor
              <> "` variant by name:"
          ,
            D.fillSep
              ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead."
              ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and"
              ,"all","its","variants","so","it","gives","you","access","to"
              , D.fromName ctor <> "."
              ]
          )

    ImportNotFound region name _ ->
      --
      -- NOTE: this should always be detected by `builder`
      -- So this error should never actually get printed out.
      --
      Report.Report "UNKNOWN IMPORT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I could not find a `" <> Name.toChars name <> "` module to import!"
          ,
            mempty
          )

    ImportOpenAlias region name ->
      Report.Report "BAD IMPORT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:"
          ,
            D.reflow $
              "Remove the (..) and it should work."
          )

    ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames ->
      let
        suggestions =
          map Name.toChars $ take 4 $
            Suggest.sort (Name.toChars home) Name.toChars possibleNames
      in
      Report.Report "BAD IMPORT" region suggestions $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "The `" <> Name.toChars home
              <> "` module does not expose `"
              <> Name.toChars value <> "`:"
          ,
            case map D.fromChars suggestions of
              [] ->
                "I cannot find any super similar exposed names. Maybe it is private?"

              [alt] ->
                D.fillSep ["Maybe","you","want",D.dullyellow alt,"instead?"]

              alts ->
                D.stack
                  [ "These names seem close though:"
                  , D.indent 4 $ D.vcat $ map D.dullyellow alts
                  ]
          )

    NotFoundVar region prefix name possibleNames ->
      notFound source region prefix name "variable" possibleNames

    NotFoundType region prefix name possibleNames ->
      notFound source region prefix name "type" possibleNames

    NotFoundVariant region prefix name possibleNames ->
      notFound source region prefix name "variant" possibleNames

    NotFoundBinop region op locals ->
      if op == "===" then
        Report.Report "UNKNOWN OPERATOR" region ["=="] $
          Code.toSnippet source region Nothing
            (
              "Elm does not have a (===) operator like JavaScript."
            ,
              "Switch to (==) instead."
            )

      else if op == "!=" || op == "!==" then
        Report.Report "UNKNOWN OPERATOR" region ["/="] $
          Code.toSnippet source region Nothing
            (
              D.reflow $
                "Elm uses a different name for the “not equal” operator:"
            ,
              D.stack
                [ D.reflow "Switch to (/=) instead."
                , D.toSimpleNote $
                    "Our (/=) operator is supposed to look like a real “not equal” sign (≠). I hope that history will remember ("
                    ++ Name.toChars op ++ ") as a weird and temporary choice."
                ]
            )

      else if op == "**" then
        Report.Report "UNKNOWN OPERATOR" region ["^","*"] $
          Code.toSnippet source region Nothing
            (
              D.reflow $
                "I do not recognize the (**) operator:"
            ,
              D.reflow $
                "Switch to (^) for exponentiation. Or switch to (*) for multiplication."
            )

      else if op == "%" then
        Report.Report "UNKNOWN OPERATOR" region [] $
          Code.toSnippet source region Nothing
            (
              D.reflow $
                "Elm does not use (%) as the remainder operator:"
            ,
              D.stack
                [ D.reflow $
                    "If you want the behavior of (%) like in JavaScript, switch to:\
                    \ "
                , D.reflow $
                    "If you want modular arithmetic like in math, switch to:\
                    \ "
                , D.reflow $
                    "The difference is how things work when negative numbers are involved."
                ]
            )

      else
        let
          suggestions =
            map Name.toChars $ take 2 $
              Suggest.sort (Name.toChars op) Name.toChars (Set.toList locals)

          format altOp =
            D.green $ "(" <> altOp <> ")"
        in
        Report.Report "UNKNOWN OPERATOR" region suggestions $
          Code.toSnippet source region Nothing
            (
              D.reflow $
                "I do not recognize the (" ++ Name.toChars op ++ ") operator."
            ,
              D.fillSep $
                ["Is","there","an","`import`","and","`exposing`","entry","for","it?"]
                ++
                  case map D.fromChars suggestions of
                    [] ->
                      []

                    alts ->
                      ["Maybe","you","want"] ++ D.commaSep "or" format alts ++ ["instead?"]
            )

    PatternHasRecordCtor region name ->
      Report.Report "BAD PATTERN" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You can construct records by using `" <> Name.toChars name
              <> "` as a function, but it is not available in pattern matching like this:"
          ,
            D.reflow $
              "I recommend matching the record as a variable and unpacking it later."
          )

    PortPayloadInvalid region portName _badType invalidPayload ->
      let
        formatDetails (aBadKindOfThing, elaboration) =
          Report.Report "PORT ERROR" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "The `" <> Name.toChars portName <> "` port is trying to transmit " <> aBadKindOfThing <> ":"
              ,
                D.stack
                  [ elaboration
                  , D.link "Hint"
                      "Ports are not a traditional FFI, so if you have tons of annoying ports, definitely read"
                      "ports"
                      "to learn how they are meant to work. They require a different mindset!"
                  ]
              )
      in
      formatDetails $
        case invalidPayload of
          ExtendedRecord ->
            (
              "an extended record"
            ,
              D.reflow $
                "But the exact shape of the record must be known at compile time. No type variables!"
            )

          Function ->
            (
              "a function"
            ,
              D.reflow $
                "But functions cannot be sent in and out ports. If we allowed functions in from JS\
                \ they may perform some side-effects. If we let functions out, they could produce\
                \ incorrect results because Elm optimizations assume there are no side-effects."
            )


          TypeVariable name ->
            (
              "an unspecified type"
            ,
              D.reflow $
                "But type variables like `" <> Name.toChars name <> "` cannot flow through ports.\
                \ I need to know exactly what type of data I am getting, so I can guarantee that\
                \ unexpected data cannot sneak in and crash the Elm program."
            )

          UnsupportedType name ->
            (
              "a `" <> Name.toChars name <> "` value"
            ,
              D.stack
                [ D.reflow $ "I cannot handle that. The types that CAN flow in and out of Elm include:"
                , D.indent 4 $
                    D.reflow $
                      "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\
                      \ tuples, records, and JSON values."
                , D.reflow $
                    "Since JSON values can flow through, you can use JSON encoders and decoders\
                    \ to allow other types through as well. More advanced users often just do\
                    \ everything with encoders and decoders for more control and better errors."
                ]
            )

    PortTypeInvalid region name portProblem ->
      let
        formatDetails (before, after) =
          Report.Report "BAD PORT" region [] $
            Code.toSnippet source region Nothing $
              (
                D.reflow before
              ,
                D.stack
                  [ after
                  , D.link "Hint" "Read" "ports"
                      "for more advice. For example, do not end up with one port per JS function!"
                  ]
              )
      in
      formatDetails $
        case portProblem of
          CmdNoArg ->
            (
              "The `" <> Name.toChars name <> "` port cannot be just a command."
            ,
              D.reflow $
                "It can be (() -> Cmd msg) if you just need to trigger a JavaScript\
                \ function, but there is often a better way to set things up."
            )

          CmdExtraArgs n ->
            (
              "The `" <> Name.toChars name <> "` port can only send ONE value out to JavaScript."
            ,
              let
                theseItemsInSomething
                  | n == 2 = "both of these items into a tuple or record"
                  | n == 3 = "these " ++ show n ++ " items into a tuple or record"
                  | True   = "these " ++ show n ++ " items into a record"
              in
              D.reflow $
                "You can put " ++ theseItemsInSomething ++ " to send them out though."
            )

          CmdBadMsg ->
            (
              "The `" <> Name.toChars name <> "` port cannot send any messages to the `update` function."
            ,
              D.reflow $
                "It must produce a (Cmd msg) type. Notice the lower case `msg` type\
                \ variable. The command will trigger some JS code, but it will not send\
                \ anything particular back to Elm."
            )

          SubBad ->
            ( "There is something off about this `" <> Name.toChars name <> "` port declaration."
            ,
              D.stack
                [ D.reflow $
                    "To receive messages from JavaScript, you need to define a port like this:"
                , D.indent 4 $ D.dullyellow $ D.fromChars $
                    "port " <> Name.toChars name <> " : (Int -> msg) -> Sub msg"
                , D.reflow $
                    "Now every time JS sends an `Int` to this port, it is converted to a `msg`.\
                    \ And if you subscribe, those `msg` values will be piped into your `update`\
                    \ function. The only thing you can customize here is the `Int` type."
                ]
            )

          NotCmdOrSub ->
            (
              "I am confused about the `" <> Name.toChars name <> "` port declaration."
            ,
              D.reflow $
                "Ports need to produce a command (Cmd) or a subscription (Sub) but\
                \ this is neither. I do not know how to handle this."
            )

    RecursiveAlias region name args tipe others ->
        aliasRecursionReport source region name args tipe others

    RecursiveDecl region name names ->
      let
        makeTheory question details =
          D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details)
      in
      Report.Report "CYCLIC DEFINITION" region [] $
        Code.toSnippet source region Nothing $
          case names of
            [] ->
              (
                D.reflow $
                  "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
              ,
                D.stack
                  [ makeTheory "Are you trying to mutate a variable?" $
                      "Elm does not have mutation, so when I see " ++ Name.toChars name
                      ++ " defined in terms of " ++ Name.toChars name
                      ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
                  , makeTheory "Maybe you DO want a recursive value?" $
                      "To define " ++ Name.toChars name ++ " we need to know what " ++ Name.toChars name
                      ++ " is, so let’s expand it. Wait, but now we need to know what " ++ Name.toChars name
                      ++ " is, so let’s expand it... This will keep going infinitely!"
                  , D.link "Hint"
                      "The root problem is often a typo in some variable name, but I recommend reading"
                      "bad-recursion"
                      "for more detailed advice, especially if you actually do need a recursive value."
                  ]
              )

            _:_ ->
              (
                D.reflow $
                  "The `" <> Name.toChars name <> "` definition is causing a very tricky infinite loop."
              ,
                D.stack
                  [ D.reflow $
                      "The `" <> Name.toChars name
                      <> "` value depends on itself through the following chain of definitions:"
                  , D.cycle 4 name names
                  , D.link "Hint"
                      "The root problem is often a typo in some variable name, but I recommend reading"
                      "bad-recursion"
                      "for more detailed advice, especially if you actually do want mutually recursive values."
                  ]
              )

    RecursiveLet (A.At region name) names ->
      Report.Report "CYCLIC VALUE" region [] $
        Code.toSnippet source region Nothing $
          case names of
            [] ->
              let
                makeTheory question details =
                  D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details)
              in
                (
                  D.reflow $
                    "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
                ,
                  D.stack
                    [ makeTheory "Are you trying to mutate a variable?" $
                        "Elm does not have mutation, so when I see " ++ Name.toChars name
                        ++ " defined in terms of " ++ Name.toChars name
                        ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
                    , makeTheory "Maybe you DO want a recursive value?" $
                        "To define " ++ Name.toChars name ++ " we need to know what " ++ Name.toChars name
                        ++ " is, so let’s expand it. Wait, but now we need to know what " ++ Name.toChars name
                        ++ " is, so let’s expand it... This will keep going infinitely!"
                    , D.link "Hint"
                        "The root problem is often a typo in some variable name, but I recommend reading"
                        "bad-recursion"
                        "for more detailed advice, especially if you actually do need a recursive value."
                    ]
                )

            _ ->
                (
                  D.reflow $
                    "I do not allow cyclic values in `let` expressions."
                ,
                  D.stack
                    [ D.reflow $
                        "The `" <> Name.toChars name
                        <> "` value depends on itself through the following chain of definitions:"
                    , D.cycle 4 name names
                    , D.link "Hint"
                        "The root problem is often a typo in some variable name, but I recommend reading"
                        "bad-recursion"
                        "for more detailed advice, especially if you actually do want mutually recursive values."
                    ]
                )

    Shadowing name r1 r2 ->
      Report.Report "SHADOWING" r2 [] $
        Code.toPair source r1 r2
          ( "These variables cannot have the same name:"
          , advice
          )
          ( D.reflow $ "The name `" <> Name.toChars name <> "` is first defined here:"
          , "But then it is defined AGAIN over here:"
          , advice
          )
      where
        advice =
          D.stack
            [ D.reflow $
                "Think of a more helpful name for one of them and you should be all set!"
            , D.link "Note"
                "Linters advise against shadowing, so Elm makes “best practices” the default. Read"
                "shadowing"
                "for more details on this choice."
            ]

    TupleLargerThanThree region ->
      Report.Report "BAD TUPLE" region [] $
        Code.toSnippet source region Nothing
          (
            "I only accept tuples with two or three items. This has too many:"
          ,
            D.stack
              [ D.reflow $
                  "I recommend switching to records. Each item will be named, and you can use\
                  \ the `point.x` syntax to access them."

              , D.link "Note" "Read" "tuples"

                  "for more comprehensive advice on working with large chunks of data in Elm."
              ]
          )

    TypeVarsUnboundInUnion unionRegion typeName allVars unbound unbounds ->
      unboundTypeVars source unionRegion ["type"] typeName allVars unbound unbounds

    TypeVarsMessedUpInAlias aliasRegion typeName allVars unusedVars unboundVars ->
      case (unusedVars, unboundVars) of
        (unused:unuseds, []) ->
          let
            backQuote name =
              "`" <> D.fromName name <> "`"

            allUnusedNames =
              map fst unusedVars

            (title, subRegion, overview, stuff) =
              case unuseds of
                [] ->
                  ("UNUSED TYPE VARIABLE"
                  , Just (snd unused)
                  , ["Type","alias",backQuote typeName,"does","not","use","the"
                    ,backQuote (fst unused),"type","variable."
                    ]
                  , [D.dullyellow (backQuote (fst unused))]
                  )

                _:_ ->
                  ( "UNUSED TYPE VARIABLES"
                  , Nothing
                  , ["Type","variables"]
                    ++ D.commaSep "and" id (map D.fromName allUnusedNames)
                    ++ ["are","unused","in","the",backQuote typeName,"definition."]
                  , D.commaSep "and" D.dullyellow (map D.fromName allUnusedNames)
                  )
          in
          Report.Report title aliasRegion [] $
            Code.toSnippet source aliasRegion subRegion
              (
                D.fillSep overview
              ,
                D.stack
                  [ D.fillSep $
                      ["I","recommend","removing"] ++ stuff ++ ["from","the","declaration,","like","this:"]
                  , D.indent 4 $ D.hsep $
                      ["type","alias",D.green (D.fromName typeName)]
                      ++ map D.fromName (filter (`notElem` allUnusedNames) allVars)
                      ++ ["=", "..."]
                  , D.reflow $
                      "Why? Well, if I allowed `type alias Height a = Float` I would need to answer\
                      \ some weird questions. Is `Height Bool` the same as `Float`? Is `Height Bool`\
                      \ the same as `Height Int`? My solution is to not need to ask them!"
                  ]
              )

        ([], unbound:unbounds) ->
          unboundTypeVars source aliasRegion ["type","alias"] typeName allVars unbound unbounds

        (_, _) ->
          let
            unused = map fst unusedVars
            unbound = map fst unboundVars

            theseAreUsed =
              case unbound of
                [x] ->
                  ["Type","variable",D.dullyellow ("`" <> D.fromName x <> "`"),"appears"
                  ,"in","the","definition,","but","I","do","not","see","it","declared."
                  ]

                _ ->
                  ["Type","variables"]
                  ++ D.commaSep "and" D.dullyellow (map D.fromName unbound)
                  ++ ["are","used","in","the","definition,","but","I","do","not","see","them","declared."]

            butTheseAreUnused =
              case unused of
                [x] ->
                  ["Likewise,","type","variable"
                  ,D.dullyellow ("`" <> D.fromName x <> "`")
                  ,"is","delared,","but","not","used."
                  ]

                _ ->
                  ["Likewise,","type","variables"]
                  ++ D.commaSep "and" D.dullyellow (map D.fromName unused)
                  ++ ["are","delared,","but","not","used."]

          in
          Report.Report "TYPE VARIABLE PROBLEMS" aliasRegion [] $
            Code.toSnippet source aliasRegion Nothing
              (
                D.reflow $
                  "Type alias `" <> Name.toChars typeName <> "` has some type variable problems."
              ,
                D.stack
                  [ D.fillSep $ theseAreUsed ++ butTheseAreUnused
                  , D.reflow $
                      "My guess is that a definition like this will work better:"
                  , D.indent 4 $ D.hsep $
                      ["type", "alias", D.fromName typeName]
                      ++ map D.fromName (filter (`notElem` unused) allVars)
                      ++ map (D.green . D.fromName) unbound
                      ++ ["=", "..."]
                  ]
              )



-- BAD TYPE VARIABLES


unboundTypeVars :: Code.Source -> A.Region -> [D.Doc] -> Name.Name -> [Name.Name] -> (Name.Name, A.Region) -> [(Name.Name, A.Region)] -> Report.Report
unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion) unboundVars =
  let
    backQuote name =
      "`" <> D.fromName name <> "`"

    (title, subRegion, overview) =
      case map fst unboundVars of
        [] ->
          ( "UNBOUND TYPE VARIABLE"
          , Just varRegion
          , ["The",backQuote typeName]
            ++ tipe
            ++ ["uses","an","unbound","type","variable",D.dullyellow (backQuote unboundVar),"in","its","definition:"]
          )

        vars ->
          ( "UNBOUND TYPE VARIABLES"
          , Nothing
          , ["Type","variables"]
            ++ D.commaSep "and" D.dullyellow (D.fromName unboundVar : map D.fromName vars)
            ++ ["are","unbound","in","the",backQuote typeName] ++ tipe ++ ["definition:"]
          )
  in
  Report.Report title declRegion [] $
    Code.toSnippet source declRegion subRegion
      (
        D.fillSep overview
      ,
        D.stack
          [ D.reflow $
              "You probably need to change the declaration to something like this:"
          , D.indent 4 $ D.hsep $
              tipe
              ++ [D.fromName typeName]
              ++ map D.fromName allVars
              ++ map (D.green . D.fromName) (unboundVar : map fst unboundVars)
              ++ ["=", "..."]
          , D.reflow $
              "Why? Well, imagine one `" ++ Name.toChars typeName ++ "` where `" ++ Name.toChars unboundVar ++
              "` is an Int and another where it is a Bool. When we explicitly list the type\
              \ variables, the type checker can see that they are actually different types."
          ]
      )



-- NAME CLASH


nameClash :: Code.Source -> A.Region -> A.Region -> String -> Report.Report
nameClash source r1 r2 messageThatEndsWithPunctuation =
  Report.Report "NAME CLASH" r2 [] $
    Code.toPair source r1 r2
      (
        D.reflow messageThatEndsWithPunctuation
      ,
        "How can I know which one you want? Rename one of them!"
      )
      (
        D.reflow (messageThatEndsWithPunctuation <> " One here:")
      ,
        "And another one here:"
      ,
        "How can I know which one you want? Rename one of them!"
      )



-- AMBIGUOUS NAME


ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> ModuleName.Canonical -> OneOrMore.OneOrMore ModuleName.Canonical -> String -> Report.Report
ambiguousName source region maybePrefix name h hs thing =
  let
    possibleHomes = List.sort (h : OneOrMore.destruct (:) hs)
  in
  Report.Report "AMBIGUOUS NAME" region [] $
    Code.toSnippet source region Nothing $
      case maybePrefix of
        Nothing ->
          let
            homeToYellowDoc (ModuleName.Canonical _ home) =
              D.dullyellow (D.fromName home <> "." <> D.fromName name)
          in
          (
            D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous:"
          ,
            D.stack
              [ D.reflow $
                  "This name is exposed by " ++ show (length possibleHomes) ++ " of your imports, so I am not\
                  \ sure which one to use:"
              , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
              , D.reflow $
                  "I recommend using qualified names for imported values. I also recommend having\
                  \ at most one `exposing (..)` per file to make name clashes like this less common\
                  \ in the long run."
              , D.link "Note" "Check out" "imports" "for more info on the import syntax."
              ]
          )

        Just prefix ->
          let
            homeToYellowDoc (ModuleName.Canonical _ home) =
              if prefix == home then
                D.cyan "import" <+> D.fromName home
              else
                D.cyan "import" <+> D.fromName home <+> D.cyan "as" <+> D.fromName prefix

            eitherOrAny =
              if length possibleHomes == 2 then "either" else "any"
          in
          (
            D.reflow $ "This usage of `" ++ toQualString prefix name ++ "` is ambiguous."
          ,
            D.stack
              [ D.reflow $
                  "It could refer to a " ++ thing ++ " from "
                  ++ eitherOrAny ++ " of these imports:"
              , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
              , D.reflowLink "Read" "imports" "to learn how to clarify which one you want."
              ]
          )



-- NOT FOUND


notFound :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> String -> PossibleNames -> Report.Report
notFound source region maybePrefix name thing (PossibleNames locals quals) =
  let
    givenName =
      maybe Name.toChars toQualString maybePrefix name

    possibleNames =
      let
        addQuals prefix localSet allNames =
          Set.foldr (\x xs -> toQualString prefix x : xs) allNames localSet
      in
      Map.foldrWithKey addQuals (map Name.toChars (Set.toList locals)) quals

    nearbyNames =
      take 4 (Suggest.sort givenName id possibleNames)

    toDetails noSuggestionDetails yesSuggestionDetails =
      case nearbyNames of
        [] ->
          D.stack
            [ D.reflow noSuggestionDetails
            , D.link "Hint" "Read" "imports" "to see how `import` declarations work in Elm."
            ]

        suggestions ->
          D.stack
            [ D.reflow yesSuggestionDetails
            , D.indent 4 $ D.vcat $ map D.dullyellow $ map D.fromChars suggestions
            , D.link "Hint" "Read" "imports" "to see how `import` declarations work in Elm."
            ]

  in
  Report.Report "NAMING ERROR" region nearbyNames $
    Code.toSnippet source region Nothing
      (
        D.reflow $
          "I cannot find a `" ++ givenName ++ "` " ++ thing ++ ":"
      ,
        case maybePrefix of
          Nothing ->
            toDetails
              "Is there an `import` or `exposing` missing up top?"
              "These names seem close though:"

          Just prefix ->
            case Map.lookup prefix quals of
              Nothing ->
                toDetails
                  ("I cannot find a `" ++ Name.toChars prefix ++ "` module. Is there an `import` for it?")
                  ("I cannot find a `" ++ Name.toChars prefix ++ "` import. These names seem close though:")

              Just _ ->
                toDetails
                  ("The `" ++ Name.toChars prefix ++ "` module does not expose a `" ++ Name.toChars name ++ "` " ++ thing ++ ".")
                  ("The `" ++ Name.toChars prefix ++ "` module does not expose a `" ++ Name.toChars name ++ "` " ++ thing ++ ". These names seem close though:")
      )


toQualString :: Name.Name -> Name.Name -> String
toQualString prefix name =
  Name.toChars prefix ++ "." ++ Name.toChars name



{-- VAR ERROR


varErrorToReport :: VarError -> Report.Report
varErrorToReport (VarError kind name problem suggestions) =
  let
    learnMore orMaybe =
      D.reflow $
        orMaybe <> " `import` works different than you expect? Learn all about it here: "
        <> D.hintLink "imports"

    namingError overview maybeStarter specializedSuggestions =
      Report.reportDoc "NAMING ERROR" Nothing overview $
        case D.maybeYouWant' maybeStarter specializedSuggestions of
          Nothing ->
            learnMore "Maybe"
          Just doc ->
            D.stack [ doc, learnMore "Or maybe" ]

    specialNamingError specialHint =
      Report.reportDoc "NAMING ERROR" Nothing (cannotFind kind name) (D.hsep specialHint)
  in
  case problem of
    Ambiguous ->
      namingError (ambiguous kind name) Nothing suggestions

    UnknownQualifier qualifier localName ->
      namingError
        (cannotFind kind name)
        (Just $ text $ "No module called `" <> qualifier <> "` has been imported.")
        (map (\modul -> modul <> "." <> localName) suggestions)

    QualifiedUnknown qualifier localName ->
      namingError
        (cannotFind kind name)
        (Just $ text $ "`" <> qualifier <> "` does not expose `" <> localName <> "`.")
        (map (\v -> qualifier <> "." <> v) suggestions)

    ExposedUnknown ->
      case name of
        "!="  -> specialNamingError (notEqualsHint name)
        "!==" -> specialNamingError (notEqualsHint name)
        "===" -> specialNamingError equalsHint
        "%"   -> specialNamingError modHint
        _     -> namingError (cannotFind kind name) Nothing suggestions


cannotFind :: VarKind -> Text -> [Doc]
cannotFind kind rawName =
  let ( a, thing, name ) = toKindInfo kind rawName in
  [ "Cannot", "find", a, thing, "named", D.dullyellow name <> ":" ]


ambiguous :: VarKind -> Text -> [Doc]
ambiguous kind rawName =
  let ( _a, thing, name ) = toKindInfo kind rawName in
  [ "This", "usage", "of", "the", D.dullyellow name, thing, "is", "ambiguous." ]


notEqualsHint :: Text -> [Doc]
notEqualsHint op =
  [ "Looking", "for", "the", "“not", "equal”", "operator?", "The", "traditional"
  , D.dullyellow $ text $ "(" <> op <> ")"
  , "is", "replaced", "by", D.green "(/=)", "in", "Elm.", "It", "is", "meant"
  , "to", "look", "like", "the", "“not", "equal”", "sign", "from", "math!", "(≠)"
  ]


equalsHint :: [Doc]
equalsHint =
  [ "A", "special", D.dullyellow "(===)", "operator", "is", "not", "needed"
  , "in", "Elm.", "We", "use", D.green "(==)", "for", "everything!"
  ]


modHint :: [Doc]
modHint =
  [ "Rather", "than", "a", D.dullyellow "(%)", "operator,"
  , "Elm", "has", "a", D.green "modBy", "function."
  , "Learn", "more", "here:"
  , ""
  ]


-}


-- ARG MISMATCH


_argMismatchReport :: Code.Source -> A.Region -> String -> Name.Name -> Int -> Int -> Report.Report
_argMismatchReport source region kind name expected actual =
  let
    numArgs =
      "too "
      <> (if actual < expected then "few" else "many")
      <> " arguments"
  in
    Report.Report (map Char.toUpper numArgs) region [] $
      Code.toSnippet source region Nothing
        (
          D.reflow $
            kind <> " " <> Name.toChars name <> " has " <> numArgs <> "."
        ,
          D.reflow $
            "Expecting " <> show expected <> ", but got " <> show actual <> "."
        )



-- BAD ALIAS RECURSION


aliasRecursionReport :: Code.Source -> A.Region -> Name.Name -> [Name.Name] -> Src.Type -> [Name.Name] -> Report.Report
aliasRecursionReport source region name args tipe others =
  case others of
    [] ->
      Report.Report "ALIAS PROBLEM" region [] $
        Code.toSnippet source region Nothing
          (
            "This type alias is recursive, forming an infinite type!"
          ,
            D.stack
              [ D.reflow $
                  "When I expand a recursive type alias, it just keeps getting bigger and bigger.\
                  \ So dealiasing results in an infinitely large type! Try this instead:"
              , D.indent 4 $
                  aliasToUnionDoc name args tipe
              , D.link "Hint"
                  "This is kind of a subtle distinction. I suggested the naive fix, but I recommend reading"
                  "recursive-alias"
                  "for ideas on how to do better."
              ]
          )

    _ ->
      Report.Report "ALIAS PROBLEM" region [] $
        Code.toSnippet source region Nothing
          (
            "This type alias is part of a mutually recursive set of type aliases."
          ,
            D.stack
              [ "It is part of this cycle of type aliases:"
              , D.cycle 4 name others
              , D.reflow $
                  "You need to convert at least one of these type aliases into a `type`."
              , D.link "Note" "Read" "recursive-alias"
                  "to learn why this `type` vs `type alias` distinction matters. It is subtle but important!"
              ]
          )


aliasToUnionDoc :: Name.Name -> [Name.Name] -> Src.Type -> Doc
aliasToUnionDoc name args tipe =
  D.vcat
    [ D.dullyellow $
        "type" <+> D.fromName name <+> (foldr (<+>) "=" (map D.fromName args))
    , D.green $
        D.indent 4 (D.fromName name)
    , D.dullyellow $
        D.indent 8 (RT.srcToDoc RT.App tipe)
    ]


================================================
FILE: compiler/src/Reporting/Error/Docs.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error.Docs
  ( Error(..)
  , SyntaxProblem(..)
  , NameProblem(..)
  , DefProblem(..)
  , toReports
  )
  where


import qualified Data.Name as Name
import qualified Data.NonEmptyList as NE

import Parse.Primitives (Row, Col)
import Parse.Symbol (BadOperator(..))
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import qualified Reporting.Render.Code as Code
import qualified Reporting.Error.Syntax as E
import qualified Reporting.Report as Report



data Error
  = NoDocs A.Region
  | ImplicitExposing A.Region
  | SyntaxProblem SyntaxProblem
  | NameProblems (NE.List NameProblem)
  | DefProblems (NE.List DefProblem)


data SyntaxProblem
  = Op Row Col
  | OpBad BadOperator Row Col
  | Name Row Col
  | Space E.Space Row Col
  | Comma Row Col
  | BadEnd Row Col


data NameProblem
  = NameDuplicate Name.Name A.Region A.Region
  | NameOnlyInDocs Name.Name A.Region
  | NameOnlyInExports Name.Name A.Region


data DefProblem
  = NoComment Name.Name A.Region
  | NoAnnotation Name.Name A.Region



-- TO REPORTS


toReports :: Code.Source -> Error -> NE.List Report.Report
toReports source err =
  case err of
    NoDocs region ->
      NE.singleton $
      Report.Report "NO DOCS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You must have a documentation comment between the module\
              \ declaration and the imports."
          ,
            D.reflow
              "Learn more at "
          )

    ImplicitExposing region ->
      NE.singleton $
      Report.Report "IMPLICIT EXPOSING" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I need you to be explicit about what this module exposes:"
          ,
            D.reflow $
              "A great API usually hides some implementation details, so it is rare that\
              \ everything in the file should be exposed. And requiring package authors\
              \ to be explicit about this is a way of adding another quality check before\
              \ code gets published. So as you write out the public API, ask yourself if\
              \ it will be easy to understand as people read the documentation!"
          )

    SyntaxProblem problem ->
      NE.singleton $
        toSyntaxProblemReport source problem

    NameProblems problems ->
      fmap (toNameProblemReport source) problems

    DefProblems problems ->
      fmap (toDefProblemReport source) problems



-- SYNTAX PROBLEM


toSyntaxProblemReport :: Code.Source -> SyntaxProblem -> Report.Report
toSyntaxProblemReport source problem =
  let
    toSyntaxReport row col details =
      let
        region = toRegion row col
      in
      Report.Report "PROBLEM IN DOCS" region [] $
        Code.toSnippet source region Nothing
          ( D.reflow "I was partway through parsing your module documentation, but I got stuck here:"
          , D.stack $
              [ D.reflow details
              , D.toSimpleHint $
                  "Read through  for\
                  \ tips on how to write module documentation!"
              ]
          )
  in
  case problem of
    Op row col ->
      toSyntaxReport row col $
        "I am trying to parse an operator like (+) or (*) but something is going wrong."

    OpBad _ row col ->
      toSyntaxReport row col $
        "I am trying to parse an operator like (+) or (*) but it looks like you are using\
        \ a reserved symbol in this case."

    Name row col ->
      toSyntaxReport row col $
        "I was expecting to see the name of another exposed value from this module."

    Space space row col ->
      E.toSpaceReport source space row col

    Comma row col ->
      toSyntaxReport row col $
        "I was expecting to see a comma next."

    BadEnd row col ->
      toSyntaxReport row col $
        "I am not really sure what I am getting stuck on though."


toRegion :: Row -> Col -> A.Region
toRegion row col =
  let
    pos = A.Position row col
  in
  A.Region pos pos



-- NAME PROBLEM


toNameProblemReport :: Code.Source -> NameProblem -> Report.Report
toNameProblemReport source problem =
  case problem of
    NameDuplicate name r1 r2 ->
      Report.Report "DUPLICATE DOCS" r2 [] $
        Code.toPair source r1 r2
          (
            D.reflow $
              "There can only be one `" <> Name.toChars name
              <> "` in your module documentation, but it is listed twice:"
          ,
            "Remove one of them!"
          )
          (
            D.reflow $
              "There can only be one `" <> Name.toChars name
              <> "` in your module documentation, but I see two. One here:"
          ,
            "And another one over here:"
          ,
            "Remove one of them!"
          )

    NameOnlyInDocs name region ->
      Report.Report "DOCS MISTAKE" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I do not see `" <> Name.toChars name
              <> "` in the `exposing` list, but it is in your module documentation:"
          ,
            D.reflow $
              "Does it need to be added to the `exposing` list as well? Or maybe you removed `"
              <> Name.toChars name <> "` and forgot to delete it here?"
          )

    NameOnlyInExports name region ->
      Report.Report "DOCS MISTAKE" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I do not see `" <> Name.toChars name
              <> "` in your module documentation, but it is in your `exposing` list:"
          ,
            D.stack
              [ D.reflow $
                  "Add a line like `@docs " <> Name.toChars name
                  <> "` to your module documentation!"
              , D.link "Note" "See" "docs" "for more guidance on writing high quality docs."
              ]
          )



-- DEF PROBLEM


toDefProblemReport :: Code.Source -> DefProblem -> Report.Report
toDefProblemReport source problem =
  case problem of
    NoComment name region ->
      Report.Report "NO DOCS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "The `" <> Name.toChars name <> "` definition does not have a documentation comment."
          ,
            D.stack
              [ D.reflow $
                  "Add documentation with nice examples of how to use it!"
              , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!"
              ]
          )

    NoAnnotation name region ->
      Report.Report "NO TYPE ANNOTATION" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "The `" <> Name.toChars name <> "` definition does not have a type annotation."
          ,
            D.stack
              [ D.reflow $
                  "I use the type variable names from your annotations when generating docs. So if\
                  \ you say `Html msg` in your type annotation, I can use `msg` in the docs and make\
                  \ them a bit clearer. So add an annotation and try to use nice type variables!"
              , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!"
              ]
          )


================================================
FILE: compiler/src/Reporting/Error/Import.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error.Import
  ( Error(..)
  , Problem(..)
  , toReport
  )
  where


import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified Reporting.Doc as D
import qualified Reporting.Render.Code as Code
import qualified Reporting.Report as Report
import qualified Reporting.Suggest as Suggest
import qualified Reporting.Annotation as A



-- ERROR


data Error =
  Error
    { _region :: A.Region
    , _import :: ModuleName.Raw
    , _unimported :: Set.Set ModuleName.Raw
    , _problem :: Problem
    }


data Problem
  = NotFound
  | Ambiguous FilePath [FilePath] Pkg.Name [Pkg.Name]
  | AmbiguousLocal FilePath FilePath [FilePath]
  | AmbiguousForeign Pkg.Name Pkg.Name [Pkg.Name]



-- TO REPORT


toReport :: Code.Source -> Error -> Report.Report
toReport source (Error region name unimportedModules problem) =
  case problem of
    NotFound ->
      Report.Report "MODULE NOT FOUND" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
          ,
            D.stack
              [
                D.reflow $
                  "I checked the \"dependencies\" and \"source-directories\" listed in your elm.json,\
                  \ but I cannot find it! Maybe it is a typo for one of these names?"
              ,
                D.dullyellow $ D.indent 4 $ D.vcat $
                  map D.fromName (toSuggestions name unimportedModules)
              ,
                case Map.lookup name Pkg.suggestions of
                  Nothing ->
                    D.toSimpleHint $
                      "If it is not a typo, check the \"dependencies\" and \"source-directories\"\
                      \ of your elm.json to make sure all the packages you need are listed there!"

                  Just dependency ->
                    D.toFancyHint
                      ["Maybe","you","want","the"
                      ,"`" <> D.fromName name <> "`"
                      ,"module","defined","in","the"
                      ,D.fromChars (Pkg.toChars dependency)
                      ,"package?","Running"
                      ,D.green (D.fromChars ("elm install " ++ Pkg.toChars dependency))
                      ,"should","make","it","available!"
                      ]
              ]
          )

    Ambiguous path _ pkg _ ->
      Report.Report "AMBIGUOUS IMPORT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
          ,
            D.stack
              [
                D.fillSep $
                  ["But","I","found","multiple","modules","with","that","name.","One","in","the"
                  ,D.dullyellow (D.fromChars (Pkg.toChars pkg))
                  ,"package,","and","another","defined","locally","in","the"
                  ,D.dullyellow (D.fromChars path)
                  ,"file.","I","do","not","have","a","way","to","choose","between","them."
                  ]
              ,
                D.reflow $
                  "Try changing the name of the locally defined module to clear up the ambiguity?"
              ]
          )

    AmbiguousLocal path1 path2 paths ->
      Report.Report "AMBIGUOUS IMPORT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
          ,
            D.stack
              [
                D.reflow $
                  "But I found multiple files in your \"source-directories\" with that name:"
              ,
                D.dullyellow $ D.indent 4 $ D.vcat $
                  map D.fromChars (path1:path2:paths)
              ,
                D.reflow $
                  "Change the module names to be distinct!"
              ]
          )

    AmbiguousForeign pkg1 pkg2 pkgs ->
      Report.Report "AMBIGUOUS IMPORT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You are trying to import a `" ++ ModuleName.toChars name ++ "` module:"
          ,
            D.stack
              [
                D.reflow $
                  "But multiple packages in your \"dependencies\" that expose a module that name:"
              ,
                D.dullyellow $ D.indent 4 $ D.vcat $
                  map (D.fromChars . Pkg.toChars) (pkg1:pkg2:pkgs)
              ,
                D.reflow $
                  "There is no way to disambiguate in cases like this right now. Of the known name\
                  \ clashes, they are usually for packages with similar purposes, so the current\
                  \ recommendation is to pick just one of them."
              , D.toSimpleNote $
                  "It seems possible to resolve this with new syntax in imports, but that is\
                  \ more complicated than it sounds. Right now, our module names are tied to GitHub\
                  \ repos, but we may want to get rid of that dependency for a variety of reasons.\
                  \ That would in turn have implications for our package infrastructure, hosting\
                  \ costs, and possibly on how package names are specified. The particular syntax\
                  \ chosen seems like it would interact with all these factors in ways that are\
                  \ difficult to predict, potentially leading to harder problems later on. So more\
                  \ design work and planning is needed on these topics."
              ]
          )



toSuggestions :: ModuleName.Raw -> Set.Set ModuleName.Raw -> [ModuleName.Raw]
toSuggestions name unimportedModules =
  take 4 $
    Suggest.sort (ModuleName.toChars name) ModuleName.toChars (Set.toList unimportedModules)


================================================
FILE: compiler/src/Reporting/Error/Json.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error.Json
  ( toReport
  , FailureToReport(..)
  , Context(..)
  , Reason(..)
  )
  where


import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as BS_UTF8
import qualified Data.NonEmptyList as NE

import Json.Decode (Error(..), Problem(..), DecodeExpectation(..), ParseError(..), StringProblem(..))
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import qualified Reporting.Exit.Help as Help
import qualified Reporting.Render.Code as Code



-- TO REPORT


toReport :: FilePath -> FailureToReport x -> Error x -> Reason -> Help.Report
toReport path ftr err reason =
  case err of
    DecodeProblem bytes problem ->
      problemToReport path ftr (Code.toSource bytes) CRoot problem reason

    ParseProblem bytes parseError ->
      parseErrorToReport path (Code.toSource bytes) parseError reason


newtype Reason =
  ExplicitReason String


because :: Reason -> String -> String
because (ExplicitReason iNeedThings) problem =
  iNeedThings ++ " " ++ problem



-- PARSE ERROR TO REPORT


parseErrorToReport :: FilePath -> Code.Source -> ParseError -> Reason -> Help.Report
parseErrorToReport path source parseError reason =
  let
    toSnippet title row col (problem, details) =
      let
        pos = A.Position row col
        surroundings = A.Region (A.Position (max 1 (row - 2)) 1) pos
        region = A.Region pos pos
      in
      Help.jsonReport title (Just path) $
        Code.toSnippet source surroundings (Just region)
          ( D.reflow (because reason problem)
          , details
          )
  in
  case parseError of
    Start row col ->
      toSnippet "EXPECTING A VALUE" row col
        (
          "I was expecting to see a JSON value next:"
        ,
          D.stack
            [ D.fillSep
                ["Try","something","like",D.dullyellow "\"this\"","or"
                ,D.dullyellow "42","to","move","on","to","better","hints!"
                ]
            , D.toSimpleNote $
                "The JSON specification does not allow trailing commas, so you can sometimes\
                \ get this error in arrays that have an extra comma at the end. In that case,\
                \ remove that last comma or add another array entry after it!"
            ]
        )

    ObjectField row col ->
      toSnippet "EXTRA COMMA" row col
        (
          "I was partway through parsing a JSON object when I got stuck here:"
        ,
          D.stack
            [ D.fillSep
                ["I","saw","a","comma","right","before","I","got","stuck","here,"
                ,"so","I","was","expecting","to","see","a","field","name","like"
                ,D.dullyellow "\"type\"","or",D.dullyellow "\"dependencies\"","next."
                ]
            , D.reflow $
                "This error is commonly caused by trailing commas in JSON objects. Those are\
                \ actually disallowed by  so check the previous line for a\
                \ trailing comma that may need to be deleted."
            , objectNote
            ]
        )

    ObjectColon row col ->
      toSnippet "EXPECTING COLON" row col
        (
          "I was partway through parsing a JSON object when I got stuck here:"
        ,
          D.stack
            [ D.reflow $ "I was expecting to see a colon next."
            , objectNote
            ]
        )

    ObjectEnd row col ->
      toSnippet "UNFINISHED OBJECT" row col
        (
          "I was partway through parsing a JSON object when I got stuck here:"
        ,
          D.stack
            [ D.reflow $
                "I was expecting to see a comma or a closing curly brace next."
            , D.reflow $
                "Is a comma missing on the previous line? Is an array missing a closing square\
                \ bracket? It is often something tricky like that!"
            , objectNote
            ]
        )

    ArrayEnd row col ->
      toSnippet "UNFINISHED ARRAY" row col
        (
          "I was partway through parsing a JSON array when I got stuck here:"
        ,
          D.stack
            [ D.reflow $ "I was expecting to see a comma or a closing square bracket next."
            , D.reflow $
                "Is a comma missing on the previous line? It is often something like that!"
            ]
        )

    StringProblem stringProblem row col ->
      case stringProblem of
        BadStringEnd ->
          toSnippet "ENDLESS STRING" row col
            (
              "I got to the end of the line without seeing the closing double quote:"
            ,
              D.fillSep $
                ["Strings","look","like",D.green "\"this\"","with","double"
                ,"quotes","on","each","end.","Is","the","closing","double"
                ,"quote","missing","in","your","code?"
                ]
            )

        BadStringControlChar ->
          toSnippet "UNEXPECTED CONTROL CHARACTER" row col
            (
              "I ran into a control character unexpectedly:"
            ,
              D.reflow $
                "These are characters that represent tabs, backspaces, newlines, and\
                \ a bunch of other invisible characters. They all come before 20 in the\
                \ ASCII range, and they are disallowed by the JSON specificaiton. Maybe\
                \ a copy/paste added one of these invisible characters to your JSON?"
            )

        BadStringEscapeChar ->
          toSnippet "UNKNOWN ESCAPE" row col
            (
              "Backslashes always start escaped characters, but I do not recognize this one:"
            ,
              D.stack
                [ D.reflow $
                    "Valid escape characters include:"
                , D.dullyellow $ D.indent 4 $ D.vcat $
                    ["\\\"","\\\\","\\/","\\b","\\f","\\n","\\r","\\t","\\u003D"]
                , D.reflow $
                    "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?"
                ]
            )

        BadStringEscapeHex ->
          toSnippet "BAD HEX ESCAPE" row col
            (
              "This is not a valid hex escape:"
            ,
              D.fillSep $
                ["Valid","hex","escapes","in","JSON","are","between"
                ,D.green "\\u0000","and",D.green "\\uFFFF"
                ,"and","always","have","exactly","four","digits."
                ]
            )

    NoLeadingZeros row col ->
      toSnippet "BAD NUMBER" row col
        (
          "Numbers cannot start with zeros like this:"
        ,
          D.reflow $ "Try deleting the leading zeros?"
        )

    NoFloats row col ->
      toSnippet "UNEXPECTED NUMBER" row col
        (
          "I got stuck while trying to parse this number:"
        ,
          D.reflow $
            "I do not accept floating point numbers like 3.1415 right now. That kind\
            \ of JSON value is not needed for any of the uses that Elm has for now."
        )

    BadEnd row col ->
      toSnippet "JSON PROBLEM" row col
        (
          "I was partway through parsing some JSON when I got stuck here:"
        ,
          D.reflow $
            "I am not really sure what is wrong. This sometimes means there is extra\
            \ stuff after a valid JSON value?"
        )


objectNote :: D.Doc
objectNote =
  D.stack
    [ D.toSimpleNote $ "Here is an example of a valid JSON object for reference:"
    , D.vcat
        [ D.indent 4 $ "{"
        , D.indent 6 $ D.dullyellow "\"name\"" <> ": " <> D.dullyellow "\"Tom\"" <> ","
        , D.indent 6 $ D.dullyellow "\"age\"" <> ": " <> D.dullyellow "42"
        , D.indent 4 $ "}"
        ]
    , D.reflow $
        "Notice that (1) the field names are in double quotes and (2) there is no\
        \ trailing comma after the last entry. Both are strict requirements in JSON!"
    ]



-- PROBLEM TO REPORT


data Context
  = CRoot
  | CField BS.ByteString Context
  | CIndex Int Context


problemToReport :: FilePath -> FailureToReport x -> Code.Source -> Context -> Problem x -> Reason -> Help.Report
problemToReport path ftr source context problem reason =
  case problem of
    Field field prob ->
      problemToReport path ftr source (CField field context) prob reason

    Index index prob ->
      problemToReport path ftr source (CIndex index context) prob reason

    OneOf p ps ->
      -- NOTE: only displays the deepest problem. This works well for the kind
      -- of JSON used by Elm, but probably would not work well in general.
      let
        (NE.List prob _) = NE.sortBy (negate . getMaxDepth) (NE.List p ps)
      in
      problemToReport path ftr source context prob reason

    Failure region x ->
      _failureToReport ftr path source context region x

    Expecting region expectation ->
      expectationToReport path source context region expectation reason


getMaxDepth :: Problem x -> Int
getMaxDepth problem =
  case problem of
    Field _ prob  -> 1 + getMaxDepth prob
    Index _ prob  -> 1 + getMaxDepth prob
    OneOf p ps    -> maximum (getMaxDepth p : map getMaxDepth ps)
    Failure _ _   -> 0
    Expecting _ _ -> 0


newtype FailureToReport x =
  FailureToReport { _failureToReport :: FilePath -> Code.Source -> Context -> A.Region -> x -> Help.Report }


expectationToReport :: FilePath -> Code.Source -> Context -> A.Region -> DecodeExpectation -> Reason -> Help.Report
expectationToReport path source context (A.Region start end) expectation reason =
  let
    (A.Position sr _) = start
    (A.Position er _) = end

    region =
      if sr == er then region else A.Region start start

    introduction =
      case context of
        CRoot ->
          "I ran into some trouble here:"

        CField field _ ->
          "I ran into trouble with the value of the \"" ++ BS_UTF8.toString field ++ "\" field:"

        CIndex index (CField field _) ->
          "When looking at the \"" ++ BS_UTF8.toString field ++ "\" field, I ran into trouble with the "
          ++ D.intToOrdinal index ++ " entry:"

        CIndex index _ ->
          "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:"

    toSnippet title aThing =
      Help.jsonReport title (Just path) $
        Code.toSnippet source region Nothing
          ( D.reflow (because reason introduction)
          , D.fillSep $ ["I","was","expecting","to","run","into"] ++ aThing
          )
  in
  case expectation of
    TObject ->
      toSnippet "EXPECTING OBJECT" ["an", D.green "OBJECT" <> "."]

    TArray ->
      toSnippet "EXPECTING ARRAY" ["an", D.green "ARRAY" <> "."]

    TString ->
      toSnippet "EXPECTING STRING" ["a", D.green "STRING" <> "."]

    TBool ->
      toSnippet "EXPECTING BOOL" ["a", D.green "BOOLEAN" <> "."]

    TInt ->
      toSnippet "EXPECTING INT" ["an", D.green "INT" <> "."]

    TObjectWith field ->
      toSnippet "MISSING FIELD"
        ["an",D.green "OBJECT","with","a"
        ,D.green ("\"" <> D.fromChars (BS_UTF8.toString field) <> "\"")
        ,"field."
        ]

    TArrayPair len ->
      toSnippet "EXPECTING PAIR"
        ["an",D.green "ARRAY","with",D.green "TWO","entries."
        ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements."
        ]


================================================
FILE: compiler/src/Reporting/Error/Main.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error.Main
  ( Error(..)
  , toReport
  )
  where


import qualified Data.Name as Name

import qualified AST.Canonical as Can
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import qualified Reporting.Error.Canonicalize as E
import qualified Reporting.Render.Code as Code
import qualified Reporting.Render.Type as RT
import qualified Reporting.Render.Type.Localizer as L
import qualified Reporting.Report as Report



-- ERROR


data Error
  = BadType A.Region Can.Type
  | BadCycle A.Region Name.Name [Name.Name]
  | BadFlags A.Region Can.Type E.InvalidPayload



-- TO REPORT


toReport :: L.Localizer -> Code.Source -> Error -> Report.Report
toReport localizer source err =
  case err of
    BadType region tipe ->
      Report.Report "BAD MAIN TYPE" region [] $
        Code.toSnippet source region Nothing
          (
            "I cannot handle this type of `main` value:"
          ,
            D.stack
              [ "The type of `main` value I am seeing is:"
              , D.indent 4 $ D.dullyellow $ RT.canToDoc localizer RT.None tipe
              , D.reflow $
                  "I only know how to handle Html, Svg, and Programs\
                  \ though. Modify `main` to be one of those types of values!"
              ]
          )

    BadCycle region name names ->
      Report.Report "BAD MAIN" region [] $
        Code.toSnippet source region Nothing
          (
            "A `main` definition cannot be defined in terms of itself."
          ,
            D.stack
              [ D.reflow $
                  "It should be a boring value with no recursion. But\
                  \ instead it is involved in this cycle of definitions:"
              , D.cycle 4 name names
              ]
          )

    BadFlags region _badType invalidPayload ->
      let
        formatDetails (aBadKindOfThing, butThatIsNoGood) =
          Report.Report "BAD FLAGS" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "Your `main` program wants " ++ aBadKindOfThing ++ " from JavaScript."
              ,
                butThatIsNoGood
              )
      in
      formatDetails $
        case invalidPayload of
          E.ExtendedRecord ->
            (
              "an extended record"
            ,
              D.reflow $
                "But the exact shape of the record must be known at compile time. No type variables!"
            )

          E.Function ->
            (
              "a function"
            ,
              D.reflow $
                "But if I allowed functions from JS, it would be possible to sneak\
                \ side-effects and runtime exceptions into Elm!"
            )

          E.TypeVariable name ->
            (
              "an unspecified type"
            ,
              D.reflow $
                "But type variables like `" ++ Name.toChars name ++ "` cannot be given as flags.\
                \ I need to know exactly what type of data I am getting, so I can guarantee that\
                \ unexpected data cannot sneak in and crash the Elm program."
            )

          E.UnsupportedType name ->
            (
              "a `" ++ Name.toChars name ++ "` value"
            ,
              D.stack
                [ D.reflow $ "I cannot handle that. The types that CAN be in flags include:"
                , D.indent 4 $
                    D.reflow $
                      "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\
                      \ tuples, records, and JSON values."
                , D.reflow $
                    "Since JSON values can flow through, you can use JSON encoders and decoders\
                    \ to allow other types through as well. More advanced users often just do\
                    \ everything with encoders and decoders for more control and better errors."
                ]
            )


================================================
FILE: compiler/src/Reporting/Error/Pattern.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error.Pattern
  ( P.Error(..)
  , toReport
  )
  where

import qualified Data.List as List

import qualified Elm.String as ES
import qualified Nitpick.PatternMatches as P
import qualified Reporting.Doc as D
import qualified Reporting.Report as Report
import qualified Reporting.Render.Code as Code



-- TO REPORT


toReport :: Code.Source -> P.Error -> Report.Report
toReport source err =
  case err of
    P.Redundant caseRegion patternRegion index ->
      Report.Report "REDUNDANT PATTERN" patternRegion [] $
        Code.toSnippet source caseRegion (Just patternRegion)
          (
            D.reflow $
              "The " <> D.intToOrdinal index <> " pattern is redundant:"
          ,
            D.reflow $
              "Any value with this shape will be handled by a previous\
              \ pattern, so it should be removed."
          )

    P.Incomplete region context unhandled ->
      case context of
        P.BadArg ->
          Report.Report "UNSAFE PATTERN" region [] $
            Code.toSnippet source region Nothing
              (
                "This pattern does not cover all possibilities:"
              ,
                D.stack
                  [ "Other possibilities include:"
                  , unhandledPatternsToDocBlock unhandled
                  , D.reflow $
                      "I would have to crash if I saw one of those! So rather than\
                      \ pattern matching in function arguments, put a `case` in\
                      \ the function body to account for all possibilities."
                  ]
              )

        P.BadDestruct ->
          Report.Report "UNSAFE PATTERN" region [] $
            Code.toSnippet source region Nothing
              (
                "This pattern does not cover all possible values:"
              ,
                D.stack
                  [ "Other possibilities include:"
                  , unhandledPatternsToDocBlock unhandled
                  , D.reflow $
                      "I would have to crash if I saw one of those! You can use\
                      \ `let` to deconstruct values only if there is ONE possibility.\
                      \ Switch to a `case` expression to account for all possibilities."
                  , D.toSimpleHint $
                      "Are you calling a function that definitely returns values\
                      \ with a very specific shape? Try making the return type of\
                      \ that function more specific!"
                  ]
              )

        P.BadCase ->
          Report.Report "MISSING PATTERNS" region [] $
            Code.toSnippet source region Nothing
              (
                "This `case` does not have branches for all possibilities:"
              ,
                D.stack
                  [ "Missing possibilities include:"
                  , unhandledPatternsToDocBlock unhandled
                  , D.reflow $
                      "I would have to crash if I saw one of those. Add branches for them!"
                  , D.link "Hint"
                      "If you want to write the code for each branch later, use `Debug.todo` as a placeholder. Read"
                      "missing-patterns"
                      "for more guidance on this workflow."
                  ]
              )



-- PATTERN TO DOC


unhandledPatternsToDocBlock :: [P.Pattern] -> D.Doc
unhandledPatternsToDocBlock unhandledPatterns =
  D.indent 4 $ D.dullyellow $ D.vcat $
    map (patternToDoc Unambiguous) unhandledPatterns


data Context
  = Arg
  | Head
  | Unambiguous
  deriving (Eq)


patternToDoc :: Context -> P.Pattern -> D.Doc
patternToDoc context pattern =
  case delist pattern [] of
    NonList P.Anything ->
      "_"

    NonList (P.Literal literal) ->
      case literal of
        P.Chr chr ->
          "'" <> D.fromChars (ES.toChars chr) <> "'"

        P.Str str ->
          "\"" <> D.fromChars (ES.toChars str) <> "\""

        P.Int int ->
          D.fromInt int

    NonList (P.Ctor _ "#0" []) ->
      "()"

    NonList (P.Ctor _ "#2" [a,b]) ->
      "( " <> patternToDoc Unambiguous a <>
      ", " <> patternToDoc Unambiguous b <>
      " )"

    NonList (P.Ctor _ "#3" [a,b,c]) ->
      "( " <> patternToDoc Unambiguous a <>
      ", " <> patternToDoc Unambiguous b <>
      ", " <> patternToDoc Unambiguous c <>
      " )"

    NonList (P.Ctor _ name args) ->
      let
        ctorDoc =
          D.hsep (D.fromName name : map (patternToDoc Arg) args)
      in
      if context == Arg && length args > 0 then
        "(" <> ctorDoc <> ")"
      else
        ctorDoc

    FiniteList [] ->
      "[]"

    FiniteList entries ->
      let entryDocs = map (patternToDoc Unambiguous) entries in
      "[" <> D.hcat (List.intersperse "," entryDocs) <> "]"

    Conses conses finalPattern ->
      let
        consDoc =
          foldr
            (\hd tl -> patternToDoc Head hd <> " :: " <> tl)
            (patternToDoc Unambiguous finalPattern)
            conses
      in
      if context == Unambiguous then
        consDoc
      else
        "(" <> consDoc <> ")"


data Structure
  = FiniteList [P.Pattern]
  | Conses [P.Pattern] P.Pattern
  | NonList P.Pattern


delist :: P.Pattern -> [P.Pattern] -> Structure
delist pattern revEntries =
  case pattern of
    P.Ctor _ "[]" [] ->
      FiniteList revEntries

    P.Ctor _ "::" [hd,tl] ->
      delist tl (hd:revEntries)

    _ ->
      case revEntries of
        [] ->
          NonList pattern

        _ ->
          Conses (reverse revEntries) pattern


================================================
FILE: compiler/src/Reporting/Error/Syntax.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error.Syntax
  ( Error(..)
  , toReport
  --
  , Module(..)
  , Exposing(..)
  --
  , Decl(..)
  , DeclType(..)
  , TypeAlias(..)
  , CustomType(..)
  , DeclDef(..)
  , Port(..)
  --
  , Expr(..)
  , Record(..)
  , Tuple(..)
  , List(..)
  , Func(..)
  , Case(..)
  , If(..)
  , Let(..)
  , Def(..)
  , Destruct(..)
  --
  , Pattern(..)
  , PRecord(..)
  , PTuple(..)
  , PList(..)
  --
  , Type(..)
  , TRecord(..)
  , TTuple(..)
  --
  , Char(..)
  , String(..)
  , Escape(..)
  , Number(..)
  --
  , Space(..)
  , toSpaceReport
  )
  where


import Prelude hiding (Char, String)
import qualified Data.Char as Char
import qualified Data.Name as Name
import Data.Word (Word16)
import Numeric (showHex)

import qualified Elm.ModuleName as ModuleName
import Parse.Primitives (Row, Col)
import Parse.Symbol (BadOperator(..))
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import qualified Reporting.Report as Report
import qualified Reporting.Render.Code as Code



-- ALL SYNTAX ERRORS


data Error
  = ModuleNameUnspecified ModuleName.Raw
  | ModuleNameMismatch ModuleName.Raw (A.Located ModuleName.Raw)
  | UnexpectedPort A.Region
  | NoPorts A.Region
  | NoPortsInPackage (A.Located Name.Name)
  | NoPortModulesInPackage A.Region
  | NoEffectsOutsideKernel A.Region
  | ParseError Module



-- MODULE


data Module
  = ModuleSpace Space Row Col
  | ModuleBadEnd Row Col
  --
  | ModuleProblem Row Col
  | ModuleName Row Col
  | ModuleExposing Exposing Row Col
  --
  | PortModuleProblem Row Col
  | PortModuleName Row Col
  | PortModuleExposing Exposing Row Col
  --
  | Effect Row Col
  --
  | FreshLine Row Col
  --
  | ImportStart Row Col
  | ImportName Row Col
  | ImportAs Row Col
  | ImportAlias Row Col
  | ImportExposing Row Col
  | ImportExposingList Exposing Row Col
  | ImportEnd Row Col -- different based on col=1 or if greater
  --
  | ImportIndentName Row Col
  | ImportIndentAlias Row Col
  | ImportIndentExposingList Row Col
  --
  | Infix Row Col
  --
  | Declarations Decl Row Col


data Exposing
  = ExposingSpace Space Row Col
  | ExposingStart Row Col
  | ExposingValue Row Col
  | ExposingOperator Row Col
  | ExposingOperatorReserved BadOperator Row Col
  | ExposingOperatorRightParen Row Col
  | ExposingTypePrivacy Row Col
  | ExposingEnd Row Col
  --
  | ExposingIndentEnd Row Col
  | ExposingIndentValue Row Col



-- DECLARATIONS


data Decl
  = DeclStart Row Col
  | DeclSpace Space Row Col
  --
  | Port Port Row Col
  | DeclType DeclType Row Col
  | DeclDef Name.Name DeclDef Row Col
  --
  | DeclFreshLineAfterDocComment Row Col


data DeclDef
  = DeclDefSpace Space Row Col
  | DeclDefEquals Row Col
  | DeclDefType Type Row Col
  | DeclDefArg Pattern Row Col
  | DeclDefBody Expr Row Col
  | DeclDefNameRepeat Row Col
  | DeclDefNameMatch Name.Name Row Col
  --
  | DeclDefIndentType Row Col
  | DeclDefIndentEquals Row Col
  | DeclDefIndentBody Row Col


data Port
  = PortSpace Space Row Col
  | PortName Row Col
  | PortColon Row Col
  | PortType Type Row Col
  | PortIndentName Row Col
  | PortIndentColon Row Col
  | PortIndentType Row Col



-- TYPE DECLARATIONS


data DeclType
  = DT_Space Space Row Col
  | DT_Name Row Col
  | DT_Alias TypeAlias Row Col
  | DT_Union CustomType Row Col
  --
  | DT_IndentName Row Col


data TypeAlias
  = AliasSpace Space Row Col
  | AliasName Row Col
  | AliasEquals Row Col
  | AliasBody Type Row Col
  --
  | AliasIndentEquals Row Col
  | AliasIndentBody Row Col


data CustomType
  = CT_Space Space Row Col
  | CT_Name Row Col
  | CT_Equals Row Col
  | CT_Bar Row Col
  | CT_Variant Row Col
  | CT_VariantArg Type Row Col
  --
  | CT_IndentEquals Row Col
  | CT_IndentBar Row Col
  | CT_IndentAfterBar Row Col
  | CT_IndentAfterEquals Row Col



-- EXPRESSIONS


data Expr
  = Let Let Row Col
  | Case Case Row Col
  | If If Row Col
  | List List Row Col
  | Record Record Row Col
  | Tuple Tuple Row Col
  | Func Func Row Col
  --
  | Dot Row Col
  | Access Row Col
  | OperatorRight Name.Name Row Col
  | OperatorReserved BadOperator Row Col
  --
  | Start Row Col
  | Char Char Row Col
  | String String Row Col
  | Number Number Row Col
  | Space Space Row Col
  | EndlessShader Row Col
  | ShaderProblem [Char.Char] Row Col
  | IndentOperatorRight Name.Name Row Col


data Record
  = RecordOpen Row Col
  | RecordEnd Row Col
  | RecordField Row Col
  | RecordEquals Row Col
  | RecordExpr Expr Row Col
  | RecordSpace Space Row Col
  --
  | RecordIndentOpen Row Col
  | RecordIndentEnd Row Col
  | RecordIndentField Row Col
  | RecordIndentEquals Row Col
  | RecordIndentExpr Row Col


data Tuple
  = TupleExpr Expr Row Col
  | TupleSpace Space Row Col
  | TupleEnd Row Col
  | TupleOperatorClose Row Col
  | TupleOperatorReserved BadOperator Row Col
  --
  | TupleIndentExpr1 Row Col
  | TupleIndentExprN Row Col
  | TupleIndentEnd Row Col


data List
  = ListSpace Space Row Col
  | ListOpen Row Col
  | ListExpr Expr Row Col
  | ListEnd Row Col
  --
  | ListIndentOpen Row Col
  | ListIndentEnd Row Col
  | ListIndentExpr Row Col


data Func
  = FuncSpace Space Row Col
  | FuncArg Pattern Row Col
  | FuncBody Expr Row Col
  | FuncArrow Row Col
  --
  | FuncIndentArg Row Col
  | FuncIndentArrow Row Col
  | FuncIndentBody Row Col


data Case
  = CaseSpace Space Row Col
  | CaseOf Row Col
  | CasePattern Pattern Row Col
  | CaseArrow Row Col
  | CaseExpr Expr Row Col
  | CaseBranch Expr Row Col
  --
  | CaseIndentOf Row Col
  | CaseIndentExpr Row Col
  | CaseIndentPattern Row Col
  | CaseIndentArrow Row Col
  | CaseIndentBranch Row Col
  | CasePatternAlignment Word16 Row Col


data If
  = IfSpace Space Row Col
  | IfThen Row Col
  | IfElse Row Col
  | IfElseBranchStart Row Col
  --
  | IfCondition Expr Row Col
  | IfThenBranch Expr Row Col
  | IfElseBranch Expr Row Col
  --
  | IfIndentCondition Row Col
  | IfIndentThen Row Col
  | IfIndentThenBranch Row Col
  | IfIndentElseBranch Row Col
  | IfIndentElse Row Col


data Let
  = LetSpace Space Row Col
  | LetIn Row Col
  | LetDefAlignment Word16 Row Col
  | LetDefName Row Col
  | LetDef Name.Name Def Row Col
  | LetDestruct Destruct Row Col
  | LetBody Expr Row Col
  | LetIndentDef Row Col
  | LetIndentIn Row Col
  | LetIndentBody Row Col


data Def
  = DefSpace Space Row Col
  | DefType Type Row Col
  | DefNameRepeat Row Col
  | DefNameMatch Name.Name Row Col
  | DefArg Pattern Row Col
  | DefEquals Row Col
  | DefBody Expr Row Col
  | DefIndentEquals Row Col
  | DefIndentType Row Col
  | DefIndentBody Row Col
  | DefAlignment Word16 Row Col


data Destruct
  = DestructSpace Space Row Col
  | DestructPattern Pattern Row Col
  | DestructEquals Row Col
  | DestructBody Expr Row Col
  | DestructIndentEquals Row Col
  | DestructIndentBody Row Col



-- PATTERNS


data Pattern
  = PRecord PRecord Row Col
  | PTuple PTuple Row Col
  | PList PList Row Col
  --
  | PStart Row Col
  | PChar Char Row Col
  | PString String Row Col
  | PNumber Number Row Col
  | PFloat Word16 Row Col
  | PAlias Row Col
  | PWildcardNotVar Name.Name Int Row Col
  | PSpace Space Row Col
  --
  | PIndentStart Row Col
  | PIndentAlias Row Col


data PRecord
  = PRecordOpen Row Col
  | PRecordEnd Row Col
  | PRecordField Row Col
  | PRecordSpace Space Row Col
  --
  | PRecordIndentOpen Row Col
  | PRecordIndentEnd Row Col
  | PRecordIndentField Row Col


data PTuple
  = PTupleOpen Row Col
  | PTupleEnd Row Col
  | PTupleExpr Pattern Row Col
  | PTupleSpace Space Row Col
  --
  | PTupleIndentEnd Row Col
  | PTupleIndentExpr1 Row Col
  | PTupleIndentExprN Row Col


data PList
  = PListOpen Row Col
  | PListEnd Row Col
  | PListExpr Pattern Row Col
  | PListSpace Space Row Col
  --
  | PListIndentOpen Row Col
  | PListIndentEnd Row Col
  | PListIndentExpr Row Col



-- TYPES


data Type
  = TRecord TRecord Row Col
  | TTuple TTuple Row Col
  --
  | TStart Row Col
  | TSpace Space Row Col
  --
  | TIndentStart Row Col


data TRecord
  = TRecordOpen Row Col
  | TRecordEnd Row Col
  --
  | TRecordField Row Col
  | TRecordColon Row Col
  | TRecordType Type Row Col
  --
  | TRecordSpace Space Row Col
  --
  | TRecordIndentOpen Row Col
  | TRecordIndentField Row Col
  | TRecordIndentColon Row Col
  | TRecordIndentType Row Col
  | TRecordIndentEnd Row Col


data TTuple
  = TTupleOpen Row Col
  | TTupleEnd Row Col
  | TTupleType Type Row Col
  | TTupleSpace Space Row Col
  --
  | TTupleIndentType1 Row Col
  | TTupleIndentTypeN Row Col
  | TTupleIndentEnd Row Col



-- LITERALS


data Char
  = CharEndless
  | CharEscape Escape
  | CharNotString Word16


data String
  = StringEndless_Single
  | StringEndless_Multi
  | StringEscape Escape


data Escape
  = EscapeUnknown
  | BadUnicodeFormat Word16
  | BadUnicodeCode Word16
  | BadUnicodeLength Word16 Int Int


data Number
  = NumberEnd
  | NumberDot Int
  | NumberHexDigit
  | NumberNoLeadingZero



-- MISC


data Space
  = HasTab
  | EndlessMultiComment



-- TO REPORT


toReport :: Code.Source -> Error -> Report.Report
toReport source err =
  case err of
    ModuleNameUnspecified name ->
      let
        region = toRegion 1 1
      in
      Report.Report "MODULE NAME MISSING" region [] $
        D.stack
          [ D.reflow $
              "I need the module name to be declared at the top of this file, like this:"
          , D.indent 4 $ D.fillSep $
              [ D.cyan "module", D.fromName name, D.cyan "exposing", "(..)" ]
          , D.reflow $
              "Try adding that as the first line of your file!"
          , D.toSimpleNote $
              "It is best to replace (..) with an explicit list of types and\
              \ functions you want to expose. When you know a value is only used\
              \ within this module, you can refactor without worrying about uses\
              \ elsewhere. Limiting exposed values can also speed up compilation\
              \ because I can skip a bunch of work if I see that the exposed API\
              \ has not changed."
          ]

    ModuleNameMismatch expectedName (A.At region actualName) ->
      Report.Report "MODULE NAME MISMATCH" region [ModuleName.toChars expectedName] $
        Code.toSnippet source region Nothing
          (
            "It looks like this module name is out of sync:"
          ,
            D.stack
              [ D.reflow $
                  "I need it to match the file path, so I was expecting to see `"
                  ++ ModuleName.toChars expectedName
                  ++ "` here. Make the following change, and you should be all set!"
              , D.indent 4 $
                  D.dullyellow (D.fromName actualName) <> " -> " <> D.green (D.fromName expectedName)
              , D.toSimpleNote $
                  "I require that module names correspond to file paths. This makes it much\
                  \ easier to explore unfamiliar codebases! So if you want to keep the current\
                  \ module name, try renaming the file instead."
              ]
          )

    UnexpectedPort region ->
      Report.Report "UNEXPECTED PORTS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You are declaring ports in a normal module."
          ,
            D.stack
              [ D.fillSep
                  ["Switch","this","to","say",D.cyan "port module","instead,"
                  ,"marking","that","this","module","contains","port","declarations."
                  ]
              , D.link "Note"
                  "Ports are not a traditional FFI for calling JS functions directly. They need a different mindset! Read"
                  "ports"
                  "to learn the syntax and how to use it effectively."
              ]
          )

    NoPorts region ->
      Report.Report "NO PORTS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "This module does not declare any ports, but it says it will:"
          ,
            D.fillSep
              ["Switch","this","to",D.cyan "module"
              ,"and","you","should","be","all","set!"
              ]
          )

    NoPortsInPackage (A.At region _) ->
      Report.Report "PACKAGES CANNOT HAVE PORTS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "Packages cannot declare any ports, so I am getting stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "Remove this port declaration."
              , noteForPortsInPackage
              ]
          )

    NoPortModulesInPackage region ->
      Report.Report "PACKAGES CANNOT HAVE PORTS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "Packages cannot declare any ports, so I am getting stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["Remove","the",D.cyan "port","keyword","and","I"
                  ,"should","be","able","to","continue."
                  ]
              , noteForPortsInPackage
              ]
          )

    NoEffectsOutsideKernel region ->
      Report.Report "INVALID EFFECT MODULE" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "It is not possible to declare an `effect module` outside the @elm organization,\
              \ so I am getting stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "Switch to a normal module declaration."
              , D.toSimpleNote $
                  "Effect modules are designed to allow certain core functionality to be\
                  \ defined separately from the compiler. So the @elm organization has access to\
                  \ this so that certain changes, extensions, and fixes can be introduced without\
                  \ needing to release new Elm binaries. For example, we want to make it possible\
                  \ to test effects, but this may require changes to the design of effect modules.\
                  \ By only having them defined in the @elm organization, that kind of design work\
                  \ can proceed much more smoothly."
              ]
          )

    ParseError modul ->
      toParseErrorReport source modul


noteForPortsInPackage :: D.Doc
noteForPortsInPackage =
  D.stack
    [ D.toSimpleNote $
        "One of the major goals of the package ecosystem is to be completely written\
        \ in Elm. This means when you install an Elm package, you can be sure you are safe\
        \ from security issues on install and that you are not going to get any runtime\
        \ exceptions coming from your new dependency. This design also sets the ecosystem\
        \ up to target other platforms more easily (like mobile phones, WebAssembly, etc.)\
        \ since no community code explicitly depends on JavaScript even existing."
    , D.reflow $
        "Given that overall goal, allowing ports in packages would lead to some pretty\
        \ surprising behavior. If ports were allowed in packages, you could install a\
        \ package but not realize that it brings in an indirect dependency that defines a\
        \ port. Now you have a program that does not work and the fix is to realize that\
        \ some JavaScript needs to be added for a dependency you did not even know about.\
        \ That would be extremely frustrating! \"So why not allow the package author to\
        \ include the necessary JS code as well?\" Now we are back in conflict with our\
        \ overall goal to keep all community packages free from runtime exceptions."
    ]


toParseErrorReport :: Code.Source -> Module -> Report.Report
toParseErrorReport source modul =
  case modul of
    ModuleSpace space row col ->
      toSpaceReport source space row col

    ModuleBadEnd row col ->
      if col == 1
      then toDeclStartReport source row col
      else toWeirdEndReport source row col

    ModuleProblem row col ->
      let
        region = toRegion row col
      in
      Report.Report "UNFINISHED MODULE DECLARATION" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I am parsing an `module` declaration, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "Here are some examples of valid `module` declarations:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "module","Main",D.cyan "exposing","(..)"]
                  , D.fillSep [D.cyan "module","Dict",D.cyan "exposing","(Dict, empty, get)"]
                  ]
              , D.reflow $
                  "I generally recommend using an explicit exposing list. I can skip compiling a bunch\
                  \ of files when the public interface of a module stays the same, so exposing fewer\
                  \ values can help improve compile times!"
              ]
          )

    ModuleName row col ->
      let
        region = toRegion row col
      in
      Report.Report "EXPECTING MODULE NAME" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was parsing an `module` declaration until I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see the module name next, like in these examples:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "module","Dict",D.cyan "exposing","(..)"]
                  , D.fillSep [D.cyan "module","Maybe",D.cyan "exposing","(..)"]
                  , D.fillSep [D.cyan "module","Html.Attributes",D.cyan "exposing","(..)"]
                  , D.fillSep [D.cyan "module","Json.Decode",D.cyan "exposing","(..)"]
                  ]
              , D.reflow $
                  "Notice that the module names all start with capital letters. That is required!"
              ]
          )

    ModuleExposing exposing row col ->
      toExposingReport source exposing row col

    PortModuleProblem row col ->
      let
        region = toRegion row col
      in
      Report.Report "UNFINISHED PORT MODULE DECLARATION" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I am parsing an `port module` declaration, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "Here are some examples of valid `port module` declarations:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "port",D.cyan "module","WebSockets",D.cyan "exposing","(send, listen, keepAlive)"]
                  , D.fillSep [D.cyan "port",D.cyan "module","Maps",D.cyan "exposing","(Location, goto)"]
                  ]
              , D.link "Note" "Read" "ports" "for more help."
              ]
          )

    PortModuleName row col ->
      let
        region = toRegion row col
      in
      Report.Report "EXPECTING MODULE NAME" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was parsing an `module` declaration until I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see the module name next, like in these examples:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "port",D.cyan "module","WebSockets",D.cyan "exposing","(send, listen, keepAlive)"]
                  , D.fillSep [D.cyan "port",D.cyan "module","Maps",D.cyan "exposing","(Location, goto)"]
                  ]
              , D.reflow $
                  "Notice that the module names start with capital letters. That is required!"
              ]
          )

    PortModuleExposing exposing row col ->
      toExposingReport source exposing row col

    Effect row col ->
      let
        region = toRegion row col
      in
      Report.Report "BAD MODULE DECLARATION" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I cannot parse this module declaration:"
          ,
            D.reflow $
              "This type of module is reserved for the @elm organization. It is used to\
              \ define certain effects, avoiding building them into the compiler."
          )

    FreshLine row col ->
      let
        region = toRegion row col

        toBadFirstLineReport keyword =
          Report.Report "TOO MUCH INDENTATION" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "This `" ++ keyword ++ "` should not have any spaces before it:"
              ,
                D.reflow $
                  "Delete the spaces before `" ++ keyword ++ "` until there are none left!"
              )

      in
      case Code.whatIsNext source row col of
        Code.Keyword "module" -> toBadFirstLineReport "module"
        Code.Keyword "import" -> toBadFirstLineReport "import"
        Code.Keyword "type" -> toBadFirstLineReport "type"
        Code.Keyword "port" -> toBadFirstLineReport "port"
        _ ->
          Report.Report "SYNTAX PROBLEM" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "I am not sure what is going on, but I recommend starting an Elm\
                      \ file with the following lines:"
                  , D.indent 4 $ D.vcat $
                      [ D.fillSep [D.cyan "import","Html"]
                      , ""
                      , "main ="
                      , "  Html.text " <> D.dullyellow "\"Hello!\""
                      ]
                  , D.reflow $
                      "You should be able to copy those lines directly into your file. Check out the\
                      \ examples at  for more help getting started!"
                  , D.toSimpleNote $
                      "This can also happen when something is indented too much!"
                  ]
              )

    ImportStart row col ->
      toImportReport source row col

    ImportName row col ->
      let
        region = toRegion row col
      in
      Report.Report "EXPECTING IMPORT NAME" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was parsing an `import` until I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see a module name next, like in these examples:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "import","Dict"]
                  , D.fillSep [D.cyan "import","Maybe"]
                  , D.fillSep [D.cyan "import","Html.Attributes",D.cyan "as","A"]
                  , D.fillSep [D.cyan "import","Json.Decode",D.cyan "exposing","(..)"]
                  ]
              , D.reflow $
                  "Notice that the module names all start with capital letters. That is required!"
              , D.reflowLink "Read" "imports" "to learn more."
              ]
          )

    ImportAs row col ->
      toImportReport source row col

    ImportAlias row col ->
      let
        region = toRegion row col
      in
      Report.Report "EXPECTING IMPORT ALIAS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was parsing an `import` until I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see an alias next, like in these examples:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "import","Html.Attributes",D.cyan "as","Attr"]
                  , D.fillSep [D.cyan "import","WebGL.Texture",D.cyan "as","Texture"]
                  , D.fillSep [D.cyan "import","Json.Decode",D.cyan "as","D"]
                  ]
              , D.reflow $
                  "Notice that the alias always starts with a capital letter. That is required!"
              , D.reflowLink "Read" "imports" "to learn more."
              ]
          )

    ImportExposing row col ->
      toImportReport source row col

    ImportExposingList exposing row col ->
      toExposingReport source exposing row col

    ImportEnd row col ->
      toImportReport source row col

    ImportIndentName row col ->
      toImportReport source row col

    ImportIndentAlias row col ->
      toImportReport source row col

    ImportIndentExposingList row col ->
      let
        region = toRegion row col
      in
      Report.Report "UNFINISHED IMPORT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was parsing an `import` until I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see the list of exposed values next. For example, here\
                  \ are two ways to expose values from the `Html` module:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "import","Html",D.cyan "exposing","(..)"]
                  , D.fillSep [D.cyan "import","Html",D.cyan "exposing","(Html, div, text)"]
                  ]
              , D.reflow $
                  "I generally recommend the second style. It is more explicit, making it\
                  \ much easier to figure out where values are coming from in large projects!"
              ]
          )

    Infix row col ->
      let
        region = toRegion row col
      in
      Report.Report "BAD INFIX" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "Something went wrong in this infix operator declaration:"
          ,
            D.reflow $
              "This feature is used by the @elm organization to define the\
              \ languages built-in operators."
          )

    Declarations decl _ _ ->
      toDeclarationsReport source decl



-- WEIRD END


toWeirdEndReport :: Code.Source -> Row -> Col -> Report.Report
toWeirdEndReport source row col =
  case Code.whatIsNext source row col of
    Code.Keyword keyword ->
      let
        region = toKeywordRegion row col keyword
      in
      Report.Report "RESERVED WORD" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I got stuck on this reserved word:"
          ,
            D.reflow $
              "The name `" ++ keyword ++ "` is reserved, so try using a different name?"
          )

    Code.Operator op ->
      let
        region = toKeywordRegion row col op
      in
      Report.Report "UNEXPECTED SYMBOL" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I ran into an unexpected symbol:"
          ,
            D.reflow $
              "I was not expecting to see a " ++ op ++ " here. Try deleting it? Maybe\
              \ I can give a better hint from there?"
          )

    Code.Close term bracket ->
      let
        region = toRegion row col
      in
      Report.Report ("UNEXPECTED " ++ map Char.toUpper term) region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I ran into an unexpected " ++ term ++ ":"
          ,
            D.reflow $
              "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?"
          )

    Code.Lower c cs ->
      let
        region = toKeywordRegion row col (c:cs)
      in
      Report.Report "UNEXPECTED NAME" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I got stuck on this name:"
          ,
            D.reflow $
              "It is confusing me a lot! Normally I can give fairly specific hints, but\
              \ something is really tripping me up this time."
          )

    Code.Upper c cs ->
      let
        region = toKeywordRegion row col (c:cs)
      in
      Report.Report "UNEXPECTED NAME" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I got stuck on this name:"
          ,
            D.reflow $
              "It is confusing me a lot! Normally I can give fairly specific hints, but\
              \ something is really tripping me up this time."
          )

    Code.Other maybeChar ->
      let
        region = toRegion row col
      in
      case maybeChar of
        Just ';' ->
          Report.Report "UNEXPECTED SEMICOLON" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "I got stuck on this semicolon:"
              ,
                D.stack
                  [ D.reflow $ "Try removing it?"
                  , D.toSimpleNote $
                      "Some languages require semicolons at the end of each statement. These are\
                      \ often called C-like languages, and they usually share a lot of language design\
                      \ choices. (E.g. side-effects, for loops, etc.) Elm manages effects with commands\
                      \ and subscriptions instead, so there is no special syntax for \"statements\" and\
                      \ therefore no need to use semicolons to separate them. I think this will make\
                      \ more sense as you work through  though!"
                  ]
              )

        Just ',' ->
          Report.Report "UNEXPECTED COMMA" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "I got stuck on this comma:"
              ,
                D.stack
                  [ D.reflow $
                      "I do not think I am parsing a list or tuple right now. Try deleting the comma?"
                  , D.toSimpleNote $
                      "If this is supposed to be part of a list, the problem may be a bit earlier.\
                      \ Perhaps the opening [ is missing? Or perhaps some value in the list has an extra\
                      \ closing ] that is making me think the list ended earlier? The same kinds of\
                      \ things could be going wrong if this is supposed to be a tuple."
                  ]
              )

        Just '`' ->
          Report.Report "UNEXPECTED CHARACTER" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "I got stuck on this character:"
              ,
                D.stack
                  [ D.reflow $
                      "It is not used for anything in Elm syntax. It is used for multi-line strings in\
                      \ some languages though, so if you want a string that spans multiple lines, you\
                      \ can use Elm's multi-line string syntax like this:"
                  , D.dullyellow $ D.indent 4 $ D.vcat $
                      [ "\"\"\""
                      , "# Multi-line Strings"
                      , ""
                      , "- start with triple double quotes"
                      , "- write whatever you want"
                      , "- no need to escape newlines or double quotes"
                      , "- end with triple double quotes"
                      , "\"\"\""
                      ]
                  , D.reflow $
                      "Otherwise I do not know what is going on! Try removing the character?"
                  ]
              )

        Just '$' ->
          Report.Report "UNEXPECTED SYMBOL" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "I got stuck on this dollar sign:"
              ,
                D.reflow $
                  "It is not used for anything in Elm syntax. Are you coming from a language where\
                  \ dollar signs can be used in variable names? If so, try a name that (1) starts\
                  \ with a letter and (2) only contains letters, numbers, and underscores."
              )

        Just c | elem c ['#','@','!','%','~'] ->
          Report.Report "UNEXPECTED SYMBOL" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "I got stuck on this symbol:"
              ,
                D.reflow $
                  "It is not used for anything in Elm syntax. Try removing it?"
              )

        _ ->
          Report.Report "SYNTAX PROBLEM" region [] $
            Code.toSnippet source region Nothing
              (
                D.reflow $
                  "I got stuck here:"
              ,
                D.reflow $
                  "Whatever I am running into is confusing me a lot! Normally I can give fairly\
                  \ specific hints, but something is really tripping me up this time."
              )



-- IMPORTS


toImportReport :: Code.Source -> Row -> Col -> Report.Report
toImportReport source row col =
  let
    region = toRegion row col
  in
  Report.Report "UNFINISHED IMPORT" region [] $
    Code.toSnippet source region Nothing
      (
        D.reflow $
          "I am partway through parsing an import, but I got stuck here:"
      ,
        D.stack
          [ D.reflow $
              "Here are some examples of valid `import` declarations:"
          , D.indent 4 $ D.vcat $
              [ D.fillSep [D.cyan "import","Html"]
              , D.fillSep [D.cyan "import","Html",D.cyan "as","H"]
              , D.fillSep [D.cyan "import","Html",D.cyan "as","H",D.cyan "exposing","(..)"]
              , D.fillSep [D.cyan "import","Html",D.cyan "exposing","(Html, div, text)"]
              ]
          , D.reflow $
              "You are probably trying to import a different module, but try to make it look like one of these examples!"
          , D.reflowLink "Read" "imports" "to learn more."
          ]
      )



-- EXPOSING


toExposingReport :: Code.Source -> Exposing -> Row -> Col -> Report.Report
toExposingReport source exposing startRow startCol =
  case exposing of
    ExposingSpace space row col ->
      toSpaceReport source space row col

    ExposingStart row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM IN EXPOSING" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I want to parse exposed values, but I am getting stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["Exposed","values","are","always","surrounded","by","parentheses."
                  ,"So","try","adding","a",D.green "(","here?"
                  ]
              , D.toSimpleNote "Here are some valid examples of `exposing` for reference:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "import","Html",D.cyan "exposing","(..)"]
                  , D.fillSep [D.cyan "import","Html",D.cyan "exposing","(Html, div, text)"]
                  ]
              , D.reflow $
                  "If you are getting tripped up, you can just expose everything for now. It should\
                  \ get easier to make an explicit exposing list as you see more examples in the wild."
              ]
          )

    ExposingValue row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I got stuck on this reserved word:"
              ,
                D.reflow $
                  "It looks like you are trying to expose `" ++ keyword ++ "` but that is a reserved word. Is there a typo?"
              )

        Code.Operator op ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col op
          in
          Report.Report "UNEXPECTED SYMBOL" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I got stuck on this symbol:"
              ,
                D.stack
                  [ D.reflow $
                      "If you are trying to expose an operator, add parentheses around it like this:"
                  , D.indent 4 $ D.dullyellow (D.fromChars op) <> " -> " <> D.green ("(" <> D.fromChars op <> ")")
                  ]
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN EXPOSING" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I got stuck while parsing these exposed values:"
              ,
                D.stack
                  [ D.reflow $
                      "I do not have an exact recommendation, so here are some valid examples\
                      \ of `exposing` for reference:"
                  , D.indent 4 $ D.vcat $
                      [ D.fillSep [D.cyan "import","Html",D.cyan "exposing","(..)"]
                      , D.fillSep [D.cyan "import","Basics",D.cyan "exposing","(Int, Float, Bool(..), (+), not, sqrt)"]
                      ]
                  , D.reflow $
                      "These examples show how to expose types, variants, operators, and functions. Everything\
                      \ should be some permutation of these examples, just with different names."
                  ]
              )

    ExposingOperator row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM IN EXPOSING" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw an open parenthesis, so I was expecting an operator next:"
          ,
            D.fillSep $
              ["It","is","possible","to","expose","operators,","so","I","was","expecting"
              ,"to","see","something","like",D.dullyellow "(+)","or",D.dullyellow "(|=)"
              ,"or",D.dullyellow "(||)","after","I","saw","that","open","parenthesis."
              ]
          )

    ExposingOperatorReserved op row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "RESERVED SYMBOL" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I cannot expose this as an operator:"
          ,
            case op of
              BadDot -> D.reflow "Try getting rid of this entry? Maybe I can give you a better hint after that?"
              BadPipe -> D.fillSep ["Maybe","you","want",D.dullyellow "(||)","instead?"]
              BadArrow -> D.reflow "Try getting rid of this entry? Maybe I can give you a better hint after that?"
              BadEquals -> D.fillSep ["Maybe","you","want",D.dullyellow "(==)","instead?"]
              BadHasType -> D.fillSep ["Maybe","you","want",D.dullyellow "(::)","instead?"]
          )

    ExposingOperatorRightParen row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM IN EXPOSING" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "It looks like you are exposing an operator, but I got stuck here:"
          ,
            D.fillSep $
              ["I","was","expecting","to","see","the","closing","parenthesis","immediately"
              ,"after","the","operator.","Try","adding","a",D.green ")","right","here?"
              ]
          )

    ExposingEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED EXPOSING" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was partway through parsing exposed values, but I got stuck here:"
          ,
            D.reflow $
              "Maybe there is a comma missing before this?"
          )

    ExposingTypePrivacy row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM EXPOSING CUSTOM TYPE VARIANTS" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "It looks like you are trying to expose the variants of a custom type:"
          ,
            D.stack
              [ D.fillSep $
                  ["You","need","to","write","something","like"
                  ,D.dullyellow "Status(..)","or",D.dullyellow "Entity(..)"
                  ,"though.","It","is","all","or","nothing,","otherwise","`case`"
                  ,"expressions","could","miss","a","variant","and","crash!"
                  ]
              , D.toSimpleNote $
                  "It is often best to keep the variants hidden! If someone pattern matches on\
                  \ the variants, it is a MAJOR change if any new variants are added. Suddenly\
                  \ their `case` expressions do not cover all variants! So if you do not need\
                  \ people to pattern match, keep the variants hidden and expose functions to\
                  \ construct values of this type. This way you can add new variants as a MINOR change!"
              ]
          )

    ExposingIndentEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED EXPOSING" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was partway through parsing exposed values, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","a","closing","parenthesis."
                  ,"Try","adding","a",D.green ")","right","here?"
                  ]
              , D.toSimpleNote $
                  "I can get confused when there is not enough indentation, so if you already\
                  \ have a closing parenthesis, it probably just needs some spaces in front of it."
              ]
          )

    ExposingIndentValue row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED EXPOSING" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was partway through parsing exposed values, but I got stuck here:"
          ,
            D.reflow $
              "I was expecting another value to expose."
          )



-- SPACES


toSpaceReport :: Code.Source -> Space -> Row -> Col -> Report.Report
toSpaceReport source space row col =
  case space of
    HasTab ->
      let
        region = toRegion row col
      in
      Report.Report "NO TABS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I ran into a tab, but tabs are not allowed in Elm files."
          ,
            D.reflow $
              "Replace the tab with spaces."
          )

    EndlessMultiComment ->
      let
        region = toWiderRegion row col 2
      in
      Report.Report "ENDLESS COMMENT" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I cannot find the end of this multi-line comment:"
          ,
            D.stack -- "{-"
              [ D.reflow "Add a -} somewhere after this to end the comment."
              , D.toSimpleHint
                  "Multi-line comments can be nested in Elm, so {- {- -} -} is a comment\
                  \ that happens to contain another comment. Like parentheses and curly braces,\
                  \ the start and end markers must always be balanced. Maybe that is the problem?"
              ]
          )



-- DECLARATIONS


toRegion :: Row -> Col -> A.Region
toRegion row col =
  let
    pos = A.Position row col
  in
  A.Region pos pos


toWiderRegion :: Row -> Col -> Word16 -> A.Region
toWiderRegion row col extra =
  A.Region
    (A.Position row col)
    (A.Position row (col + extra))


toKeywordRegion :: Row -> Col -> [Char.Char] -> A.Region
toKeywordRegion row col keyword =
  A.Region
    (A.Position row col)
    (A.Position row (col + fromIntegral (length keyword)))


toDeclarationsReport :: Code.Source -> Decl -> Report.Report
toDeclarationsReport source decl =
  case decl of
    DeclStart row col ->
      toDeclStartReport source row col

    DeclSpace space row col ->
      toSpaceReport source space row col

    Port port_ row col ->
      toPortReport source port_ row col

    DeclType declType row col ->
      toDeclTypeReport source declType row col

    DeclDef name declDef row col ->
      toDeclDefReport source name declDef row col

    DeclFreshLineAfterDocComment row col ->
      let
        region = toRegion row col
      in
      Report.Report "EXPECTING DECLARATION" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I just saw a doc comment, but then I got stuck here:"
          ,
            D.reflow $
              "I was expecting to see the corresponding declaration next, starting on a fresh\
              \ line with no indentation."
          )


toDeclStartReport :: Code.Source -> Row -> Col -> Report.Report
toDeclStartReport source row col =
  case Code.whatIsNext source row col of
    Code.Close term bracket ->
      let
        region = toRegion row col
      in
      Report.Report ("STRAY " ++ map Char.toUpper term) region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was not expecting to see a " ++ term ++ " here:"
          , D.reflow $
              "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?"
          )

    Code.Keyword keyword ->
      let
        region = toKeywordRegion row col keyword
      in
      Report.Report "RESERVED WORD" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was not expecting to run into the `" ++ keyword ++ "` keyword here:"
          ,
            case keyword of
              "import" ->
                D.reflow $
                  "It is reserved for declaring imports at the top of your module. If you want\
                  \ another import, try moving it up top with the other imports. If you want to\
                  \ define a value or function, try changing the name to something else!"

              "case" ->
                D.stack
                  [ D.reflow $
                      "It is reserved for writing `case` expressions. Try using a different name?"
                  , D.toSimpleNote $
                      "If you are trying to write a `case` expression, it needs to be part of a\
                      \ definition. So you could write something like this instead:"
                  , D.indent 4 $ D.vcat $
                      [ D.indent 0 $ D.fillSep ["getWidth","maybeWidth","="]
                      , D.indent 2 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
                      , D.indent 4 $ D.fillSep [D.blue "Just","width","->"]
                      , D.indent 6 $ D.fillSep ["width","+",D.dullyellow "200"]
                      , ""
                      , D.indent 4 $ D.fillSep [D.blue "Nothing","->"]
                      , D.indent 6 $ D.fillSep [D.dullyellow "400"]
                      ]
                  , D.reflow $
                      "This defines a `getWidth` function that you can use elsewhere in your program."
                  ]

              "if" ->
                D.stack
                  [ D.reflow $
                      "It is reserved for writing `if` expressions. Try using a different name?"
                  , D.toSimpleNote $
                      "If you are trying to write an `if` expression, it needs to be part of a\
                      \ definition. So you could write something like this instead:"
                  , D.indent 4 $ D.vcat $
                      [ "greet name ="
                      , D.fillSep $
                          [" "
                          ,D.cyan "if","name","==",D.dullyellow "\"Abraham Lincoln\""
                          ,D.cyan "then",D.dullyellow "\"Greetings Mr. President.\""
                          ,D.cyan "else",D.dullyellow "\"Hey!\""
                          ]
                      ]
                  , D.reflow $
                      "This defines a `reviewPowerLevel` function that you can use elsewhere in your program."
                  ]

              _ ->
                D.reflow $
                  "It is a reserved word. Try changing the name to something else?"
          )

    Code.Upper c cs ->
      let
        region = toRegion row col
      in
      Report.Report "UNEXPECTED CAPITAL LETTER" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "Declarations always start with a lower-case letter, so I am getting stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["Try","a","name","like"
                  ,D.green (D.fromChars (Char.toLower c : cs))
                  ,"instead?"
                  ]
              , D.toSimpleNote $
                  "Here are a couple valid declarations for reference:"
              , D.indent 4 $ D.vcat $
                  [ "greet : String -> String"
                  , "greet name ="
                  , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                  , ""
                  , D.cyan "type" <> " User = Anonymous | LoggedIn String"
                  ]
              , D.reflow $
                  "Notice that they always start with a lower-case letter. Capitalization matters!"
              ]
          )

    Code.Other (Just char) | elem char ['(', '{', '[', '+', '-', '*', '/', '^', '&', '|', '"', '\'', '!', '@', '#', '$', '%'] ->
      let
        region = toRegion row col
      in
      Report.Report "UNEXPECTED SYMBOL" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I am getting stuck because this line starts with the " ++ [char] ++ " symbol:"
          ,
            D.stack
              [ D.reflow $
                  "When a line has no spaces at the beginning, I expect it to be a declaration like one of these:"
              , D.indent 4 $ D.vcat $
                  [ "greet : String -> String"
                  , "greet name ="
                  , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                  , ""
                  , D.cyan "type" <> " User = Anonymous | LoggedIn String"
                  ]
              , D.reflow $
                  "If this is not supposed to be a declaration, try adding some spaces before it?"
              ]
          )

    _ ->
      let
        region = toRegion row col
      in
      Report.Report "WEIRD DECLARATION" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I am trying to parse a declaration, but I am getting stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "When a line has no spaces at the beginning, I expect it to be a declaration like one of these:"
              , D.indent 4 $ D.vcat $
                  [ "greet : String -> String"
                  , "greet name ="
                  , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                  , ""
                  , D.cyan "type" <> " User = Anonymous | LoggedIn String"
                  ]
              , D.reflow $
                  "Try to make your declaration look like one of those? Or if this is not\
                  \ supposed to be a declaration, try adding some spaces before it?"
              ]
          )


-- PORT


toPortReport :: Code.Source -> Port -> Row -> Col -> Report.Report
toPortReport source port_ startRow startCol =
  case port_ of
    PortSpace space row col ->
      toSpaceReport source space row col

    PortName row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I cannot handle ports with names like this:"
              ,
                D.reflow $
                  "You are trying to make a port named `" ++ keyword
                  ++ "` but that is a reserved word. Try using some other name?"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PORT PROBLEM" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I just saw the start of a `port` declaration, but then I got stuck here:"
              ,
                D.stack
                  [ D.fillSep
                      ["I","was","expecting","to","see","a","name","like"
                      ,D.dullyellow "send","or",D.dullyellow "receive","next."
                      ,"Something","that","starts","with","a","lower-case","letter."
                      ]
                  , portNote
                  ]
              )

    PortColon row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PORT PROBLEM" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the start of a `port` declaration, but then I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see a colon next. And then a type that tells me\
                  \ what type of values are going to flow through."
              , portNote
              ]
          )

    PortType tipe row col ->
      toTypeReport source TC_Port tipe row col

    PortIndentName row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PORT" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the start of a `port` declaration, but then I got stuck here:"
          ,
            D.stack
              [ D.fillSep
                  ["I","was","expecting","to","see","a","name","like"
                  ,D.dullyellow "send","or",D.dullyellow "receive","next."
                  ,"Something","that","starts","with","a","lower-case","letter."
                  ]
              , portNote
              ]
          )

    PortIndentColon row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PORT" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the start of a `port` declaration, but then I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see a colon next. And then a type that tells me\
                  \ what type of values are going to flow through."
              , portNote
              ]
          )

    PortIndentType row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PORT" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the start of a `port` declaration, but then I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see a type next. Here are examples of outgoing and\
                  \ incoming ports for reference:"
              , D.indent 4 $ D.vcat $
                  [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
                  , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
                  ]
              , D.reflow $
                  "The first line defines a `send` port so you can send strings out to JavaScript.\
                  \ Maybe you send them on a WebSocket or put them into IndexedDB. The second line\
                  \ defines a `receive` port so you can receive strings from JavaScript. Maybe you\
                  \ get receive messages when new WebSocket messages come in or when an entry in\
                  \ IndexedDB changes for some external reason."
              ]
          )


portNote :: D.Doc
portNote =
  D.stack
    [ D.toSimpleNote $
        "Here are some example `port` declarations for reference:"
    , D.indent 4 $ D.vcat $
        [ D.fillSep [D.cyan "port","send",":","String -> Cmd msg"]
        , D.fillSep [D.cyan "port","receive",":","(String -> msg) -> Sub msg"]
        ]
    , D.reflow $
        "The first line defines a `send` port so you can send strings out to JavaScript.\
        \ Maybe you send them on a WebSocket or put them into IndexedDB. The second line\
        \ defines a `receive` port so you can receive strings from JavaScript. Maybe you\
        \ get receive messages when new WebSocket messages come in or when the IndexedDB\
        \ is changed for some external reason."
    ]



-- DECL TYPE


toDeclTypeReport :: Code.Source -> DeclType -> Row -> Col -> Report.Report
toDeclTypeReport source declType startRow startCol =
  case declType of
    DT_Space space row col ->
      toSpaceReport source space row col

    DT_Name row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "EXPECTING TYPE NAME" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I think I am parsing a type declaration, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","a","name","like",D.dullyellow "Status","or",D.dullyellow "Style"
                  ,"next.","Just","make","sure","it","is","a","name","that","starts","with","a","capital","letter!"
                  ]
              , customTypeNote
              ]
          )

    DT_Alias typeAlias row col ->
      toTypeAliasReport source typeAlias row col

    DT_Union customType row col ->
      toCustomTypeReport source customType row col

    DT_IndentName row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "EXPECTING TYPE NAME" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I think I am parsing a type declaration, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","a","name","like",D.dullyellow "Status","or",D.dullyellow "Style"
                  ,"next.","Just","make","sure","it","is","a","name","that","starts","with","a","capital","letter!"
                  ]
              , customTypeNote
              ]
          )


toTypeAliasReport :: Code.Source -> TypeAlias -> Row -> Col -> Report.Report
toTypeAliasReport source typeAlias startRow startCol =
  case typeAlias of
    AliasSpace space row col ->
      toSpaceReport source space row col

    AliasName row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "EXPECTING TYPE ALIAS NAME" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a type alias, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","a","name","like",D.dullyellow "Person","or",D.dullyellow "Point"
                  ,"next.","Just","make","sure","it","is","a","name","that","starts","with","a","capital","letter!"
                  ]
              , typeAliasNote
              ]
          )

    AliasEquals row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I ran into a reserved word unexpectedly while parsing this type alias:"
              ,
                D.stack
                  [ D.reflow $
                      "It looks like you are trying use `" ++ keyword
                      ++ "` as a type variable, but it is a reserved word. Try using a different name?"
                  , typeAliasNote
                  ]
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN TYPE ALIAS" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a type alias, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "I was expecting to see a type variable or an equals sign next."
                  , typeAliasNote
                  ]
              )

    AliasBody tipe row col ->
      toTypeReport source TC_TypeAlias tipe row col

    AliasIndentEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED TYPE ALIAS" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a type alias, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see a type variable or an equals sign next."
              , typeAliasNote
              ]
          )

    AliasIndentBody row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED TYPE ALIAS" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a type alias, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","to","see","a","type","next.","Something","as","simple"
                  ,"as",D.dullyellow "Int","or",D.dullyellow "Float","would","work!"
                  ]
              , typeAliasNote
              ]
          )


typeAliasNote :: D.Doc
typeAliasNote =
  D.stack
    [ D.toSimpleNote $
        "Here is an example of a valid `type alias` for reference:"
    , D.vcat $
        [ D.indent 4 $ D.fillSep [D.cyan "type",D.cyan "alias","Person","="]
        , D.indent 6 $ D.vcat $
             ["{ name : String"
             ,", age : Int"
             ,", height : Float"
             ,"}"
             ]
        ]
    , D.reflow $
        "This would let us use `Person` as a shorthand for that record type. Using this\
        \ shorthand makes type annotations much easier to read, and makes changing code\
        \ easier if you decide later that there is more to a person than age and height!"
    ]


toCustomTypeReport :: Code.Source -> CustomType -> Row -> Col -> Report.Report
toCustomTypeReport source customType startRow startCol =
  case customType of
    CT_Space space row col ->
      toSpaceReport source space row col

    CT_Name row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "EXPECTING TYPE NAME" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I think I am parsing a type declaration, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","a","name","like",D.dullyellow "Status","or",D.dullyellow "Style"
                  ,"next.","Just","make","sure","it","is","a","name","that","starts","with","a","capital","letter!"
                  ]
              , customTypeNote
              ]
          )

    CT_Equals row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I ran into a reserved word unexpectedly while parsing this custom type:"
              ,
                D.stack
                  [ D.reflow $
                      "It looks like you are trying use `" ++ keyword
                      ++ "` as a type variable, but it is a reserved word. Try using a different name?"
                  , customTypeNote
                  ]
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN CUSTOM TYPE" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a custom type, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "I was expecting to see a type variable or an equals sign next."
                  , customTypeNote
                  ]
              )

    CT_Bar row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM IN CUSTOM TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a custom type, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see a vertical bar like | next."
              , customTypeNote
              ]
          )

    CT_Variant row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM IN CUSTOM TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a custom type, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","to","see","a","variant","name","next."
                  ,"Something","like",D.dullyellow "Success","or",D.dullyellow "Sandwich" <> "."
                  ,"Any","name","that","starts","with","a","capital","letter","really!"
                  ]
              , customTypeNote
              ]
          )

    CT_VariantArg tipe row col ->
      toTypeReport source TC_CustomType tipe row col

    CT_IndentEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED CUSTOM TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a custom type, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see a type variable or an equals sign next."
              , customTypeNote
              ]
          )

    CT_IndentBar row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED CUSTOM TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a custom type, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see a vertical bar like | next."
              , customTypeNote
              ]
          )

    CT_IndentAfterBar row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED CUSTOM TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a custom type, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I just saw a vertical bar, so I was expecting to see another variant defined next."
              , customTypeNote
              ]
          )

    CT_IndentAfterEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED CUSTOM TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a custom type, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I just saw an equals sign, so I was expecting to see the first variant defined next."
              , customTypeNote
              ]
          )


customTypeNote :: D.Doc
customTypeNote =
  D.stack
    [ D.toSimpleNote $
        "Here is an example of a valid `type` declaration for reference:"
    , D.vcat $
        [ D.indent 4 $ D.fillSep [D.cyan "type","Status"]
        , D.indent 6 $ D.fillSep ["=","Failure"]
        , D.indent 6 $ D.fillSep ["|","Waiting"]
        , D.indent 6 $ D.fillSep ["|","Success","String"]
        ]
    , D.reflow $
        "This defines a new `Status` type with three variants. This could be useful if\
        \ we are waiting for an HTTP request. Maybe we start with `Waiting` and then\
        \ switch to `Failure` or `Success \"message from server\"` depending on how\
        \ things go. Notice that the Success variant has some associated data, allowing\
        \ us to store a String if the request goes well!"
    ]



-- DECL DEF


toDeclDefReport :: Code.Source -> Name.Name -> DeclDef -> Row -> Col -> Report.Report
toDeclDefReport source name declDef startRow startCol =
  case declDef of
    DeclDefSpace space row col ->
      toSpaceReport source space row col

    DeclDefEquals row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.fillSep
                  ["The","name"
                  ,"`" <> D.cyan (D.fromChars keyword) <> "`"
                  ,"is","reserved","in","Elm,","so","it","cannot"
                  ,"be","used","as","an","argument","here:"
                  ]
              ,
                D.stack
                  [ D.reflow $
                      "Try renaming it to something else."
                  , case keyword of
                      "as" ->
                        D.toFancyNote
                          ["This","keyword","is","reserved","for","pattern","matches","like"
                          ,"((x,y)",D.cyan "as","point)","where","you","want","to","name","a","tuple","and"
                          ,"the","values","it","contains."
                          ]

                      _ ->
                        D.toSimpleNote $
                          "The `" ++ keyword ++ "` keyword has a special meaning in Elm, so it can only be used in certain situations."
                  ]
              )

        Code.Operator "->" ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toWiderRegion row col 2
          in
          Report.Report "MISSING COLON?" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was not expecting to see an arrow here:"
              ,
                D.stack
                  [ D.fillSep
                      ["This","usually","means","a",D.green ":","is","missing","a","bit","earlier","in"
                      ,"a","type","annotation.","It","could","be","something","else","though,","so"
                      ,"here","is","a","valid","definition","for","reference:"
                      ]
                  , D.indent 4 $ D.vcat $
                      [ "greet : String -> String"
                      , "greet name ="
                      , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                      ]
                  , D.reflow $
                      "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
                  ]
              )

        Code.Operator op ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col op
          in
          Report.Report "UNEXPECTED SYMBOL" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was not expecting to see this symbol here:"
              ,
                D.stack
                  [ D.reflow $
                      "I am not sure what is going wrong exactly, so here is a valid\
                      \ definition (with an optional type annotation) for reference:"
                  , D.indent 4 $ D.vcat $
                      [ "greet : String -> String"
                      , "greet name ="
                      , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                      ]
                  , D.reflow $
                      "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
                  ]
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN DEFINITION" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:"
              ,
                D.stack
                  [ D.reflow $
                      "I am not sure what is going wrong exactly, so here is a valid\
                      \ definition (with an optional type annotation) for reference:"
                  , D.indent 4 $ D.vcat $
                      [ "greet : String -> String"
                      , "greet name ="
                      , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                      ]
                  , D.reflow $
                      "Try to use that format!"
                  ]
              )

    DeclDefType tipe row col ->
      toTypeReport source (TC_Annotation name) tipe row col

    DeclDefArg pattern row col ->
      toPatternReport source PArg pattern row col

    DeclDefBody expr row col ->
      toExprReport source (InDef name startRow startCol) expr row col

    DeclDefNameRepeat row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "EXPECTING DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the type annotation for `" ++ Name.toChars name
              ++ "` so I was expecting to see its definition here:"
          ,
            D.stack
              [ D.reflow $
                  "Type annotations always appear directly above the relevant\
                  \ definition, without anything else in between. (Not even doc comments!)"
              , declDefNote
              ]
          )

    DeclDefNameMatch defName row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "NAME MISMATCH" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw a type annotation for `" ++ Name.toChars name ++ "`, but it is followed by a definition for `" ++ Name.toChars defName ++ "`:"
          ,
            D.stack
              [ D.reflow $
                  "These names do not match! Is there a typo?"
              , D.indent 4 $ D.fillSep $
                  [D.dullyellow (D.fromName defName),"->",D.green (D.fromName name)]
              ]
          )

    DeclDefIndentType row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck while parsing the `" ++ Name.toChars name ++ "` type annotation:"
          ,
            D.stack
              [ D.reflow $
                  "I just saw a colon, so I am expecting to see a type next."
              , declDefNote
              ]
          )

    DeclDefIndentEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see an argument or an equals sign next."
              , declDefNote
              ]
          )

    DeclDefIndentBody row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see an expression next. What is it equal to?"
              , declDefNote
              ]
          )


declDefNote :: D.Doc
declDefNote =
  D.stack
    [ D.reflow $
        "Here is a valid definition (with a type annotation) for reference:"
    , D.indent 4 $ D.vcat $
        [ "greet : String -> String"
        , "greet name ="
        , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
        ]
    , D.reflow $
        "The top line (called a \"type annotation\") is optional. You can leave it off\
        \ if you want. As you get more comfortable with Elm and as your project grows,\
        \ it becomes more and more valuable to add them though! They work great as\
        \ compiler-verified documentation, and they often improve error messages!"
    ]



-- CONTEXT


data Context
  = InNode Node Row Col Context
  | InDef Name.Name Row Col
  | InDestruct Row Col


data Node
  = NRecord
  | NParens
  | NList
  | NFunc
  | NCond
  | NThen
  | NElse
  | NCase
  | NBranch
  deriving (Eq)


getDefName :: Context -> Maybe Name.Name
getDefName context =
  case context of
    InDestruct _ _ -> Nothing
    InDef name _ _ -> Just name
    InNode _ _ _ c -> getDefName c


isWithin :: Node -> Context -> Bool
isWithin desiredNode context =
  case context of
    InDestruct _ _          -> False
    InDef _ _ _             -> False
    InNode actualNode _ _ _ -> desiredNode == actualNode



-- EXPR REPORTS


toExprReport :: Code.Source -> Context -> Expr -> Row -> Col -> Report.Report
toExprReport source context expr startRow startCol =
  case expr of
    Let let_ row col ->
      toLetReport source context let_ row col

    Case case_ row col ->
      toCaseReport source context case_ row col

    If if_ row col ->
      toIfReport source context if_ row col

    List list row col ->
      toListReport source context list row col

    Record record row col ->
      toRecordReport source context record row col

    Tuple tuple row col ->
      toTupleReport source context tuple row col

    Func func row col ->
      toFuncReport source context func row col

    Dot row col ->
      let region = toRegion row col in
      Report.Report "EXPECTING RECORD ACCESSOR" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was expecting to see a record accessor here:"
          ,
            D.fillSep
              ["Something","like",D.dullyellow".name","or",D.dullyellow".price"
              ,"that","accesses","a","value","from","a","record."
              ]
          )

    Access row col ->
      let region = toRegion row col in
      Report.Report "EXPECTING RECORD ACCESSOR" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I am trying to parse a record accessor here:"
          ,
            D.stack
              [
                D.fillSep
                  ["Something","like",D.dullyellow".name","or",D.dullyellow".price"
                  ,"that","accesses","a","value","from","a","record."
                  ]
              ,
                D.toSimpleNote $
                  "Record field names must start with a lower case letter!"
              ]
          )

    OperatorRight op row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
        isMath = elem op ["-","+","*","/","^"]
      in
      Report.Report "MISSING EXPRESSION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
                "I just saw a " ++ Name.toChars op ++ " "
                ++ (if isMath then "sign" else "operator")
                ++ ", so I am getting stuck here:"
          ,
            if isMath then
              D.fillSep
                ["I","was","expecting","to","see","an","expression","next."
                ,"Something","like",D.dullyellow "42","or",D.dullyellow "1000"
                ,"that","makes","sense","with","a",D.fromName op,"sign."
                ]
            else if op == "&&" || op == "||" then
              D.fillSep
                ["I","was","expecting","to","see","an","expression","next."
                ,"Something","like",D.dullyellow "True","or",D.dullyellow "False"
                ,"that","makes","sense","with","boolean","logic."
                ]
            else if op == "|>" then
              D.reflow $
                "I was expecting to see a function next."
            else if op == "<|" then
              D.reflow $
                "I was expecting to see an argument next."
            else
              D.reflow $
                "I was expecting to see an expression next."
          )

    OperatorReserved operator row col ->
      toOperatorReport source context operator row col

    Start row col ->
      let
        (contextRow, contextCol, aThing) =
          case context of
            InDestruct r c       -> (r, c, "a definition")
            InDef name r c       -> (r, c, "the `" ++ Name.toChars name ++ "` definition")
            InNode NRecord r c _ -> (r, c, "a record")
            InNode NParens r c _ -> (r, c, "some parentheses")
            InNode NList   r c _ -> (r, c, "a list")
            InNode NFunc   r c _ -> (r, c, "an anonymous function")
            InNode NCond   r c _ -> (r, c, "an `if` expression")
            InNode NThen   r c _ -> (r, c, "an `if` expression")
            InNode NElse   r c _ -> (r, c, "an `if` expression")
            InNode NCase   r c _ -> (r, c, "a `case` expression")
            InNode NBranch r c _ -> (r, c, "a `case` expression")

        surroundings = A.Region (A.Position contextRow contextCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "MISSING EXPRESSION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing " ++ aThing ++ ", but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","to","see","an","expression","like"
                  ,D.dullyellow "42","or",D.dullyellow"\"hello\"" <> "."
                  ,"Once","there","is","something","there,","I","can","probably"
                  ,"give","a","more","specific","hint!"
                  ]
              , D.toSimpleNote $
                  "This can also happen if I run into reserved words like `let` or `as` unexpectedly.\
                  \ Or if I run into operators in unexpected spots. Point is, there are a\
                  \ couple ways I can get confused and give sort of weird advice!"
              ]
          )

    Char char row col ->
      toCharReport source char row col

    String string row col ->
      toStringReport source string row col

    Number number row col ->
      toNumberReport source number row col

    Space space row col ->
      toSpaceReport source space row col

    EndlessShader row col ->
      let
        region = toWiderRegion row col 6
      in
      Report.Report "ENDLESS SHADER" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow "I cannot find the end of this shader:"
          ,
            D.reflow "Add a |] somewhere after this to end the shader."
          )

    ShaderProblem problem row col ->
      let
        region = toRegion row col
      in
      Report.Report "SHADER PROBLEM" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I ran into a problem while parsing this GLSL block."
          ,
            D.stack
              [ D.reflow $
                  "I use a 3rd party GLSL parser for now, and I did my best to extract their error message:"
              , D.indent 4 $ D.vcat $
                  map D.fromChars (filter (/="") (lines problem))
              ]
          )

    IndentOperatorRight op row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "MISSING EXPRESSION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see an expression after this " ++ Name.toChars op ++ " operator:"
          ,
            D.stack
              [
                D.fillSep $
                  ["You","can","just","put","anything","for","now,","like"
                  ,D.dullyellow "42","or",D.dullyellow"\"hello\"" <> "."
                  ,"Once","there","is","something","there,","I","can","probably"
                  ,"give","a","more","specific","hint!"
                  ]
              ,
                D.toSimpleNote $
                  "I may be getting confused by your indentation? The easiest way to make sure\
                  \ this is not an indentation problem is to put the expression on the right of\
                  \ the " ++ Name.toChars op ++ " operator on the same line."
              ]
          )



-- CHAR


toCharReport :: Code.Source -> Char -> Row -> Col -> Report.Report
toCharReport source char row col =
  case char of
    CharEndless ->
      let
        region = toRegion row col
      in
      Report.Report "MISSING SINGLE QUOTE" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I thought I was parsing a character, but I got to the end of\
              \ the line without seeing the closing single quote:"
          ,
            D.reflow $
              "Add a closing single quote here!"
          )

    CharEscape escape ->
      toEscapeReport source escape row col

    CharNotString width ->
      let
        region = toWiderRegion row col width
      in
      Report.Report "NEEDS DOUBLE QUOTES" region [] $
        Code.toSnippet source region Nothing
          (
            "The following string uses single quotes:"
          ,
            D.stack
              [ "Please switch to double quotes instead:"
              , D.indent 4 $
                  D.dullyellow "'this'" <> " => " <> D.green "\"this\""
              , D.toSimpleNote $
                  "Elm uses double quotes for strings like \"hello\", whereas it uses single\
                  \ quotes for individual characters like 'a' and 'ø'. This distinction helps with\
                  \ code like (String.any (\\c -> c == 'X') \"90210\") where you are inspecting\
                  \ individual characters."
              ]
          )



-- STRING


toStringReport :: Code.Source -> String -> Row -> Col -> Report.Report
toStringReport source string row col =
  case string of
    StringEndless_Single ->
      let
        region = toRegion row col
      in
      Report.Report "ENDLESS STRING" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I got to the end of the line without seeing the closing double quote:"
          ,
            D.stack
              [ D.fillSep $
                  ["Strings","look","like",D.green "\"this\"","with","double"
                  ,"quotes","on","each","end.","Is","the","closing","double"
                  ,"quote","missing","in","your","code?"
                  ]
              , D.toSimpleNote $
                  "For a string that spans multiple lines, you can use the multi-line string\
                  \ syntax like this:"
              , D.dullyellow $ D.indent 4 $ D.vcat $
                  [ "\"\"\""
                  , "# Multi-line Strings"
                  , ""
                  , "- start with triple double quotes"
                  , "- write whatever you want"
                  , "- no need to escape newlines or double quotes"
                  , "- end with triple double quotes"
                  , "\"\"\""
                  ]
              ]
          )

    StringEndless_Multi ->
      let
        region = toWiderRegion row col 3
      in
      Report.Report "ENDLESS STRING" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I cannot find the end of this multi-line string:"
          ,
            D.stack
              [ D.reflow "Add a \"\"\" somewhere after this to end the string."
              , D.toSimpleNote $
                  "Here is a valid multi-line string for reference:"
              , D.dullyellow $ D.indent 4 $ D.vcat $
                  [ "\"\"\""
                  , "# Multi-line Strings"
                  , ""
                  , "- start with triple double quotes"
                  , "- write whatever you want"
                  , "- no need to escape newlines or double quotes"
                  , "- end with triple double quotes"
                  , "\"\"\""
                  ]
              ]
          )

    StringEscape escape ->
      toEscapeReport source escape row col



-- ESCAPES


toEscapeReport :: Code.Source -> Escape -> Row -> Col -> Report.Report
toEscapeReport source escape row col =
  case escape of
    EscapeUnknown ->
      let
        region = toWiderRegion row col 2
      in
      Report.Report "UNKNOWN ESCAPE" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "Backslashes always start escaped characters, but I do not recognize this one:"
          ,
            D.stack
              [ D.reflow $
                  "Valid escape characters include:"
              , D.dullyellow $ D.indent 4 $ D.vcat $
                    [ "\\n"
                    , "\\r"
                    , "\\t"
                    , "\\\""
                    , "\\\'"
                    , "\\\\"
                    , "\\u{003D}"
                    ]
              , D.reflow $
                  "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?"
              , D.toSimpleNote $
                  "The last style lets encode ANY character by its Unicode code\
                  \ point. That means \\u{0009} and \\t are the same. You can use\
                  \ that style for anything not covered by the other six escapes!"
              ]
          )

    BadUnicodeFormat width ->
      let
        region = toWiderRegion row col width
      in
      Report.Report "BAD UNICODE ESCAPE" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I ran into an invalid Unicode escape:"
          ,
            D.stack
              [ D.reflow $
                  "Here are some examples of valid Unicode escapes:"
              , D.dullyellow $ D.indent 4 $ D.vcat $
                  [ "\\u{0041}"
                  , "\\u{03BB}"
                  , "\\u{6728}"
                  , "\\u{1F60A}"
                  ]
              , D.reflow $
                  "Notice that the code point is always surrounded by curly braces.\
                  \ Maybe you are missing the opening or closing curly brace?"
              ]
            )
    BadUnicodeCode width ->
      let
        region = toWiderRegion row col width
      in
      Report.Report "BAD UNICODE ESCAPE" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "This is not a valid code point:"
          ,
            D.reflow $
              "The valid code points are between 0 and 10FFFF inclusive."
          )

    BadUnicodeLength width numDigits badCode ->
      let
        region = toWiderRegion row col width
      in
      Report.Report "BAD UNICODE ESCAPE" region [] $
        Code.toSnippet source region Nothing $
          if numDigits < 4 then
            (
              D.reflow $
                "Every code point needs at least four digits:"
            ,
              let
                goodCode = replicate (4 - numDigits) '0' ++ map Char.toUpper (showHex badCode "")
                suggestion = "\\u{" <> D.fromChars goodCode <> "}"
              in
              D.fillSep ["Try",D.green suggestion,"instead?"]
            )

          else
            (
              D.reflow $
                "This code point has too many digits:"
            ,
              D.fillSep $
                ["Valid","code","points","are","between"
                ,D.green "\\u{0000}","and",D.green "\\u{10FFFF}" <> ","
                ,"so","try","trimming","any","leading","zeros","until"
                ,"you","have","between","four","and","six","digits."
                ]
            )



-- NUMBERS


toNumberReport :: Code.Source -> Number -> Row -> Col -> Report.Report
toNumberReport source number row col =
  let
    region = toRegion row col
  in
  case number of
    NumberEnd ->
      Report.Report "WEIRD NUMBER" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I thought I was reading a number, but I ran into some weird stuff here:"
          ,
            D.stack
              [ D.reflow $
                  "I recognize numbers in the following formats:"
              , D.indent 4 $ D.vcat [ "42", "3.14", "6.022e23", "0x002B" ]
              , D.reflow $
                  "So is there a way to write it like one of those?"
              ]
          )

    NumberDot int ->
      Report.Report "WEIRD NUMBER" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "Numbers cannot end with a dot like this:"
          ,
            D.fillSep
              ["Switching","to",D.green (D.fromChars (show int))
              ,"or",D.green (D.fromChars (show int ++ ".0"))
              ,"will","work","though!"
              ]
          )

    NumberHexDigit ->
      Report.Report "WEIRD HEXIDECIMAL" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I thought I was reading a hexidecimal number until I got here:"
          ,
            D.stack
              [ D.reflow $
                  "Valid hexidecimal digits include 0123456789abcdefABCDEF, so I can\
                  \ only recognize things like this:"
              , D.indent 4 $ D.vcat [ "0x2B", "0x002B", "0x00ffb3" ]
              ]
          )

    NumberNoLeadingZero ->
      Report.Report "LEADING ZEROS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I do not accept numbers with leading zeros:"
          ,
            D.stack
              [ D.reflow $
                  "Just delete the leading zeros and it should work!"
              , D.toSimpleNote $
                  "Some languages let you to specify octal numbers by adding a leading zero.\
                  \ So in C, writing 0111 is the same as writing 73. Some people are used to\
                  \ that, but others probably want it to equal 111. Either path is going to\
                  \ surprise people from certain backgrounds, so Elm tries to avoid this whole\
                  \ situation."
              ]
          )



-- OPERATORS


toOperatorReport :: Code.Source -> Context -> BadOperator -> Row -> Col -> Report.Report
toOperatorReport source context operator row col =
  case operator of
    BadDot ->
      let
        region = toRegion row col
      in
      Report.Report "UNEXPECTED SYMBOL" region [] $
        Code.toSnippet source region Nothing
          (
            "I was not expecting this dot:"
          ,
            D.reflow $
              "Dots are for record access and decimal points, so\
              \ they cannot float around on their own. Maybe\
              \ there is some extra whitespace?"
          )

    BadPipe ->
      let
        region = toRegion row col
      in
      Report.Report "UNEXPECTED SYMBOL" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was not expecting this vertical bar:"
          ,
            D.reflow $
              "Vertical bars should only appear in custom type declarations. Maybe you want || instead?"
          )

    BadArrow ->
      let
        region = toWiderRegion row col 2
      in
      Report.Report "UNEXPECTED ARROW" region [] $
        Code.toSnippet source region Nothing $
          if isWithin NCase context then
            (
              D.reflow $
                "I am parsing a `case` expression right now, but this arrow is confusing me:"
            ,
              D.stack
                [ D.reflow "Maybe the `of` keyword is missing on a previous line?"
                , noteForCaseError
                ]
            )

          else if isWithin NBranch context then
            (
              D.reflow $
                "I am parsing a `case` expression right now, but this arrow is confusing me:"
            ,
              D.stack
                [ D.reflow $
                    "It makes sense to see arrows around here, so I suspect it is something earlier. Maybe this pattern is indented a bit farther than the previous patterns?"
                , noteForCaseIndentError
                ]
            )

          else
            (
              D.reflow $
                "I was partway through parsing an expression when I got stuck on this arrow:"
            ,
              D.stack
                [ "Arrows should only appear in `case` expressions and anonymous functions.\n\
                  \Maybe it was supposed to be a > sign instead?"
                , D.toSimpleNote $
                    "The syntax for anonymous functions is (\\x -> x + 1) so the arguments all appear\
                    \ after the backslash and before the arrow. Maybe a backslash is missing earlier?"
                ]
            )

    BadEquals ->
      let
        region = toRegion row col
      in
      Report.Report "UNEXPECTED EQUALS" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I was not expecting to see this equals sign:"
          ,
            D.stack
              [
                D.reflow "Maybe you want == instead? To check if two values are equal?"
              ,
                D.toSimpleNote $
                  if isWithin NRecord context then
                    "Records look like { x = 3, y = 4 } with the equals sign right\
                    \ after the field name. So maybe you forgot a comma?"
                  else
                    case getDefName context of
                      Nothing ->
                        "I may be getting confused by your indentation. I need all definitions to be indented\
                        \ exactly the same amount, so if this is meant to be a new definition, it may have too\
                        \ many spaces in front of it."

                      Just name ->
                        "I may be getting confused by your indentation. I think I am still parsing the `"
                        ++ Name.toChars name ++ "` definition. Is this supposed to be part of a definition\
                        \ after that? If so, the problem may be a bit before the equals sign. I need all\
                        \ definitions to be indented exactly the same amount, so the problem may be that\
                        \ this new definition has too many spaces in front of it."
              ]
          )

    BadHasType ->
      let
        region = toRegion row col
      in
      Report.Report "UNEXPECTED SYMBOL" region [] $
        Code.toSnippet source region Nothing $
          (
            D.reflow $
              "I was not expecting to run into the \"has type\" symbol here:"
          ,
            case getDefName context of
              Nothing ->
                D.fillSep
                  ["Maybe","you","want",D.green "::","instead?"
                  ,"To","put","something","on","the","front","of","a","list?"
                  ]

              Just name ->
                D.stack
                  [
                    D.fillSep
                      ["Maybe","you","want",D.green "::","instead?"
                      ,"To","put","something","on","the","front","of","a","list?"
                      ]
                  , D.toSimpleNote $
                      "The single colon is reserved for type annotations and record types, but I think\
                      \ I am parsing the definition of `" ++ Name.toChars name ++ "` right now."
                  ,
                    D.toSimpleNote $
                      "I may be getting confused by your indentation. Is this supposed to be part of\
                      \ a type annotation AFTER the `" ++ Name.toChars name ++ "` definition? If so,\
                      \ the problem may be a bit before the \"has type\" symbol. I need all definitions to\
                      \ be exactly aligned (with exactly the same indentation) so the problem may be that\
                      \ this new definition is indented a bit too much."
                  ]
          )



-- CASE


toLetReport :: Code.Source -> Context -> Let -> Row -> Col -> Report.Report
toLetReport source context let_ startRow startCol =
  case let_ of
    LetSpace space row col ->
      toSpaceReport source space row col

    LetIn row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "LET PROBLEM" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was partway through parsing a `let` expression, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["Based","on","the","indentation,","I","was","expecting","to","see","the",D.cyan "in"
                  ,"keyword","next.","Is","there","a","typo?"
                  ]
              , D.toSimpleNote $
                  "This can also happen if you are trying to define another value within the `let` but\
                  \ it is not indented enough. Make sure each definition has exactly the same amount of\
                  \ spaces before it. They should line up exactly!"
              ]
          )

    LetDefAlignment _ row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "LET PROBLEM" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was partway through parsing a `let` expression, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["Based","on","the","indentation,","I","was","expecting","to","see","the",D.cyan "in"
                  ,"keyword","next.","Is","there","a","typo?"
                  ]
              , D.toSimpleNote $
                  "This can also happen if you are trying to define another value within the `let` but\
                  \ it is not indented enough. Make sure each definition has exactly the same amount of\
                  \ spaces before it. They should line up exactly!"
              ]
          )

    LetDefName row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was partway through parsing a `let` expression, but I got stuck here:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as a variable name, but\
                  \ it is a reserved word! Try using a different name instead."
              )

        _ ->
          toUnfinishLetReport source row col startRow startCol $
            D.reflow $
              "I was expecting the name of a definition next."

    LetDef name def row col ->
      toLetDefReport source name def row col

    LetDestruct destruct row col ->
      toLetDestructReport source destruct row col

    LetBody expr row col ->
      toExprReport source context expr row col

    LetIndentDef row col ->
      toUnfinishLetReport source row col startRow startCol $
        D.reflow $
          "I was expecting a value to be defined here."

    LetIndentIn row col ->
      toUnfinishLetReport source row col startRow startCol $
        D.fillSep $
          ["I","was","expecting","to","see","the",D.cyan "in","keyword","next."
          ,"Or","maybe","more","of","that","expression?"
          ]

    LetIndentBody row col ->
      toUnfinishLetReport source row col startRow startCol $
        D.reflow $
          "I was expecting an expression next. Tell me what should happen with the value you just defined!"


toUnfinishLetReport :: Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report
toUnfinishLetReport source row col startRow startCol message =
  let
    surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
    region = toRegion row col
  in
  Report.Report "UNFINISHED LET" region [] $
    Code.toSnippet source surroundings (Just region)
      (
        D.reflow $
          "I was partway through parsing a `let` expression, but I got stuck here:"
      ,
        D.stack
          [ message
          , D.toSimpleNote $
              "Here is an example with a valid `let` expression for reference:"
          , D.indent 4 $ D.vcat $
              [ D.indent 0 $ D.fillSep ["viewPerson","person","="]
              , D.indent 2 $ D.fillSep [D.cyan "let"]
              , D.indent 4 $ D.fillSep ["fullName","="]
              , D.indent 6 $ D.fillSep ["person.firstName","++",D.dullyellow "\" \"","++","person.lastName"]
              , D.indent 2 $ D.fillSep [D.cyan "in"]
              , D.indent 2 $ D.fillSep ["div","[]","[","text","fullName","]"]
              ]
          , D.reflow $
              "Here we defined a `viewPerson` function that turns a person into some HTML. We use\
              \ a `let` expression to define the `fullName` we want to show. Notice the indentation! The\
              \ `fullName` is indented more than the `let` keyword, and the actual value of `fullName` is\
              \ indented a bit more than that. That is important!"
          ]
      )


toLetDefReport :: Code.Source -> Name.Name -> Def -> Row -> Col -> Report.Report
toLetDefReport source name def startRow startCol =
  case def of
    DefSpace space row col ->
      toSpaceReport source space row col

    DefType tipe row col ->
      toTypeReport source (TC_Annotation name) tipe row col

    DefNameRepeat row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "EXPECTING DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the type annotation for `" ++ Name.toChars name
              ++ "` so I was expecting to see its definition here:"
          ,
            D.stack
              [ D.reflow $
                  "Type annotations always appear directly above the relevant\
                  \ definition, without anything else in between."
              , defNote
              ]
          )

    DefNameMatch defName row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "NAME MISMATCH" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw a type annotation for `" ++ Name.toChars name ++ "`, but it is followed by a definition for `" ++ Name.toChars defName ++ "`:"
          ,
            D.stack
              [ D.reflow $
                  "These names do not match! Is there a typo?"
              , D.indent 4 $ D.fillSep $
                  [D.dullyellow (D.fromName defName),"->",D.green (D.fromName name)]
              ]
          )

    DefArg pattern row col ->
      toPatternReport source PArg pattern row col

    DefEquals row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.fillSep
                  ["The","name"
                  ,"`" <> D.cyan (D.fromChars keyword) <> "`"
                  ,"is","reserved","in","Elm,","so","it","cannot"
                  ,"be","used","as","an","argument","here:"
                  ]
              ,
                D.stack
                  [ D.reflow $
                      "Try renaming it to something else."
                  , case keyword of
                      "as" ->
                        D.toFancyNote
                          ["This","keyword","is","reserved","for","pattern","matches","like"
                          ,"((x,y)",D.cyan "as","point)","where","you","want","to","name","a","tuple","and"
                          ,"the","values","it","contains."
                          ]

                      _ ->
                        D.toSimpleNote $
                          "The `" ++ keyword ++ "` keyword has a special meaning in Elm, so it can only be used in certain situations."
                  ]
              )

        Code.Operator "->" ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toWiderRegion row col 2
          in
          Report.Report "MISSING COLON?" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was not expecting to see an arrow here:"
              ,
                D.stack
                  [ D.fillSep
                      ["This","usually","means","a",D.green ":","is","missing","a","bit","earlier","in"
                      ,"a","type","annotation.","It","could","be","something","else","though,","so"
                      ,"here","is","a","valid","definition","for","reference:"
                      ]
                  , D.indent 4 $ D.vcat $
                      [ "greet : String -> String"
                      , "greet name ="
                      , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                      ]
                  , D.reflow $
                      "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
                  ]
              )

        Code.Operator op ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col op
          in
          Report.Report "UNEXPECTED SYMBOL" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was not expecting to see this symbol here:"
              ,
                D.stack
                  [ D.reflow $
                      "I am not sure what is going wrong exactly, so here is a valid\
                      \ definition (with an optional type annotation) for reference:"
                  , D.indent 4 $ D.vcat $
                      [ "greet : String -> String"
                      , "greet name ="
                      , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                      ]
                  , D.reflow $
                      "Try to use that format with your `" ++ Name.toChars name ++ "` definition!"
                  ]
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN DEFINITION" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:"
              ,
                D.stack
                  [ D.reflow $
                      "I am not sure what is going wrong exactly, so here is a valid\
                      \ definition (with an optional type annotation) for reference:"
                  , D.indent 4 $ D.vcat $
                      [ "greet : String -> String"
                      , "greet name ="
                      , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
                      ]
                  , D.reflow $
                      "Try to use that format!"
                  ]
              )

    DefBody expr row col ->
      toExprReport source (InDef name startRow startCol) expr row col

    DefIndentEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see an argument or an equals sign next."
              , defNote
              ]
          )

    DefIndentType row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck while parsing the `" ++ Name.toChars name ++ "` type annotation:"
          ,
            D.stack
              [ D.reflow $
                  "I just saw a colon, so I am expecting to see a type next."
              , defNote
              ]
          )

    DefIndentBody row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see an expression next. What is it equal to?"
              , declDefNote
              ]
          )

    DefAlignment indent row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
        offset = indent - col
      in
      Report.Report "PROBLEM IN DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:"
          ,
            D.reflow $
              "I just saw a type annotation indented " ++ show indent ++ " spaces, so I was\
              \ expecting to see the corresponding definition next with the exact same amount\
              \ of indentation. It looks like this line needs "
              ++ show offset ++ " more " ++ (if offset == 1 then "space" else "spaces") ++ "?"
          )



defNote :: D.Doc
defNote =
  D.stack
    [ D.reflow $
        "Here is a valid definition (with a type annotation) for reference:"
    , D.indent 4 $ D.vcat $
        [ "greet : String -> String"
        , "greet name ="
        , "  " <> D.dullyellow "\"Hello \"" <> " ++ name ++ " <> D.dullyellow "\"!\""
        ]
    , D.reflow $
        "The top line (called a \"type annotation\") is optional. You can leave it off\
        \ if you want. As you get more comfortable with Elm and as your project grows,\
        \ it becomes more and more valuable to add them though! They work great as\
        \ compiler-verified documentation, and they often improve error messages!"
    ]


toLetDestructReport :: Code.Source -> Destruct -> Row -> Col -> Report.Report
toLetDestructReport source destruct startRow startCol =
  case destruct of
    DestructSpace space row col ->
      toSpaceReport source space row col

    DestructPattern pattern row col ->
      toPatternReport source PLet pattern row col

    DestructEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM IN DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck trying to parse this definition:"
          ,
            case Code.whatIsNext source row col of
              Code.Operator ":" ->
                D.stack
                  [ D.reflow $
                      "I was expecting to see an equals sign next, followed by an expression\
                      \ telling me what to compute."
                  , D.toSimpleNote $
                      "It looks like you may be trying to write a type annotation? It is not\
                      \ possible to add type annotations on destructuring definitions like this.\
                      \ You can assign a name to the overall structure, put a type annotation on\
                      \ that, and then destructure separately though."
                  ]

              _ ->
                D.reflow $
                  "I was expecting to see an equals sign next, followed by an expression\
                  \ telling me what to compute."
          )

    DestructBody expr row col ->
      toExprReport source (InDestruct startRow startCol) expr row col

    DestructIndentEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck trying to parse this definition:"
          ,
            D.reflow $
              "I was expecting to see an equals sign next, followed by an expression\
              \ telling me what to compute."
          )

    DestructIndentBody row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED DEFINITION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck while parsing this definition:"
          ,
            D.reflow $
              "I was expecting to see an expression next. What is it equal to?"
          )



-- CASE


toCaseReport :: Code.Source -> Context -> Case -> Row -> Col -> Report.Report
toCaseReport source context case_ startRow startCol =
  case case_ of
    CaseSpace space row col ->
      toSpaceReport source space row col

    CaseOf row col ->
      toUnfinishCaseReport source row col startRow startCol $
        D.fillSep ["I","was","expecting","to","see","the",D.dullyellow "of","keyword","next."]

    CasePattern pattern row col ->
      toPatternReport source PCase pattern row col

    CaseArrow row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a `case` expression, but I got stuck here:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` in one of your\
                  \ patterns, but it is a reserved word. Try using a different name?"
              )

        Code.Operator ":" ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNEXPECTED OPERATOR" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a `case` expression, but I got stuck here:"
              ,
                D.fillSep $
                  ["I","am","seeing",D.dullyellow ":","but","maybe","you","want",D.green "::","instead?"
                  ,"For","pattern","matching","on","lists?"
                  ]
              )

        Code.Operator "=" ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNEXPECTED OPERATOR" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a `case` expression, but I got stuck here:"
              ,
                D.fillSep $
                  ["I","am","seeing",D.dullyellow "=","but","maybe","you","want",D.green "->","instead?"
                  ]
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "MISSING ARROW" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a `case` expression, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow "I was expecting to see an arrow next."
                  , noteForCaseIndentError
                  ]
              )

    CaseExpr expr row col ->
      toExprReport source (InNode NCase startRow startCol context) expr row col

    CaseBranch expr row col ->
      toExprReport source (InNode NBranch startRow startCol context) expr row col

    CaseIndentOf row col ->
      toUnfinishCaseReport source row col startRow startCol $
        D.fillSep ["I","was","expecting","to","see","the",D.dullyellow "of","keyword","next."]

    CaseIndentExpr row col ->
      toUnfinishCaseReport source row col startRow startCol $
        D.reflow "I was expecting to see a expression next."

    CaseIndentPattern row col ->
      toUnfinishCaseReport source row col startRow startCol $
        D.reflow "I was expecting to see a pattern next."

    CaseIndentArrow row col ->
      toUnfinishCaseReport source row col startRow startCol $
        D.fillSep
          ["I","just","saw","a","pattern,","so","I","was","expecting"
          ,"to","see","a",D.dullyellow "->","next."
          ]

    CaseIndentBranch row col ->
      toUnfinishCaseReport source row col startRow startCol $
        D.reflow $
          "I was expecting to see an expression next. What should I do when\
          \ I run into this particular pattern?"

    CasePatternAlignment indent row col ->
      toUnfinishCaseReport source row col startRow startCol $
        D.reflow $
          "I suspect this is a pattern that is not indented far enough? (" ++ show indent ++ " spaces)"


toUnfinishCaseReport :: Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report
toUnfinishCaseReport source row col startRow startCol message =
  let
    surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
    region = toRegion row col
  in
  Report.Report "UNFINISHED CASE" region [] $
    Code.toSnippet source surroundings (Just region)
      (
        D.reflow $
          "I was partway through parsing a `case` expression, but I got stuck here:"
      ,
        D.stack
          [ message
          , noteForCaseError
          ]
      )


noteForCaseError :: D.Doc
noteForCaseError =
  D.stack
    [ D.toSimpleNote $
        "Here is an example of a valid `case` expression for reference."
    , D.vcat $
        [ D.indent 4 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
        , D.indent 6 $ D.fillSep [D.blue "Just","width","->"]
        , D.indent 8 $ D.fillSep ["width","+",D.dullyellow "200"]
        , ""
        , D.indent 6 $ D.fillSep [D.blue "Nothing","->"]
        , D.indent 8 $ D.fillSep [D.dullyellow "400"]
        ]
    , D.reflow $
        "Notice the indentation. Each pattern is aligned, and each branch is indented\
        \ a bit more than the corresponding pattern. That is important!"
    ]


noteForCaseIndentError :: D.Doc
noteForCaseIndentError =
  D.stack
    [ D.toSimpleNote $
        "Sometimes I get confused by indentation, so try to make your `case` look\
        \ something like this:"
    , D.vcat $
        [ D.indent 4 $ D.fillSep [D.cyan "case","maybeWidth",D.cyan "of"]
        , D.indent 6 $ D.fillSep [D.blue "Just","width","->"]
        , D.indent 8 $ D.fillSep ["width","+",D.dullyellow "200"]
        , ""
        , D.indent 6 $ D.fillSep [D.blue "Nothing","->"]
        , D.indent 8 $ D.fillSep [D.dullyellow "400"]
        ]
    , D.reflow $
        "Notice the indentation! Patterns are aligned with each other. Same indentation.\
        \ The expressions after each arrow are all indented a bit more than the patterns.\
        \ That is important!"
    ]



-- IF


toIfReport :: Code.Source -> Context -> If -> Row -> Col -> Report.Report
toIfReport source context if_ startRow startCol =
  case if_ of
    IfSpace space row col ->
      toSpaceReport source space row col

    IfThen row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED IF" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see more of this `if` expression, but I got stuck here:"
          ,
            D.fillSep $
              ["I","was","expecting","to","see","the",D.cyan "then","keyword","next."
              ]
          )

    IfElse row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED IF" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see more of this `if` expression, but I got stuck here:"
          ,
            D.fillSep $
              ["I","was","expecting","to","see","the",D.cyan "else","keyword","next."
              ]
          )

    IfElseBranchStart row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED IF" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the start of an `else` branch, but then I got stuck here:"
          ,
            D.reflow $
              "I was expecting to see an expression next. Maybe it is not filled in yet?"
          )

    IfCondition expr row col ->
      toExprReport source (InNode NCond startRow startCol context) expr row col

    IfThenBranch expr row col ->
      toExprReport source (InNode NThen startRow startCol context) expr row col

    IfElseBranch expr row col ->
      toExprReport source (InNode NElse startRow startCol context) expr row col

    IfIndentCondition row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED IF" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see more of this `if` expression, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","to","see","an","expression","like",D.dullyellow "x < 0"
                  ,"that","evaluates","to","True","or","False."
                  ]
              , D.toSimpleNote $
                  "I can be confused by indentation. Maybe something is not indented enough?"
              ]
          )

    IfIndentThen row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED IF" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see more of this `if` expression, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","to","see","the",D.cyan "then","keyword","next."
                  ]
              , D.toSimpleNote $
                  "I can be confused by indentation. Maybe something is not indented enough?"
              ]
          )

    IfIndentThenBranch row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED IF" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck after the start of this `then` branch:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see an expression next. Maybe it is not filled in yet?"
              , D.toSimpleNote $
                  "I can be confused by indentation, so if the `then` branch is already\
                  \ present, it may not be indented enough for me to recognize it."
              ]
          )

    IfIndentElseBranch row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED IF" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I got stuck after the start of this `else` branch:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see an expression next. Maybe it is not filled in yet?"
              , D.toSimpleNote $
                  "I can be confused by indentation, so if the `else` branch is already\
                  \ present, it may not be indented enough for me to recognize it."
              ]
          )

    IfIndentElse row col ->
      case Code.nextLineStartsWithKeyword "else" source row of
        Just (elseRow, elseCol) ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position elseRow elseCol)
            region = toWiderRegion elseRow elseCol 4
          in
          Report.Report "WEIRD ELSE BRANCH" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was partway through an `if` expression when I got stuck here:"
              ,
                D.fillSep $
                  ["I","think","this",D.cyan "else","keyword","needs","to","be","indented","more."
                  ,"Try","adding","some","spaces","before","it."
                  ]
              )

        Nothing ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED IF" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was expecting to see an `else` branch after this:"
              ,
                D.stack
                  [ D.fillSep
                      ["I","know","what","to","do","when","the","condition","is","True,"
                      ,"but","what","happens","when","it","is","False?"
                      ,"Add","an",D.cyan "else","branch","to","handle","that","scenario!"
                      ]
                  ]
              )



-- RECORD


toRecordReport :: Code.Source -> Context -> Record -> Row -> Col -> Report.Report
toRecordReport source context record startRow startCol =
  case record of
    RecordOpen row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I just started parsing a record, but I got stuck on this field name:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as a field name, but \
                  \ that is a reserved word. Try using a different name!"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN RECORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I just started parsing a record, but I got stuck here:"
              ,
                D.stack
                  [ D.fillSep
                      ["I","was","expecting","to","see","a","record","field","defined","next,"
                      ,"so","I","am","looking","for","a","name","like"
                      ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "."
                      ]
                  , D.toSimpleNote $
                      "Field names must start with a lower-case letter. After that, you can use\
                      \ any sequence of letters, numbers, and underscores."
                  , noteForRecordError
                  ]
              )

    RecordEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM IN RECORD" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep
                  ["I","was","expecting","to","see","a","closing","curly","brace","before","this,"
                  ,"so","try","adding","a",D.dullyellow "}","and","see","if","that","helps?"
                  ]
              , D.toSimpleNote $
                  "When I get stuck like this, it usually means that there is a missing parenthesis\
                  \ or bracket somewhere earlier. It could also be a stray keyword or operator."
              ]
          )

    RecordField row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a record, but I got stuck on this field name:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as a field name, but \
                  \ that is a reserved word. Try using a different name!"
              )

        Code.Other (Just ',') ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "EXTRA COMMA" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a record, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "I am seeing two commas in a row. This is the second one!"
                  , D.reflow $
                      "Just delete one of the commas and you should be all set!"
                  , noteForRecordError
                  ]
              )

        Code.Close _ '}' ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "EXTRA COMMA" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a record, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "Trailing commas are not allowed in records. Try deleting the comma that appears\
                      \ before this closing curly brace."
                  , noteForRecordError
                  ]
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN RECORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a record, but I got stuck here:"
              ,
                D.stack
                  [ D.fillSep
                      ["I","was","expecting","to","see","another","record","field","defined","next,"
                      ,"so","I","am","looking","for","a","name","like"
                      ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "."
                      ]
                  , D.toSimpleNote $
                      "Field names must start with a lower-case letter. After that, you can use\
                      \ any sequence of letters, numbers, and underscores."
                  , noteForRecordError
                  ]
              )

    RecordEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "PROBLEM IN RECORD" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
                  ,"an","equals","sign","next.","So","try","putting","an",D.green "=","sign","here?"
                  ]
              , noteForRecordError
              ]
          )

    RecordExpr expr row col ->
      toExprReport source (InNode NRecord startRow startCol context) expr row col

    RecordSpace space row col ->
      toSpaceReport source space row col

    RecordIndentOpen row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the opening curly brace of a record, but then I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","am","expecting","a","record","like",D.dullyellow "{ x = 3, y = 4 }","here."
                  ,"Try","defining","some","fields","of","your","own?"
                  ]
              , noteForRecordIndentError
              ]
          )

    RecordIndentEnd row col ->
      case Code.nextLineStartsWithCloseCurly source row of
        Just (curlyRow, curlyCol) ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol)
            region = toRegion curlyRow curlyCol
          in
          Report.Report "NEED MORE INDENTATION" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was partway through parsing a record, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "I need this curly brace to be indented more. Try adding some spaces before it!"
                  , noteForRecordError
                  ]
              )

        Nothing ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED RECORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was partway through parsing a record, but I got stuck here:"
              ,
                D.stack
                  [ D.fillSep $
                      ["I","was","expecting","to","see","a","closing","curly","brace","next."
                      ,"Try","putting","a",D.green "}","next","and","see","if","that","helps?"
                      ]
                  , noteForRecordIndentError
                  ]
              )

    RecordIndentField row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record, but I got stuck after that last comma:"
          ,
            D.stack
              [ D.reflow $
                  "Trailing commas are not allowed in records, so the fix may be to\
                  \ delete that last comma? Or maybe you were in the middle of defining\
                  \ an additional field?"
              , noteForRecordError
              ]
          )

    RecordIndentEquals row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record. I just saw a record\
              \ field, so I was expecting to see an equals sign next:"
          ,
            D.stack
              [ D.fillSep $
                  ["Try","putting","an",D.green "=","followed","by","an","expression?"
                  ]
              , noteForRecordIndentError
              ]
          )

    RecordIndentExpr row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record, and I was expecting to run into an expression next:"
          ,
            D.stack
              [ D.fillSep $
                  ["Try","putting","something","like"
                  ,D.dullyellow "42","or",D.dullyellow"\"hello\"","for","now?"
                  ]
              , noteForRecordIndentError
              ]
          )


noteForRecordError :: D.Doc
noteForRecordError =
  D.stack $
    [ D.toSimpleNote
        "If you are trying to define a record across multiple lines, I recommend using this format:"
    , D.indent 4 $ D.vcat $
        [ "{ name = " <> D.dullyellow "\"Alice\""
        , ", age = " <> D.dullyellow "42"
        , ", height = " <> D.dullyellow "1.75"
        , "}"
        ]
    , D.reflow $
        "Notice that each line starts with some indentation. Usually two or four spaces.\
        \ This is the stylistic convention in the Elm ecosystem."
    ]


noteForRecordIndentError :: D.Doc
noteForRecordIndentError =
  D.stack
    [ D.toSimpleNote
        "I may be confused by indentation. For example, if you are trying to define\
        \ a record across multiple lines, I recommend using this format:"
    , D.indent 4 $ D.vcat $
        [ "{ name = " <> D.dullyellow "\"Alice\""
        , ", age = " <> D.dullyellow "42"
        , ", height = " <> D.dullyellow "1.75"
        , "}"
        ]
    , D.reflow $
        "Notice that each line starts with some indentation. Usually two or four spaces.\
        \ This is the stylistic convention in the Elm ecosystem!"
    ]



-- TUPLE


toTupleReport :: Code.Source -> Context -> Tuple -> Row -> Col -> Report.Report
toTupleReport source context tuple startRow startCol =
  case tuple of
    TupleExpr expr row col ->
      toExprReport source (InNode NParens startRow startCol context) expr row col

    TupleSpace space row col ->
      toSpaceReport source space row col

    TupleEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PARENTHESES" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see a closing parentheses next, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"]
              , D.toSimpleNote $
                  "I can get stuck when I run into keywords, operators, parentheses, or brackets\
                  \ unexpectedly. So there may be some earlier syntax trouble (like extra parenthesis\
                  \ or missing brackets) that is confusing me."
              ]
          )

    TupleOperatorClose row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED OPERATOR FUNCTION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow "I was expecting a closing parenthesis here:"
          ,
            D.stack
              [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps!"]
              , D.toSimpleNote $
                  "I think I am parsing an operator function right now, so I am expecting to see\
                  \ something like (+) or (&&) where an operator is surrounded by parentheses with\
                  \ no extra spaces."
              ]
          )

    TupleOperatorReserved operator row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNEXPECTED SYMBOL" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I ran into an unexpected symbol here:"
          ,
            D.fillSep $
              case operator of
                BadDot -> ["Maybe","you","wanted","a","record","accessor","like",D.dullyellow ".x","or",D.dullyellow ".name","instead?"]
                BadPipe -> ["Try",D.dullyellow "(||)","instead?","To","turn","boolean","OR","into","a","function?"]
                BadArrow -> ["Maybe","you","wanted",D.dullyellow "(>)","or",D.dullyellow "(>=)","instead?"]
                BadEquals -> ["Try",D.dullyellow "(==)","instead?","To","make","a","function","that","checks","equality?"]
                BadHasType -> ["Try",D.dullyellow "(::)","instead?","To","add","values","to","the","front","of","lists?"]
          )

    TupleIndentExpr1 row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PARENTHESES" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw an open parenthesis, so I was expecting to see an expression next."
          ,
            D.stack
              [ D.fillSep $
                  ["Something","like",D.dullyellow "(4 + 5)","or"
                  ,D.dullyellow "(String.reverse \"desserts\")" <> "."
                  ,"Anything","where","you","are","putting","parentheses","around","normal","expressions."
                  ]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe you have an expression but it is not indented enough?"
              ]
          )

    TupleIndentExprN row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED TUPLE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I think I am in the middle of parsing a tuple. I just saw a comma, so I was expecting to see an expression next."
          ,
            D.stack
              [ D.fillSep $
                  ["A","tuple","looks","like",D.dullyellow "(3,4)","or"
                  ,D.dullyellow "(\"Tom\",42)" <> ","
                  ,"so","I","think","there","is","an","expression","missing","here?"
                  ]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe you have an expression but it is not indented enough?"
              ]
          )

    TupleIndentEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PARENTHESES" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see a closing parenthesis next:"
          ,
            D.stack
              [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps!"]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe you have a closing parenthesis but it is not indented enough?"
              ]
          )


toListReport :: Code.Source -> Context -> List -> Row -> Col -> Report.Report
toListReport source context list startRow startCol =
  case list of
    ListSpace space row col ->
      toSpaceReport source space row col

    ListOpen row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a list, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep
                  ["I","was","expecting","to","see","a","closing","square","bracket","before","this,"
                  ,"so","try","adding","a",D.dullyellow "]","and","see","if","that","helps?"
                  ]
              , D.toSimpleNote $
                  "When I get stuck like this, it usually means that there is a missing parenthesis\
                  \ or bracket somewhere earlier. It could also be a stray keyword or operator."
              ]
          )

    ListExpr expr row col ->
      case expr of
        Start r c ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position r c)
            region = toRegion r c
          in
          Report.Report "UNFINISHED LIST" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was expecting to see another list entry after that last comma:"
              ,
                D.stack
                  [ D.reflow $
                      "Trailing commas are not allowed in lists, so the fix may be to delete the comma?"
                  , D.toSimpleNote
                      "I recommend using the following format for lists that span multiple lines:"
                  , D.indent 4 $ D.vcat $
                      [ "[ " <> D.dullyellow "\"Alice\""
                      , ", " <> D.dullyellow "\"Bob\""
                      , ", " <> D.dullyellow "\"Chuck\""
                      , "]"
                      ]
                  , D.reflow $
                      "Notice that each line starts with some indentation. Usually two or four spaces.\
                      \ This is the stylistic convention in the Elm ecosystem."
                  ]
              )

        _ ->
          toExprReport source (InNode NList startRow startCol context) expr row col

    ListEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a list, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep
                  ["I","was","expecting","to","see","a","closing","square","bracket","before","this,"
                  ,"so","try","adding","a",D.dullyellow "]","and","see","if","that","helps?"
                  ]
              , D.toSimpleNote $
                  "When I get stuck like this, it usually means that there is a missing parenthesis\
                  \ or bracket somewhere earlier. It could also be a stray keyword or operator."
              ]
          )

    ListIndentOpen row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I cannot find the end of this list:"
          ,
            D.stack
              [ D.fillSep $
                  ["You","could","change","it","to","something","like"
                  ,D.dullyellow "[3,4,5]"
                  ,"or","even","just"
                  ,D.dullyellow "[]" <> "."
                  ,"Anything","where","there","is","an","open","and","close","square","brace,"
                  ,"and","where","the","elements","of","the","list","are","separated","by","commas."
                  ]
              , D.toSimpleNote
                  "I may be confused by indentation. For example, if you are trying to define\
                  \ a list across multiple lines, I recommend using this format:"
              , D.indent 4 $ D.vcat $
                  [ "[ " <> D.dullyellow "\"Alice\""
                  , ", " <> D.dullyellow "\"Bob\""
                  , ", " <> D.dullyellow "\"Chuck\""
                  , "]"
                  ]
              , D.reflow $
                  "Notice that each line starts with some indentation. Usually two or four spaces.\
                  \ This is the stylistic convention in the Elm ecosystem."
              ]
          )

    ListIndentEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I cannot find the end of this list:"
          ,
            D.stack
              [ D.fillSep $
                  ["You","can","just","add","a","closing",D.dullyellow "]"
                  ,"right","here,","and","I","will","be","all","set!"
                  ]
              , D.toSimpleNote
                  "I may be confused by indentation. For example, if you are trying to define\
                  \ a list across multiple lines, I recommend using this format:"
              , D.indent 4 $ D.vcat $
                  [ "[ " <> D.dullyellow "\"Alice\""
                  , ", " <> D.dullyellow "\"Bob\""
                  , ", " <> D.dullyellow "\"Chuck\""
                  , "]"
                  ]
              , D.reflow $
                  "Notice that each line starts with some indentation. Usually two or four spaces.\
                  \ This is the stylistic convention in the Elm ecosystem."
              ]
          )

    ListIndentExpr row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see another list entry after this comma:"
          ,
            D.stack
              [ D.reflow $
                  "Trailing commas are not allowed in lists, so the fix may be to delete the comma?"
              , D.toSimpleNote
                  "I recommend using the following format for lists that span multiple lines:"
              , D.indent 4 $ D.vcat $
                  [ "[ " <> D.dullyellow "\"Alice\""
                  , ", " <> D.dullyellow "\"Bob\""
                  , ", " <> D.dullyellow "\"Chuck\""
                  , "]"
                  ]
              , D.reflow $
                  "Notice that each line starts with some indentation. Usually two or four spaces.\
                  \ This is the stylistic convention in the Elm ecosystem."
              ]
          )


toFuncReport :: Code.Source -> Context -> Func -> Row -> Col -> Report.Report
toFuncReport source context func startRow startCol =
  case func of
    FuncSpace space row col ->
      toSpaceReport source space row col

    FuncArg pattern row col ->
      toPatternReport source PArg pattern row col

    FuncBody expr row col ->
      toExprReport source (InNode NFunc startRow startCol context) expr row col

    FuncArrow row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was parsing an anonymous function, but I got stuck here:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as an argument, but\
                  \ it is a reserved word in this language. Try using a different argument name!"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I just saw the beginning of an anonymous function, so I was expecting to see an arrow next:"
              ,
                D.fillSep $
                  ["The","syntax","for","anonymous","functions","is"
                  ,D.dullyellow "(\\x -> x + 1)"
                  ,"so","I","am","missing","the","arrow","and","the","body","of","the","function."
                  ]
              )

    FuncIndentArg row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "MISSING ARGUMENT" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the beginning of an anonymous function, so I was expecting to see an argument next:"
          ,
            D.stack
              [ D.fillSep
                  ["Something","like",D.dullyellow"x","or",D.dullyellow "name" <> "."
                  ,"Anything","that","starts","with","a","lower","case","letter!"
                  ]
              , D.toSimpleNote $
                  "The syntax for anonymous functions is (\\x -> x + 1) where the backslash\
                  \ is meant to look a bit like a lambda if you squint. This visual pun seemed\
                  \ like a better idea at the time!"
              ]
          )

    FuncIndentArrow row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the beginning of an anonymous function, so I was expecting to see an arrow next:"
          ,
            D.stack
              [ D.fillSep $
                  ["The","syntax","for","anonymous","functions","is"
                  ,D.dullyellow "(\\x -> x + 1)"
                  ,"so","I","am","missing","the","arrow","and","the","body","of","the","function."
                  ]
              , D.toSimpleNote $
                  "It is possible that I am confused about indetation! I generally recommend\
                  \ switching to named functions if the definition cannot fit inline nicely, so\
                  \ either (1) try to fit the whole anonymous function on one line or (2) break\
                  \ the whole thing out into a named function. Things tend to be clearer that way!"
              ]
          )

    FuncIndentBody row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED ANONYMOUS FUNCTION" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see the body of your anonymous function next:"
          ,
            D.stack
              [ D.fillSep $
                  ["The","syntax","for","anonymous","functions","is"
                  ,D.dullyellow "(\\x -> x + 1)"
                  ,"so","I","am","missing","all","the","stuff","after","the","arrow!"
                  ]
              , D.toSimpleNote $
                  "It is possible that I am confused about indetation! I generally recommend\
                  \ switching to named functions if the definition cannot fit inline nicely, so\
                  \ either (1) try to fit the whole anonymous function on one line or (2) break\
                  \ the whole thing out into a named function. Things tend to be clearer that way!"
              ]
          )



-- PATTERN


data PContext
  = PCase
  | PArg
  | PLet


toPatternReport :: Code.Source -> PContext -> Pattern -> Row -> Col -> Report.Report
toPatternReport source context pattern startRow startCol =
  case pattern of
    PRecord record row col ->
      toPRecordReport source record row col

    PTuple tuple row col ->
      toPTupleReport source context tuple row col

    PList list row col ->
      toPListReport source context list row col

    PStart row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
            inThisThing =
              case context of
                PArg  -> "as an argument"
                PCase -> "in this pattern"
                PLet  -> "in this pattern"
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` " ++ inThisThing ++ ":"
              ,
                D.reflow $
                  "This is a reserved word! Try using some other name?"
              )

        Code.Operator "-" ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNEXPECTED SYMBOL" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I ran into a minus sign unexpectedly in this pattern:"
              ,
                D.reflow $
                  "It is not possible to pattern match on negative numbers at this\
                  \ time. Try using an `if` expression for that sort of thing for now."
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN PATTERN" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I wanted to parse a pattern next, but I got stuck here:"
              ,
                D.fillSep $
                  ["I","am","not","sure","why","I","am","getting","stuck","exactly."
                  ,"I","just","know","that","I","want","a","pattern","next."
                  ,"Something","as","simple","as"
                  ,D.dullyellow "maybeHeight","or",D.dullyellow "result"
                  ,"would","work!"
                  ]
              )

    PChar char row col ->
      toCharReport source char row col

    PString string row col ->
      toStringReport source string row col

    PNumber number row col ->
      toNumberReport source number row col

    PFloat width row col ->
      let
        region = toWiderRegion row col width
      in
      Report.Report "UNEXPECTED PATTERN" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "I cannot pattern match with floating point numbers:"
          ,
            D.fillSep $
              ["Equality","on","floats","can","be","unreliable,","so","you","usually","want"
              ,"to","check","that","they","are","nearby","with","some","sort","of"
              ,D.dullyellow "(abs (actual - expected) < 0.001)","check."
              ]
          )

    PAlias row col ->
      let
        region = toRegion row col
      in
      Report.Report "UNFINISHED PATTERN" region [] $
        Code.toSnippet source region Nothing $
          (
            D.reflow $
              "I was expecting to see a variable name after the `as` keyword:"
          ,
            D.stack
              [ D.fillSep $
                  ["The","`as`","keyword","lets","you","write","patterns","like"
                  ,"((" <> D.dullyellow "x" <> "," <> D.dullyellow "y" <> ") " <> D.cyan "as" <> D.dullyellow " point" <> ")"
                  ,"so","you","can","refer","to","individual","parts","of","the","tuple","with"
                  ,D.dullyellow "x","and",D.dullyellow "y","or","you","refer","to","the","whole"
                  ,"thing","with",D.dullyellow "point" <> "."
                  ]
              , D.reflow $
                  "So I was expecting to see a variable name after the `as` keyword here. Sometimes\
                  \ people just want to use `as` as a variable name though. Try using a different name\
                  \ in that case!"
              ]
          )

    PWildcardNotVar name width row col ->
      let
        region = toWiderRegion row col (fromIntegral width)
        examples =
          case dropWhile (=='_') (Name.toChars name) of
            [] -> [D.dullyellow "x","or",D.dullyellow "age"]
            c:cs -> [D.dullyellow (D.fromChars (Char.toLower c : cs))]
      in
      Report.Report "UNEXPECTED NAME" region [] $
        Code.toSnippet source region Nothing $
          (
            D.reflow $
              "Variable names cannot start with underscores like this:"
          ,
            D.fillSep $
              ["You","can","either","have","an","underscore","like",D.dullyellow "_","to"
              ,"ignore","the","value,","or","you","can","have","a","name","like"
              ] ++ examples ++ ["to","use","the","matched","value." ]
          )

    PSpace space row col ->
      toSpaceReport source space row col

    PIndentStart row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PATTERN" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I wanted to parse a pattern next, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","am","not","sure","why","I","am","getting","stuck","exactly."
                  ,"I","just","know","that","I","want","a","pattern","next."
                  ,"Something","as","simple","as"
                  ,D.dullyellow "maybeHeight","or",D.dullyellow "result"
                  ,"would","work!"
                  ]
              , D.toSimpleNote $
                  "I can get confused by indentation. If you think there is a pattern next, maybe\
                  \ it needs to be indented a bit more?"
              ]
          )

    PIndentAlias row col ->
      let
        region = toRegion row col
      in
      Report.Report "UNFINISHED PATTERN" region [] $
        Code.toSnippet source region Nothing $
          (
            D.reflow $
              "I was expecting to see a variable name after the `as` keyword:"
          ,
            D.stack
              [ D.fillSep $
                  ["The","`as`","keyword","lets","you","write","patterns","like"
                  ,"((" <> D.dullyellow "x" <> "," <> D.dullyellow "y" <> ") " <> D.cyan "as" <> D.dullyellow " point" <> ")"
                  ,"so","you","can","refer","to","individual","parts","of","the","tuple","with"
                  ,D.dullyellow "x","and",D.dullyellow "y","or","you","refer","to","the","whole"
                  ,"thing","with",D.dullyellow "point."
                  ]
              , D.reflow $
                  "So I was expecting to see a variable name after the `as` keyword here. Sometimes\
                  \ people just want to use `as` as a variable name though. Try using a different name\
                  \ in that case!"
              ]
          )


toPRecordReport :: Code.Source -> PRecord -> Row -> Col -> Report.Report
toPRecordReport source record startRow startCol =
  case record of
    PRecordOpen row col ->
      toUnfinishRecordPatternReport source row col startRow startCol $
        D.reflow "I was expecting to see a field name next."

    PRecordEnd row col ->
      toUnfinishRecordPatternReport source row col startRow startCol $
        D.fillSep
          ["I","was","expecting","to","see","a","closing","curly","brace","next."
          ,"Try","adding","a",D.dullyellow "}","here?"
          ]

    PRecordField row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was not expecting to see `" ++ keyword ++ "` as a record field name:"
              ,
                D.reflow $
                  "This is a reserved word, not available for variable names. Try another name!"
              )

        _ ->
          toUnfinishRecordPatternReport source row col startRow startCol $
            D.reflow "I was expecting to see a field name next."

    PRecordSpace space row col ->
      toSpaceReport source space row col

    PRecordIndentOpen row col ->
      toUnfinishRecordPatternReport source row col startRow startCol $
        D.reflow "I was expecting to see a field name next."

    PRecordIndentEnd row col ->
      toUnfinishRecordPatternReport source row col startRow startCol $
        D.fillSep
          ["I","was","expecting","to","see","a","closing","curly","brace","next."
          ,"Try","adding","a",D.dullyellow "}","here?"
          ]

    PRecordIndentField row col ->
      toUnfinishRecordPatternReport source row col startRow startCol $
        D.reflow "I was expecting to see a field name next."


toUnfinishRecordPatternReport :: Code.Source -> Row -> Col -> Row -> Col -> D.Doc -> Report.Report
toUnfinishRecordPatternReport source row col startRow startCol message =
  let
    surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
    region = toRegion row col
  in
  Report.Report "UNFINISHED RECORD PATTERN" region [] $
    Code.toSnippet source surroundings (Just region)
      (
        D.reflow $
          "I was partway through parsing a record pattern, but I got stuck here:"
      ,
        D.stack
          [ message
          , D.toFancyHint $
              ["A","record","pattern","looks","like",D.dullyellow "{x,y}","or",D.dullyellow "{name,age}"
              ,"where","you","list","the","field","names","you","want","to","access."
              ]
          ]
      )



toPTupleReport :: Code.Source -> PContext -> PTuple -> Row -> Col -> Report.Report
toPTupleReport source context tuple startRow startCol =
  case tuple of
    PTupleOpen row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as a variable name:"
              ,
                D.reflow $
                  "This is a reserved word! Try using some other name?"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED PARENTHESES" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I just saw an open parenthesis, but I got stuck here:"
              ,
                D.fillSep
                  ["I","was","expecting","to","see","a","pattern","next."
                  ,"Maybe","it","will","end","up","being","something"
                  ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
                  ]
              )

    PTupleEnd row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region) $
              (
                D.reflow $
                  "I ran into a reserved word in this pattern:"
              ,
                D.reflow $
                  "The `" ++ keyword ++ "` keyword is reserved. Try using a different name instead!"
              )

        Code.Operator op ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col op
          in
          Report.Report "UNEXPECTED SYMBOL" region [] $
            Code.toSnippet source surroundings (Just region) $
              (
                D.reflow $
                  "I ran into the " ++ op ++ " symbol unexpectedly in this pattern:"
              ,
                D.reflow $
                  "Only the :: symbol that works in patterns. It is useful if you\
                  \ are pattern matching on lists, trying to get the first element\
                  \ off the front. Did you want that instead?"
              )

        Code.Close term bracket ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report ("STRAY " ++ map Char.toUpper term) region [] $
            Code.toSnippet source surroundings (Just region) $
              (
                D.reflow $
                  "I ran into a an unexpected " ++ term ++ " in this pattern:"
              ,
                D.reflow $
                  "This " ++ bracket : " does not match up with an earlier open " ++ term ++ ". Try deleting it?"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED PARENTHESES" region [] $
            Code.toSnippet source surroundings (Just region) $
              (
                D.reflow $
                  "I was partway through parsing a pattern, but I got stuck here:"
              ,
                D.fillSep
                  ["I","was","expecting","a","closing","parenthesis","next,","so"
                  ,"try","adding","a",D.dullyellow ")","to","see","if","that","helps?"
                  ]
              )

    PTupleExpr pattern row col ->
      toPatternReport source context pattern row col

    PTupleSpace space row col ->
      toSpaceReport source space row col

    PTupleIndentEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PARENTHESES" region [] $
        Code.toSnippet source surroundings (Just region) $
          (
            D.reflow $
              "I was expecting a closing parenthesis next:"
          ,
            D.stack
              [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe you have a closing parenthesis but it is not indented enough?"
              ]
          )

    PTupleIndentExpr1 row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PARENTHESES" region [] $
        Code.toSnippet source surroundings (Just region) $
          (
            D.reflow $
              "I just saw an open parenthesis, but then I got stuck here:"
          ,
            D.fillSep
              ["I","was","expecting","to","see","a","pattern","next."
              ,"Maybe","it","will","end","up","being","something"
              ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "?"
              ]
          )

    PTupleIndentExprN row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED TUPLE PATTERN" region [] $
        Code.toSnippet source surroundings (Just region) $
          (
            D.reflow $
              "I am partway through parsing a tuple pattern, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep
                  ["I","was","expecting","to","see","a","pattern","next."
                  ,"I","am","expecting","the","final","result","to","be","something"
                  ,"like",D.dullyellow "(x,y)","or",D.dullyellow "(name, _)" <> "."
                  ]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so the problem\
                  \ may be that the next part is not indented enough?"
              ]
          )


toPListReport :: Code.Source -> PContext -> PList -> Row -> Col -> Report.Report
toPListReport source context list startRow startCol =
  case list of
    PListOpen row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` to name an element of a list:"
              ,
                D.reflow $
                  "This is a reserved word though! Try using some other name?"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED LIST PATTERN" region [] $
            Code.toSnippet source surroundings (Just region) $
              (
                D.reflow $
                  "I just saw an open square bracket, but then I got stuck here:"
              ,
                D.fillSep ["Try","adding","a",D.dullyellow "]","to","see","if","that","helps?"]
              )

    PListEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST PATTERN" region [] $
        Code.toSnippet source surroundings (Just region) $
          (
            D.reflow $
              "I was expecting a closing square bracket to end this list pattern:"
          ,
            D.fillSep ["Try","adding","a",D.dullyellow "]","to","see","if","that","helps?"]
          )

    PListExpr pattern row col ->
      toPatternReport source context pattern row col

    PListSpace space row col ->
      toSpaceReport source space row col

    PListIndentOpen row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST PATTERN" region [] $
        Code.toSnippet source surroundings (Just region) $
          (
            D.reflow $
              "I just saw an open square bracket, but then I got stuck here:"
          ,
            D.stack
              [ D.fillSep ["Try","adding","a",D.dullyellow "]","to","see","if","that","helps?"]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe there is something next, but it is not indented enough?"
              ]
          )

    PListIndentEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST PATTERN" region [] $
        Code.toSnippet source surroundings (Just region) $
          (
            D.reflow $
              "I was expecting a closing square bracket to end this list pattern:"
          ,
            D.stack
              [ D.fillSep ["Try","adding","a",D.dullyellow "]","to","see","if","that","helps?"]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe you have a closing square bracket but it is not indented enough?"
              ]
          )

    PListIndentExpr row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED LIST PATTERN" region [] $
        Code.toSnippet source surroundings (Just region) $
          (
            D.reflow $
              "I am partway through parsing a list pattern, but I got stuck here:"
          ,
            D.stack
              [ D.reflow $
                  "I was expecting to see another pattern next. Maybe a variable name."
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe there is more to this pattern but it is not indented enough?"
              ]
          )



-- TYPES


data TContext
  = TC_Annotation Name.Name
  | TC_CustomType
  | TC_TypeAlias
  | TC_Port


toTypeReport :: Code.Source -> TContext -> Type -> Row -> Col -> Report.Report
toTypeReport source context tipe startRow startCol =
  case tipe of
    TRecord record row col ->
      toTRecordReport source context record row col

    TTuple tuple row col ->
      toTTupleReport source context tuple row col

    TStart row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was expecting to see a type next, but I got stuck on this reserved word:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as a type variable, but \
                  \ it is a reserved word. Try using a different name!"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col

            thing =
              case context of
                TC_Annotation _ -> "type annotation"
                TC_CustomType -> "custom type"
                TC_TypeAlias -> "type alias"
                TC_Port -> "port"

            something =
              case context of
                TC_Annotation name -> "the `" ++ Name.toChars name ++ "` type annotation"
                TC_CustomType -> "a custom type"
                TC_TypeAlias -> "a type alias"
                TC_Port -> "a port"
          in
          Report.Report ("PROBLEM IN " ++ map Char.toUpper thing) region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was partway through parsing " ++ something ++ ", but I got stuck here:"
              ,
                D.fillSep $
                  ["I","was","expecting","to","see","a","type","next."
                  ,"Try","putting",D.dullyellow "Int","or",D.dullyellow "String","for","now?"
                  ]
              )

    TSpace space row col ->
      toSpaceReport source space row col

    TIndentStart row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col

        thing =
          case context of
            TC_Annotation _ -> "type annotation"
            TC_CustomType -> "custom type"
            TC_TypeAlias -> "type alias"
            TC_Port -> "port"
      in
      Report.Report ("UNFINISHED " ++ map Char.toUpper thing) region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was partway through parsing a " ++ thing ++ ", but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","was","expecting","to","see","a","type","next."
                  ,"Try","putting",D.dullyellow "Int","or",D.dullyellow "String","for","now?"
                  ]
              , D.toSimpleNote $
                  "I can get confused by indentation. If you think there is already a type\
                  \ next, maybe it is not indented enough?"
              ]
          )


toTRecordReport :: Code.Source -> TContext -> TRecord -> Row -> Col -> Report.Report
toTRecordReport source context record startRow startCol =
  case record of
    TRecordOpen row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I just started parsing a record type, but I got stuck on this field name:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as a field name, but \
                  \ that is a reserved word. Try using a different name!"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED RECORD TYPE" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I just started parsing a record type, but I got stuck here:"
              ,
                D.fillSep
                  ["Record","types","look","like",D.dullyellow "{ name : String, age : Int },"
                  ,"so","I","was","expecting","to","see","a","field","name","next."
                  ]
              )

    TRecordEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record type, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep
                  ["I","was","expecting","to","see","a","closing","curly","brace","before","this,"
                  ,"so","try","adding","a",D.dullyellow "}","and","see","if","that","helps?"
                  ]
              , D.toSimpleNote $
                  "When I get stuck like this, it usually means that there is a missing parenthesis\
                  \ or bracket somewhere earlier. It could also be a stray keyword or operator."
              ]
          )

    TRecordField row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a record type, but I got stuck on this field name:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as a field name, but \
                  \ that is a reserved word. Try using a different name!"
              )

        Code.Other (Just ',') ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "EXTRA COMMA" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a record type, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "I am seeing two commas in a row. This is the second one!"
                  , D.reflow $
                      "Just delete one of the commas and you should be all set!"
                  , noteForRecordTypeError
                  ]
              )

        Code.Close _ '}' ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "EXTRA COMMA" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a record type, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "Trailing commas are not allowed in record types. Try deleting the comma that\
                      \ appears before this closing curly brace."
                  , noteForRecordTypeError
                  ]
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "PROBLEM IN RECORD TYPE" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I am partway through parsing a record type, but I got stuck here:"
              ,
                D.stack
                  [ D.fillSep
                      ["I","was","expecting","to","see","another","record","field","defined","next,"
                      ,"so","I","am","looking","for","a","name","like"
                      ,D.dullyellow "userName","or",D.dullyellow "plantHeight" <> "."
                      ]
                  , noteForRecordTypeError
                  ]
              )

    TRecordColon row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record type, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","just","saw","a","field","name,","so","I","was","expecting","to","see"
                  ,"a","colon","next.","So","try","putting","an",D.green ":","sign","here?"
                  ]
              , noteForRecordTypeError
              ]
          )

    TRecordType tipe row col ->
      toTypeReport source context tipe row col

    TRecordSpace space row col ->
      toSpaceReport source space row col

    TRecordIndentOpen row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw the opening curly brace of a record type, but then I got stuck here:"
          ,
            D.stack
              [ D.fillSep $
                  ["I","am","expecting","a","record","like",D.dullyellow "{ name : String, age : Int }","here."
                  ,"Try","defining","some","fields","of","your","own?"
                  ]
              , noteForRecordTypeIndentError
              ]
          )

    TRecordIndentEnd row col ->
      case Code.nextLineStartsWithCloseCurly source row of
        Just (curlyRow, curlyCol) ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position curlyRow curlyCol)
            region = toRegion curlyRow curlyCol
          in
          Report.Report "NEED MORE INDENTATION" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was partway through parsing a record type, but I got stuck here:"
              ,
                D.stack
                  [ D.reflow $
                      "I need this curly brace to be indented more. Try adding some spaces before it!"
                  , noteForRecordTypeError
                  ]
              )

        Nothing ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED RECORD TYPE" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I was partway through parsing a record type, but I got stuck here:"
              ,
                D.stack
                  [ D.fillSep $
                      ["I","was","expecting","to","see","a","closing","curly","brace","next."
                      ,"Try","putting","a",D.green "}","next","and","see","if","that","helps?"
                      ]
                  , noteForRecordTypeIndentError
                  ]
              )

    TRecordIndentField row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record type, but I got stuck after that last comma:"
          ,
            D.stack
              [ D.reflow $
                  "Trailing commas are not allowed in record types, so the fix may be to\
                  \ delete that last comma? Or maybe you were in the middle of defining\
                  \ an additional field?"
              , noteForRecordTypeIndentError
              ]
          )

    TRecordIndentColon row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record type. I just saw a record\
              \ field, so I was expecting to see a colon next:"
          ,
            D.stack
              [ D.fillSep $
                  ["Try","putting","an",D.green ":","followed","by","a","type?"
                  ]
              , noteForRecordTypeIndentError
              ]
          )

    TRecordIndentType row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED RECORD TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I am partway through parsing a record type, and I was expecting to run into a type next:"
          ,
            D.stack
              [ D.fillSep $
                  ["Try","putting","something","like"
                  ,D.dullyellow "Int","or",D.dullyellow "String","for","now?"
                  ]
              , noteForRecordTypeIndentError
              ]
          )


noteForRecordTypeError :: D.Doc
noteForRecordTypeError =
  D.stack $
    [ D.toSimpleNote
        "If you are trying to define a record type across multiple lines, I recommend using this format:"
    , D.indent 4 $ D.vcat $
        [ "{ name : String"
        , ", age : Int"
        , ", height : Float"
        , "}"
        ]
    , D.reflow $
        "Notice that each line starts with some indentation. Usually two or four spaces.\
        \ This is the stylistic convention in the Elm ecosystem."
    ]


noteForRecordTypeIndentError :: D.Doc
noteForRecordTypeIndentError =
  D.stack $
    [ D.toSimpleNote
        "I may be confused by indentation. For example, if you are trying to define\
        \ a record type across multiple lines, I recommend using this format:"
    , D.indent 4 $ D.vcat $
        [ "{ name : String"
        , ", age : Int"
        , ", height : Float"
        , "}"
        ]
    , D.reflow $
        "Notice that each line starts with some indentation. Usually two or four spaces.\
        \ This is the stylistic convention in the Elm ecosystem."
    ]


toTTupleReport :: Code.Source -> TContext -> TTuple -> Row -> Col -> Report.Report
toTTupleReport source context tuple startRow startCol =
  case tuple of
    TTupleOpen row col ->
      case Code.whatIsNext source row col of
        Code.Keyword keyword ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toKeywordRegion row col keyword
          in
          Report.Report "RESERVED WORD" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I ran into a reserved word unexpectedly:"
              ,
                D.reflow $
                  "It looks like you are trying to use `" ++ keyword ++ "` as a variable name, but \
                  \ it is a reserved word. Try using a different name!"
              )

        _ ->
          let
            surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
            region = toRegion row col
          in
          Report.Report "UNFINISHED PARENTHESES" region [] $
            Code.toSnippet source surroundings (Just region)
              (
                D.reflow $
                  "I just saw an open parenthesis, so I was expecting to see a type next."
              ,
                D.fillSep $
                  ["Something","like",D.dullyellow "(Maybe Int)","or"
                  ,D.dullyellow "(List Person)" <> "."
                  ,"Anything","where","you","are","putting","parentheses","around","normal","types."
                  ]
              )

    TTupleEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PARENTHESES" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see a closing parenthesis next, but I got stuck here:"
          ,
            D.stack
              [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps?"]
              , D.toSimpleNote $
                  "I can get stuck when I run into keywords, operators, parentheses, or brackets\
                  \ unexpectedly. So there may be some earlier syntax trouble (like extra parenthesis\
                  \ or missing brackets) that is confusing me."
              ]
          )

    TTupleType tipe row col ->
      toTypeReport source context tipe row col

    TTupleSpace space row col ->
      toSpaceReport source space row col

    TTupleIndentType1 row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PARENTHESES" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I just saw an open parenthesis, so I was expecting to see a type next."
          ,
            D.stack
              [ D.fillSep $
                  ["Something","like",D.dullyellow "(Maybe Int)","or"
                  ,D.dullyellow "(List Person)" <> "."
                  ,"Anything","where","you","are","putting","parentheses","around","normal","types."
                  ]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe you have a type but it is not indented enough?"
              ]
          )

    TTupleIndentTypeN row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED TUPLE TYPE" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I think I am in the middle of parsing a tuple type. I just saw a comma, so I was expecting to see a type next."
          ,
            D.stack
              [ D.fillSep $
                  ["A","tuple","type","looks","like",D.dullyellow "(Float,Float)","or"
                  ,D.dullyellow "(String,Int)" <> ","
                  ,"so","I","think","there","is","a","type","missing","here?"
                  ]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe you have an expression but it is not indented enough?"
              ]
          )

    TTupleIndentEnd row col ->
      let
        surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
        region = toRegion row col
      in
      Report.Report "UNFINISHED PARENTHESES" region [] $
        Code.toSnippet source surroundings (Just region)
          (
            D.reflow $
              "I was expecting to see a closing parenthesis next:"
          ,
            D.stack
              [ D.fillSep ["Try","adding","a",D.dullyellow ")","to","see","if","that","helps!"]
              , D.toSimpleNote $
                  "I can get confused by indentation in cases like this, so\
                  \ maybe you have a closing parenthesis but it is not indented enough?"
              ]
          )


================================================
FILE: compiler/src/Reporting/Error/Type.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error.Type
  ( Error(..)
  -- expectations
  , Expected(..)
  , Context(..)
  , SubContext(..)
  , MaybeName(..)
  , Category(..)
  , PExpected(..)
  , PContext(..)
  , PCategory(..)
  , typeReplace
  , ptypeReplace
  -- make reports
  , toReport
  )
  where


import Prelude hiding (round)
import qualified Data.Map as Map
import qualified Data.Name as Name

import qualified AST.Canonical as Can
import qualified Data.Index as Index
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import qualified Reporting.Render.Code as Code
import qualified Reporting.Render.Type as RT
import qualified Reporting.Render.Type.Localizer as L
import qualified Reporting.Report as Report
import qualified Reporting.Suggest as Suggest
import qualified Type.Error as T



-- ERRORS


data Error
  = BadExpr A.Region Category T.Type (Expected T.Type)
  | BadPattern A.Region PCategory T.Type (PExpected T.Type)
  | InfiniteType A.Region Name.Name T.Type



-- EXPRESSION EXPECTATIONS


data Expected tipe
  = NoExpectation tipe
  | FromContext A.Region Context tipe
  | FromAnnotation Name.Name Int SubContext tipe


data Context
  = ListEntry Index.ZeroBased
  | Negate
  | OpLeft Name.Name
  | OpRight Name.Name
  | IfCondition
  | IfBranch Index.ZeroBased
  | CaseBranch Index.ZeroBased
  | CallArity MaybeName Int
  | CallArg MaybeName Index.ZeroBased
  | RecordAccess A.Region (Maybe Name.Name) A.Region Name.Name
  | RecordUpdateKeys Name.Name (Map.Map Name.Name Can.FieldUpdate)
  | RecordUpdateValue Name.Name
  | Destructure


data SubContext
  = TypedIfBranch Index.ZeroBased
  | TypedCaseBranch Index.ZeroBased
  | TypedBody


data MaybeName
  = FuncName Name.Name
  | CtorName Name.Name
  | OpName Name.Name
  | NoName


data Category
  = List
  | Number
  | Float
  | String
  | Char
  | If
  | Case
  | CallResult MaybeName
  | Lambda
  | Accessor Name.Name
  | Access Name.Name
  | Record
  | Tuple
  | Unit
  | Shader
  | Effects
  | Local Name.Name
  | Foreign Name.Name



-- PATTERN EXPECTATIONS


data PExpected tipe
  = PNoExpectation tipe
  | PFromContext A.Region PContext tipe


data PContext
  = PTypedArg Name.Name Index.ZeroBased
  | PCaseMatch Index.ZeroBased
  | PCtorArg Name.Name Index.ZeroBased
  | PListEntry Index.ZeroBased
  | PTail


data PCategory
  = PRecord
  | PUnit
  | PTuple
  | PList
  | PCtor Name.Name
  | PInt
  | PStr
  | PChr
  | PBool



-- HELPERS


typeReplace :: Expected a -> b -> Expected b
typeReplace expectation tipe =
  case expectation of
    NoExpectation _ ->
      NoExpectation tipe

    FromContext region context _ ->
      FromContext region context tipe

    FromAnnotation name arity context _ ->
      FromAnnotation name arity context tipe


ptypeReplace :: PExpected a -> b -> PExpected b
ptypeReplace expectation tipe =
  case expectation of
    PNoExpectation _ ->
      PNoExpectation tipe

    PFromContext region context _ ->
      PFromContext region context tipe



-- TO REPORT


toReport :: Code.Source -> L.Localizer -> Error -> Report.Report
toReport source localizer err =
  case err of
    BadExpr region category actualType expected ->
      toExprReport source localizer region category actualType expected

    BadPattern region category tipe expected ->
      toPatternReport source localizer region category tipe expected

    InfiniteType region name overallType ->
      toInfiniteReport source localizer region name overallType



-- TO PATTERN REPORT


toPatternReport :: Code.Source -> L.Localizer -> A.Region -> PCategory -> T.Type -> PExpected T.Type -> Report.Report
toPatternReport source localizer patternRegion category tipe expected =
  Report.Report "TYPE MISMATCH" patternRegion [] $
  case expected of
    PNoExpectation expectedType ->
      Code.toSnippet source patternRegion Nothing $
        ( "This pattern is being used in an unexpected way:"
        , patternTypeComparison localizer tipe expectedType
            (addPatternCategory "It is" category)
            "But it needs to match:"
            []
        )

    PFromContext region context expectedType ->
      Code.toSnippet source region (Just patternRegion) $
        case context of
          PTypedArg name index ->
            ( D.reflow $
                "The " <> D.ordinal index <> " argument to `" <> Name.toChars name <> "` is weird."
            , patternTypeComparison localizer tipe expectedType
                (addPatternCategory "The argument is a pattern that matches" category)
                ( "But the type annotation on `" <> Name.toChars name
                  <> "` says the " <> D.ordinal index <> " argument should be:"
                )
                []
            )

          PCaseMatch index ->
            if index == Index.first then
              (
                D.reflow $
                  "The 1st pattern in this `case` causing a mismatch:"
              ,
                patternTypeComparison localizer tipe expectedType
                  (addPatternCategory "The first pattern is trying to match" category)
                  "But the expression between `case` and `of` is:"
                  [ D.reflow $
                      "These can never match! Is the pattern the problem? Or is it the expression?"
                  ]
              )
            else
              ( D.reflow $
                  "The " <> D.ordinal index <> " pattern in this `case` does not match the previous ones."
              , patternTypeComparison localizer tipe expectedType
                  (addPatternCategory ("The " <> D.ordinal index <> " pattern is trying to match") category)
                  "But all the previous patterns match:"
                  [ D.link "Note"
                      "A `case` expression can only handle one type of value, so you may want to use"
                      "custom-types"
                      "to handle “mixing” types."
                  ]
              )

          PCtorArg name index ->
            ( D.reflow $
                "The " <> D.ordinal index <> " argument to `" <> Name.toChars name <> "` is weird."
            , patternTypeComparison localizer tipe expectedType
                (addPatternCategory "It is trying to match" category)
                ( "But `" <> Name.toChars name <> "` needs its "
                  <> D.ordinal index <> " argument to be:"
                )
                []
            )

          PListEntry index ->
            ( D.reflow $
                "The " <> D.ordinal index <> " pattern in this list does not match all the previous ones:"
            , patternTypeComparison localizer tipe expectedType
                (addPatternCategory ("The " <> D.ordinal index <> " pattern is trying to match") category)
                "But all the previous patterns in the list are:"
                [ D.link "Hint"
                    "Everything in a list must be the same type of value. This way, we never\
                    \ run into unexpected values partway through a List.map, List.foldl, etc. Read"
                    "custom-types"
                    "to learn how to “mix” types."
                ]
            )

          PTail ->
            ( D.reflow $
                "The pattern after (::) is causing issues."
            , patternTypeComparison localizer tipe expectedType
                (addPatternCategory "The pattern after (::) is trying to match" category)
                "But it needs to match lists like this:"
                []
            )



-- PATTERN HELPERS


patternTypeComparison :: L.Localizer -> T.Type -> T.Type -> String -> String -> [D.Doc] -> D.Doc
patternTypeComparison localizer actual expected iAmSeeing insteadOf contextHints =
  let
    (actualDoc, expectedDoc, problems) =
      T.toComparison localizer actual expected
  in
  D.stack $
    [ D.reflow iAmSeeing
    , D.indent 4 actualDoc
    , D.reflow insteadOf
    , D.indent 4 expectedDoc
    ]
    ++ problemsToHint problems
    ++ contextHints


addPatternCategory :: String -> PCategory -> String
addPatternCategory iAmTryingToMatch category =
  iAmTryingToMatch <>
    case category of
      PRecord -> " record values of type:"
      PUnit -> " unit values:"
      PTuple -> " tuples of type:"
      PList -> " lists of type:"
      PCtor name -> " `" <> Name.toChars name <> "` values of type:"
      PInt -> " integers:"
      PStr -> " strings:"
      PChr -> " characters:"
      PBool -> " booleans:"



-- EXPR HELPERS


typeComparison :: L.Localizer -> T.Type -> T.Type -> String -> String -> [D.Doc] -> D.Doc
typeComparison localizer actual expected iAmSeeing insteadOf contextHints =
  let
    (actualDoc, expectedDoc, problems) =
      T.toComparison localizer actual expected
  in
  D.stack $
    [ D.reflow iAmSeeing
    , D.indent 4 actualDoc
    , D.reflow insteadOf
    , D.indent 4 expectedDoc
    ]
    ++ contextHints
    ++ problemsToHint problems


loneType :: L.Localizer -> T.Type -> T.Type -> D.Doc -> [D.Doc] -> D.Doc
loneType localizer actual expected iAmSeeing furtherDetails =
  let
    (actualDoc, _, problems) =
      T.toComparison localizer actual expected
  in
  D.stack $
    [ iAmSeeing
    , D.indent 4 actualDoc
    ]
    ++ furtherDetails
    ++ problemsToHint problems


addCategory :: String -> Category -> String
addCategory thisIs category =
  case category of
    Local name -> "This `" <> Name.toChars name <> "` value is a:"
    Foreign name -> "This `" <> Name.toChars name <> "` value is a:"
    Access field -> "The value at ." <> Name.toChars field <> " is a:"
    Accessor field -> "This ." <> Name.toChars field <> " field access function has type:"
    If -> "This `if` expression produces:"
    Case -> "This `case` expression produces:"
    List -> thisIs <> " a list of type:"
    Number -> thisIs <> " a number of type:"
    Float -> thisIs <> " a float of type:"
    String -> thisIs <> " a string of type:"
    Char -> thisIs <> " a character of type:"
    Lambda -> thisIs <> " an anonymous function of type:"
    Record -> thisIs <> " a record of type:"
    Tuple -> thisIs <> " a tuple of type:"
    Unit -> thisIs <> " a unit value:"
    Shader -> thisIs <> " a GLSL shader of type:"
    Effects -> thisIs <> " a thing for CORE LIBRARIES ONLY."
    CallResult maybeName ->
      case maybeName of
        NoName -> thisIs <> ":"
        FuncName name -> "This `" <> Name.toChars name <> "` call produces:"
        CtorName name -> "This `" <> Name.toChars name <> "` call produces:"
        OpName _ -> thisIs <> ":"


problemsToHint :: [T.Problem] -> [D.Doc]
problemsToHint problems =
  case problems of
    [] ->
      []

    problem : _ ->
      problemToHint problem


problemToHint :: T.Problem -> [D.Doc]
problemToHint problem =
  case problem of
    T.IntFloat ->
      [ D.fancyLink "Note" ["Read"] "implicit-casts"
          ["to","learn","why","Elm","does","not","implicitly","convert"
          ,"Ints","to","Floats.","Use",D.green "toFloat","and"
          ,D.green "round","to","do","explicit","conversions."
          ]
      ]

    T.StringFromInt ->
      [ D.toFancyHint
          ["Want","to","convert","an","Int","into","a","String?"
          ,"Use","the",D.green "String.fromInt","function!"
          ]
      ]

    T.StringFromFloat ->
      [ D.toFancyHint
          ["Want","to","convert","a","Float","into","a","String?"
          ,"Use","the",D.green "String.fromFloat","function!"
          ]
      ]

    T.StringToInt ->
      [ D.toFancyHint
          ["Want","to","convert","a","String","into","an","Int?"
          ,"Use","the",D.green "String.toInt","function!"
          ]
      ]

    T.StringToFloat ->
      [ D.toFancyHint
          ["Want","to","convert","a","String","into","a","Float?"
          ,"Use","the",D.green "String.toFloat","function!"
          ]
      ]

    T.AnythingToBool ->
      [ D.toSimpleHint $
          "Elm does not have “truthiness” such that ints and strings and lists\
          \ are automatically converted to booleans. Do that conversion explicitly!"
      ]

    T.AnythingFromMaybe ->
      [ D.toFancyHint
          ["Use",D.green "Maybe.withDefault","to","handle","possible","errors."
          ,"Longer","term,","it","is","usually","better","to","write","out","the"
          ,"full","`case`","though!"
          ]
      ]

    T.ArityMismatch x y ->
      [ D.toSimpleHint $
          if x < y then
            "It looks like it takes too few arguments. I was expecting " ++ show (y - x) ++ " more."
          else
            "It looks like it takes too many arguments. I see " ++ show (x - y) ++ " extra."
      ]

    T.BadFlexSuper direction super _ tipe ->
      case tipe of
        T.Lambda _ _ _   -> badFlexSuper direction super tipe
        T.Infinite       -> []
        T.Error          -> []
        T.FlexVar _      -> []
        T.FlexSuper s _  -> badFlexFlexSuper super s
        T.RigidVar y     -> badRigidVar y (toASuperThing super)
        T.RigidSuper s _ -> badRigidSuper s (toASuperThing super)
        T.Type _ _ _     -> badFlexSuper direction super tipe
        T.Record _ _     -> badFlexSuper direction super tipe
        T.Unit           -> badFlexSuper direction super tipe
        T.Tuple _ _ _    -> badFlexSuper direction super tipe
        T.Alias _ _ _ _  -> badFlexSuper direction super tipe

    T.BadRigidVar x tipe ->
      case tipe of
        T.Lambda _ _ _   -> badRigidVar x "a function"
        T.Infinite       -> []
        T.Error          -> []
        T.FlexVar _      -> []
        T.FlexSuper s _  -> badRigidVar x (toASuperThing s)
        T.RigidVar y     -> badDoubleRigid x y
        T.RigidSuper _ y -> badDoubleRigid x y
        T.Type _ n _     -> badRigidVar x ("a `" ++ Name.toChars n ++ "` value")
        T.Record _ _     -> badRigidVar x "a record"
        T.Unit           -> badRigidVar x "a unit value"
        T.Tuple _ _ _    -> badRigidVar x "a tuple"
        T.Alias _ n _ _  -> badRigidVar x ("a `" ++ Name.toChars n ++ "` value")

    T.BadRigidSuper super x tipe ->
      case tipe of
        T.Lambda _ _ _   -> badRigidSuper super "a function"
        T.Infinite       -> []
        T.Error          -> []
        T.FlexVar _      -> []
        T.FlexSuper s _  -> badRigidSuper super (toASuperThing s)
        T.RigidVar y     -> badDoubleRigid x y
        T.RigidSuper _ y -> badDoubleRigid x y
        T.Type _ n _     -> badRigidSuper super ("a `" ++ Name.toChars n ++ "` value")
        T.Record _ _     -> badRigidSuper super "a record"
        T.Unit           -> badRigidSuper super "a unit value"
        T.Tuple _ _ _    -> badRigidSuper super "a tuple"
        T.Alias _ n _ _  -> badRigidSuper super ("a `" ++ Name.toChars n ++ "` value")

    T.FieldsMissing fields ->
      case map (D.green . D.fromName) fields of
        [] ->
          []

        [f1] ->
          [ D.toFancyHint ["Looks","like","the",f1,"field","is","missing."]
          ]

        fieldDocs ->
          [ D.toFancyHint $
              ["Looks","like","fields"] ++ D.commaSep "and" id fieldDocs ++ ["are","missing."]
          ]


    T.FieldTypo typo possibilities ->
      case Suggest.sort (Name.toChars typo) Name.toChars possibilities of
        [] ->
          []

        nearest:_ ->
          [ D.toFancyHint $
              ["Seems","like","a","record","field","typo.","Maybe"
              ,D.dullyellow (D.fromName typo),"should","be"
              ,D.green (D.fromName nearest) <> "?"
              ]
          , D.toSimpleHint
              "Can more type annotations be added? Type annotations always help me give\
              \ more specific messages, and I think they could help a lot in this case!"
          ]



-- BAD RIGID HINTS


badRigidVar :: Name.Name -> String -> [D.Doc]
badRigidVar name aThing =
  [ D.toSimpleHint $
      "Your type annotation uses type variable `" ++ Name.toChars name ++
      "` which means ANY type of value can flow through, but your code is saying it specifically wants "
      ++ aThing ++ ". Maybe change your type annotation to\
      \ be more specific? Maybe change the code to be more general?"
  , D.reflowLink "Read" "type-annotations" "for more advice!"
  ]


badDoubleRigid :: Name.Name -> Name.Name -> [D.Doc]
badDoubleRigid x y =
  [ D.toSimpleHint $
      "Your type annotation uses `" ++ Name.toChars x ++ "` and `" ++ Name.toChars y ++
      "` as separate type variables. Your code seems to be saying they are the\
      \ same though. Maybe they should be the same in your type annotation?\
      \ Maybe your code uses them in a weird way?"
  , D.reflowLink "Read" "type-annotations" "for more advice!"
  ]


toASuperThing :: T.Super -> String
toASuperThing super =
  case super of
    T.Number     -> "a `number` value"
    T.Comparable -> "a `comparable` value"
    T.CompAppend -> "a `compappend` value"
    T.Appendable -> "an `appendable` value"



-- BAD SUPER HINTS


badFlexSuper :: T.Direction -> T.Super -> T.Type -> [D.Doc]
badFlexSuper direction super tipe =
  case super of
    T.Comparable ->
      case tipe of
        T.Record _ _ ->
          [ D.link "Hint"
              "I do not know how to compare records. I can only compare ints, floats,\
              \ chars, strings, lists of comparable values, and tuples of comparable values.\
              \ Check out" "comparing-records" "for ideas on how to proceed."
          ]

        T.Type _ name _ ->
          [ D.toSimpleHint $
              "I do not know how to compare `" ++ Name.toChars name ++ "` values. I can only\
              \ compare ints, floats, chars, strings, lists of comparable values, and tuples\
              \ of comparable values."
          , D.reflowLink
              "Check out" "comparing-custom-types" "for ideas on how to proceed."
          ]

        _ ->
          [ D.toSimpleHint $
              "I only know how to compare ints, floats, chars, strings, lists of\
              \ comparable values, and tuples of comparable values."
          ]

    T.Appendable ->
      [ D.toSimpleHint "I only know how to append strings and lists."
      ]

    T.CompAppend ->
      [ D.toSimpleHint "Only strings and lists are both comparable and appendable."
      ]

    T.Number ->
      case tipe of
        T.Type home name _ | T.isString home name ->
          case direction of
            T.Have ->
              [ D.toFancyHint ["Try","using",D.green "String.fromInt","to","convert","it","to","a","string?"]
              ]

            T.Need ->
              [ D.toFancyHint ["Try","using",D.green "String.toInt","to","convert","it","to","an","integer?"]
              ]

        _ ->
          [ D.toFancyHint ["Only",D.green "Int","and",D.green "Float","values","work","as","numbers."]
          ]


badRigidSuper :: T.Super -> String -> [D.Doc]
badRigidSuper super aThing =
  let
    (superType, manyThings) =
      case super of
        T.Number -> ("number", "ints AND floats")
        T.Comparable -> ("comparable", "ints, floats, chars, strings, lists, and tuples")
        T.Appendable -> ("appendable", "strings AND lists")
        T.CompAppend -> ("compappend", "strings AND lists")
  in
  [ D.toSimpleHint $
      "The `" ++ superType ++ "` in your type annotation is saying that "
      ++ manyThings ++ " can flow through, but your code is saying it specifically wants "
      ++ aThing ++ ". Maybe change your type annotation to\
      \ be more specific? Maybe change the code to be more general?"
  , D.reflowLink "Read" "type-annotations" "for more advice!"
  ]


badFlexFlexSuper :: T.Super -> T.Super -> [D.Doc]
badFlexFlexSuper s1 s2 =
  let
    likeThis super =
      case super of
        T.Number -> "a number"
        T.Comparable -> "comparable"
        T.CompAppend -> "a compappend"
        T.Appendable -> "appendable"
  in
    [ D.toSimpleHint $
        "There are no values in Elm that are both "
        ++ likeThis s1 ++ " and " ++ likeThis s2 ++ "."
    ]



-- TO EXPR REPORT


toExprReport :: Code.Source -> L.Localizer -> A.Region -> Category -> T.Type -> Expected T.Type -> Report.Report
toExprReport source localizer exprRegion category tipe expected =
  case expected of
    NoExpectation expectedType ->
      Report.Report "TYPE MISMATCH" exprRegion [] $
        Code.toSnippet source exprRegion Nothing
          ( "This expression is being used in an unexpected way:"
          , typeComparison localizer tipe expectedType
              (addCategory "It is" category)
              "But you are trying to use it as:"
              []
          )

    FromAnnotation name _arity subContext expectedType ->
      let
        thing =
          case subContext of
            TypedIfBranch index   -> D.ordinal index <> " branch of this `if` expression:"
            TypedCaseBranch index -> D.ordinal index <> " branch of this `case` expression:"
            TypedBody             -> "body of the `" <> Name.toChars name <> "` definition:"

        itIs =
          case subContext of
            TypedIfBranch index   -> "The " <> D.ordinal index <> " branch is"
            TypedCaseBranch index -> "The " <> D.ordinal index <> " branch is"
            TypedBody             -> "The body is"
      in
      Report.Report "TYPE MISMATCH" exprRegion [] $
        Code.toSnippet source exprRegion Nothing $
          ( D.reflow ("Something is off with the " <> thing)
          , typeComparison localizer tipe expectedType
              (addCategory itIs category)
              ("But the type annotation on `" <> Name.toChars name <> "` says it should be:")
              []
          )

    FromContext region context expectedType ->
      let
        mismatch (maybeHighlight, problem, thisIs, insteadOf, furtherDetails) =
          Report.Report "TYPE MISMATCH" exprRegion [] $
            Code.toSnippet source region maybeHighlight
              ( D.reflow problem
              , typeComparison localizer tipe expectedType (addCategory thisIs category) insteadOf furtherDetails
              )

        badType (maybeHighlight, problem, thisIs, furtherDetails) =
          Report.Report "TYPE MISMATCH" exprRegion [] $
            Code.toSnippet source region maybeHighlight
              ( D.reflow problem
              , loneType localizer tipe expectedType (D.reflow (addCategory thisIs category)) furtherDetails
              )

        custom maybeHighlight docPair =
          Report.Report "TYPE MISMATCH" exprRegion [] $
            Code.toSnippet source region maybeHighlight docPair
      in
      case context of
        ListEntry index ->
          let ith = D.ordinal index in
          mismatch
          ( Just exprRegion
          , "The " <> ith <> " element of this list does not match all the previous elements:"
          , "The " <> ith <> " element is"
          , "But all the previous elements in the list are:"
          , [ D.link "Hint"
                "Everything in a list must be the same type of value. This way, we never\
                \ run into unexpected values partway through a List.map, List.foldl, etc. Read"
                "custom-types"
                "to learn how to “mix” types."
            ]
          )

        Negate ->
          badType
          ( Just exprRegion
          , "I do not know how to negate this type of value:"
          , "It is"
          , [ D.fillSep
                ["But","I","only","now","how","to","negate"
                ,D.dullyellow "Int","and",D.dullyellow "Float","values."
                ]
            ]
          )

        OpLeft op ->
          custom (Just exprRegion) $
            opLeftToDocs localizer category op tipe expectedType

        OpRight op ->
          case opRightToDocs localizer category op tipe expectedType of
            EmphBoth details ->
              custom Nothing details

            EmphRight details ->
              custom (Just exprRegion) details

        IfCondition ->
          badType
          ( Just exprRegion
          , "This `if` condition does not evaluate to a boolean value, True or False."
          , "It is"
          , [ D.fillSep ["But","I","need","this","`if`","condition","to","be","a",D.dullyellow "Bool","value."]
            ]
          )

        IfBranch index ->
          let ith = D.ordinal index in
          mismatch
          ( Just exprRegion
          , "The " <> ith <> " branch of this `if` does not match all the previous branches:"
          , "The " <> ith <> " branch is"
          , "But all the previous branches result in:"
          , [ D.link "Hint"
                "All branches in an `if` must produce the same type of values. This way, no\
                \ matter which branch we take, the result is always a consistent shape. Read"
                "custom-types"
                "to learn how to “mix” types."
            ]
          )

        CaseBranch index ->
          let ith = D.ordinal index in
          mismatch
          ( Just exprRegion
          , "The " <> ith <> " branch of this `case` does not match all the previous branches:"
          , "The " <> ith <> " branch is"
          , "But all the previous branches result in:"
          , [ D.link "Hint"
                "All branches in a `case` must produce the same type of values. This way, no\
                \ matter which branch we take, the result is always a consistent shape. Read"
                "custom-types"
                "to learn how to “mix” types."
            ]
          )

        CallArity maybeFuncName numGivenArgs ->
          Report.Report "TOO MANY ARGS" exprRegion [] $
          Code.toSnippet source region (Just exprRegion) $
          case countArgs tipe of
            0 ->
              let
                thisValue =
                  case maybeFuncName of
                    NoName        -> "This value"
                    FuncName name -> "The `" <> Name.toChars name <> "` value"
                    CtorName name -> "The `" <> Name.toChars name <> "` value"
                    OpName op     -> "The (" <> Name.toChars op <> ") operator"
              in
              ( D.reflow $ thisValue <> " is not a function, but it was given " <> D.args numGivenArgs <> "."
              , D.reflow $ "Are there any missing commas? Or missing parentheses?"
              )

            n ->
              let
                thisFunction =
                  case maybeFuncName of
                    NoName        -> "This function"
                    FuncName name -> "The `" <> Name.toChars name <> "` function"
                    CtorName name -> "The `" <> Name.toChars name <> "` constructor"
                    OpName op     -> "The (" <> Name.toChars op <> ") operator"
              in
              ( D.reflow $ thisFunction <> " expects " <> D.args n <> ", but it got " <> show numGivenArgs <> " instead."
              , D.reflow $ "Are there any missing commas? Or missing parentheses?"
              )

        CallArg maybeFuncName index ->
          let
            ith = D.ordinal index

            thisFunction =
              case maybeFuncName of
                NoName        -> "this function"
                FuncName name -> "`" <> Name.toChars name <> "`"
                CtorName name -> "`" <> Name.toChars name <> "`"
                OpName op     -> "(" <> Name.toChars op <> ")"
          in
          mismatch
          ( Just exprRegion
          , "The " <> ith <> " argument to " <> thisFunction <> " is not what I expect:"
          , "This argument is"
          , "But " <> thisFunction <> " needs the " <> ith <> " argument to be:"
          ,
            if Index.toHuman index == 1 then
              []
            else
              [ D.toSimpleHint $
                 "I always figure out the argument types from left to right. If an argument\
                  \ is acceptable, I assume it is “correct” and move on. So the problem may\
                  \ actually be in one of the previous arguments!"
              ]
          )

        RecordAccess recordRegion maybeName fieldRegion field ->
          case T.iteratedDealias tipe of
            T.Record fields ext ->
              custom (Just fieldRegion)
                ( D.reflow $
                    "This "
                    <> maybe "" (\n -> "`" <> Name.toChars n <> "`") maybeName
                    <> " record does not have a `" <> Name.toChars field <> "` field:"
                , case Suggest.sort (Name.toChars field) (Name.toChars . fst) (Map.toList fields) of
                    [] ->
                      D.reflow "In fact, it is a record with NO fields!"

                    f:fs ->
                      D.stack
                        [ D.reflow $
                            "This is usually a typo. Here are the "
                            <> maybe "" (\n -> "`" <> Name.toChars n <> "`") maybeName
                            <> " fields that are most similar:"
                        , toNearbyRecord localizer f fs ext
                        , D.fillSep
                            ["So","maybe",D.dullyellow (D.fromName field)
                            ,"should","be",D.green (D.fromName (fst f)) <> "?"
                            ]
                        ]
                )

            _ ->
              badType
              ( Just recordRegion
              , "This is not a record, so it has no fields to access!"
              , "It is"
              , [ D.fillSep
                    ["But","I","need","a","record","with","a"
                    ,D.dullyellow (D.fromName field),"field!"
                    ]
                ]
              )

        RecordUpdateKeys record expectedFields ->
          case T.iteratedDealias tipe of
            T.Record actualFields ext ->
              case Map.lookupMin (Map.difference expectedFields actualFields) of
                Nothing ->
                  mismatch
                  ( Nothing
                  , "Something is off with this record update:"
                  , "The `" <> Name.toChars record <> "` record is"
                  , "But this update needs it to be compatable with:"
                  , [ D.reflow
                        "Do you mind creating an  that produces this error message and\
                        \ sharing it at  so we\
                        \ can try to give better advice here?"
                    ]
                  )

                Just (field, Can.FieldUpdate fieldRegion _) ->
                  let
                    rStr = "`" <> Name.toChars record <> "`"
                    fStr = "`" <> Name.toChars field <> "`"
                  in
                  custom (Just fieldRegion)
                    ( D.reflow $
                        "The " <> rStr <> " record does not have a " <> fStr <> " field:"
                    , case Suggest.sort (Name.toChars field) (Name.toChars . fst) (Map.toList actualFields) of
                        [] ->
                          D.reflow $ "In fact, " <> rStr <> " is a record with NO fields!"

                        f:fs ->
                          D.stack
                            [ D.reflow $
                                "This is usually a typo. Here are the " <> rStr <> " fields that are most similar:"
                            , toNearbyRecord localizer f fs ext
                            , D.fillSep
                                ["So","maybe",D.dullyellow (D.fromName field)
                                ,"should","be",D.green (D.fromName (fst f)) <> "?"
                                ]
                            ]
                    )

            _ ->
              badType
              ( Just exprRegion
              , "This is not a record, so it has no fields to update!"
              , "It is"
              , [ D.reflow $ "But I need a record!"
                ]
              )

        RecordUpdateValue field ->
          mismatch
          ( Just exprRegion
          , "I cannot update the `" <> Name.toChars field <> "` field like this:"
          , "You are trying to update `" <> Name.toChars field <> "` to be"
          , "But it should be:"
          , [ D.toSimpleNote
                "The record update syntax does not allow you to change the type of fields.\
                \ You can achieve that with record constructors or the record literal syntax."
            ]
          )

        Destructure ->
          mismatch
          ( Nothing
          , "This definition is causing issues:"
          , "You are defining"
          , "But then trying to destructure it as:"
          , []
          )



-- HELPERS


countArgs :: T.Type -> Int
countArgs tipe =
  case tipe of
    T.Lambda _ _ stuff ->
      1 + length stuff

    _ ->
      0



-- FIELD NAME HELPERS


toNearbyRecord :: L.Localizer -> (Name.Name, T.Type) -> [(Name.Name, T.Type)] -> T.Extension -> D.Doc
toNearbyRecord localizer f fs ext =
  D.indent 4 $
    if length fs <= 3 then
      RT.vrecord (map (fieldToDocs localizer) (f:fs)) (extToDoc ext)
    else
      RT.vrecordSnippet (fieldToDocs localizer f) (map (fieldToDocs localizer) (take 3 fs))


fieldToDocs :: L.Localizer -> (Name.Name, T.Type) -> (D.Doc, D.Doc)
fieldToDocs localizer (name, tipe) =
  ( D.fromName name
  , T.toDoc localizer RT.None tipe
  )


extToDoc :: T.Extension -> Maybe D.Doc
extToDoc ext =
  case ext of
    T.Closed      -> Nothing
    T.FlexOpen  x -> Just (D.fromName x)
    T.RigidOpen x -> Just (D.fromName x)



-- OP LEFT


opLeftToDocs :: L.Localizer -> Category -> Name.Name -> T.Type -> T.Type -> (D.Doc, D.Doc)
opLeftToDocs localizer category op tipe expected =
  case op of
    "+"
      | isString tipe -> badStringAdd
      | isList tipe   -> badListAdd localizer category "left" tipe expected
      | otherwise     -> badMath localizer category "Addition" "left" "+" tipe expected []

    "*"
      | isList tipe  -> badListMul localizer category "left" tipe expected
      | otherwise    -> badMath localizer category "Multiplication" "left" "*" tipe expected []

    "-"  -> badMath localizer category "Subtraction" "left" "-" tipe expected []
    "^"  -> badMath localizer category "Exponentiation" "left" "^" tipe expected []
    "/"  -> badFDiv localizer "left" tipe expected
    "//" -> badIDiv localizer "left" tipe expected
    "&&" -> badBool localizer "&&" "left" tipe expected
    "||" -> badBool localizer "||" "left" tipe expected
    "<"  -> badCompLeft localizer category "<" "left" tipe expected
    ">"  -> badCompLeft localizer category ">" "left" tipe expected
    "<=" -> badCompLeft localizer category "<=" "left" tipe expected
    ">=" -> badCompLeft localizer category ">=" "left" tipe expected

    "++" -> badAppendLeft localizer category tipe expected

    "<|" ->
      ( "The left side of (<|) needs to be a function so I can pipe arguments to it!"
      , loneType localizer tipe expected
          (D.reflow (addCategory "I am seeing" category))
          [ D.reflow $ "This needs to be some kind of function though!"
          ]
      )

    _ ->
      ( D.reflow $
          "The left argument of (" <> Name.toChars op <> ") is causing problems:"
      , typeComparison localizer tipe expected
          (addCategory "The left argument is" category)
          ("But (" <> Name.toChars op <> ") needs the left argument to be:")
          []
      )



-- OP RIGHT


data RightDocs
  = EmphBoth (D.Doc, D.Doc)
  | EmphRight (D.Doc, D.Doc)


opRightToDocs :: L.Localizer -> Category -> Name.Name -> T.Type -> T.Type -> RightDocs
opRightToDocs localizer category op tipe expected =
  case op of
    "+"
      | isFloat expected && isInt tipe -> badCast op FloatInt
      | isInt expected && isFloat tipe -> badCast op IntFloat
      | isString tipe -> EmphRight $ badStringAdd
      | isList tipe   -> EmphRight $ badListAdd localizer category "right" tipe expected
      | otherwise     -> EmphRight $ badMath localizer category "Addition" "right" "+" tipe expected []

    "*"
      | isFloat expected && isInt tipe -> badCast op FloatInt
      | isInt expected && isFloat tipe -> badCast op IntFloat
      | isList tipe -> EmphRight $ badListMul localizer category "right" tipe expected
      | otherwise   -> EmphRight $ badMath localizer category "Multiplication" "right" "*" tipe expected []

    "-"
      | isFloat expected && isInt tipe -> badCast op FloatInt
      | isInt expected && isFloat tipe -> badCast op IntFloat
      | otherwise ->
          EmphRight $ badMath localizer category "Subtraction" "right" "-" tipe expected []

    "^"
      | isFloat expected && isInt tipe -> badCast op FloatInt
      | isInt expected && isFloat tipe -> badCast op IntFloat
      | otherwise ->
          EmphRight $ badMath localizer category "Exponentiation" "right" "^" tipe expected []

    "/"  -> EmphRight $ badFDiv localizer "right" tipe expected
    "//" -> EmphRight $ badIDiv localizer "right" tipe expected
    "&&" -> EmphRight $ badBool localizer "&&" "right" tipe expected
    "||" -> EmphRight $ badBool localizer "||" "right" tipe expected
    "<"  -> badCompRight localizer "<" tipe expected
    ">"  -> badCompRight localizer ">" tipe expected
    "<=" -> badCompRight localizer "<=" tipe expected
    ">=" -> badCompRight localizer ">=" tipe expected
    "==" -> badEquality localizer "==" tipe expected
    "/=" -> badEquality localizer "/=" tipe expected

    "::" -> badConsRight localizer category tipe expected
    "++" -> badAppendRight localizer category tipe expected

    "<|" ->
      EmphRight
        ( D.reflow $ "I cannot send this through the (<|) pipe:"
        , typeComparison localizer tipe expected
            "The argument is:"
            "But (<|) is piping it to a function that expects:"
            []
        )

    "|>" ->
      case (tipe, expected) of
        (T.Lambda expectedArgType _ _, T.Lambda argType _ _) ->
          EmphRight
            ( D.reflow $ "This function cannot handle the argument sent through the (|>) pipe:"
            , typeComparison localizer argType expectedArgType
                "The argument is:"
                "But (|>) is piping it to a function that expects:"
                []
            )

        _ ->
          EmphRight
            ( D.reflow $ "The right side of (|>) needs to be a function so I can pipe arguments to it!"
            , loneType localizer tipe expected
                (D.reflow (addCategory "But instead of a function, I am seeing" category))
                []
            )

    _ ->
      badOpRightFallback localizer category op tipe expected


badOpRightFallback :: L.Localizer -> Category -> Name.Name -> T.Type -> T.Type -> RightDocs
badOpRightFallback localizer category op tipe expected =
  EmphRight
    ( D.reflow $
        "The right argument of (" <> Name.toChars op <> ") is causing problems."
    , typeComparison localizer tipe expected
        (addCategory "The right argument is" category)
        ("But (" <> Name.toChars op <> ") needs the right argument to be:")
        [ D.toSimpleHint $
            "With operators like (" ++ Name.toChars op ++ ") I always check the left\
            \ side first. If it seems fine, I assume it is correct and check the right\
            \ side. So the problem may be in how the left and right arguments interact!"
        ]
    )


isInt :: T.Type -> Bool
isInt tipe =
  case tipe of
    T.Type home name [] ->
      T.isInt home name

    _ ->
      False


isFloat :: T.Type -> Bool
isFloat tipe =
  case tipe of
    T.Type home name [] ->
      T.isFloat home name

    _ ->
      False


isString :: T.Type -> Bool
isString tipe =
  case tipe of
    T.Type home name [] ->
      T.isString home name

    _ ->
      False


isList :: T.Type -> Bool
isList tipe =
  case tipe of
    T.Type home name [_] ->
      T.isList home name

    _ ->
      False



-- BAD CONS


badConsRight :: L.Localizer -> Category -> T.Type -> T.Type -> RightDocs
badConsRight localizer category tipe expected =
  case tipe of
    T.Type home1 name1 [actualElement] | T.isList home1 name1 ->
      case expected of
        T.Type home2 name2 [expectedElement] | T.isList home2 name2 ->
          EmphBoth
            ( D.reflow "I am having trouble with this (::) operator:"
            , typeComparison localizer expectedElement actualElement
                "The left side of (::) is:"
                "But you are trying to put that into a list filled with:"
                ( case expectedElement of
                    T.Type home name [_] | T.isList home name ->
                      [ D.toSimpleHint
                          "Are you trying to append two lists? The (++) operator\
                          \ appends lists, whereas the (::) operator is only for\
                          \ adding ONE element to a list."
                      ]

                    _ ->
                      [ D.reflow
                          "Lists need ALL elements to be the same type though."
                      ]
                )
            )

        _ ->
          badOpRightFallback localizer category "::" tipe expected

    _ ->
      EmphRight
        ( D.reflow "The (::) operator can only add elements onto lists."
        , loneType localizer tipe expected
            (D.reflow (addCategory "The right side is" category))
            [D.fillSep ["But","(::)","needs","a",D.dullyellow "List","on","the","right."]
            ]
        )



-- BAD APPEND


data AppendType
  = ANumber D.Doc D.Doc
  | AString
  | AList
  | AOther


toAppendType :: T.Type -> AppendType
toAppendType tipe =
  case tipe of
    T.Type home name _
      | T.isInt    home name -> ANumber "Int" "String.fromInt"
      | T.isFloat  home name -> ANumber "Float" "String.fromFloat"
      | T.isString home name -> AString
      | T.isList   home name -> AList

    T.FlexSuper T.Number _ -> ANumber "number" "String.fromInt"

    _ -> AOther


badAppendLeft :: L.Localizer -> Category -> T.Type -> T.Type -> (D.Doc, D.Doc)
badAppendLeft localizer category tipe expected =
  case toAppendType tipe of
    ANumber thing stringFromThing ->
      ( D.fillSep
          ["The","(++)","operator","can","append","List","and","String"
          ,"values,","but","not",D.dullyellow thing,"values","like","this:"
          ]
      , D.fillSep
          ["Try","using",D.green stringFromThing,"to","turn","it","into","a","string?"
          ,"Or","put","it","in","[]","to","make","it","a","list?"
          ,"Or","switch","to","the","(::)","operator?"
          ]
      )

    _ ->
      ( D.reflow $
          "The (++) operator cannot append this type of value:"
      , loneType localizer tipe expected
          (D.reflow (addCategory "I am seeing" category))
          [ D.fillSep
              ["But","the","(++)","operator","is","only","for","appending"
              ,D.dullyellow "List","and",D.dullyellow "String","values."
              ,"Maybe","put","this","value","in","[]","to","make","it","a","list?"
              ]
          ]
      )


badAppendRight :: L.Localizer -> Category -> T.Type -> T.Type -> RightDocs
badAppendRight localizer category tipe expected =
  case (toAppendType expected, toAppendType tipe) of
    (AString, ANumber thing stringFromThing) ->
      EmphRight
        ( D.fillSep
            ["I","thought","I","was","appending",D.dullyellow "String","values","here,"
            ,"not",D.dullyellow thing,"values","like","this:"
            ]
        , D.fillSep
            ["Try","using",D.green stringFromThing,"to","turn","it","into","a","string?"]
        )

    (AList, ANumber thing _) ->
      EmphRight
        ( D.fillSep
            ["I","thought","I","was","appending",D.dullyellow "List","values","here,"
            ,"not",D.dullyellow thing,"values","like","this:"
            ]
        , D.reflow "Try putting it in [] to make it a list?"
        )

    (AString, AList) ->
      EmphBoth
        ( D.reflow $
            "The (++) operator needs the same type of value on both sides:"
        , D.fillSep
            ["I","see","a",D.dullyellow "String","on","the","left","and","a"
            ,D.dullyellow "List","on","the","right.","Which","should","it","be?"
            ,"Does","the","string","need","[]","around","it","to","become","a","list?"
            ]
        )

    (AList, AString) ->
      EmphBoth
        ( D.reflow $
            "The (++) operator needs the same type of value on both sides:"
        , D.fillSep
            ["I","see","a",D.dullyellow "List","on","the","left","and","a"
            ,D.dullyellow "String","on","the","right.","Which","should","it","be?"
            ,"Does","the","string","need","[]","around","it","to","become","a","list?"
            ]
        )

    (_,_) ->
      EmphBoth
        ( D.reflow $
            "The (++) operator cannot append these two values:"
        , typeComparison localizer expected tipe
            "I already figured out that the left side of (++) is:"
            (addCategory "But this clashes with the right side, which is" category)
            []
        )



-- BAD MATH


data ThisThenThat = FloatInt | IntFloat


badCast :: Name.Name -> ThisThenThat -> RightDocs
badCast op thisThenThat =
  EmphBoth
    ( D.reflow $
        "I need both sides of (" <> Name.toChars op <> ") to be the exact same type. Both Int or both Float."
    , let
        anInt = ["an", D.dullyellow "Int"]
        aFloat = ["a", D.dullyellow "Float"]
        toFloat = D.green "toFloat"
        round = D.green "round"
      in
      case thisThenThat of
        FloatInt ->
          badCastHelp aFloat anInt round toFloat

        IntFloat ->
          badCastHelp anInt aFloat toFloat round
    )


badCastHelp :: [D.Doc] -> [D.Doc] -> D.Doc -> D.Doc -> D.Doc
badCastHelp anInt aFloat toFloat round =
  D.stack
    [ D.fillSep $
        ["But","I","see"]
        ++ anInt
        ++ ["on","the","left","and"]
        ++ aFloat
        ++ ["on","the","right."]
    , D.fillSep
        ["Use",toFloat,"on","the","left","(or",round,"on"
        ,"the","right)","to","make","both","sides","match!"
        ]
    , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats."
    ]


badStringAdd :: (D.Doc, D.Doc)
badStringAdd =
  (
    D.fillSep ["I","cannot","do","addition","with",D.dullyellow "String","values","like","this","one:"]
  ,
    D.stack
      [ D.fillSep
          ["The","(+)","operator","only","works","with",D.dullyellow "Int","and",D.dullyellow "Float","values."
          ]
      , D.toFancyHint
          ["Switch","to","the",D.green "(++)","operator","to","append","strings!"
          ]
      ]
  )


badListAdd :: L.Localizer -> Category -> String -> T.Type -> T.Type -> (D.Doc, D.Doc)
badListAdd localizer category direction tipe expected =
  (
    "I cannot do addition with lists:"
  ,
    loneType localizer tipe expected
      (D.reflow (addCategory ("The " <> direction <> " side of (+) is") category))
      [ D.fillSep
          ["But","(+)","only","works","with",D.dullyellow "Int","and",D.dullyellow "Float","values."
          ]
      , D.toFancyHint
          ["Switch","to","the",D.green "(++)","operator","to","append","lists!"
          ]
      ]
  )


badListMul :: L.Localizer -> Category -> String -> T.Type -> T.Type -> (D.Doc, D.Doc)
badListMul localizer category direction tipe expected =
  badMath localizer category "Multiplication" direction "*" tipe expected
    [
      D.toFancyHint
        [ "Maybe", "you", "want"
        , D.green "List.repeat"
        , "to", "build","a","list","of","repeated","values?"
        ]
    ]


badMath :: L.Localizer -> Category -> String -> String -> String -> T.Type -> T.Type -> [D.Doc] -> (D.Doc, D.Doc)
badMath localizer category operation direction op tipe expected otherHints =
  (
    D.reflow $
      operation ++ " does not work with this value:"
  ,
    loneType localizer tipe expected
      (D.reflow (addCategory ("The " <> direction <> " side of (" <> op <> ") is") category))
      ( [ D.fillSep
            ["But","(" <> D.fromChars op <> ")","only","works","with"
            ,D.dullyellow "Int","and",D.dullyellow "Float","values."
            ]
        ]
        ++ otherHints
      )
  )


badFDiv :: L.Localizer -> D.Doc -> T.Type -> T.Type -> (D.Doc, D.Doc)
badFDiv localizer direction tipe expected =
  (
    D.reflow $
      "The (/) operator is specifically for floating-point division:"
  ,
    if isInt tipe then
      D.stack
        [ D.fillSep
            ["The",direction,"side","of","(/)","must","be","a"
            ,D.dullyellow "Float" <> ","
            ,"but","I","am","seeing","an",D.dullyellow "Int" <> "."
            ,"I","recommend:"
            ]
        , D.vcat
            [ D.green "toFloat" <> " for explicit conversions     " <> D.black "(toFloat 5 / 2) == 2.5"
            , D.green "(//)   " <> " for integer division         " <> D.black "(5 // 2)        == 2"
            ]
        , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats."
        ]

    else
      loneType localizer tipe expected
        (D.fillSep
          ["The",direction,"side","of","(/)","must","be","a"
          ,D.dullyellow "Float" <> ",","but","instead","I","am","seeing:"
          ]
        )
        []
  )


badIDiv :: L.Localizer -> D.Doc -> T.Type -> T.Type -> (D.Doc, D.Doc)
badIDiv localizer direction tipe expected =
  (
    D.reflow $
      "The (//) operator is specifically for integer division:"
  ,
    if isFloat tipe then
      D.stack
        [ D.fillSep
            ["The",direction,"side","of","(//)","must","be","an"
            ,D.dullyellow "Int" <> ","
            ,"but","I","am","seeing","a",D.dullyellow "Float" <> "."
            ,"I","recommend","doing","the","conversion","explicitly"
            ,"with","one","of","these","functions:"
            ]
        , D.vcat
            [ D.green "round" <> " 3.5     == 4"
            , D.green "floor" <> " 3.5     == 3"
            , D.green "ceiling" <> " 3.5   == 4"
            , D.green "truncate" <> " 3.5  == 3"
            ]
        , D.link "Note" "Read" "implicit-casts" "to learn why Elm does not implicitly convert Ints to Floats."
        ]
    else
      loneType localizer tipe expected
        ( D.fillSep
            ["The",direction,"side","of","(//)","must","be","an"
            ,D.dullyellow "Int" <> ",","but","instead","I","am","seeing:"
            ]
        )
        []
  )



-- BAD BOOLS


badBool :: L.Localizer -> D.Doc -> D.Doc -> T.Type -> T.Type -> (D.Doc, D.Doc)
badBool localizer op direction tipe expected =
  (
    D.reflow $
      "I am struggling with this boolean operation:"
  ,
    loneType localizer tipe expected
      ( D.fillSep
          ["Both","sides","of","(" <> op <> ")","must","be"
          ,D.dullyellow "Bool","values,","but","the",direction,"side","is:"
          ]
      )
      []
  )



-- BAD COMPARISON


badCompLeft :: L.Localizer -> Category -> String -> String -> T.Type -> T.Type -> (D.Doc, D.Doc)
badCompLeft localizer category op direction tipe expected =
  (
    D.reflow $
      "I cannot do a comparison with this value:"
  ,
    loneType localizer tipe expected
      (D.reflow (addCategory ("The " <> direction <> " side of (" <> op <> ") is") category))
      [ D.fillSep
          ["But","(" <> D.fromChars op <> ")","only","works","on"
          ,D.dullyellow "Int" <> ","
          ,D.dullyellow "Float" <> ","
          ,D.dullyellow "Char" <> ","
          ,"and"
          ,D.dullyellow "String"
          ,"values.","It","can","work","on","lists","and","tuples"
          ,"of","comparable","values","as","well,","but","it","is"
          ,"usually","better","to","find","a","different","path."
          ]
      ]
  )


badCompRight :: L.Localizer -> String -> T.Type -> T.Type -> RightDocs
badCompRight localizer op tipe expected =
  EmphBoth
    (
      D.reflow $
        "I need both sides of (" <> op <> ") to be the same type:"
    ,
      typeComparison localizer expected tipe
        ("The left side of (" <> op <> ") is:")
        "But the right side is:"
        [ D.reflow $
            "I cannot compare different types though! Which side of (" <> op <> ") is the problem?"
        ]
    )



-- BAD EQUALITY


badEquality :: L.Localizer -> String -> T.Type -> T.Type -> RightDocs
badEquality localizer op tipe expected =
  EmphBoth
    (
      D.reflow $
        "I need both sides of (" <> op <> ") to be the same type:"
    ,
      typeComparison localizer expected tipe
        ("The left side of (" <> op <> ") is:")
        "But the right side is:"
        [ if isFloat tipe || isFloat expected then
            D.toSimpleNote $
              "Equality on floats is not 100% reliable due to the design of IEEE 754. I\
              \ recommend a check like (abs (x - y) < 0.0001) instead."
          else
            D.reflow  "Different types can never be equal though! Which side is messed up?"
        ]
    )



-- INFINITE TYPES


toInfiniteReport :: Code.Source -> L.Localizer -> A.Region -> Name.Name -> T.Type -> Report.Report
toInfiniteReport source localizer region name overallType =
  Report.Report "INFINITE TYPE" region [] $
    Code.toSnippet source region Nothing
      (
        D.reflow $
          "I am inferring a weird self-referential type for " <> Name.toChars name <> ":"
      ,
        D.stack
          [ D.reflow $
              "Here is my best effort at writing down the type. You will see ∞ for\
              \ parts of the type that repeat something already printed out infinitely."
          , D.indent 4 (D.dullyellow (T.toDoc localizer RT.None overallType))
          , D.reflowLink
              "Staring at this type is usually not so helpful, so I recommend reading the hints at"
              "infinite-type"
              "to get unstuck!"
          ]
      )


================================================
FILE: compiler/src/Reporting/Error.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Error
  ( Module(..)
  , Error(..)
  , toDoc
  , toJson
  )
  where


import qualified Data.ByteString as B
import qualified Data.NonEmptyList as NE
import qualified Data.OneOrMore as OneOrMore
import qualified System.FilePath as FP

import qualified Elm.ModuleName as ModuleName
import qualified File
import qualified Json.Encode as E
import Json.Encode ((==>))
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import qualified Reporting.Error.Canonicalize as Canonicalize
import qualified Reporting.Error.Docs as Docs
import qualified Reporting.Error.Import as Import
import qualified Reporting.Error.Main as Main
import qualified Reporting.Error.Pattern as Pattern
import qualified Reporting.Error.Syntax as Syntax
import qualified Reporting.Error.Type as Type
import qualified Reporting.Render.Code as Code
import qualified Reporting.Render.Type.Localizer as L
import qualified Reporting.Report as Report



-- MODULE


data Module =
  Module
    { _name :: ModuleName.Raw
    , _absolutePath :: FilePath
    , _modificationTime :: File.Time
    , _source :: B.ByteString
    , _error :: Error
    }



-- ERRORS


data Error
  = BadSyntax Syntax.Error
  | BadImports (NE.List Import.Error)
  | BadNames (OneOrMore.OneOrMore Canonicalize.Error)
  | BadTypes L.Localizer (NE.List Type.Error)
  | BadMains L.Localizer (OneOrMore.OneOrMore Main.Error)
  | BadPatterns (NE.List Pattern.Error)
  | BadDocs Docs.Error



-- TO REPORT


toReports :: Code.Source -> Error -> NE.List Report.Report
toReports source err =
  case err of
    BadSyntax syntaxError ->
      NE.List (Syntax.toReport source syntaxError) []

    BadImports errs ->
      fmap (Import.toReport source) errs

    BadNames errs ->
      fmap (Canonicalize.toReport source) (OneOrMore.destruct NE.List errs)

    BadTypes localizer errs ->
      fmap (Type.toReport source localizer) errs

    BadMains localizer errs ->
      fmap (Main.toReport localizer source) (OneOrMore.destruct NE.List errs)

    BadPatterns errs ->
      fmap (Pattern.toReport source) errs

    BadDocs docsErr ->
      Docs.toReports source docsErr



-- TO DOC


toDoc :: FilePath -> Module -> [Module] -> D.Doc
toDoc root err errs =
  let
    (NE.List m ms) = NE.sortBy _modificationTime (NE.List err errs)
  in
  D.vcat (toDocHelp root m ms)


toDocHelp :: FilePath -> Module -> [Module] -> [D.Doc]
toDocHelp root module1 modules =
  case modules of
    [] ->
      [moduleToDoc root module1
      ,""
      ]

    module2 : otherModules ->
      moduleToDoc root module1
      : toSeparator module1 module2
      : toDocHelp root module2 otherModules


toSeparator :: Module -> Module -> D.Doc
toSeparator beforeModule afterModule =
  let
    before = ModuleName.toChars (_name beforeModule) ++ "  ↑    "
    after  = "    ↓  " ++  ModuleName.toChars (_name afterModule)
  in
    D.dullred $ D.vcat $
      [ D.indent (80 - length before) (D.fromChars before)
      , "====o======================================================================o===="
      , D.fromChars after
      , ""
      , ""
      ]



-- MODULE TO DOC


moduleToDoc :: FilePath -> Module -> D.Doc
moduleToDoc root (Module _ absolutePath _ source err) =
  let
    reports =
      toReports (Code.toSource source) err

    relativePath =
      FP.makeRelative root absolutePath
  in
  D.vcat $ map (reportToDoc relativePath) (NE.toList reports)


reportToDoc :: FilePath -> Report.Report -> D.Doc
reportToDoc relativePath (Report.Report title _ _ message) =
  D.vcat
    [ toMessageBar title relativePath
    , ""
    , message
    , ""
    ]


toMessageBar :: String -> FilePath -> D.Doc
toMessageBar title filePath =
  let
    usedSpace =
      4 + length title + 1 + length filePath
  in
    D.dullcyan $ D.fromChars $
      "-- " ++ title
      ++ " " ++ replicate (max 1 (80 - usedSpace)) '-'
      ++ " " ++ filePath



-- TO JSON


toJson :: Module -> E.Value
toJson (Module name path _ source err) =
  let
    reports =
      toReports (Code.toSource source) err
  in
  E.object
    [ "path" ==> E.chars path
    , "name" ==> E.name name
    , "problems" ==> E.array (map reportToJson (NE.toList reports))
    ]


reportToJson :: Report.Report -> E.Value
reportToJson (Report.Report title region _sgstns message) =
  E.object
    [ "title" ==> E.chars title
    , "region" ==> encodeRegion region
    , "message" ==> D.encode message
    ]


encodeRegion :: A.Region -> E.Value
encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
  E.object
    [ "start" ==>
          E.object
            [ "line" ==> E.int (fromIntegral sr)
            , "column" ==> E.int (fromIntegral sc)
            ]
    , "end" ==>
          E.object
            [ "line" ==> E.int (fromIntegral er)
            , "column" ==> E.int (fromIntegral ec)
            ]
    ]


================================================
FILE: compiler/src/Reporting/Render/Code.hs
================================================
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Render.Code
  ( Source
  , toSource
  , toSnippet
  , toPair
  , Next(..)
  , whatIsNext
  , nextLineStartsWithKeyword
  , nextLineStartsWithCloseCurly
  )
  where


import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8_BS
import qualified Data.Char as Char
import qualified Data.IntSet as IntSet
import qualified Data.List as List
import qualified Data.Name as Name
import qualified Data.Set as Set
import Data.Word (Word16)

import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import Reporting.Doc (Doc)
import Parse.Primitives (Row, Col)
import Parse.Symbol (binopCharSet)
import Parse.Variable (reservedWords)



-- CODE


newtype Source =
  Source [(Word16, String)]


toSource :: B.ByteString -> Source
toSource source =
  Source $ zip [1..] $
    lines (UTF8_BS.toString source) ++ [""]



-- CODE FORMATTING


toSnippet :: Source -> A.Region -> Maybe A.Region -> (D.Doc, D.Doc) -> D.Doc
toSnippet source region highlight (preHint, postHint) =
  D.vcat
    [ preHint
    , ""
    , render source region highlight
    , postHint
    ]


toPair :: Source -> A.Region -> A.Region -> (D.Doc, D.Doc) -> (D.Doc, D.Doc, D.Doc) -> D.Doc
toPair source r1 r2 (oneStart, oneEnd) (twoStart, twoMiddle, twoEnd) =
  case renderPair source r1 r2 of
    OneLine codeDocs ->
      D.vcat
        [ oneStart
        , ""
        , codeDocs
        , oneEnd
        ]

    TwoChunks code1 code2 ->
      D.vcat
        [ twoStart
        , ""
        , code1
        , twoMiddle
        , ""
        , code2
        , twoEnd
        ]



-- RENDER SNIPPET


(|>) :: a -> (a -> b) -> b
(|>) a f =
  f a


render :: Source -> A.Region -> Maybe A.Region -> Doc
render (Source sourceLines) region@(A.Region (A.Position startLine _) (A.Position endLine _)) maybeSubRegion =
  let
    relevantLines =
      sourceLines
        |> drop (fromIntegral (startLine - 1))
        |> take (fromIntegral (1 + endLine - startLine))

    width =
      length (show (fst (last relevantLines)))

    smallerRegion =
      maybe region id maybeSubRegion
  in
    case makeUnderline width endLine smallerRegion of
      Nothing ->
        drawLines True width smallerRegion relevantLines D.empty

      Just underline ->
        drawLines False width smallerRegion relevantLines underline


makeUnderline :: Int -> Word16 -> A.Region -> Maybe Doc
makeUnderline width realEndLine (A.Region (A.Position start c1) (A.Position end c2)) =
  if start /= end || end < realEndLine then
    Nothing

  else
    let
      spaces = replicate (fromIntegral c1 + width + 1) ' '
      zigzag = replicate (max 1 (fromIntegral (c2 - c1))) '^'
    in
      Just (D.fromChars spaces <> D.red (D.fromChars zigzag))


drawLines :: Bool -> Int -> A.Region -> [(Word16, String)] -> Doc -> Doc
drawLines addZigZag width (A.Region (A.Position startLine _) (A.Position endLine _)) sourceLines finalLine =
  D.vcat $
    map (drawLine addZigZag width startLine endLine) sourceLines
    ++ [finalLine]


drawLine :: Bool -> Int -> Word16 -> Word16 -> (Word16, String) -> Doc
drawLine addZigZag width startLine endLine (n, line) =
  addLineNumber addZigZag width startLine endLine n (D.fromChars line)


addLineNumber :: Bool -> Int -> Word16 -> Word16 -> Word16 -> Doc -> Doc
addLineNumber addZigZag width start end n line =
  let
    number =
      show n

    lineNumber =
      replicate (width - length number) ' ' ++ number ++ "|"

    spacer =
      if addZigZag && start <= n && n <= end then
        D.red ">"
      else
        " "
  in
    D.fromChars lineNumber <> spacer <> line



-- RENDER PAIR


data CodePair
  = OneLine Doc
  | TwoChunks Doc Doc


renderPair :: Source -> A.Region -> A.Region -> CodePair
renderPair source@(Source sourceLines) region1 region2 =
  let
    (A.Region (A.Position startRow1 startCol1) (A.Position endRow1 endCol1)) = region1
    (A.Region (A.Position startRow2 startCol2) (A.Position endRow2 endCol2)) = region2
  in
  if startRow1 == endRow1 && endRow1 == startRow2 && startRow2 == endRow2 then
    let
      lineNumber = show startRow1
      spaces1 = replicate (fromIntegral startCol1 + length lineNumber + 1) ' '
      zigzag1 = replicate (fromIntegral (endCol1 - startCol1)) '^'
      spaces2 = replicate (fromIntegral (startCol2 - endCol1)) ' '
      zigzag2 = replicate (fromIntegral (endCol2 - startCol2)) '^'

      (Just line) = List.lookup startRow1 sourceLines
    in
    OneLine $
      D.vcat
        [ D.fromChars lineNumber <> "| " <> D.fromChars line
        , D.fromChars spaces1 <> D.red (D.fromChars zigzag1) <>
          D.fromChars spaces2 <> D.red (D.fromChars zigzag2)
        ]

  else
    TwoChunks
      (render source region1 Nothing)
      (render source region2 Nothing)



-- WHAT IS NEXT?


data Next
  = Keyword [Char]
  | Operator [Char]
  | Close [Char] Char
  | Upper Char [Char]
  | Lower Char [Char]
  | Other (Maybe Char)


whatIsNext :: Source -> Row -> Col -> Next
whatIsNext (Source sourceLines) row col =
  case List.lookup row sourceLines of
    Nothing ->
      Other Nothing

    Just line ->
      case drop (fromIntegral col - 1) line of
        [] ->
          Other Nothing

        c:cs
          | Char.isUpper c -> Upper c (takeWhile isInner cs)
          | Char.isLower c -> detectKeywords c cs
          | isSymbol c     -> Operator (c : takeWhile isSymbol cs)
          | c == ')'       -> Close "parenthesis" ')'
          | c == ']'       -> Close "square bracket" ']'
          | c == '}'       -> Close "curly brace" '}'
          | otherwise      -> Other (Just c)


detectKeywords :: Char -> [Char] -> Next
detectKeywords c rest =
  let
    cs = takeWhile isInner rest
    name = c : cs
  in
  if Set.member (Name.fromChars name) reservedWords
  then Keyword name
  else Lower c name


isInner :: Char -> Bool
isInner char =
  Char.isAlphaNum char || char == '_'


isSymbol :: Char -> Bool
isSymbol char =
  IntSet.member (Char.ord char) binopCharSet


startsWithKeyword :: [Char] -> [Char] -> Bool
startsWithKeyword restOfLine keyword =
  List.isPrefixOf keyword restOfLine
  &&
  case drop (length keyword) restOfLine of
    [] ->
      True

    c:_ ->
      not (isInner c)


nextLineStartsWithKeyword :: [Char] -> Source -> Row -> Maybe (Row, Col)
nextLineStartsWithKeyword keyword (Source sourceLines) row =
  case List.lookup (row + 1) sourceLines of
    Nothing ->
      Nothing

    Just line ->
      if startsWithKeyword (dropWhile (==' ') line) keyword then
        Just (row + 1, 1 + fromIntegral (length (takeWhile (==' ') line)))
      else
        Nothing


nextLineStartsWithCloseCurly :: Source -> Row -> Maybe (Row, Col)
nextLineStartsWithCloseCurly (Source sourceLines) row =
  case List.lookup (row + 1) sourceLines of
    Nothing ->
      Nothing

    Just line ->
      case dropWhile (==' ') line of
        '}':_ ->
          Just (row + 1, 1 + fromIntegral (length (takeWhile (==' ') line)))

        _ ->
          Nothing


================================================
FILE: compiler/src/Reporting/Render/Type/Localizer.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Render.Type.Localizer
  ( Localizer
  , toDoc
  , toChars
  , empty
  , fromNames
  , fromModule
  )
  where


import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.Set as Set

import qualified AST.Source as Src
import qualified Elm.ModuleName as ModuleName
import qualified Reporting.Doc as D
import qualified Reporting.Annotation as A



-- LOCALIZER


newtype Localizer =
  Localizer (Map.Map Name.Name Import)


data Import =
  Import
    { _alias :: Maybe Name.Name
    , _exposing :: Exposing
    }


data Exposing
  = All
  | Only (Set.Set Name.Name)


empty :: Localizer
empty =
  Localizer Map.empty



-- LOCALIZE


toDoc :: Localizer -> ModuleName.Canonical -> Name.Name -> D.Doc
toDoc localizer home name =
  D.fromChars (toChars localizer home name)


toChars :: Localizer -> ModuleName.Canonical -> Name.Name -> String
toChars (Localizer localizer) moduleName@(ModuleName.Canonical _ home) name =
  case Map.lookup home localizer of
    Nothing ->
      Name.toChars home <> "." <> Name.toChars name

    Just (Import alias exposing) ->
      case exposing of
        All ->
          Name.toChars name

        Only set ->
          if Set.member name set then
            Name.toChars name
          else if name == Name.list && moduleName == ModuleName.list then
            "List"
          else
            Name.toChars (maybe home id alias) <> "." <> Name.toChars name



-- FROM NAMES


fromNames :: Map.Map Name.Name a -> Localizer
fromNames names =
  Localizer $ Map.map (\_ -> Import Nothing All) names



-- FROM MODULE


fromModule :: Src.Module -> Localizer
fromModule modul@(Src.Module _ _ _ imports _ _ _ _ _) =
  Localizer $ Map.fromList $
    (Src.getName modul, Import Nothing All) : map toPair imports


toPair :: Src.Import -> (Name.Name, Import)
toPair (Src.Import (A.At _ name) alias exposing) =
  ( name
  , Import alias (toExposing exposing)
  )


toExposing :: Src.Exposing -> Exposing
toExposing exposing =
  case exposing of
    Src.Open ->
      All

    Src.Explicit exposedList ->
      Only (foldr addType Set.empty exposedList)


addType :: Src.Exposed -> Set.Set Name.Name -> Set.Set Name.Name
addType exposed types =
  case exposed of
    Src.Lower _               -> types
    Src.Upper (A.At _ name) _ -> Set.insert name types
    Src.Operator _ _          -> types


================================================
FILE: compiler/src/Reporting/Render/Type.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Render.Type
  ( Context(..)
  , lambda
  , apply
  , tuple
  , record
  , vrecordSnippet
  , vrecord
  , srcToDoc
  , canToDoc
  )
  where


import qualified Data.Maybe as Maybe
import qualified Data.Name as Name

import qualified AST.Source as Src
import qualified AST.Canonical as Can
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import Reporting.Doc (Doc, (<+>))
import qualified Reporting.Render.Type.Localizer as L



-- TO DOC


data Context
  = None
  | Func
  | App


lambda :: Context -> Doc -> Doc -> [Doc] -> Doc
lambda context arg1 arg2 args =
  let
    lambdaDoc =
      D.align $ D.sep (arg1 : map ("->" <+>) (arg2:args))
  in
  case context of
    None -> lambdaDoc
    Func -> D.cat [ "(", lambdaDoc, ")" ]
    App  -> D.cat [ "(", lambdaDoc, ")" ]


apply :: Context -> Doc -> [Doc] -> Doc
apply context name args =
  case args of
    [] ->
      name

    _:_ ->
      let
        applyDoc =
          D.hang 4 (D.sep (name : args))
      in
      case context of
        App  -> D.cat [ "(", applyDoc, ")" ]
        Func -> applyDoc
        None -> applyDoc


tuple :: Doc -> Doc -> [Doc] -> Doc
tuple a b cs =
  let
    entries =
      zipWith (<+>) ("(" : repeat ",") (a:b:cs)
  in
  D.align $ D.sep [ D.cat entries, ")" ]


record :: [(Doc, Doc)] -> Maybe Doc -> Doc
record entries maybeExt =
  case (map entryToDoc entries, maybeExt) of
    ([], Nothing) ->
        "{}"

    (fields, Nothing) ->
        D.align $ D.sep $
          [ D.cat (zipWith (<+>) ("{" : repeat ",") fields)
          , "}"
          ]

    (fields, Just ext) ->
        D.align $ D.sep $
          [ D.hang 4 $ D.sep $
              [ "{" <+> ext
              , D.cat (zipWith (<+>) ("|" : repeat ",") fields)
              ]
          , "}"
          ]


entryToDoc :: (Doc, Doc) -> Doc
entryToDoc (fieldName, fieldType) =
  D.hang 4 (D.sep [ fieldName <+> ":", fieldType ])


vrecordSnippet :: (Doc, Doc) -> [(Doc, Doc)] -> Doc
vrecordSnippet entry entries =
  let
    field  = "{" <+> entryToDoc entry
    fields = zipWith (<+>) (repeat ",") (map entryToDoc entries ++ ["..."])
  in
  D.vcat (field : fields ++ ["}"])


vrecord :: [(Doc, Doc)] -> Maybe Doc -> Doc
vrecord entries maybeExt =
  case (map entryToDoc entries, maybeExt) of
    ([], Nothing) ->
      "{}"

    (fields, Nothing) ->
      D.vcat $
        zipWith (<+>) ("{" : repeat ",") fields ++ ["}"]

    (fields, Just ext) ->
      D.vcat
        [ D.hang 4 $ D.vcat $
            [ "{" <+> ext
            , D.cat (zipWith (<+>) ("|" : repeat ",") fields)
            ]
        , "}"
        ]



-- SOURCE TYPE TO DOC


srcToDoc :: Context -> Src.Type -> Doc
srcToDoc context (A.At _ tipe) =
  case tipe of
    Src.TLambda arg1 result ->
      let
        (arg2, rest) = collectSrcArgs result
      in
      lambda context
        (srcToDoc Func arg1)
        (srcToDoc Func arg2)
        (map (srcToDoc Func) rest)

    Src.TVar name ->
      D.fromName name

    Src.TType _ name args ->
      apply context
        (D.fromName name)
        (map (srcToDoc App) args)

    Src.TTypeQual _ home name args ->
      apply context
        (D.fromName home <> "." <> D.fromName name)
        (map (srcToDoc App) args)

    Src.TRecord fields ext ->
      record
        (map srcFieldToDocs fields)
        (fmap (D.fromName . A.toValue) ext)

    Src.TUnit ->
      "()"

    Src.TTuple a b cs ->
      tuple
        (srcToDoc None a)
        (srcToDoc None b)
        (map (srcToDoc None) cs)


srcFieldToDocs :: (A.Located Name.Name, Src.Type) -> (Doc, Doc)
srcFieldToDocs (A.At _ fieldName, fieldType) =
  ( D.fromName fieldName
  , srcToDoc None fieldType
  )


collectSrcArgs :: Src.Type -> (Src.Type, [Src.Type])
collectSrcArgs tipe =
  case tipe of
    A.At _ (Src.TLambda a result) ->
      let
        (b, cs) = collectSrcArgs result
      in
      (a, b:cs)

    _ ->
      (tipe, [])



-- CANONICAL TYPE TO DOC


canToDoc :: L.Localizer -> Context -> Can.Type -> Doc
canToDoc localizer context tipe =
  case tipe of
    Can.TLambda arg1 result ->
      let
        (arg2, rest) = collectArgs result
      in
      lambda context
        (canToDoc localizer Func arg1)
        (canToDoc localizer Func arg2)
        (map (canToDoc localizer Func) rest)

    Can.TVar name ->
      D.fromName name

    Can.TType home name args ->
      apply context
        (L.toDoc localizer home name)
        (map (canToDoc localizer App) args)

    Can.TRecord fields ext ->
      record
        (map (canFieldToDoc localizer) (Can.fieldsToList fields))
        (fmap D.fromName ext)

    Can.TUnit ->
      "()"

    Can.TTuple a b maybeC ->
      tuple
        (canToDoc localizer None a)
        (canToDoc localizer None b)
        (map (canToDoc localizer None) (Maybe.maybeToList maybeC))

    Can.TAlias home name args _ ->
      apply context
        (L.toDoc localizer home name)
        (map (canToDoc localizer App . snd) args)


canFieldToDoc :: L.Localizer -> (Name.Name, Can.Type) -> (Doc, Doc)
canFieldToDoc localizer (name, tipe) =
  ( D.fromName name
  , canToDoc localizer None tipe
  )


collectArgs :: Can.Type -> (Can.Type, [Can.Type])
collectArgs tipe =
  case tipe of
    Can.TLambda a rest ->
      let
        (b, cs) = collectArgs rest
      in
      (a, b:cs)

    _ ->
      (tipe, [])


================================================
FILE: compiler/src/Reporting/Report.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Report
    ( Report(..)
    )
    where


import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D



-- BUILD REPORTS


data Report =
  Report
    { _title :: String
    , _region :: A.Region
    , _sgstns :: [String]
    , _message :: D.Doc
    }


================================================
FILE: compiler/src/Reporting/Result.hs
================================================
{-# LANGUAGE Rank2Types #-}
module Reporting.Result
  ( Result(..)
  , run
  , ok
  , warn
  , throw
  , mapError
  )
  where


import qualified Data.OneOrMore as OneOrMore
import qualified Reporting.Warning as Warning



-- RESULT


newtype Result info warnings error a =
  Result (
    forall result.
      info
      -> warnings
      -> (info -> warnings -> OneOrMore.OneOrMore error -> result)
      -> (info -> warnings -> a -> result)
      -> result
  )


run :: Result () [w] e a -> ([w], Either (OneOrMore.OneOrMore e) a)
run (Result k) =
  k () []
    (\() w e -> (reverse w, Left e))
    (\() w a -> (reverse w, Right a))



-- HELPERS


ok :: a -> Result i w e a
ok a =
  Result $ \i w _ good ->
    good i w a


warn :: Warning.Warning -> Result i [Warning.Warning] e ()
warn warning =
  Result $ \i warnings _ good ->
    good i (warning:warnings) ()


throw :: e -> Result i w e a
throw e =
  Result $ \i w bad _ ->
    bad i w (OneOrMore.one e)


mapError :: (e -> e') -> Result i w e a -> Result i w e' a
mapError func (Result k) =
  Result $ \i w bad good ->
    let
      bad1 i1 w1 e1 =
        bad i1 w1 (OneOrMore.map func e1)
    in
    k i w bad1 good



-- FANCY INSTANCE STUFF


instance Functor (Result i w e) where
  fmap func (Result k) =
    Result $ \i w bad good ->
      let
        good1 i1 w1 value =
          good i1 w1 (func value)
      in
      k i w bad good1


instance Applicative (Result i w e) where
  pure = ok

  (<*>) (Result kf) (Result kv) =
    Result $ \i w bad good ->
      let
        bad1 i1 w1 e1 =
          let
            bad2 i2 w2 e2 = bad i2 w2 (OneOrMore.more e1 e2)
            good2 i2 w2 _value = bad i2 w2 e1
          in
          kv i1 w1 bad2 good2

        good1 i1 w1 func =
          let
            bad2 i2 w2 e2 = bad i2 w2 e2
            good2 i2 w2 value = good i2 w2 (func value)
          in
          kv i1 w1 bad2 good2
      in
      kf i w bad1 good1

  (*>) (Result ka) (Result kb) =
    Result $ \i w bad good ->
      let
        good1 i1 w1 _ =
          kb i1 w1 bad good
      in
      ka i w bad good1


instance Monad (Result i w e) where
  (>>=) (Result ka) callback =
    Result $ \i w bad good ->
      let
        good1 i1 w1 a =
          case callback a of
            Result kb -> kb i1 w1 bad good
      in
      ka i w bad good1

  -- PERF add INLINE to these?


================================================
FILE: compiler/src/Reporting/Suggest.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Suggest
  ( distance
  , sort
  , rank
  )
  where


import qualified Data.Char as Char
import qualified Data.List as List
import qualified Text.EditDistance as Dist



-- DISTANCE


distance :: String -> String -> Int
distance x y =
  Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y



-- SORT


sort :: String -> (a -> String) -> [a] -> [a]
sort target toString values =
  List.sortOn (distance (toLower target) . toLower . toString) values


toLower :: String -> String
toLower string =
  map Char.toLower string



-- RANK


rank :: String -> (a -> String) -> [a] -> [(Int,a)]
rank target toString values =
  let
    toRank v =
      distance (toLower target) (toLower (toString v))

    addRank v =
      (toRank v, v)
  in
  List.sortOn fst (map addRank values)


================================================
FILE: compiler/src/Reporting/Warning.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Reporting.Warning
  ( Warning(..)
  , Context(..)
  , toReport
  )
  where


import qualified Data.Name as Name

import qualified AST.Canonical as Can
import qualified AST.Utils.Type as Type
import qualified Reporting.Annotation as A
import qualified Reporting.Doc as D
import qualified Reporting.Report as Report
import qualified Reporting.Render.Code as Code
import qualified Reporting.Render.Type as RT
import qualified Reporting.Render.Type.Localizer as L



-- ALL POSSIBLE WARNINGS


data Warning
  = UnusedImport A.Region Name.Name
  | UnusedVariable A.Region Context Name.Name
  | MissingTypeAnnotation A.Region Name.Name Can.Type


data Context = Def | Pattern



-- TO REPORT


toReport :: L.Localizer -> Code.Source -> Warning -> Report.Report
toReport localizer source warning =
  case warning of
    UnusedImport region moduleName ->
      Report.Report "unused import" region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "Nothing from the `" <> Name.toChars moduleName <> "` module is used in this file."
          ,
            "I recommend removing unused imports."
          )

    UnusedVariable region context name ->
      let title = defOrPat context "unused definition" "unused variable" in
      Report.Report title region [] $
        Code.toSnippet source region Nothing
          (
            D.reflow $
              "You are not using `" <> Name.toChars name <> "` anywhere."
          ,
            D.stack
              [ D.reflow $
                  "Is there a typo? Maybe you intended to use `" <> Name.toChars name
                  <> "` somewhere but typed another name instead?"
              , D.reflow $
                  defOrPat context
                    ( "If you are sure there is no typo, remove the definition.\
                      \ This way future readers will not have to wonder why it is there!"
                    )
                    ( "If you are sure there is no typo, replace `" <> Name.toChars name
                      <> "` with _ so future readers will not have to wonder why it is there!"
                    )
              ]
          )

    MissingTypeAnnotation region name inferredType ->
        Report.Report "missing type annotation" region [] $
          Code.toSnippet source region Nothing
            (
              D.reflow $
                case Type.deepDealias inferredType of
                  Can.TLambda _ _ ->
                    "The `" <> Name.toChars name <> "` function has no type annotation."

                  _ ->
                    "The `" <> Name.toChars name <> "` definition has no type annotation."
            ,
              D.stack
                [ "I inferred the type annotation myself though! You can copy it into your code:"
                , D.green $ D.hang 4 $ D.sep $
                    [ D.fromName name <> " :"
                    , RT.canToDoc localizer RT.None inferredType
                    ]
                ]
            )


defOrPat :: Context -> a -> a -> a
defOrPat context def pat =
  case context of
    Def -> def
    Pattern -> pat



================================================
FILE: compiler/src/Type/Constrain/Expression.hs
================================================
module Type.Constrain.Expression
  ( constrain
  , constrainDef
  , constrainRecursiveDefs
  )
  where


import qualified Data.Map.Strict as Map
import qualified Data.Name as Name

import qualified AST.Canonical as Can
import qualified AST.Utils.Shader as Shader
import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Type as E
import Reporting.Error.Type (Expected(..), Context(..), SubContext(..), MaybeName(..), Category(..), PExpected(..), PContext(..))
import qualified Type.Constrain.Pattern as Pattern
import qualified Type.Instantiate as Instantiate
import Type.Type as Type hiding (Descriptor(..))



-- CONSTRAIN


-- As we step past type annotations, the free type variables are added to
-- the "rigid type variables" dict. Allowing sharing of rigid variables
-- between nested type annotations.
--
-- So if you have a top-level type annotation like (func : a -> b) the RTV
-- dictionary will hold variables for `a` and `b`
--
type RTV =
  Map.Map Name.Name Type


constrain :: RTV -> Can.Expr -> Expected Type -> IO Constraint
constrain rtv (A.At region expression) expected =
  case expression of
    Can.VarLocal name ->
      return (CLocal region name expected)

    Can.VarTopLevel _ name ->
      return (CLocal region name expected)

    Can.VarKernel _ _ ->
      return CTrue

    Can.VarForeign _ name annotation ->
      return $ CForeign region name annotation expected

    Can.VarCtor _ _ name _ annotation ->
      return $ CForeign region name annotation expected

    Can.VarDebug _ name annotation ->
      return $ CForeign region name annotation expected

    Can.VarOperator op _ _ annotation ->
      return $ CForeign region op annotation expected

    Can.Str _ ->
      return $ CEqual region String Type.string expected

    Can.Chr _ ->
      return $ CEqual region Char Type.char expected

    Can.Int _ ->
      do  var <- mkFlexNumber
          return $ exists [var] $ CEqual region E.Number (VarN var) expected

    Can.Float _ ->
      return $ CEqual region Float Type.float expected

    Can.List elements ->
      constrainList rtv region elements expected

    Can.Negate expr ->
      do  numberVar <- mkFlexNumber
          let numberType = VarN numberVar
          numberCon <- constrain rtv expr (FromContext region Negate numberType)
          let negateCon = CEqual region E.Number numberType expected
          return $ exists [numberVar] $ CAnd [ numberCon, negateCon ]

    Can.Binop op _ _ annotation leftExpr rightExpr ->
      constrainBinop rtv region op annotation leftExpr rightExpr expected

    Can.Lambda args body ->
      constrainLambda rtv region args body expected

    Can.Call func args ->
      constrainCall rtv region func args expected

    Can.If branches finally ->
      constrainIf rtv region branches finally expected

    Can.Case expr branches ->
      constrainCase rtv region expr branches expected

    Can.Let def body ->
      constrainDef rtv def
      =<< constrain rtv body expected

    Can.LetRec defs body ->
      constrainRecursiveDefs rtv defs
      =<< constrain rtv body expected

    Can.LetDestruct pattern expr body ->
      constrainDestruct rtv region pattern expr
      =<< constrain rtv body expected

    Can.Accessor field ->
      do  extVar <- mkFlexVar
          fieldVar <- mkFlexVar
          let extType = VarN extVar
          let fieldType = VarN fieldVar
          let recordType = RecordN (Map.singleton field fieldType) extType
          return $ exists [ fieldVar, extVar ] $
            CEqual region (Accessor field) (FunN recordType fieldType) expected

    Can.Access expr (A.At accessRegion field) ->
      do  extVar <- mkFlexVar
          fieldVar <- mkFlexVar
          let extType = VarN extVar
          let fieldType = VarN fieldVar
          let recordType = RecordN (Map.singleton field fieldType) extType

          let context = RecordAccess (A.toRegion expr) (getAccessName expr) accessRegion field
          recordCon <- constrain rtv expr (FromContext region context recordType)

          return $ exists [ fieldVar, extVar ] $
            CAnd
              [ recordCon
              , CEqual region (Access field) fieldType expected
              ]

    Can.Update name expr fields ->
      constrainUpdate rtv region name expr fields expected

    Can.Record fields ->
      constrainRecord rtv region fields expected

    Can.Unit ->
      return $ CEqual region Unit UnitN expected

    Can.Tuple a b maybeC ->
      constrainTuple rtv region a b maybeC expected

    Can.Shader _src types ->
      constrainShader region types expected



-- CONSTRAIN LAMBDA


constrainLambda :: RTV -> A.Region -> [Can.Pattern] -> Can.Expr -> Expected Type -> IO Constraint
constrainLambda rtv region args body expected =
  do  (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-
        constrainArgs args

      bodyCon <-
        constrain rtv body (NoExpectation resultType)

      return $ exists vars $
        CAnd
          [ CLet
              { _rigidVars = []
              , _flexVars = pvars
              , _header = headers
              , _headerCon = CAnd (reverse revCons)
              , _bodyCon = bodyCon
              }
          , CEqual region Lambda tipe expected
          ]



-- CONSTRAIN CALL


constrainCall :: RTV -> A.Region -> Can.Expr -> [Can.Expr] -> Expected Type -> IO Constraint
constrainCall rtv region func@(A.At funcRegion _) args expected =
  do  let maybeName = getName func

      funcVar <- mkFlexVar
      resultVar <- mkFlexVar
      let funcType = VarN funcVar
      let resultType = VarN resultVar

      funcCon <- constrain rtv func (NoExpectation funcType)

      (argVars, argTypes, argCons) <-
        unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeName) args

      let arityType = foldr FunN resultType argTypes
      let category = CallResult maybeName

      return $ exists (funcVar:resultVar:argVars) $
        CAnd
          [ funcCon
          , CEqual funcRegion category funcType (FromContext region (CallArity maybeName (length args)) arityType)
          , CAnd argCons
          , CEqual region category resultType expected
          ]


constrainArg :: RTV -> A.Region -> MaybeName -> Index.ZeroBased -> Can.Expr -> IO (Variable, Type, Constraint)
constrainArg rtv region maybeName index arg =
  do  argVar <- mkFlexVar
      let argType = VarN argVar
      argCon <- constrain rtv arg (FromContext region (CallArg maybeName index) argType)
      return (argVar, argType, argCon)


getName :: Can.Expr -> MaybeName
getName (A.At _ expr) =
  case expr of
    Can.VarLocal name        -> FuncName name
    Can.VarTopLevel _ name   -> FuncName name
    Can.VarForeign _ name _  -> FuncName name
    Can.VarCtor _ _ name _ _ -> CtorName name
    Can.VarOperator op _ _ _ -> OpName op
    Can.VarKernel _ name     -> FuncName name
    _                        -> NoName


getAccessName :: Can.Expr -> Maybe Name.Name
getAccessName (A.At _ expr) =
  case expr of
    Can.VarLocal name       -> Just name
    Can.VarTopLevel _ name  -> Just name
    Can.VarForeign _ name _ -> Just name
    _                       -> Nothing



-- CONSTRAIN BINOP


constrainBinop :: RTV -> A.Region -> Name.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expected Type -> IO Constraint
constrainBinop rtv region op annotation leftExpr rightExpr expected =
  do  leftVar <- mkFlexVar
      rightVar <- mkFlexVar
      answerVar <- mkFlexVar
      let leftType = VarN leftVar
      let rightType = VarN rightVar
      let answerType = VarN answerVar
      let binopType = leftType ==> rightType ==> answerType

      let opCon = CForeign region op annotation (NoExpectation binopType)

      leftCon <- constrain rtv leftExpr (FromContext region (OpLeft op) leftType)
      rightCon <- constrain rtv rightExpr (FromContext region (OpRight op) rightType)

      return $ exists [ leftVar, rightVar, answerVar ] $
        CAnd
          [ opCon
          , leftCon
          , rightCon
          , CEqual region (CallResult (OpName op)) answerType expected
          ]



-- CONSTRAIN LISTS


constrainList :: RTV -> A.Region -> [Can.Expr] -> Expected Type -> IO Constraint
constrainList rtv region entries expected =
  do  entryVar <- mkFlexVar
      let entryType = VarN entryVar
      let listType = AppN ModuleName.list Name.list [entryType]

      entryCons <-
        Index.indexedTraverse (constrainListEntry rtv region entryType) entries

      return $ exists [entryVar] $
        CAnd
          [ CAnd entryCons
          , CEqual region List listType expected
          ]


constrainListEntry :: RTV -> A.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint
constrainListEntry rtv region tipe index expr =
  constrain rtv expr (FromContext region (ListEntry index) tipe)



-- CONSTRAIN IF EXPRESSIONS


constrainIf :: RTV -> A.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expected Type -> IO Constraint
constrainIf rtv region branches final expected =
  do  let boolExpect = FromContext region IfCondition Type.bool
      let (conditions, exprs) = foldr (\(c,e) (cs,es) -> (c:cs,e:es)) ([],[final]) branches

      condCons <-
        traverse (\c -> constrain rtv c boolExpect) conditions

      case expected of
        FromAnnotation name arity _ tipe ->
          do  branchCons <- Index.indexedForA exprs $ \index expr ->
                constrain rtv expr (FromAnnotation name arity (TypedIfBranch index) tipe)
              return $
                CAnd
                  [ CAnd condCons
                  , CAnd branchCons
                  ]

        _ ->
          do  branchVar <- mkFlexVar
              let branchType = VarN branchVar

              branchCons <- Index.indexedForA exprs $ \index expr ->
                constrain rtv expr (FromContext region (IfBranch index) branchType)

              return $ exists [branchVar] $
                CAnd
                  [ CAnd condCons
                  , CAnd branchCons
                  , CEqual region If branchType expected
                  ]



-- CONSTRAIN CASE EXPRESSIONS


constrainCase :: RTV -> A.Region -> Can.Expr -> [Can.CaseBranch] -> Expected Type -> IO Constraint
constrainCase rtv region expr branches expected =
  do  ptrnVar <- mkFlexVar
      let ptrnType = VarN ptrnVar
      exprCon <- constrain rtv expr (NoExpectation ptrnType)

      case expected of
        FromAnnotation name arity _ tipe ->
          do  branchCons <- Index.indexedForA branches $ \index branch ->
                constrainCaseBranch rtv branch
                  (PFromContext region (PCaseMatch index) ptrnType)
                  (FromAnnotation name arity (TypedCaseBranch index) tipe)

              return $ exists [ptrnVar] $ CAnd (exprCon:branchCons)

        _ ->
          do  branchVar <- mkFlexVar
              let branchType = VarN branchVar

              branchCons <- Index.indexedForA branches $ \index branch ->
                constrainCaseBranch rtv branch
                  (PFromContext region (PCaseMatch index) ptrnType)
                  (FromContext region (CaseBranch index) branchType)

              return $ exists [ptrnVar,branchVar] $
                CAnd
                  [ exprCon
                  , CAnd branchCons
                  , CEqual region Case branchType expected
                  ]


constrainCaseBranch :: RTV -> Can.CaseBranch -> PExpected Type -> Expected Type -> IO Constraint
constrainCaseBranch rtv (Can.CaseBranch pattern expr) pExpect bExpect =
  do  (Pattern.State headers pvars revCons) <-
        Pattern.add pattern pExpect Pattern.emptyState

      CLet [] pvars headers (CAnd (reverse revCons))
        <$> constrain rtv expr bExpect



-- CONSTRAIN RECORD


constrainRecord :: RTV -> A.Region -> Map.Map Name.Name Can.Expr -> Expected Type -> IO Constraint
constrainRecord rtv region fields expected =
  do  dict <- traverse (constrainField rtv) fields

      let getType (_, t, _) = t
      let recordType = RecordN (Map.map getType dict) EmptyRecordN
      let recordCon = CEqual region Record recordType expected

      let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
      let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict

      return $ exists vars (CAnd cons)


constrainField :: RTV -> Can.Expr -> IO (Variable, Type, Constraint)
constrainField rtv expr =
  do  var <- mkFlexVar
      let tipe = VarN var
      con <- constrain rtv expr (NoExpectation tipe)
      return (var, tipe, con)



-- CONSTRAIN RECORD UPDATE


constrainUpdate :: RTV -> A.Region -> Name.Name -> Can.Expr -> Map.Map Name.Name Can.FieldUpdate -> Expected Type -> IO Constraint
constrainUpdate rtv region name expr fields expected =
  do  extVar <- mkFlexVar
      fieldDict <- Map.traverseWithKey (constrainUpdateField rtv region) fields

      recordVar <- mkFlexVar
      let recordType = VarN recordVar
      let fieldsType = RecordN (Map.map (\(_,t,_) -> t) fieldDict) (VarN extVar)

      -- NOTE: fieldsType is separate so that Error propagates better
      let fieldsCon = CEqual region Record recordType (NoExpectation fieldsType)
      let recordCon = CEqual region Record recordType expected

      let vars = Map.foldr (\(v,_,_) vs -> v:vs) [recordVar,extVar] fieldDict
      let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] fieldDict

      con <- constrain rtv expr (FromContext region (RecordUpdateKeys name fields) recordType)

      return $ exists vars $ CAnd (fieldsCon:con:cons)


constrainUpdateField :: RTV -> A.Region -> Name.Name -> Can.FieldUpdate -> IO (Variable, Type, Constraint)
constrainUpdateField rtv region field (Can.FieldUpdate _ expr) =
  do  var <- mkFlexVar
      let tipe = VarN var
      con <- constrain rtv expr (FromContext region (RecordUpdateValue field) tipe)
      return (var, tipe, con)



-- CONSTRAIN TUPLE


constrainTuple :: RTV -> A.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expected Type -> IO Constraint
constrainTuple rtv region a b maybeC expected =
  do  aVar <- mkFlexVar
      bVar <- mkFlexVar
      let aType = VarN aVar
      let bType = VarN bVar

      aCon <- constrain rtv a (NoExpectation aType)
      bCon <- constrain rtv b (NoExpectation bType)

      case maybeC of
        Nothing ->
          do  let tupleType = TupleN aType bType Nothing
              let tupleCon = CEqual region Tuple tupleType expected
              return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]

        Just c ->
          do  cVar <- mkFlexVar
              let cType = VarN cVar

              cCon <- constrain rtv c (NoExpectation cType)

              let tupleType = TupleN aType bType (Just cType)
              let tupleCon = CEqual region Tuple tupleType expected

              return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]



-- CONSTRAIN SHADER


constrainShader :: A.Region -> Shader.Types -> Expected Type -> IO Constraint
constrainShader region (Shader.Types attributes uniforms varyings) expected =
  do  attrVar <- mkFlexVar
      unifVar <- mkFlexVar
      let attrType = VarN attrVar
      let unifType = VarN unifVar

      let shaderType =
            AppN ModuleName.webgl Name.shader
              [ toShaderRecord attributes attrType
              , toShaderRecord uniforms unifType
              , toShaderRecord varyings EmptyRecordN
              ]

      return $ exists [ attrVar, unifVar ] $
        CEqual region Shader shaderType expected


toShaderRecord :: Map.Map Name.Name Shader.Type -> Type -> Type
toShaderRecord types baseRecType =
  if Map.null types then
    baseRecType
  else
    RecordN (Map.map glToType types) baseRecType


glToType :: Shader.Type -> Type
glToType glType =
  case glType of
    Shader.V2 -> Type.vec2
    Shader.V3 -> Type.vec3
    Shader.V4 -> Type.vec4
    Shader.M4 -> Type.mat4
    Shader.Int -> Type.int
    Shader.Float -> Type.float
    Shader.Texture -> Type.texture



-- CONSTRAIN DESTRUCTURES


constrainDestruct :: RTV -> A.Region -> Can.Pattern -> Can.Expr -> Constraint -> IO Constraint
constrainDestruct rtv region pattern expr bodyCon =
  do  patternVar <- mkFlexVar
      let patternType = VarN patternVar

      (Pattern.State headers pvars revCons) <-
        Pattern.add pattern (PNoExpectation patternType) Pattern.emptyState

      exprCon <-
        constrain rtv expr (FromContext region Destructure patternType)

      return $ CLet [] (patternVar:pvars) headers (CAnd (reverse (exprCon:revCons))) bodyCon



-- CONSTRAIN DEF


constrainDef :: RTV -> Can.Def -> Constraint -> IO Constraint
constrainDef rtv def bodyCon =
  case def of
    Can.Def (A.At region name) args expr ->
      do  (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-
            constrainArgs args

          exprCon <-
            constrain rtv expr (NoExpectation resultType)

          return $
            CLet
              { _rigidVars = []
              , _flexVars = vars
              , _header = Map.singleton name (A.At region tipe)
              , _headerCon =
                  CLet
                    { _rigidVars = []
                    , _flexVars = pvars
                    , _header = headers
                    , _headerCon = CAnd (reverse revCons)
                    , _bodyCon = exprCon
                    }
              , _bodyCon = bodyCon
              }

    Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType ->
      do  let newNames = Map.difference freeVars rtv
          newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames
          let newRtv = Map.union rtv (Map.map VarN newRigids)

          (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <-
            constrainTypedArgs newRtv name typedArgs srcResultType

          let expected = FromAnnotation name (length typedArgs) TypedBody resultType
          exprCon <-
            constrain newRtv expr expected

          return $
            CLet
              { _rigidVars = Map.elems newRigids
              , _flexVars = []
              , _header = Map.singleton name (A.At region tipe)
              , _headerCon =
                  CLet
                    { _rigidVars = []
                    , _flexVars = pvars
                    , _header = headers
                    , _headerCon = CAnd (reverse revCons)
                    , _bodyCon = exprCon
                    }
              , _bodyCon = bodyCon
              }



-- CONSTRAIN RECURSIVE DEFS


data Info =
  Info
    { _vars :: [Variable]
    , _cons :: [Constraint]
    , _headers :: Map.Map Name.Name (A.Located Type)
    }


{-# NOINLINE emptyInfo #-}
emptyInfo :: Info
emptyInfo =
  Info [] [] Map.empty


constrainRecursiveDefs :: RTV -> [Can.Def] -> Constraint -> IO Constraint
constrainRecursiveDefs rtv defs bodyCon =
  recDefsHelp rtv defs bodyCon emptyInfo emptyInfo


recDefsHelp :: RTV -> [Can.Def] -> Constraint -> Info -> Info -> IO Constraint
recDefsHelp rtv defs bodyCon rigidInfo flexInfo =
  case defs of
    [] ->
      do  let (Info rigidVars rigidCons rigidHeaders) = rigidInfo
          let (Info flexVars  flexCons  flexHeaders ) = flexInfo
          return $
            CLet rigidVars [] rigidHeaders CTrue $
              CLet [] flexVars flexHeaders (CLet [] [] flexHeaders CTrue (CAnd flexCons)) $
                CAnd [ CAnd rigidCons, bodyCon ]

    def : otherDefs ->
      case def of
        Can.Def (A.At region name) args expr ->
          do  let (Info flexVars flexCons flexHeaders) = flexInfo

              (Args newFlexVars tipe resultType (Pattern.State headers pvars revCons)) <-
                argsHelp args (Pattern.State Map.empty flexVars [])

              exprCon <-
                constrain rtv expr (NoExpectation resultType)

              let defCon =
                    CLet
                      { _rigidVars = []
                      , _flexVars = pvars
                      , _header = headers
                      , _headerCon = CAnd (reverse revCons)
                      , _bodyCon = exprCon
                      }

              recDefsHelp rtv otherDefs bodyCon rigidInfo $
                Info
                  { _vars = newFlexVars
                  , _cons = defCon : flexCons
                  , _headers = Map.insert name (A.At region tipe) flexHeaders
                  }

        Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType ->
          do  let newNames = Map.difference freeVars rtv
              newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames
              let newRtv = Map.union rtv (Map.map VarN newRigids)

              (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <-
                constrainTypedArgs newRtv name typedArgs srcResultType

              exprCon <-
                constrain newRtv expr $
                  FromAnnotation name (length typedArgs) TypedBody resultType

              let defCon =
                    CLet
                      { _rigidVars = []
                      , _flexVars = pvars
                      , _header = headers
                      , _headerCon = CAnd (reverse revCons)
                      , _bodyCon = exprCon
                      }

              let (Info rigidVars rigidCons rigidHeaders) = rigidInfo
              recDefsHelp rtv otherDefs bodyCon
                ( Info
                    { _vars = Map.foldr (:) rigidVars newRigids
                    , _cons = CLet (Map.elems newRigids) [] Map.empty defCon CTrue : rigidCons
                    , _headers = Map.insert name (A.At region tipe) rigidHeaders
                    }
                )
                flexInfo



-- CONSTRAIN ARGS


data Args =
  Args
    { _a_vars :: [Variable]
    , _a_type :: Type
    , _a_result :: Type
    , _a_state :: Pattern.State
    }


constrainArgs :: [Can.Pattern] -> IO Args
constrainArgs args =
  argsHelp args Pattern.emptyState


argsHelp :: [Can.Pattern] -> Pattern.State -> IO Args
argsHelp args state =
  case args of
    [] ->
      do  resultVar <- mkFlexVar
          let resultType = VarN resultVar
          return $ Args [resultVar] resultType resultType state

    pattern : otherArgs ->
      do  argVar <- mkFlexVar
          let argType = VarN argVar

          (Args vars tipe result newState) <-
            argsHelp otherArgs =<<
              Pattern.add pattern (PNoExpectation argType) state

          return (Args (argVar:vars) (FunN argType tipe) result newState)



-- CONSTRAIN TYPED ARGS


data TypedArgs =
  TypedArgs
    { _t_type :: Type
    , _t_result :: Type
    , _t_state :: Pattern.State
    }


constrainTypedArgs :: Map.Map Name.Name Type -> Name.Name -> [(Can.Pattern, Can.Type)] -> Can.Type -> IO TypedArgs
constrainTypedArgs rtv name args srcResultType =
  typedArgsHelp rtv name Index.first args srcResultType Pattern.emptyState


typedArgsHelp :: Map.Map Name.Name Type -> Name.Name -> Index.ZeroBased -> [(Can.Pattern, Can.Type)] -> Can.Type -> Pattern.State -> IO TypedArgs
typedArgsHelp rtv name index args srcResultType state =
  case args of
    [] ->
      do  resultType <- Instantiate.fromSrcType rtv srcResultType
          return $ TypedArgs resultType resultType state

    (pattern@(A.At region _), srcType) : otherArgs ->
      do  argType <- Instantiate.fromSrcType rtv srcType
          let expected = PFromContext region (PTypedArg name index) argType

          (TypedArgs tipe resultType newState) <-
            typedArgsHelp rtv name (Index.next index) otherArgs srcResultType =<<
              Pattern.add pattern expected state

          return (TypedArgs (FunN argType tipe) resultType newState)


================================================
FILE: compiler/src/Type/Constrain/Module.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Type.Constrain.Module
  ( constrain
  )
  where


import qualified Data.Map.Strict as Map
import qualified Data.Name as Name

import qualified AST.Canonical as Can
import qualified Elm.ModuleName as ModuleName
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Type as E
import qualified Type.Constrain.Expression as Expr
import qualified Type.Instantiate as Instantiate
import Type.Type (Type(..), Constraint(..), (==>), mkFlexVar, nameToRigid, never)



-- CONSTRAIN


constrain :: Can.Module -> IO Constraint
constrain (Can.Module home _ _ decls _ _ _ effects) =
  case effects of
    Can.NoEffects ->
      constrainDecls decls CSaveTheEnvironment

    Can.Ports ports ->
      Map.foldrWithKey letPort (constrainDecls decls CSaveTheEnvironment) ports

    Can.Manager r0 r1 r2 manager ->
      case manager of
        Can.Cmd cmdName ->
          letCmd home cmdName =<<
            constrainDecls decls =<< constrainEffects home r0 r1 r2 manager

        Can.Sub subName ->
          letSub home subName =<<
            constrainDecls decls =<< constrainEffects home r0 r1 r2 manager

        Can.Fx cmdName subName ->
          letCmd home cmdName =<<
          letSub home subName =<<
            constrainDecls decls =<< constrainEffects home r0 r1 r2 manager



-- CONSTRAIN DECLARATIONS


constrainDecls :: Can.Decls -> Constraint -> IO Constraint
constrainDecls decls finalConstraint =
  case decls of
    Can.Declare def otherDecls ->
      Expr.constrainDef Map.empty def =<< constrainDecls otherDecls finalConstraint

    Can.DeclareRec def defs otherDecls ->
      Expr.constrainRecursiveDefs Map.empty (def:defs) =<< constrainDecls otherDecls finalConstraint

    Can.SaveTheEnvironment ->
      return finalConstraint



-- PORT HELPERS


letPort :: Name.Name -> Can.Port -> IO Constraint -> IO Constraint
letPort name port_ makeConstraint =
  case port_ of
    Can.Incoming freeVars _ srcType ->
      do  vars <- Map.traverseWithKey (\k _ -> nameToRigid k) freeVars
          tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
          let header = Map.singleton name (A.At A.zero tipe)
          CLet (Map.elems vars) [] header CTrue <$> makeConstraint

    Can.Outgoing freeVars _ srcType ->
      do  vars <- Map.traverseWithKey (\k _ -> nameToRigid k) freeVars
          tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
          let header = Map.singleton name (A.At A.zero tipe)
          CLet (Map.elems vars) [] header CTrue <$> makeConstraint



-- EFFECT MANAGER HELPERS


letCmd :: ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint
letCmd home tipe constraint =
  do  msgVar <- mkFlexVar
      let msg = VarN msgVar
      let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd Name.cmd [msg])
      let header = Map.singleton "command" (A.At A.zero cmdType)
      return $ CLet [msgVar] [] header CTrue constraint


letSub :: ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint
letSub home tipe constraint =
  do  msgVar <- mkFlexVar
      let msg = VarN msgVar
      let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub Name.sub [msg])
      let header = Map.singleton "subscription" (A.At A.zero subType)
      return $ CLet [msgVar] [] header CTrue constraint


constrainEffects :: ModuleName.Canonical -> A.Region -> A.Region -> A.Region -> Can.Manager -> IO Constraint
constrainEffects home r0 r1 r2 manager =
  do  s0 <- mkFlexVar
      s1 <- mkFlexVar
      s2 <- mkFlexVar
      m1 <- mkFlexVar
      m2 <- mkFlexVar
      sm1 <- mkFlexVar
      sm2 <- mkFlexVar

      let state0 = VarN s0
      let state1 = VarN s1
      let state2 = VarN s2
      let msg1 = VarN m1
      let msg2 = VarN m2
      let self1 = VarN sm1
      let self2 = VarN sm2

      let onSelfMsg = router msg2 self2 ==> self2 ==> state2 ==> task state2
      let onEffects =
            case manager of
              Can.Cmd cmd    -> router msg1 self1 ==> effectList home cmd msg1 ==> state1 ==> task state1
              Can.Sub sub    -> router msg1 self1 ==> effectList home sub msg1 ==> state1 ==> task state1
              Can.Fx cmd sub -> router msg1 self1 ==> effectList home cmd msg1 ==> effectList home sub msg1 ==> state1 ==> task state1

      let effectCons =
            CAnd
              [ CLocal r0 "init" (E.NoExpectation (task state0))
              , CLocal r1 "onEffects" (E.NoExpectation onEffects)
              , CLocal r2 "onSelfMsg" (E.NoExpectation onSelfMsg)
              , CEqual r1 E.Effects state0 (E.NoExpectation state1)
              , CEqual r2 E.Effects state0 (E.NoExpectation state2)
              , CEqual r2 E.Effects self1 (E.NoExpectation self2)
              ]

      CLet [] [s0,s1,s2,m1,m2,sm1,sm2] Map.empty effectCons <$>
        case manager of
          Can.Cmd cmd ->
            checkMap "cmdMap" home cmd CSaveTheEnvironment

          Can.Sub sub ->
            checkMap "subMap" home sub CSaveTheEnvironment

          Can.Fx cmd sub ->
            checkMap "cmdMap" home cmd =<<
              checkMap "subMap" home sub CSaveTheEnvironment


effectList :: ModuleName.Canonical -> Name.Name -> Type -> Type
effectList home name msg =
  AppN ModuleName.list Name.list [AppN home name [msg]]


task :: Type -> Type
task answer =
  AppN ModuleName.platform Name.task [ never, answer ]


router :: Type -> Type -> Type
router msg self =
  AppN ModuleName.platform Name.router [ msg, self ]


checkMap :: Name.Name -> ModuleName.Canonical -> Name.Name -> Constraint -> IO Constraint
checkMap name home tipe constraint =
  do  a <- mkFlexVar
      b <- mkFlexVar
      let mapType = toMapType home tipe (VarN a) (VarN b)
      let mapCon = CLocal A.zero name (E.NoExpectation mapType)
      return $ CLet [a,b] [] Map.empty mapCon constraint


toMapType :: ModuleName.Canonical -> Name.Name -> Type -> Type -> Type
toMapType home tipe a b =
  (a ==> b) ==> AppN home tipe [a] ==> AppN home tipe [b]


================================================
FILE: compiler/src/Type/Constrain/Pattern.hs
================================================
module Type.Constrain.Pattern
  ( State(..)
  , emptyState
  , add
  )
  where


import Control.Arrow (second)
import Control.Monad (foldM)
import qualified Data.Map.Strict as Map
import qualified Data.Name as Name

import qualified AST.Canonical as Can
import qualified Data.Index as Index
import qualified Elm.ModuleName as ModuleName
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Type as E
import qualified Type.Instantiate as Instantiate
import Type.Type as T



-- ACTUALLY ADD CONSTRAINTS


-- The constraints are stored in reverse order so that adding a new
-- constraint is O(1) and we can reverse it at some later time.
--
data State =
  State
    { _headers :: Header
    , _vars :: [Variable]
    , _revCons :: [Constraint]
    }


type Header = Map.Map Name.Name (A.Located Type)


add :: Can.Pattern -> E.PExpected Type -> State -> IO State
add (A.At region pattern) expectation state =
  case pattern of
    Can.PAnything ->
      return state

    Can.PVar name ->
      return $ addToHeaders region name expectation state

    Can.PAlias realPattern name ->
      add realPattern expectation $
        addToHeaders region name expectation state

    Can.PUnit ->
      do  let (State headers vars revCons) = state
          let unitCon = CPattern region E.PUnit UnitN expectation
          return $ State headers vars (unitCon:revCons)

    Can.PTuple a b maybeC ->
      addTuple region a b maybeC expectation state

    Can.PCtor home typeName (Can.Union typeVars _ _ _) ctorName _ args ->
      addCtor region home typeName typeVars ctorName args expectation state

    Can.PList patterns ->
      do  entryVar <- mkFlexVar
          let entryType = VarN entryVar
          let listType = AppN ModuleName.list Name.list [entryType]

          (State headers vars revCons) <-
            foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)

          let listCon = CPattern region E.PList listType expectation
          return $ State headers (entryVar:vars) (listCon:revCons)

    Can.PCons headPattern tailPattern ->
      do  entryVar <- mkFlexVar
          let entryType = VarN entryVar
          let listType = AppN ModuleName.list Name.list [entryType]

          let headExpectation = E.PNoExpectation entryType
          let tailExpectation = E.PFromContext region E.PTail listType

          (State headers vars revCons) <-
            add headPattern headExpectation =<<
              add tailPattern tailExpectation state

          let listCon = CPattern region E.PList listType expectation
          return $ State headers (entryVar:vars) (listCon : revCons)

    Can.PRecord fields ->
      do  extVar <- mkFlexVar
          let extType = VarN extVar

          fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
          let fieldTypes = Map.fromList (map (fmap VarN) fieldVars)
          let recordType = RecordN fieldTypes extType

          let (State headers vars revCons) = state
          let recordCon = CPattern region E.PRecord recordType expectation
          return $
            State
              { _headers = Map.union headers (Map.map (A.At region) fieldTypes)
              , _vars = map snd fieldVars ++ extVar : vars
              , _revCons = recordCon : revCons
              }

    Can.PInt _ ->
      do  let (State headers vars revCons) = state
          let intCon = CPattern region E.PInt T.int expectation
          return $ State headers vars (intCon:revCons)

    Can.PStr _ ->
      do  let (State headers vars revCons) = state
          let strCon = CPattern region E.PStr T.string expectation
          return $ State headers vars (strCon:revCons)

    Can.PChr _ ->
      do  let (State headers vars revCons) = state
          let chrCon = CPattern region E.PChr T.char expectation
          return $ State headers vars (chrCon:revCons)

    Can.PBool _ _ ->
      do  let (State headers vars revCons) = state
          let boolCon = CPattern region E.PBool T.bool expectation
          return $ State headers vars (boolCon:revCons)



-- STATE HELPERS


{-# NOINLINE emptyState #-}
emptyState :: State
emptyState =
  State Map.empty [] []


addToHeaders :: A.Region -> Name.Name -> E.PExpected Type -> State -> State
addToHeaders region name expectation (State headers vars revCons) =
  let
    tipe = getType expectation
    newHeaders = Map.insert name (A.At region tipe) headers
  in
  State newHeaders vars revCons


getType :: E.PExpected Type -> Type
getType expectation =
  case expectation of
    E.PNoExpectation tipe -> tipe
    E.PFromContext _ _ tipe -> tipe



-- CONSTRAIN LIST


addEntry :: A.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
addEntry listRegion tipe state (index, pattern) =
  let
    expectation =
      E.PFromContext listRegion (E.PListEntry index) tipe
  in
  add pattern expectation state



-- CONSTRAIN TUPLE


addTuple :: A.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> E.PExpected Type -> State -> IO State
addTuple region a b maybeC expectation state =
  do  aVar <- mkFlexVar
      bVar <- mkFlexVar
      let aType = VarN aVar
      let bType = VarN bVar

      case maybeC of
        Nothing ->
          do  (State headers vars revCons) <-
                simpleAdd b bType =<<
                  simpleAdd a aType state

              let tupleCon = CPattern region E.PTuple (TupleN aType bType Nothing) expectation

              return $ State headers (aVar:bVar:vars) (tupleCon:revCons)

        Just c ->
          do  cVar <- mkFlexVar
              let cType = VarN cVar

              (State headers vars revCons) <-
                simpleAdd c cType =<<
                  simpleAdd b bType =<<
                    simpleAdd a aType state

              let tupleCon = CPattern region E.PTuple (TupleN aType bType (Just cType)) expectation

              return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons)


simpleAdd :: Can.Pattern -> Type -> State -> IO State
simpleAdd pattern patternType state =
  add pattern (E.PNoExpectation patternType) state



-- CONSTRAIN CONSTRUCTORS


addCtor :: A.Region -> ModuleName.Canonical -> Name.Name -> [Name.Name] -> Name.Name -> [Can.PatternCtorArg] -> E.PExpected Type -> State -> IO State
addCtor region home typeName typeVarNames ctorName args expectation state =
  do  varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
      let typePairs = map (second VarN) varPairs
      let freeVarDict = Map.fromList typePairs

      (State headers vars revCons) <-
        foldM (addCtorArg region ctorName freeVarDict) state args

      let ctorType = AppN home typeName (map snd typePairs)
      let ctorCon = CPattern region (E.PCtor ctorName) ctorType expectation

      return $
        State
          { _headers = headers
          , _vars = map snd varPairs ++ vars
          , _revCons = ctorCon : revCons
          }


addCtorArg :: A.Region -> Name.Name -> Map.Map Name.Name Type -> State -> Can.PatternCtorArg -> IO State
addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
  do  tipe <- Instantiate.fromSrcType freeVarDict srcType
      let expectation = E.PFromContext region (E.PCtorArg ctorName index) tipe
      add pattern expectation state


================================================
FILE: compiler/src/Type/Error.hs
================================================
{-# OPTIONS_GHC -fno-warn-x-partial #-}
{-# LANGUAGE OverloadedStrings #-}
module Type.Error
  ( Type(..)
  , Super(..)
  , Extension(..)
  , iteratedDealias
  , toDoc
  , Problem(..)
  , Direction(..)
  , toComparison
  , isInt
  , isFloat
  , isString
  , isChar
  , isList
  )
  where


import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Name as Name

import qualified Data.Bag as Bag
import qualified Elm.ModuleName as ModuleName
import qualified Reporting.Doc as D
import qualified Reporting.Render.Type as RT
import qualified Reporting.Render.Type.Localizer as L



-- ERROR TYPES


data Type
  = Lambda Type Type [Type]
  | Infinite
  | Error
  | FlexVar Name.Name
  | FlexSuper Super Name.Name
  | RigidVar Name.Name
  | RigidSuper Super Name.Name
  | Type ModuleName.Canonical Name.Name [Type]
  | Record (Map.Map Name.Name Type) Extension
  | Unit
  | Tuple Type Type (Maybe Type)
  | Alias ModuleName.Canonical Name.Name [(Name.Name, Type)] Type


data Super
  = Number
  | Comparable
  | Appendable
  | CompAppend
  deriving (Eq)


data Extension
  = Closed
  | FlexOpen Name.Name
  | RigidOpen Name.Name


iteratedDealias :: Type -> Type
iteratedDealias tipe =
  case tipe of
    Alias _ _ _ real ->
      iteratedDealias real

    _ ->
      tipe



-- TO DOC


toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
toDoc localizer ctx tipe =
  case tipe of
    Lambda a b cs ->
      RT.lambda ctx
        (toDoc localizer RT.Func a)
        (toDoc localizer RT.Func b)
        (map (toDoc localizer RT.Func) cs)

    Infinite ->
      "∞"

    Error ->
      "?"

    FlexVar name ->
      D.fromName name

    FlexSuper _ name ->
      D.fromName name

    RigidVar name ->
      D.fromName name

    RigidSuper _ name ->
      D.fromName name

    Type home name args ->
      RT.apply ctx
        (L.toDoc localizer home name)
        (map (toDoc localizer RT.App) args)

    Record fields ext ->
      RT.record (fieldsToDocs localizer fields) (extToDoc ext)

    Unit ->
      "()"

    Tuple a b maybeC ->
      RT.tuple
        (toDoc localizer RT.None a)
        (toDoc localizer RT.None b)
        (map (toDoc localizer RT.None) (Maybe.maybeToList maybeC))

    Alias home name args _ ->
      aliasToDoc localizer ctx home name args


aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Type)] -> D.Doc
aliasToDoc localizer ctx home name args =
  RT.apply ctx
    (L.toDoc localizer home name)
    (map (toDoc localizer RT.App . snd) args)


fieldsToDocs :: L.Localizer -> Map.Map Name.Name Type -> [(D.Doc, D.Doc)]
fieldsToDocs localizer fields =
  Map.foldrWithKey (addField localizer) [] fields


addField :: L.Localizer -> Name.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)]
addField localizer fieldName fieldType docs =
  let
    f = D.fromName fieldName
    t = toDoc localizer RT.None fieldType
  in
  (f,t) : docs


extToDoc :: Extension -> Maybe D.Doc
extToDoc ext =
  case ext of
    Closed -> Nothing
    FlexOpen x -> Just (D.fromName x)
    RigidOpen x -> Just (D.fromName x)



-- DIFF


data Diff a =
  Diff a a Status


data Status
  = Similar
  | Different (Bag.Bag Problem)


data Problem
  = IntFloat
  | StringFromInt
  | StringFromFloat
  | StringToInt
  | StringToFloat
  | AnythingToBool
  | AnythingFromMaybe
  | ArityMismatch Int Int
  | BadFlexSuper Direction Super Name.Name Type
  | BadRigidVar Name.Name Type
  | BadRigidSuper Super Name.Name Type
  | FieldTypo Name.Name [Name.Name]
  | FieldsMissing [Name.Name]


data Direction = Have | Need


instance Functor Diff where
  fmap func (Diff a b status) =
    Diff (func a) (func b) status


instance Applicative Diff where
  pure a =
    Diff a a Similar

  (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =
    Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)


merge :: Status -> Status -> Status
merge status1 status2 =
  case status1 of
    Similar ->
      status2

    Different problems1 ->
      case status2 of
        Similar ->
          status1

        Different problems2 ->
          Different (Bag.append problems1 problems2)



-- COMPARISON


toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
toComparison localizer tipe1 tipe2 =
  case toDiff localizer RT.None tipe1 tipe2 of
    Diff doc1 doc2 Similar ->
      (doc1, doc2, [])

    Diff doc1 doc2 (Different problems) ->
      (doc1, doc2, Bag.toList problems)


toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
toDiff localizer ctx tipe1 tipe2 =
  case (tipe1, tipe2) of
    (Unit    , Unit    ) -> same localizer ctx tipe1
    (Error   , Error   ) -> same localizer ctx tipe1
    (Infinite, Infinite) -> same localizer ctx tipe1

    (FlexVar      x, FlexVar      y) | x == y -> same localizer ctx tipe1
    (FlexSuper _  x, FlexSuper _  y) | x == y -> same localizer ctx tipe1
    (RigidVar     x, RigidVar     y) | x == y -> same localizer ctx tipe1
    (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1

    (FlexVar _, _        ) -> similar localizer ctx tipe1 tipe2
    (_        , FlexVar _) -> similar localizer ctx tipe1 tipe2

    (FlexSuper s _, t            ) | isSuper s t -> similar localizer ctx tipe1 tipe2
    (t            , FlexSuper s _) | isSuper s t -> similar localizer ctx tipe1 tipe2

    (Lambda a b cs, Lambda x y zs) ->
      if length cs == length zs then
        RT.lambda ctx
          <$> toDiff localizer RT.Func a x
          <*> toDiff localizer RT.Func b y
          <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
      else
        let f = toDoc localizer RT.Func in
        different
          (D.dullyellow (RT.lambda ctx (f a) (f b) (map f cs)))
          (D.dullyellow (RT.lambda ctx (f x) (f y) (map f zs)))
          (Bag.one (ArityMismatch (2 + length cs) (2 + length zs)))

    (Tuple a b Nothing, Tuple x y Nothing) ->
      RT.tuple
        <$> toDiff localizer RT.None a x
        <*> toDiff localizer RT.None b y
        <*> pure []

    (Tuple a b (Just c), Tuple x y (Just z)) ->
      RT.tuple
        <$> toDiff localizer RT.None a x
        <*> toDiff localizer RT.None b y
        <*> ((:[]) <$> toDiff localizer RT.None c z)

    (Record fields1 ext1, Record fields2 ext2) ->
      diffRecord localizer fields1 ext1 fields2 ext2

    (Type home1 name1 args1, Type home2 name2 args2) | home1 == home2 && name1 == name2 ->
      RT.apply ctx (L.toDoc localizer home1 name1)
        <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2)

    (Alias home1 name1 args1 _, Alias home2 name2 args2 _) | home1 == home2 && name1 == name2 ->
      RT.apply ctx (L.toDoc localizer home1 name1)
        <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2))

    -- start trying to find specific problems

    (Type home1 name1 args1, Type home2 name2 args2) | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
      different
        (nameClashToDoc ctx localizer home1 name1 args1)
        (nameClashToDoc ctx localizer home2 name2 args2)
        Bag.empty

    (Type home name [t1], t2) | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->
      different
        (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t1])
        (toDoc localizer ctx t2)
        (Bag.one AnythingFromMaybe)

    (t1, Type home name [t2]) | isList home name && isSimilar (toDiff localizer ctx t1 t2) ->
      different
        (toDoc localizer ctx t1)
        (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
        Bag.empty

    (Alias home1 name1 args1 t1, t2) ->
      case diffAliasedRecord localizer t1 t2 of
        Just (Diff _ doc2 status) ->
          Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status

        Nothing ->
          case t2 of
            Type home2 name2 args2 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
              different
                (nameClashToDoc ctx localizer home1 name1 (map snd args1))
                (nameClashToDoc ctx localizer home2 name2 args2)
                Bag.empty

            _ ->
              different
                (D.dullyellow (toDoc localizer ctx tipe1))
                (D.dullyellow (toDoc localizer ctx tipe2))
                Bag.empty

    (t1, Alias home2 name2 args2 t2) ->
      case diffAliasedRecord localizer t1 t2 of
        Just (Diff doc1 _ status) ->
          Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status

        Nothing ->
          case t1 of
            Type home1 name1 args1 | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
              different
                (nameClashToDoc ctx localizer home1 name1 args1)
                (nameClashToDoc ctx localizer home2 name2 (map snd args2))
                Bag.empty

            _ ->
              different
                (D.dullyellow (toDoc localizer ctx tipe1))
                (D.dullyellow (toDoc localizer ctx tipe2))
                Bag.empty

    pair ->
      let
        doc1 = D.dullyellow (toDoc localizer ctx tipe1)
        doc2 = D.dullyellow (toDoc localizer ctx tipe2)
      in
      different doc1 doc2 $
        case pair of
          (RigidVar     x, other) -> Bag.one $ BadRigidVar x other
          (FlexSuper  s x, other) -> Bag.one $ BadFlexSuper Have s x other
          (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
          (other, RigidVar     x) -> Bag.one $ BadRigidVar x other
          (other, FlexSuper  s x) -> Bag.one $ BadFlexSuper Need s x other
          (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other

          (Type home1 name1 [], Type home2 name2 [])
            | isInt   home1 name1 && isFloat  home2 name2 -> Bag.one IntFloat
            | isFloat home1 name1 && isInt    home2 name2 -> Bag.one IntFloat
            | isInt   home1 name1 && isString home2 name2 -> Bag.one StringFromInt
            | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
            | isString home1 name1 && isInt   home2 name2 -> Bag.one StringToInt
            | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
            | isBool home2 name2 -> Bag.one AnythingToBool

          (_, _) ->
            Bag.empty



-- DIFF HELPERS


same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc
same localizer ctx tipe =
  let
    doc = toDoc localizer ctx tipe
  in
  Diff doc doc Similar


similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
similar localizer ctx t1 t2 =
  Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar


different :: a -> a -> Bag.Bag Problem -> Diff a
different a b problems =
  Diff a b (Different problems)


isSimilar :: Diff a -> Bool
isSimilar (Diff _ _ status) =
  case status of
    Similar -> True
    Different _ -> False



-- IS TYPE?


isBool :: ModuleName.Canonical -> Name.Name -> Bool
isBool home name =
  home == ModuleName.basics && name == Name.bool


isInt :: ModuleName.Canonical -> Name.Name -> Bool
isInt home name =
  home == ModuleName.basics && name == Name.int


isFloat :: ModuleName.Canonical -> Name.Name -> Bool
isFloat home name =
  home == ModuleName.basics && name == Name.float


isString :: ModuleName.Canonical -> Name.Name -> Bool
isString home name =
  home == ModuleName.string && name == Name.string


isChar :: ModuleName.Canonical -> Name.Name -> Bool
isChar home name =
  home == ModuleName.char && name == Name.char


isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
isMaybe home name =
  home == ModuleName.maybe && name == Name.maybe


isList :: ModuleName.Canonical -> Name.Name -> Bool
isList home name =
  home == ModuleName.list && name == Name.list



-- IS SUPER?


isSuper :: Super -> Type -> Bool
isSuper super tipe =
  case iteratedDealias tipe of
    Type h n args ->
      case super of
        Number     -> isInt h n || isFloat h n
        Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isList h n && isSuper super (head args)
        Appendable -> isString h n || isList h n
        CompAppend -> isString h n || isList h n && isSuper Comparable (head args)

    Tuple a b maybeC ->
      case super of
        Number     -> False
        Comparable -> isSuper super a && isSuper super b && maybe True (isSuper super) maybeC
        Appendable -> False
        CompAppend -> False

    _ ->
      False



-- NAME CLASH


nameClashToDoc :: RT.Context -> L.Localizer -> ModuleName.Canonical -> Name.Name -> [Type] -> D.Doc
nameClashToDoc ctx localizer (ModuleName.Canonical _ home) name args =
  RT.apply ctx
    (D.yellow (D.fromName home) <> D.dullyellow ("." <> D.fromName name))
    (map (toDoc localizer RT.App) args)



-- DIFF ALIASED RECORD


diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)
diffAliasedRecord localizer t1 t2 =
  case (iteratedDealias t1, iteratedDealias t2) of
    (Record fields1 ext1, Record fields2 ext2) ->
      Just (diffRecord localizer fields1 ext1 fields2 ext2)

    _ ->
      Nothing



-- RECORD DIFFS


diffRecord :: L.Localizer -> Map.Map Name.Name Type -> Extension -> Map.Map Name.Name Type -> Extension -> Diff D.Doc
diffRecord localizer fields1 ext1 fields2 ext2 =
  let
    toUnknownDocs field tipe =
      ( D.dullyellow (D.fromName field), toDoc localizer RT.None tipe )

    toOverlapDocs field t1 t2 =
      (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2

    left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)
    both = Map.intersectionWithKey toOverlapDocs fields1 fields2
    right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)

    fieldsDiff =
      Map.elems <$>
        if Map.null left && Map.null right then
          sequenceA both
        else
          Map.union
            <$> sequenceA both
            <*> Diff left right (Different Bag.empty)

    (Diff doc1 doc2 status) =
      RT.record
        <$> fieldsDiff
        <*> extToDiff ext1 ext2
  in
  Diff doc1 doc2 $ merge status $
    case (hasFixedFields ext1, hasFixedFields ext2) of
      (True, True) ->
        case Map.lookupMin left of
          Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
          Nothing ->
            if Map.null right
              then Similar
              else Different $ Bag.one $ FieldsMissing (Map.keys right)

      (False, True) ->
        case Map.lookupMin left of
          Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
          Nothing    -> Similar

      (True, False) ->
        case Map.lookupMin right of
          Just (f,_) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
          Nothing    -> Similar

      (False, False) ->
        Similar


hasFixedFields :: Extension -> Bool
hasFixedFields ext =
  case ext of
    Closed      -> True
    FlexOpen _  -> False
    RigidOpen _ -> True



-- DIFF RECORD EXTENSION


extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)
extToDiff ext1 ext2 =
  let
    status = extToStatus ext1 ext2
    extDoc1 = extToDoc ext1
    extDoc2 = extToDoc ext2
  in
  case status of
    Similar ->
      Diff extDoc1 extDoc2 status

    Different _ ->
      Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status


extToStatus :: Extension -> Extension -> Status
extToStatus ext1 ext2 =
  case ext1 of
    Closed ->
      case ext2 of
        Closed      -> Similar
        FlexOpen  _ -> Similar
        RigidOpen _ -> Different Bag.empty

    FlexOpen _ ->
      Similar

    RigidOpen x ->
      case ext2 of
        Closed      -> Different Bag.empty
        FlexOpen  _ -> Similar
        RigidOpen y ->
          if x == y
            then Similar
            else Different $ Bag.one $ BadRigidVar x (RigidVar y)


================================================
FILE: compiler/src/Type/Instantiate.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Type.Instantiate
  ( FreeVars
  , fromSrcType
  )
  where


import qualified Data.Map.Strict as Map
import Data.Map.Strict ((!))
import qualified Data.Name as Name

import qualified AST.Canonical as Can
import Type.Type



-- FREE VARS


type FreeVars =
  Map.Map Name.Name Type



-- FROM SOURCE TYPE


fromSrcType :: Map.Map Name.Name Type -> Can.Type -> IO Type
fromSrcType freeVars sourceType =
  case sourceType of
    Can.TLambda arg result ->
      FunN
        <$> fromSrcType freeVars arg
        <*> fromSrcType freeVars result

    Can.TVar name ->
      return (freeVars ! name)

    Can.TType home name args ->
      AppN home name <$> traverse (fromSrcType freeVars) args

    Can.TAlias home name args aliasedType ->
      do  targs <- traverse (traverse (fromSrcType freeVars)) args
          AliasN home name targs <$>
            case aliasedType of
              Can.Filled realType ->
                fromSrcType freeVars realType

              Can.Holey realType ->
                fromSrcType (Map.fromList targs) realType

    Can.TTuple a b maybeC ->
      TupleN
        <$> fromSrcType freeVars a
        <*> fromSrcType freeVars b
        <*> traverse (fromSrcType freeVars) maybeC

    Can.TUnit ->
      return UnitN

    Can.TRecord fields maybeExt ->
      RecordN
        <$> traverse (fromSrcFieldType freeVars) fields
        <*>
          case maybeExt of
            Nothing ->
              return EmptyRecordN

            Just ext ->
              return (freeVars ! ext)


fromSrcFieldType :: Map.Map Name.Name Type -> Can.FieldType -> IO Type
fromSrcFieldType freeVars (Can.FieldType _ tipe) =
  fromSrcType freeVars tipe


================================================
FILE: compiler/src/Type/Occurs.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Type.Occurs
  ( occurs
  )
  where


import Data.Foldable (foldrM)
import qualified Data.Map.Strict as Map

import Type.Type as Type
import qualified Type.UnionFind as UF



-- OCCURS


occurs :: Type.Variable -> IO Bool
occurs var =
  occursHelp [] var False


occursHelp :: [Type.Variable] -> Type.Variable -> Bool -> IO Bool
occursHelp seen var foundCycle =
  if elem var seen then
    return True

  else
    do  (Descriptor content _ _ _) <- UF.get var
        case content of
          FlexVar _ ->
              return foundCycle

          FlexSuper _ _ ->
              return foundCycle

          RigidVar _ ->
              return foundCycle

          RigidSuper _ _ ->
              return foundCycle

          Structure term ->
              let newSeen = var : seen in
              case term of
                App1 _ _ args ->
                    foldrM (occursHelp newSeen) foundCycle args

                Fun1 a b ->
                    occursHelp newSeen a =<<
                      occursHelp newSeen b foundCycle

                EmptyRecord1 ->
                    return foundCycle

                Record1 fields ext ->
                    occursHelp newSeen ext =<<
                      foldrM (occursHelp newSeen) foundCycle (Map.elems fields)

                Unit1 ->
                    return foundCycle

                Tuple1 a b maybeC ->
                    case maybeC of
                      Nothing ->
                        occursHelp newSeen a =<<
                          occursHelp newSeen b foundCycle

                      Just c ->
                        occursHelp newSeen a =<<
                          occursHelp newSeen b =<<
                            occursHelp newSeen c foundCycle

          Alias _ _ args _ ->
              foldrM (occursHelp (var:seen)) foundCycle (map snd args)

          Error ->
              return foundCycle


================================================
FILE: compiler/src/Type/Solve.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Type.Solve
  ( run
  )
  where


import Control.Monad
import qualified Data.Map.Strict as Map
import Data.Map.Strict ((!))
import qualified Data.Name as Name
import qualified Data.NonEmptyList as NE
import qualified Data.Vector as Vector
import qualified Data.Vector.Mutable as MVector

import qualified AST.Canonical as Can
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Type as Error
import qualified Reporting.Render.Type as RT
import qualified Reporting.Render.Type.Localizer as L
import qualified Type.Occurs as Occurs
import Type.Type as Type
import qualified Type.Error as ET
import qualified Type.Unify as Unify
import qualified Type.UnionFind as UF



-- RUN SOLVER


run :: Constraint -> IO (Either (NE.List Error.Error) (Map.Map Name.Name Can.Annotation))
run constraint =
  do  pools <- MVector.replicate 8 []

      (State env _ errors) <-
        solve Map.empty outermostRank pools emptyState constraint

      case errors of
        [] ->
          Right <$> traverse Type.toAnnotation env

        e:es ->
          return $ Left (NE.List e es)



{-# NOINLINE emptyState #-}
emptyState :: State
emptyState =
  State Map.empty (nextMark noMark) []



-- SOLVER


type Env =
  Map.Map Name.Name Variable


type Pools =
  MVector.IOVector [Variable]


data State =
  State
    { _env :: Env
    , _mark :: Mark
    , _errors :: [Error.Error]
    }


solve :: Env -> Int -> Pools -> State -> Constraint -> IO State
solve env rank pools state constraint =
  case constraint of
    CTrue ->
      return state

    CSaveTheEnvironment ->
      return (state { _env = env })

    CEqual region category tipe expectation ->
      do  actual <- typeToVariable rank pools tipe
          expected <- expectedToVariable rank pools expectation
          answer <- Unify.unify actual expected
          case answer of
            Unify.Ok vars ->
              do  introduce rank pools vars
                  return state

            Unify.Err vars actualType expectedType ->
              do  introduce rank pools vars
                  return $ addError state $
                    Error.BadExpr region category actualType $
                      Error.typeReplace expectation expectedType

    CLocal region name expectation ->
      do  actual <- makeCopy rank pools (env ! name)
          expected <- expectedToVariable rank pools expectation
          answer <- Unify.unify actual expected
          case answer of
            Unify.Ok vars ->
              do  introduce rank pools vars
                  return state

            Unify.Err vars actualType expectedType ->
              do  introduce rank pools vars
                  return $ addError state $
                    Error.BadExpr region (Error.Local name) actualType $
                      Error.typeReplace expectation expectedType

    CForeign region name (Can.Forall freeVars srcType) expectation ->
      do  actual <- srcTypeToVariable rank pools freeVars srcType
          expected <- expectedToVariable rank pools expectation
          answer <- Unify.unify actual expected
          case answer of
            Unify.Ok vars ->
              do  introduce rank pools vars
                  return state

            Unify.Err vars actualType expectedType ->
              do  introduce rank pools vars
                  return $ addError state $
                    Error.BadExpr region (Error.Foreign name) actualType $
                      Error.typeReplace expectation expectedType

    CPattern region category tipe expectation ->
      do  actual <- typeToVariable rank pools tipe
          expected <- patternExpectationToVariable rank pools expectation
          answer <- Unify.unify actual expected
          case answer of
            Unify.Ok vars ->
              do  introduce rank pools vars
                  return state

            Unify.Err vars actualType expectedType ->
              do  introduce rank pools vars
                  return $ addError state $
                    Error.BadPattern region category actualType
                      (Error.ptypeReplace expectation expectedType)

    CAnd constraints ->
      foldM (solve env rank pools) state constraints

    CLet [] flexs _ headerCon CTrue ->
      do  introduce rank pools flexs
          solve env rank pools state headerCon

    CLet [] [] header headerCon subCon ->
      do  state1 <- solve env rank pools state headerCon
          locals <- traverse (A.traverse (typeToVariable rank pools)) header
          let newEnv = Map.union env (Map.map A.toValue locals)
          state2 <- solve newEnv rank pools state1 subCon
          foldM occurs state2 $ Map.toList locals

    CLet rigids flexs header headerCon subCon ->
      do
          -- work in the next pool to localize header
          let nextRank = rank + 1
          let poolsLength = MVector.length pools
          nextPools <-
            if nextRank < poolsLength
              then return pools
              else MVector.grow pools poolsLength

          -- introduce variables
          let vars = rigids ++ flexs
          forM_ vars $ \var ->
            UF.modify var $ \(Descriptor content _ mark copy) ->
              Descriptor content nextRank mark copy
          MVector.write nextPools nextRank vars

          -- run solver in next pool
          locals <- traverse (A.traverse (typeToVariable nextRank nextPools)) header
          (State savedEnv mark errors) <-
            solve env nextRank nextPools state headerCon

          let youngMark = mark
          let visitMark = nextMark youngMark
          let finalMark = nextMark visitMark

          -- pop pool
          generalize youngMark visitMark nextRank nextPools
          MVector.write nextPools nextRank []

          -- check that things went well
          mapM_ isGeneric rigids

          let newEnv = Map.union env (Map.map A.toValue locals)
          let tempState = State savedEnv finalMark errors
          newState <- solve newEnv rank nextPools tempState subCon

          foldM occurs newState (Map.toList locals)


-- Check that a variable has rank == noRank, meaning that it can be generalized.
isGeneric :: Variable -> IO ()
isGeneric var =
  do  (Descriptor _ rank _ _) <- UF.get var
      if rank == noRank
        then return ()
        else
          do  tipe <- Type.toErrorType var
              error $
                "You ran into a compiler bug. Here are some details for the developers:\n\n"
                ++ "    " ++ show (ET.toDoc L.empty RT.None tipe) ++ " [rank = " ++ show rank ++ "]\n\n"
                ++
                  "Please create an  and then report it\n\
                  \at \n\n"



-- EXPECTATIONS TO VARIABLE


expectedToVariable :: Int -> Pools -> Error.Expected Type -> IO Variable
expectedToVariable rank pools expectation =
  typeToVariable rank pools $
    case expectation of
      Error.NoExpectation tipe ->
        tipe

      Error.FromContext _ _ tipe ->
        tipe

      Error.FromAnnotation _ _ _ tipe ->
        tipe


patternExpectationToVariable :: Int -> Pools -> Error.PExpected Type -> IO Variable
patternExpectationToVariable rank pools expectation =
  typeToVariable rank pools $
    case expectation of
      Error.PNoExpectation tipe ->
        tipe

      Error.PFromContext _ _ tipe ->
        tipe



-- ERROR HELPERS


addError :: State -> Error.Error -> State
addError (State savedEnv rank errors) err =
  State savedEnv rank (err:errors)



-- OCCURS CHECK


occurs :: State -> (Name.Name, A.Located Variable) -> IO State
occurs state (name, A.At region variable) =
  do  hasOccurred <- Occurs.occurs variable
      if hasOccurred
        then
          do  errorType <- Type.toErrorType variable
              (Descriptor _ rank mark copy) <- UF.get variable
              UF.set variable (Descriptor Error rank mark copy)
              return $ addError state (Error.InfiniteType region name errorType)
        else
          return state



-- GENERALIZE


{-| Every variable has rank less than or equal to the maxRank of the pool.
This sorts variables into the young and old pools accordingly.
-}
generalize :: Mark -> Mark -> Int -> Pools -> IO ()
generalize youngMark visitMark youngRank pools =
  do  youngVars <- MVector.read pools youngRank
      rankTable <- poolToRankTable youngMark youngRank youngVars

      -- get the ranks right for each entry.
      -- start at low ranks so that we only have to pass
      -- over the information once.
      Vector.imapM_
        (\rank table -> mapM_ (adjustRank youngMark visitMark rank) table)
        rankTable

      -- For variables that have rank lowerer than youngRank, register them in
      -- the appropriate old pool if they are not redundant.
      Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
        forM_ vars $ \var ->
          do  isRedundant <- UF.redundant var
              if isRedundant
                then return ()
                else
                  do  (Descriptor _ rank _ _) <- UF.get var
                      MVector.modify pools (var:) rank

      -- For variables with rank youngRank
      --   If rank < youngRank: register in oldPool
      --   otherwise generalize
      forM_ (Vector.unsafeLast rankTable) $ \var ->
        do  isRedundant <- UF.redundant var
            if isRedundant
              then return ()
              else
                do  (Descriptor content rank mark copy) <- UF.get var
                    if rank < youngRank
                      then MVector.modify pools (var:) rank
                      else UF.set var $ Descriptor content noRank mark copy


poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])
poolToRankTable youngMark youngRank youngInhabitants =
  do  mutableTable <- MVector.replicate (youngRank + 1) []

      -- Sort the youngPool variables into buckets by rank.
      forM_ youngInhabitants $ \var ->
        do  (Descriptor content rank _ copy) <- UF.get var
            UF.set var (Descriptor content rank youngMark copy)
            MVector.modify mutableTable (var:) rank

      Vector.unsafeFreeze mutableTable



-- ADJUST RANK

--
-- Adjust variable ranks such that ranks never increase as you move deeper.
-- This way the outermost rank is representative of the entire structure.
--
adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
adjustRank youngMark visitMark groupRank var =
  do  (Descriptor content rank mark copy) <- UF.get var
      if mark == youngMark then
          do  -- Set the variable as marked first because it may be cyclic.
              UF.set var $ Descriptor content rank visitMark copy
              maxRank <- adjustRankContent youngMark visitMark groupRank content
              UF.set var $ Descriptor content maxRank visitMark copy
              return maxRank

        else if mark == visitMark then
          return rank

        else
          do  let minRank = min groupRank rank
              -- TODO how can minRank ever be groupRank?
              UF.set var $ Descriptor content minRank visitMark copy
              return minRank


adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
adjustRankContent youngMark visitMark groupRank content =
  let
    go = adjustRank youngMark visitMark groupRank
  in
    case content of
      FlexVar _ ->
          return groupRank

      FlexSuper _ _ ->
          return groupRank

      RigidVar _ ->
          return groupRank

      RigidSuper _ _ ->
          return groupRank

      Structure flatType ->
        case flatType of
          App1 _ _ args ->
            foldM (\rank arg -> max rank <$> go arg) outermostRank args

          Fun1 arg result ->
              max <$> go arg <*> go result

          EmptyRecord1 ->
              -- THEORY: an empty record never needs to get generalized
              return outermostRank

          Record1 fields extension ->
              do  extRank <- go extension
                  foldM (\rank field -> max rank <$> go field) extRank fields

          Unit1 ->
              -- THEORY: a unit never needs to get generalized
              return outermostRank

          Tuple1 a b maybeC ->
              do  ma <- go a
                  mb <- go b
                  case maybeC of
                    Nothing ->
                      return (max ma mb)

                    Just c ->
                      max (max ma mb) <$> go c

      Alias _ _ args _ ->
          -- THEORY: anything in the realVar would be outermostRank
          foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args

      Error ->
          return groupRank



-- REGISTER VARIABLES


introduce :: Int -> Pools -> [Variable] -> IO ()
introduce rank pools variables =
  do  MVector.modify pools (variables++) rank
      forM_ variables $ \var ->
        UF.modify var $ \(Descriptor content _ mark copy) ->
          Descriptor content rank mark copy



-- TYPE TO VARIABLE


typeToVariable :: Int -> Pools -> Type -> IO Variable
typeToVariable rank pools tipe =
  typeToVar rank pools Map.empty tipe


-- PERF working with @mgriffith we noticed that a 784 line entry in a `let` was
-- causing a ~1.5 second slowdown. Moving it to the top-level to be a function
-- saved all that time. The slowdown seems to manifest in `typeToVar` and in
-- `register` in particular. Have not explored further yet. Top-level definitions
-- are recommended in cases like this anyway, so there is at least a safety
-- valve for now.
--
typeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Type -> IO Variable
typeToVar rank pools aliasDict tipe =
  let go = typeToVar rank pools aliasDict in
  case tipe of
    VarN v ->
      return v

    AppN home name args ->
      do  argVars <- traverse go args
          register rank pools (Structure (App1 home name argVars))

    FunN a b ->
      do  aVar <- go a
          bVar <- go b
          register rank pools (Structure (Fun1 aVar bVar))

    AliasN home name args aliasType ->
      do  argVars <- traverse (traverse go) args
          aliasVar <- typeToVar rank pools (Map.fromList argVars) aliasType
          register rank pools (Alias home name argVars aliasVar)

    PlaceHolder name ->
      return (aliasDict ! name)

    RecordN fields ext ->
      do  fieldVars <- traverse go fields
          extVar <- go ext
          register rank pools (Structure (Record1 fieldVars extVar))

    EmptyRecordN ->
      register rank pools emptyRecord1

    UnitN ->
      register rank pools unit1

    TupleN a b c ->
      do  aVar <- go a
          bVar <- go b
          cVar <- traverse go c
          register rank pools (Structure (Tuple1 aVar bVar cVar))


register :: Int -> Pools -> Content -> IO Variable
register rank pools content =
  do  var <- UF.fresh (Descriptor content rank noMark Nothing)
      MVector.modify pools (var:) rank
      return var


{-# NOINLINE emptyRecord1 #-}
emptyRecord1 :: Content
emptyRecord1 =
  Structure EmptyRecord1


{-# NOINLINE unit1 #-}
unit1 :: Content
unit1 =
  Structure Unit1



-- SOURCE TYPE TO VARIABLE


srcTypeToVariable :: Int -> Pools -> Map.Map Name.Name () -> Can.Type -> IO Variable
srcTypeToVariable rank pools freeVars srcType =
  let
    nameToContent name
      | Name.isNumberType     name = FlexSuper Number (Just name)
      | Name.isComparableType name = FlexSuper Comparable (Just name)
      | Name.isAppendableType name = FlexSuper Appendable (Just name)
      | Name.isCompappendType name = FlexSuper CompAppend (Just name)
      | otherwise                  = FlexVar (Just name)

    makeVar name _ =
      UF.fresh (Descriptor (nameToContent name) rank noMark Nothing)
  in
  do  flexVars <- Map.traverseWithKey makeVar freeVars
      MVector.modify pools (Map.elems flexVars ++) rank
      srcTypeToVar rank pools flexVars srcType


srcTypeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Can.Type -> IO Variable
srcTypeToVar rank pools flexVars srcType =
  let go = srcTypeToVar rank pools flexVars in
  case srcType of
    Can.TLambda argument result ->
      do  argVar <- go argument
          resultVar <- go result
          register rank pools (Structure (Fun1 argVar resultVar))

    Can.TVar name ->
      return (flexVars ! name)

    Can.TType home name args ->
      do  argVars <- traverse go args
          register rank pools (Structure (App1 home name argVars))

    Can.TRecord fields maybeExt ->
      do  fieldVars <- traverse (srcFieldTypeToVar rank pools flexVars) fields
          extVar <-
            case maybeExt of
              Nothing -> register rank pools emptyRecord1
              Just ext -> return (flexVars ! ext)
          register rank pools (Structure (Record1 fieldVars extVar))

    Can.TUnit ->
      register rank pools unit1

    Can.TTuple a b c ->
      do  aVar <- go a
          bVar <- go b
          cVar <- traverse go c
          register rank pools (Structure (Tuple1 aVar bVar cVar))

    Can.TAlias home name args aliasType ->
      do  argVars <- traverse (traverse go) args
          aliasVar <-
            case aliasType of
              Can.Holey tipe ->
                srcTypeToVar rank pools (Map.fromList argVars) tipe

              Can.Filled tipe ->
                go tipe

          register rank pools (Alias home name argVars aliasVar)


srcFieldTypeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Can.FieldType -> IO Variable
srcFieldTypeToVar rank pools flexVars (Can.FieldType _ srcTipe) =
  srcTypeToVar rank pools flexVars srcTipe



-- COPY


makeCopy :: Int -> Pools -> Variable -> IO Variable
makeCopy rank pools var =
  do  copy <- makeCopyHelp rank pools var
      restore var
      return copy


makeCopyHelp :: Int -> Pools -> Variable -> IO Variable
makeCopyHelp maxRank pools variable =
  do  (Descriptor content rank _ maybeCopy) <- UF.get variable

      case maybeCopy of
        Just copy ->
          return copy

        Nothing ->
          if rank /= noRank then
            return variable

          else
            do  let makeDescriptor c = Descriptor c maxRank noMark Nothing
                copy <- UF.fresh $ makeDescriptor content
                MVector.modify pools (copy:) maxRank

                -- Link the original variable to the new variable. This lets us
                -- avoid making multiple copies of the variable we are instantiating.
                --
                -- Need to do this before recursively copying to avoid looping.
                UF.set variable $
                  Descriptor content rank noMark (Just copy)

                -- Now we recursively copy the content of the variable.
                -- We have already marked the variable as copied, so we
                -- will not repeat this work or crawl this variable again.
                case content of
                  Structure term ->
                    do  newTerm <- traverseFlatType (makeCopyHelp maxRank pools) term
                        UF.set copy $ makeDescriptor (Structure newTerm)
                        return copy

                  FlexVar _ ->
                    return copy

                  FlexSuper _ _ ->
                    return copy

                  RigidVar name ->
                    do  UF.set copy $ makeDescriptor $ FlexVar (Just name)
                        return copy

                  RigidSuper super name ->
                    do  UF.set copy $ makeDescriptor $ FlexSuper super (Just name)
                        return copy

                  Alias home name args realType ->
                    do  newArgs <- mapM (traverse (makeCopyHelp maxRank pools)) args
                        newRealType <- makeCopyHelp maxRank pools realType
                        UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)
                        return copy

                  Error ->
                    return copy



-- RESTORE


restore :: Variable -> IO ()
restore variable =
  do  (Descriptor content _ _ maybeCopy) <- UF.get variable
      case maybeCopy of
        Nothing ->
          return ()

        Just _ ->
          do  UF.set variable $ Descriptor content noRank noMark Nothing
              restoreContent content


restoreContent :: Content -> IO ()
restoreContent content =
  case content of
    FlexVar _ ->
      return ()

    FlexSuper _ _ ->
      return ()

    RigidVar _ ->
      return ()

    RigidSuper _ _ ->
      return ()

    Structure term ->
      case term of
        App1 _ _ args ->
          mapM_ restore args

        Fun1 arg result ->
          do  restore arg
              restore result

        EmptyRecord1 ->
          return ()

        Record1 fields ext ->
          do  mapM_ restore fields
              restore ext

        Unit1 ->
          return ()

        Tuple1 a b maybeC ->
          do  restore a
              restore b
              case maybeC of
                Nothing -> return ()
                Just c  -> restore c

    Alias _ _ args var ->
      do  mapM_ (traverse restore) args
          restore var

    Error ->
        return ()



-- TRAVERSE FLAT TYPE


traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
traverseFlatType f flatType =
  case flatType of
    App1 home name args ->
        liftM (App1 home name) (traverse f args)

    Fun1 a b ->
        liftM2 Fun1 (f a) (f b)

    EmptyRecord1 ->
        pure EmptyRecord1

    Record1 fields ext ->
        liftM2 Record1 (traverse f fields) (f ext)

    Unit1 ->
        pure Unit1

    Tuple1 a b cs ->
        liftM3 Tuple1 (f a) (f b) (traverse f cs)


================================================
FILE: compiler/src/Type/Type.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Type.Type
  ( Constraint(..)
  , exists
  , Variable
  , FlatType(..)
  , Type(..)
  , Descriptor(Descriptor)
  , Content(..)
  , SuperType(..)
  , noRank
  , outermostRank
  , Mark
  , noMark
  , nextMark
  , (==>)
  , int, float, char, string, bool, never
  , vec2, vec3, vec4, mat4, texture
  , mkFlexVar
  , mkFlexNumber
  , unnamedFlexVar
  , unnamedFlexSuper
  , nameToFlex
  , nameToRigid
  , toAnnotation
  , toErrorType
  )
  where


import Control.Monad.State.Strict (StateT, liftIO)
import qualified Control.Monad.State.Strict as State
import Data.Foldable (foldrM)
import qualified Data.Map.Strict as Map
import qualified Data.Name as Name
import Data.Word (Word32)

import qualified AST.Canonical as Can
import qualified AST.Utils.Type as Type
import qualified Elm.ModuleName as ModuleName
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Type as E
import qualified Type.Error as ET
import qualified Type.UnionFind as UF



-- CONSTRAINTS


data Constraint
  = CTrue
  | CSaveTheEnvironment
  | CEqual A.Region E.Category Type (E.Expected Type)
  | CLocal A.Region Name.Name (E.Expected Type)
  | CForeign A.Region Name.Name Can.Annotation (E.Expected Type)
  | CPattern A.Region E.PCategory Type (E.PExpected Type)
  | CAnd [Constraint]
  | CLet
      { _rigidVars :: [Variable]
      , _flexVars :: [Variable]
      , _header :: Map.Map Name.Name (A.Located Type)
      , _headerCon :: Constraint
      , _bodyCon :: Constraint
      }


exists :: [Variable] -> Constraint -> Constraint
exists flexVars constraint =
  CLet [] flexVars Map.empty constraint CTrue



-- TYPE PRIMITIVES


type Variable =
    UF.Point Descriptor


data FlatType
    = App1 ModuleName.Canonical Name.Name [Variable]
    | Fun1 Variable Variable
    | EmptyRecord1
    | Record1 (Map.Map Name.Name Variable) Variable
    | Unit1
    | Tuple1 Variable Variable (Maybe Variable)


data Type
    = PlaceHolder Name.Name
    | AliasN ModuleName.Canonical Name.Name [(Name.Name, Type)] Type
    | VarN Variable
    | AppN ModuleName.Canonical Name.Name [Type]
    | FunN Type Type
    | EmptyRecordN
    | RecordN (Map.Map Name.Name Type) Type
    | UnitN
    | TupleN Type Type (Maybe Type)



-- DESCRIPTORS


data Descriptor =
  Descriptor
    { _content :: Content
    , _rank :: Int
    , _mark :: Mark
    , _copy :: Maybe Variable
    }


data Content
    = FlexVar (Maybe Name.Name)
    | FlexSuper SuperType (Maybe Name.Name)
    | RigidVar Name.Name
    | RigidSuper SuperType Name.Name
    | Structure FlatType
    | Alias ModuleName.Canonical Name.Name [(Name.Name,Variable)] Variable
    | Error


data SuperType
  = Number
  | Comparable
  | Appendable
  | CompAppend
  deriving (Eq)


makeDescriptor :: Content -> Descriptor
makeDescriptor content =
  Descriptor content noRank noMark Nothing



-- RANKS


noRank :: Int
noRank =
  0


outermostRank :: Int
outermostRank =
  1



-- MARKS


newtype Mark = Mark Word32
  deriving (Eq, Ord)


noMark :: Mark
noMark =
  Mark 2


occursMark :: Mark
occursMark =
  Mark 1


getVarNamesMark :: Mark
getVarNamesMark =
  Mark 0


{-# INLINE nextMark #-}
nextMark :: Mark -> Mark
nextMark (Mark mark) =
  Mark (mark + 1)



-- FUNCTION TYPES


infixr 9 ==>


{-# INLINE (==>) #-}
(==>) :: Type -> Type -> Type
(==>) =
  FunN



-- PRIMITIVE TYPES


{-# NOINLINE int #-}
int :: Type
int = AppN ModuleName.basics "Int" []


{-# NOINLINE float #-}
float :: Type
float = AppN ModuleName.basics "Float" []


{-# NOINLINE char #-}
char :: Type
char = AppN ModuleName.char "Char" []


{-# NOINLINE string #-}
string :: Type
string = AppN ModuleName.string "String" []


{-# NOINLINE bool #-}
bool :: Type
bool = AppN ModuleName.basics "Bool" []


{-# NOINLINE never #-}
never :: Type
never = AppN ModuleName.basics "Never" []



-- WEBGL TYPES


{-# NOINLINE vec2 #-}
vec2 :: Type
vec2 = AppN ModuleName.vector2 "Vec2" []


{-# NOINLINE vec3 #-}
vec3 :: Type
vec3 = AppN ModuleName.vector3 "Vec3" []


{-# NOINLINE vec4 #-}
vec4 :: Type
vec4 = AppN ModuleName.vector4 "Vec4" []


{-# NOINLINE mat4 #-}
mat4 :: Type
mat4 = AppN ModuleName.matrix4 "Mat4" []


{-# NOINLINE texture #-}
texture :: Type
texture = AppN ModuleName.texture "Texture" []



-- MAKE FLEX VARIABLES


mkFlexVar :: IO Variable
mkFlexVar =
  UF.fresh flexVarDescriptor


{-# NOINLINE flexVarDescriptor #-}
flexVarDescriptor :: Descriptor
flexVarDescriptor =
  makeDescriptor unnamedFlexVar


{-# NOINLINE unnamedFlexVar #-}
unnamedFlexVar :: Content
unnamedFlexVar =
  FlexVar Nothing



-- MAKE FLEX NUMBERS


mkFlexNumber :: IO Variable
mkFlexNumber =
  UF.fresh flexNumberDescriptor


{-# NOINLINE flexNumberDescriptor #-}
flexNumberDescriptor :: Descriptor
flexNumberDescriptor =
  makeDescriptor (unnamedFlexSuper Number)


unnamedFlexSuper :: SuperType -> Content
unnamedFlexSuper super =
  FlexSuper super Nothing



-- MAKE NAMED VARIABLES


nameToFlex :: Name.Name -> IO Variable
nameToFlex name =
  UF.fresh $ makeDescriptor $
    maybe FlexVar FlexSuper (toSuper name) (Just name)


nameToRigid :: Name.Name -> IO Variable
nameToRigid name =
  UF.fresh $ makeDescriptor $
    maybe RigidVar RigidSuper (toSuper name) name


toSuper :: Name.Name -> Maybe SuperType
toSuper name =
  if Name.isNumberType name then
      Just Number

  else if Name.isComparableType name then
      Just Comparable

  else if Name.isAppendableType name then
      Just Appendable

  else if Name.isCompappendType name then
      Just CompAppend

  else
      Nothing



-- TO TYPE ANNOTATION


toAnnotation :: Variable -> IO Can.Annotation
toAnnotation variable =
  do  userNames <- getVarNames variable Map.empty
      (tipe, NameState freeVars _ _ _ _ _) <-
        State.runStateT (variableToCanType variable) (makeNameState userNames)
      return $ Can.Forall freeVars tipe


variableToCanType :: Variable -> StateT NameState IO Can.Type
variableToCanType variable =
  do  (Descriptor content _ _ _) <- liftIO $ UF.get variable
      case content of
        Structure term ->
            termToCanType term

        FlexVar maybeName ->
          case maybeName of
            Just name ->
              return (Can.TVar name)

            Nothing ->
              do  name <- getFreshVarName
                  liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
                  return (Can.TVar name)

        FlexSuper super maybeName ->
          case maybeName of
            Just name ->
              return (Can.TVar name)

            Nothing ->
              do  name <- getFreshSuperName super
                  liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
                  return (Can.TVar name)

        RigidVar name ->
            return (Can.TVar name)

        RigidSuper _ name ->
            return (Can.TVar name)

        Alias home name args realVariable ->
            do  canArgs <- traverse (traverse variableToCanType) args
                canType <- variableToCanType realVariable
                return (Can.TAlias home name canArgs (Can.Filled canType))

        Error ->
            error "cannot handle Error types in variableToCanType"


termToCanType :: FlatType -> StateT NameState IO Can.Type
termToCanType term =
  case term of
    App1 home name args ->
      Can.TType home name <$> traverse variableToCanType args

    Fun1 a b ->
      Can.TLambda
        <$> variableToCanType a
        <*> variableToCanType b

    EmptyRecord1 ->
      return $ Can.TRecord Map.empty Nothing

    Record1 fields extension ->
      do  canFields <- traverse fieldToCanType fields
          canExt <- Type.iteratedDealias <$> variableToCanType extension
          return $
              case canExt of
                Can.TRecord subFields subExt ->
                    Can.TRecord (Map.union subFields canFields) subExt

                Can.TVar name ->
                    Can.TRecord canFields (Just name)

                _ ->
                    error "Used toAnnotation on a type that is not well-formed"

    Unit1 ->
      return Can.TUnit

    Tuple1 a b maybeC ->
      Can.TTuple
        <$> variableToCanType a
        <*> variableToCanType b
        <*> traverse variableToCanType maybeC


fieldToCanType :: Variable -> StateT NameState IO Can.FieldType
fieldToCanType variable =
  do  tipe <- variableToCanType variable
      return (Can.FieldType 0 tipe)



-- TO ERROR TYPE


toErrorType :: Variable -> IO ET.Type
toErrorType variable =
  do  userNames <- getVarNames variable Map.empty
      State.evalStateT (variableToErrorType variable) (makeNameState userNames)


variableToErrorType :: Variable -> StateT NameState IO ET.Type
variableToErrorType variable =
  do  descriptor <- liftIO $ UF.get variable
      let mark = _mark descriptor
      if mark == occursMark
        then
          return ET.Infinite

        else
          do  liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
              errType <- contentToErrorType variable (_content descriptor)
              liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
              return errType


contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type
contentToErrorType variable content =
  case content of
    Structure term ->
        termToErrorType term

    FlexVar maybeName ->
      case maybeName of
        Just name ->
          return (ET.FlexVar name)

        Nothing ->
          do  name <- getFreshVarName
              liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
              return (ET.FlexVar name)

    FlexSuper super maybeName ->
      case maybeName of
        Just name ->
          return (ET.FlexSuper (superToSuper super) name)

        Nothing ->
          do  name <- getFreshSuperName super
              liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
              return (ET.FlexSuper (superToSuper super) name)

    RigidVar name ->
        return (ET.RigidVar name)

    RigidSuper super name ->
        return (ET.RigidSuper (superToSuper super) name)

    Alias home name args realVariable ->
        do  errArgs <- traverse (traverse variableToErrorType) args
            errType <- variableToErrorType realVariable
            return (ET.Alias home name errArgs errType)

    Error ->
        return ET.Error


superToSuper :: SuperType -> ET.Super
superToSuper super =
  case super of
    Number -> ET.Number
    Comparable -> ET.Comparable
    Appendable -> ET.Appendable
    CompAppend -> ET.CompAppend


termToErrorType :: FlatType -> StateT NameState IO ET.Type
termToErrorType term =
  case term of
    App1 home name args ->
      ET.Type home name <$> traverse variableToErrorType args

    Fun1 a b ->
      do  arg <- variableToErrorType a
          result <- variableToErrorType b
          return $
            case result of
              ET.Lambda arg1 arg2 others ->
                ET.Lambda arg arg1 (arg2:others)

              _ ->
                ET.Lambda arg result []

    EmptyRecord1 ->
      return $ ET.Record Map.empty ET.Closed

    Record1 fields extension ->
      do  errFields <- traverse variableToErrorType fields
          errExt <- ET.iteratedDealias <$> variableToErrorType extension
          return $
              case errExt of
                ET.Record subFields subExt ->
                    ET.Record (Map.union subFields errFields) subExt

                ET.FlexVar ext ->
                    ET.Record errFields (ET.FlexOpen ext)

                ET.RigidVar ext ->
                    ET.Record errFields (ET.RigidOpen ext)

                _ ->
                    error "Used toErrorType on a type that is not well-formed"

    Unit1 ->
      return ET.Unit

    Tuple1 a b maybeC ->
      ET.Tuple
        <$> variableToErrorType a
        <*> variableToErrorType b
        <*> traverse variableToErrorType maybeC



-- MANAGE FRESH VARIABLE NAMES


data NameState =
  NameState
    { _taken :: Map.Map Name.Name ()
    , _normals :: Int
    , _numbers :: Int
    , _comparables :: Int
    , _appendables :: Int
    , _compAppends :: Int
    }


makeNameState :: Map.Map Name.Name Variable -> NameState
makeNameState taken =
  NameState (Map.map (const ()) taken) 0 0 0 0 0



-- FRESH VAR NAMES


getFreshVarName :: (Monad m) => StateT NameState m Name.Name
getFreshVarName =
  do  index <- State.gets _normals
      taken <- State.gets _taken
      let (name, newIndex, newTaken) = getFreshVarNameHelp index taken
      State.modify $ \state -> state { _taken = newTaken, _normals = newIndex }
      return name


getFreshVarNameHelp :: Int -> Map.Map Name.Name () -> (Name.Name, Int, Map.Map Name.Name ())
getFreshVarNameHelp index taken =
  let
    name =
      Name.fromTypeVariableScheme index
  in
  if Map.member name taken then
    getFreshVarNameHelp (index + 1) taken
  else
    ( name, index + 1, Map.insert name () taken )



-- FRESH SUPER NAMES


getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m Name.Name
getFreshSuperName super =
  case super of
    Number ->
      getFreshSuper "number" _numbers (\index state -> state { _numbers = index })

    Comparable ->
      getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })

    Appendable ->
      getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })

    CompAppend ->
      getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })


getFreshSuper :: (Monad m) => Name.Name -> (NameState -> Int) -> (Int -> NameState -> NameState) -> StateT NameState m Name.Name
getFreshSuper prefix getter setter =
  do  index <- State.gets getter
      taken <- State.gets _taken
      let (name, newIndex, newTaken) = getFreshSuperHelp prefix index taken
      State.modify (\state -> setter newIndex state { _taken = newTaken })
      return name


getFreshSuperHelp :: Name.Name -> Int -> Map.Map Name.Name () -> (Name.Name, Int, Map.Map Name.Name ())
getFreshSuperHelp prefix index taken =
  let
    name =
      Name.fromTypeVariable prefix index
  in
    if Map.member name taken then
      getFreshSuperHelp prefix (index + 1) taken

    else
      ( name, index + 1, Map.insert name () taken )



-- GET ALL VARIABLE NAMES


getVarNames :: Variable -> Map.Map Name.Name Variable -> IO (Map.Map Name.Name Variable)
getVarNames var takenNames =
  do  (Descriptor content rank mark copy) <- UF.get var
      if mark == getVarNamesMark
        then return takenNames
        else
        do  UF.set var (Descriptor content rank getVarNamesMark copy)
            case content of
              Error ->
                return takenNames

              FlexVar maybeName ->
                case maybeName of
                  Nothing ->
                    return takenNames

                  Just name ->
                    addName 0 name var (FlexVar . Just) takenNames

              FlexSuper super maybeName ->
                case maybeName of
                  Nothing ->
                    return takenNames

                  Just name ->
                    addName 0 name var (FlexSuper super . Just) takenNames

              RigidVar name ->
                addName 0 name var RigidVar takenNames

              RigidSuper super name ->
                addName 0 name var (RigidSuper super) takenNames

              Alias _ _ args _ ->
                foldrM getVarNames takenNames (map snd args)

              Structure flatType ->
                case flatType of
                  App1 _ _ args ->
                    foldrM getVarNames takenNames args

                  Fun1 arg body ->
                    getVarNames arg =<< getVarNames body takenNames

                  EmptyRecord1 ->
                    return takenNames

                  Record1 fields extension ->
                    getVarNames extension =<<
                      foldrM getVarNames takenNames (Map.elems fields)

                  Unit1 ->
                    return takenNames

                  Tuple1 a b Nothing ->
                    getVarNames a =<< getVarNames b takenNames

                  Tuple1 a b (Just c) ->
                    getVarNames a =<< getVarNames b =<< getVarNames c takenNames



-- REGISTER NAME / RENAME DUPLICATES


addName :: Int -> Name.Name -> Variable -> (Name.Name -> Content) -> Map.Map Name.Name Variable -> IO (Map.Map Name.Name Variable)
addName index givenName var makeContent takenNames =
  let
    indexedName =
      Name.fromTypeVariable givenName index
  in
    case Map.lookup indexedName takenNames of
      Nothing ->
        do  if indexedName == givenName then return () else
              UF.modify var $ \(Descriptor _ rank mark copy) ->
                Descriptor (makeContent indexedName) rank mark copy
            return $ Map.insert indexedName var takenNames

      Just otherVar ->
        do  same <- UF.equivalent var otherVar
            if same
              then return takenNames
              else addName (index + 1) givenName var makeContent takenNames


================================================
FILE: compiler/src/Type/Unify.hs
================================================
{-# LANGUAGE OverloadedStrings, Rank2Types #-}
module Type.Unify
  ( Answer(..)
  , unify
  )
  where


import qualified Data.Map.Strict as Map
import qualified Data.Name as Name

import qualified Elm.ModuleName as ModuleName
import qualified Type.Error as Error
import qualified Type.Occurs as Occurs
import Type.Type as Type
import qualified Type.UnionFind as UF



-- UNIFY


data Answer
  = Ok [Variable]
  | Err [Variable] Error.Type Error.Type


unify :: Variable -> Variable -> IO Answer
unify v1 v2 =
  case guardedUnify v1 v2 of
    Unify k ->
      k [] onSuccess $ \vars () ->
        do  t1 <- Type.toErrorType v1
            t2 <- Type.toErrorType v2
            UF.union v1 v2 errorDescriptor
            return (Err vars t1 t2)


onSuccess :: [Variable] -> () -> IO Answer
onSuccess vars () =
  return (Ok vars)


{-# NOINLINE errorDescriptor #-}
errorDescriptor :: Descriptor
errorDescriptor =
  Descriptor Error noRank noMark Nothing



-- CPS UNIFIER


newtype Unify a =
  Unify (forall r.
    [Variable]
    -> ([Variable] -> a -> IO r)
    -> ([Variable] -> () -> IO r)
    -> IO r
  )


instance Functor Unify where
  fmap func (Unify kv) =
    Unify $ \vars ok err ->
      let
        ok1 vars1 value =
          ok vars1 (func value)
      in
      kv vars ok1 err


instance Applicative Unify where
  pure a =
    Unify $ \vars ok _ ->
      ok vars a

  (<*>) (Unify kf) (Unify kv) =
    Unify $ \vars ok err ->
      let
        ok1 vars1 func =
          let
            ok2 vars2 value =
              ok vars2 (func value)
          in
          kv vars1 ok2 err
      in
      kf vars ok1 err

  (*>) (Unify ka) (Unify kb) =
    Unify $ \vars ok err ->
      let
        ok1 vars1 _ = kb vars1 ok err
      in
      ka vars ok1 err


instance Monad Unify where
  (>>=) (Unify ka) callback =
    Unify $ \vars ok err ->
      let
        ok1 vars1 a =
          case callback a of
            Unify kb -> kb vars1 ok err
      in
      ka vars ok1 err


register :: IO Variable -> Unify Variable
register mkVar =
  Unify $ \vars ok _ ->
    do  var <- mkVar
        ok (var:vars) var


mismatch :: Unify a
mismatch =
  Unify $ \vars _ err ->
    err vars ()



-- UNIFICATION HELPERS


data Context =
  Context
    { _first :: Variable
    , _firstDesc :: Descriptor
    , _second :: Variable
    , _secondDesc :: Descriptor
    }


reorient :: Context -> Context
reorient (Context var1 desc1 var2 desc2) =
  Context var2 desc2 var1 desc1



-- MERGE


merge :: Context -> Content -> Unify ()
merge (Context var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
  Unify $ \vars ok _ ->
    ok vars =<<
      UF.union var1 var2 (Descriptor content (min rank1 rank2) noMark Nothing)


fresh :: Context -> Content -> Unify Variable
fresh (Context _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
  register $ UF.fresh $
    Descriptor content (min rank1 rank2) noMark Nothing



-- ACTUALLY UNIFY THINGS


guardedUnify :: Variable -> Variable -> Unify ()
guardedUnify left right =
  Unify $ \vars ok err ->
    do  equivalent <- UF.equivalent left right
        if equivalent
          then ok vars ()
          else
            do  leftDesc <- UF.get left
                rightDesc <- UF.get right
                case actuallyUnify (Context left leftDesc right rightDesc) of
                  Unify k ->
                    k vars ok err


subUnify :: Variable -> Variable -> Unify ()
subUnify var1 var2 =
  guardedUnify var1 var2


actuallyUnify :: Context -> Unify ()
actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
  case firstContent of
    FlexVar _ ->
        unifyFlex context firstContent secondContent

    FlexSuper super _ ->
        unifyFlexSuper context super firstContent secondContent

    RigidVar _ ->
        unifyRigid context Nothing firstContent secondContent

    RigidSuper super _ ->
        unifyRigid context (Just super) firstContent secondContent

    Alias home name args realVar ->
        unifyAlias context home name args realVar secondContent

    Structure flatType ->
        unifyStructure context flatType firstContent secondContent

    Error ->
        -- If there was an error, just pretend it is okay. This lets us avoid
        -- "cascading" errors where one problem manifests as multiple message.
        merge context Error



-- UNIFY FLEXIBLE VARIABLES


unifyFlex :: Context -> Content -> Content -> Unify ()
unifyFlex context content otherContent =
  case otherContent of
    Error ->
        merge context Error

    FlexVar maybeName ->
        merge context $
          case maybeName of
            Nothing ->
              content

            Just _ ->
              otherContent

    FlexSuper _ _ ->
        merge context otherContent

    RigidVar _ ->
        merge context otherContent

    RigidSuper _ _ ->
        merge context otherContent

    Alias _ _ _ _ ->
        merge context otherContent

    Structure _ ->
        merge context otherContent



-- UNIFY RIGID VARIABLES


unifyRigid :: Context -> Maybe SuperType -> Content -> Content -> Unify ()
unifyRigid context maybeSuper content otherContent =
  case otherContent of
    FlexVar _ ->
        merge context content

    FlexSuper otherSuper _ ->
        case maybeSuper of
          Just super ->
            if combineRigidSupers super otherSuper then
              merge context content
            else
              mismatch

          Nothing ->
            mismatch

    RigidVar _ ->
        mismatch

    RigidSuper _ _ ->
        mismatch

    Alias _ _ _ _ ->
        mismatch

    Structure _ ->
        mismatch

    Error ->
        merge context Error



-- UNIFY SUPER VARIABLES


unifyFlexSuper :: Context -> SuperType -> Content -> Content -> Unify ()
unifyFlexSuper context super content otherContent =
  case otherContent of
    Structure flatType ->
        unifyFlexSuperStructure context super flatType

    RigidVar _ ->
        mismatch

    RigidSuper otherSuper _ ->
        if combineRigidSupers otherSuper super then
            merge context otherContent
        else
            mismatch

    FlexVar _ ->
        merge context content

    FlexSuper otherSuper _ ->
      case super of
        Number ->
          case otherSuper of
            Number     -> merge context content
            Comparable -> merge context content
            Appendable -> mismatch
            CompAppend -> mismatch

        Comparable ->
          case otherSuper of
            Comparable -> merge context otherContent
            Number     -> merge context otherContent
            Appendable -> merge context (Type.unnamedFlexSuper CompAppend)
            CompAppend -> merge context otherContent

        Appendable ->
          case otherSuper of
            Appendable -> merge context otherContent
            Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
            CompAppend -> merge context otherContent
            Number     -> mismatch

        CompAppend ->
          case otherSuper of
            Comparable -> merge context content
            Appendable -> merge context content
            CompAppend -> merge context content
            Number     -> mismatch

    Alias _ _ _ realVar ->
        subUnify (_first context) realVar

    Error ->
        merge context Error


combineRigidSupers :: SuperType -> SuperType -> Bool
combineRigidSupers rigid flex =
  rigid == flex
  || (rigid == Number && flex == Comparable)
  || (rigid == CompAppend && (flex == Comparable || flex == Appendable))


atomMatchesSuper :: SuperType -> ModuleName.Canonical -> Name.Name -> Bool
atomMatchesSuper super home name =
  case super of
    Number ->
      isNumber home name

    Comparable ->
      isNumber home name
      || Error.isString home name
      || Error.isChar home name

    Appendable ->
      Error.isString home name

    CompAppend ->
      Error.isString home name


isNumber :: ModuleName.Canonical -> Name.Name -> Bool
isNumber home name =
  home == ModuleName.basics
  &&
  (name == Name.int || name == Name.float)


unifyFlexSuperStructure :: Context -> SuperType -> FlatType -> Unify ()
unifyFlexSuperStructure context super flatType =
  case flatType of
    App1 home name [] ->
      if atomMatchesSuper super home name then
        merge context (Structure flatType)
      else
        mismatch

    App1 home name [variable] | home == ModuleName.list && name == Name.list ->
      case super of
        Number ->
            mismatch

        Appendable ->
            merge context (Structure flatType)

        Comparable ->
            do  comparableOccursCheck context
                unifyComparableRecursive variable
                merge context (Structure flatType)

        CompAppend ->
            do  comparableOccursCheck context
                unifyComparableRecursive variable
                merge context (Structure flatType)

    Tuple1 a b maybeC ->
      case super of
        Number ->
            mismatch

        Appendable ->
            mismatch

        Comparable ->
            do  comparableOccursCheck context
                unifyComparableRecursive a
                unifyComparableRecursive b
                case maybeC of
                  Nothing -> return ()
                  Just c  -> unifyComparableRecursive c
                merge context (Structure flatType)

        CompAppend ->
            mismatch

    _ ->
      mismatch


-- TODO: is there some way to avoid doing this?
-- Do type classes require occurs checks?
comparableOccursCheck :: Context -> Unify ()
comparableOccursCheck (Context _ _ var _) =
  Unify $ \vars ok err ->
    do  hasOccurred <- Occurs.occurs var
        if hasOccurred
          then err vars ()
          else ok vars ()


unifyComparableRecursive :: Variable -> Unify ()
unifyComparableRecursive var =
  do  compVar <- register $
        do  (Descriptor _ rank _ _) <- UF.get var
            UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
      guardedUnify compVar var



-- UNIFY ALIASES


unifyAlias :: Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Variable)] -> Variable -> Content -> Unify ()
unifyAlias context home name args realVar otherContent =
  case otherContent of
    FlexVar _ ->
      merge context (Alias home name args realVar)

    FlexSuper _ _ ->
      subUnify realVar (_second context)

    RigidVar _ ->
      subUnify realVar (_second context)

    RigidSuper _ _ ->
      subUnify realVar (_second context)

    Alias otherHome otherName otherArgs otherRealVar ->
      if name == otherName && home == otherHome then
        Unify $ \vars ok err ->
          let
            ok1 vars1 () =
              case merge context otherContent of
                Unify k ->
                  k vars1 ok err
          in
          unifyAliasArgs vars context args otherArgs ok1 err

      else
        subUnify realVar otherRealVar

    Structure _ ->
      subUnify realVar (_second context)

    Error ->
      merge context Error


unifyAliasArgs :: [Variable] -> Context -> [(Name.Name,Variable)] -> [(Name.Name,Variable)] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r
unifyAliasArgs vars context args1 args2 ok err =
  case args1 of
    (_,arg1):others1 ->
      case args2 of
        (_,arg2):others2 ->
          case subUnify arg1 arg2 of
            Unify k ->
              k vars
                (\vs () -> unifyAliasArgs vs context others1 others2 ok err)
                (\vs () -> unifyAliasArgs vs context others1 others2 err err)

        _ ->
          err vars ()

    [] ->
      case args2 of
        [] ->
          ok vars ()

        _ ->
          err vars ()



-- UNIFY STRUCTURES


unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
unifyStructure context flatType content otherContent =
  case otherContent of
    FlexVar _ ->
        merge context content

    FlexSuper super _ ->
        unifyFlexSuperStructure (reorient context) super flatType

    RigidVar _ ->
        mismatch

    RigidSuper _ _ ->
        mismatch

    Alias _ _ _ realVar ->
        subUnify (_first context) realVar

    Structure otherFlatType ->
        case (flatType, otherFlatType) of
          (App1 home name args, App1 otherHome otherName otherArgs) | home == otherHome && name == otherName ->
              Unify $ \vars ok err ->
                let
                  ok1 vars1 () =
                    case merge context otherContent of
                      Unify k ->
                        k vars1 ok err
                in
                unifyArgs vars context args otherArgs ok1 err

          (Fun1 arg1 res1, Fun1 arg2 res2) ->
              do  subUnify arg1 arg2
                  subUnify res1 res2
                  merge context otherContent

          (EmptyRecord1, EmptyRecord1) ->
              merge context otherContent

          (Record1 fields ext, EmptyRecord1) | Map.null fields ->
              subUnify ext (_second context)

          (EmptyRecord1, Record1 fields ext) | Map.null fields ->
              subUnify (_first context) ext

          (Record1 fields1 ext1, Record1 fields2 ext2) ->
              Unify $ \vars ok err ->
                do  structure1 <- gatherFields fields1 ext1
                    structure2 <- gatherFields fields2 ext2
                    case unifyRecord context structure1 structure2 of
                      Unify k ->
                        k vars ok err

          (Tuple1 a b Nothing, Tuple1 x y Nothing) ->
              do  subUnify a x
                  subUnify b y
                  merge context otherContent

          (Tuple1 a b (Just c), Tuple1 x y (Just z)) ->
              do  subUnify a x
                  subUnify b y
                  subUnify c z
                  merge context otherContent

          (Unit1, Unit1) ->
              merge context otherContent

          _ ->
              mismatch

    Error ->
        merge context Error



-- UNIFY ARGS


unifyArgs :: [Variable] -> Context -> [Variable] -> [Variable] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r
unifyArgs vars context args1 args2 ok err =
  case args1 of
    arg1:others1 ->
      case args2 of
        arg2:others2 ->
          case subUnify arg1 arg2 of
            Unify k ->
              k vars
                (\vs () -> unifyArgs vs context others1 others2 ok err)
                (\vs () -> unifyArgs vs context others1 others2 err err)

        _ ->
          err vars ()

    [] ->
      case args2 of
        [] ->
          ok vars ()

        _ ->
          err vars ()



-- UNIFY RECORDS


unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2) =
  let
    sharedFields = Map.intersectionWith (,) fields1 fields2
    uniqueFields1 = Map.difference fields1 fields2
    uniqueFields2 = Map.difference fields2 fields1
  in
  if Map.null uniqueFields1 then

    if Map.null uniqueFields2 then
      do  subUnify ext1 ext2
          unifySharedFields context sharedFields Map.empty ext1

    else
      do  subRecord <- fresh context (Structure (Record1 uniqueFields2 ext2))
          subUnify ext1 subRecord
          unifySharedFields context sharedFields Map.empty subRecord

  else

    if Map.null uniqueFields2 then
      do  subRecord <- fresh context (Structure (Record1 uniqueFields1 ext1))
          subUnify subRecord ext2
          unifySharedFields context sharedFields Map.empty subRecord

    else
      do  let otherFields = Map.union uniqueFields1 uniqueFields2
          ext <- fresh context Type.unnamedFlexVar
          sub1 <- fresh context (Structure (Record1 uniqueFields1 ext))
          sub2 <- fresh context (Structure (Record1 uniqueFields2 ext))
          subUnify ext1 sub2
          subUnify sub1 ext2
          unifySharedFields context sharedFields otherFields ext


unifySharedFields :: Context -> Map.Map Name.Name (Variable, Variable) -> Map.Map Name.Name Variable -> Variable -> Unify ()
unifySharedFields context sharedFields otherFields ext =
  do  matchingFields <- Map.traverseMaybeWithKey unifyField sharedFields
      if Map.size sharedFields == Map.size matchingFields
        then merge context (Structure (Record1 (Map.union matchingFields otherFields) ext))
        else mismatch


unifyField :: Name.Name -> (Variable, Variable) -> Unify (Maybe Variable)
unifyField _ (actual, expected) =
  Unify $ \vars ok _ ->
    case subUnify actual expected of
      Unify k ->
        k vars
          (\vs () -> ok vs (Just actual))
          (\vs () -> ok vs Nothing)



-- GATHER RECORD STRUCTURE


data RecordStructure =
  RecordStructure
    { _fields :: Map.Map Name.Name Variable
    , _extension :: Variable
    }


gatherFields :: Map.Map Name.Name Variable -> Variable -> IO RecordStructure
gatherFields fields variable =
  do  (Descriptor content _ _ _) <- UF.get variable
      case content of
        Structure (Record1 subFields subExt) ->
            gatherFields (Map.union fields subFields) subExt

        Alias _ _ _ var ->
            -- TODO may be dropping useful alias info here
            gatherFields fields var

        _ ->
            return (RecordStructure fields variable)



================================================
FILE: compiler/src/Type/UnionFind.hs
================================================
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Type.UnionFind
  ( Point
  , fresh
  , union
  , equivalent
  , redundant
  , get
  , set
  , modify
  )
  where


{- This is based on the following implementations:

  - https://hackage.haskell.org/package/union-find-0.2/docs/src/Data-UnionFind-IO.html
  - http://yann.regis-gianas.org/public/mini/code_UnionFind.html

It seems like the OCaml one came first, but I am not sure.

Compared to the Haskell implementation, the major changes here include:

  1. No more reallocating PointInfo when changing the weight
  2. Using the strict modifyIORef

-}


import Control.Monad ( when )
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.Word (Word32)



-- POINT


newtype Point a =
  Pt (IORef (PointInfo a))
  deriving Eq


data PointInfo a
  = Info {-# UNPACK #-} !(IORef Word32) {-# UNPACK #-} !(IORef a)
  | Link {-# UNPACK #-} !(Point a)



-- HELPERS


fresh :: a -> IO (Point a)
fresh value =
  do  weight <- newIORef 1
      desc <- newIORef value
      link <- newIORef (Info weight desc)
      return (Pt link)


repr :: Point a -> IO (Point a)
repr point@(Pt ref) =
  do  pInfo <- readIORef ref
      case pInfo of
        Info _ _ ->
          return point

        Link point1@(Pt ref1) ->
          do  point2 <- repr point1
              when (point2 /= point1) $
                do  pInfo1 <- readIORef ref1
                    writeIORef ref pInfo1
              return point2


get :: Point a -> IO a
get point@(Pt ref) =
  do  pInfo <- readIORef ref
      case pInfo of
        Info _ descRef ->
          readIORef descRef

        Link (Pt ref1) ->
          do  link' <- readIORef ref1
              case link' of
                Info _ descRef ->
                  readIORef descRef

                Link _ ->
                  get =<< repr point


set :: Point a -> a -> IO ()
set point@(Pt ref) newDesc =
  do  pInfo <- readIORef ref
      case pInfo of
        Info _ descRef ->
          writeIORef descRef newDesc

        Link (Pt ref1) ->
          do  link' <- readIORef ref1
              case link' of
                Info _ descRef ->
                  writeIORef descRef newDesc

                Link _ ->
                  do  newPoint <- repr point
                      set newPoint newDesc


modify :: Point a -> (a -> a) -> IO ()
modify point@(Pt ref) func =
  do  pInfo <- readIORef ref
      case pInfo of
        Info _ descRef ->
          modifyIORef' descRef func

        Link (Pt ref1) ->
          do  link' <- readIORef ref1
              case link' of
                Info _ descRef ->
                  modifyIORef' descRef func

                Link _ ->
                  do  newPoint <- repr point
                      modify newPoint func


union :: Point a -> Point a -> a -> IO ()
union p1 p2 newDesc =
  do  point1@(Pt ref1) <- repr p1
      point2@(Pt ref2) <- repr p2

      Info w1 d1 <- readIORef ref1
      Info w2 d2 <- readIORef ref2

      if point1 == point2
        then writeIORef d1 newDesc
        else do
          weight1 <- readIORef w1
          weight2 <- readIORef w2

          let !newWeight = weight1 + weight2

          if weight1 >= weight2
            then
              do  writeIORef ref2 (Link point1)
                  writeIORef w1 newWeight
                  writeIORef d1 newDesc
            else
              do  writeIORef ref1 (Link point2)
                  writeIORef w2 newWeight
                  writeIORef d2 newDesc


equivalent :: Point a -> Point a -> IO Bool
equivalent p1 p2 =
  do  v1 <- repr p1
      v2 <- repr p2
      return (v1 == v2)


redundant :: Point a -> IO Bool
redundant (Pt ref) =
  do  pInfo <- readIORef ref
      case pInfo of
        Info _ _ ->
          return False

        Link _ ->
          return True


================================================
FILE: docs/elm.json/application.md
================================================
# `elm.json` for applications

This is a decent baseline for pretty much any applications made with Elm. You will need these dependencies or more.

```json
{
    "type": "application",
    "source-directories": [
        "src"
    ],
    "elm-version": "0.19.1",
    "dependencies": {
        "direct": {
            "elm/browser": "1.0.0",
            "elm/core": "1.0.0",
            "elm/html": "1.0.0",
            "elm/json": "1.0.0"
        },
        "indirect": {
            "elm/time": "1.0.0",
            "elm/url": "1.0.0",
            "elm/virtual-dom": "1.0.0"
        }
    },
    "test-dependencies": {
        "direct": {},
        "indirect": {}
    }
}
```





## `"type"`

Either `"application"` or `"package"`. All the other fields are based on this choice!





## `"source-directories"`

A list of directories where Elm code lives. Most projects just use `"src"` for everything.





## `"elm-version"`

The exact version of Elm this builds with. Should be `"0.19.1"` for most people!





## `"dependencies"`

All the packages you depend upon. We use exact versions, so your `elm.json` file doubles as a "lock file" that ensures reliable builds.

You can use modules from any `"direct"` dependency in your code. Some `"direct"` dependencies have their own dependencies that folks typically do not care about. These are the `"indirect"` dependencies. They are listed explicitly so that (1) builds are reproducible and (2) you can easily review the quantity and quality of dependencies.

**Note:** We plan to eventually have a screen in `reactor` that helps add, remove, and upgrade packages. It can sometimes be tricky to keep all of the constraints happy, so we think having a UI will help a lot. If you get into trouble in the meantime, adding things back one-by-one often helps, and I hope you do not get into trouble!





## `"test-dependencies"`

All the packages that you use in `tests/` with `elm-test` but not in the application you actually want to ship. This also uses exact versions to make tests more reliable.


================================================
FILE: docs/elm.json/package.md
================================================
# `elm.json` for packages

This is roughly `elm.json` for the `elm/json` package:

```json
{
    "type": "package",
    "name": "elm/json",
    "summary": "Encode and decode JSON values",
    "license": "BSD-3-Clause",
    "version": "1.0.0",
    "exposed-modules": [
        "Json.Decode",
        "Json.Encode"
    ],
    "elm-version": "0.19.0 <= v < 0.20.0",
    "dependencies": {
        "elm/core": "1.0.0 <= v < 2.0.0"
    },
    "test-dependencies": {}
}
```





## `"type"`

Either `"application"` or `"package"`. All the other fields are based on this choice.





## `"name"`

The name of a GitHub repo like `"elm-lang/core"` or `"rtfeldman/elm-css"`.

> **Note:** We currently only support GitHub repos to ensure that there are no author name collisions. This seems like a pretty tricky problem to solve in a pleasant way. For example, do we have to keep an author name registry and give them out as we see them? But if someone is the same person on two platforms? And how to make this all happen in a way this is really nice for typical Elm users? Etc. So adding other hosting endpoints is harder than it sounds.





## `"summary"`

A short summary that will appear on [`package.elm-lang.org`](https://package.elm-lang.org/) that describes what the package is for. Must be under 80 characters.





## `"license"`

An OSI approved SPDX code like `"BSD-3-Clause"` or `"MIT"`. These are the two most common licenses in the Elm ecosystem, and BSD-3-Clause is a good default. But you can see the full list of options [here](https://spdx.org/licenses/).





## `"version"`

All packages start at `"1.0.0"` and from there, Elm automatically enforces semantic versioning by comparing API changes.

So if you make a PATCH change and call `elm bump` it will update you to `"1.0.1"`. And if you then decide to remove a function (a MAJOR change) and call `elm bump` it will update you to `"2.0.0"`. Etc.





## `"exposed-modules"`

A list of modules that will be exposed to people using your package. The order you list them will be the order they appear on [`package.elm-lang.org`](https://package.elm-lang.org/).

**Note:** If you have five or more modules, you can use a labelled list like [this](https://github.com/elm-lang/core/blob/master/elm.json). We show the labels on the package website to help people sort through larger packages with distinct categories. Labels must be under 20 characters.





## `"elm-version"`

The range of Elm compilers that work with your package. Right now `"0.19.0 <= v < 0.20.0"` is always what you want for this.





## `"dependencies"`

A list of packages that you depend upon. In each application, there can only be one version of each package, so wide ranges are great. Fewer dependencies is even better though!

> **Note:** Dependency ranges should only express _tested_ ranges. It is not nice to use optimistic ranges and end up causing build failures for your users down the line. Eventually we would like to have an automated system that tries to build and test packages as new packages come out. If it all works, we could send a PR to the author widening the range.





## `"test-dependencies"`

Dependencies that are only used in the `tests/` directory by `elm test`. Values from these packages will not appear in any final build artifacts.


================================================
FILE: docs/upgrade-instructions/0.16.md
================================================
# Upgrading to 0.16

Upgrading should be pretty easy. Everything is quite mechanical, so I would not be very afraid of this process.


## Update elm-package.json

First thing you want to do is update your `elm-package.json` file. The fields that need work are `repository`, `elm-version`, and `dependencies`.

If you have some dummy information in `repository`, something like `https://github.com/USER/PROJECT.git`, you will need to change it such that the project is all lower case. This should work: `https://github.com/user/project.git`.

Here is a working `elm-version`:

```json
{
    "elm-version": "0.16.0 <= v < 0.17.0"
}
```

Here are the latest bounds for a bunch of `dependencies`.

```json
{
    "dependencies": {
        "elm-lang/core": "3.0.0 <= v < 4.0.0",
        "evancz/elm-effects": "2.0.1 <= v < 3.0.0",
        "evancz/elm-html": "4.0.2 <= v < 5.0.0",
        "evancz/elm-http": "3.0.0 <= v < 4.0.0",
        "evancz/elm-markdown": "2.0.0 <= v < 3.0.0",
        "evancz/elm-svg": "2.0.1 <= v < 3.0.0",
        "evancz/start-app": "2.0.2 <= v < 3.0.0"
    },
}
```

The easiest way to get this all set up is to remove everything from `dependencies` and just install the things you need one at a time with `elm-package install`.


## Updating Syntax

The major syntax changes are:




  

    feature
    0.15.1 
    0.16
  


  

    field update
    
{ record | x <- 42 }

    
{ record | x = 42 }

  


  

    field addition
    
{ record | x = 42 }

    removed
  


  

    field deletion
    
{ record - x }

    removed
  


  

    record constructors that add fields
    

type alias Named r =
  { r | name : String }
  
-- generates a function like this:
-- Named : String -> r -> Named r


    		
    

type alias Named r =
  { r | name : String }


Generates no function. Field addition is gone. A function
will still be generated for "closed" records though.
    		
  


  

    field parameters
    

type alias Foo =
  { prefix : String -> String }

foo : Foo
foo = { prefix x = "prefix" ++ x }


    		
    

type alias Foo =
  { prefix : String -> String }

foo : Foo
foo = { prefix = \x-> "prefix" ++ x }
    

  


  

    multi-way if
    

if | x < 0 -> "left"
   | x > 0 -> "right"
   | otherwise -> "neither"


    		
    

if x < 0 then
    "left"

else if x > 0 then
    "right"

else
    "neither"


    		
  




The most common by far should be the record update change. That was the only syntax that used the `<-` operator, so you can pretty safely do a find-and-replace from `<-` to `=` and be all set.

The multi-way if is also pretty easy. You just translate it into the equivalent `if/then/else` construct. As you are doing this, notice the style used. It should look quite a bit like Python or any C-like language really. You start with an `if` and do `else if` until you are done. The body of each branch should be indented and things look way nicer if you have a blank line between each branch. I sometimes put a blank line above and below each branch, especially when the branch is more complex.

If you are using field addition and deletion, it is possible to translate your code into:

  1. A union type that models things with a simpler API, like [in this case](https://github.com/elm-lang/elm-compiler/issues/985#issuecomment-121927230).
  2. Nesting records instead of adding things onto them. Rather than adding a field, create an outer record that contains a field for the two things you are trying to put together. This seems to lead to nicer code in the long run.


## Incomplete Pattern Matches

As of 0.16, incomplete pattern matches are caught at compile time as errors. This is true both of `case` expressions and function arguments.

As I updated things, I ran into this only when I had been tricky with `Maybe` and `List` where I knew something about their structure based on some incidental details. The nicest example of this was [some code in package.elm-lang.org](https://gist.github.com/evancz/e590750a5bd1ea04c2d2) where the priority has often been "get it working" over "excellent quality code".

The compiler should give you pretty nice hints in all these cases, so I think the best advice is just to expect this sort of thing and treat it as an oppurtunity to clean your code up a bit where you were being tricky.


## Updating Library Usages

There is not actually a lot that changed in `elm-lang/core` and in `evancz/*` libraries.

The most noticable removals will be:

  * `Basics.otherwise`
  * `Signal.(<~)`
  * `Signal.(~)`

`otherwise` is gone because it is very useless without the multi-way if syntax.

Removing `(<~)` and `(~)` is in the spirit of "infix functions should be avoided" and the overall move towards removing redundant and ugly syntax in this release. You can instead use `Signal.mapN` to fill the void here. If you are combining a ton of signals, you can redefine the equivalent of `(~)` like this:

```elm
andMap : Signal (a -> b) -> Signal a -> Signal b
andMap =
  Signal.map2 (<|)
```

Otherwise it is pretty much all small bug fixes and improvements to documentation.


================================================
FILE: docs/upgrade-instructions/0.17.md
================================================

# Upgrading to 0.17

Upgrading should be pretty easy. Everything is quite mechanical, so I would not be very afraid of this process.


## Update elm-package.json

Some core packages have been renamed:

  - `evancz/elm-html` is now `elm-lang/html`
  - `evancz/elm-svg` is now `elm-lang/svg`
  - `evancz/virtual-dom` is now `elm-lang/virtual-dom`
  - The functionality of `evancz/start-app` now lives in `elm-lang/html` in `Html.App`
  - The functionality of `evancz/elm-effects` now lives in `elm-lang/core` in `Platform.*`
  - The functionality of `Graphics.*` now lives in `evancz/elm-graphics`

So the first thing you want to do is update your `elm-package.json` file. Here is one that has been properly updated:

```json
{
    "version": "1.0.0",
    "summary": "let people do a cool thing in a fun way",
    "repository": "https://github.com/user/project.git",
    "license": "BSD3",
    "source-directories": [
        "src"
    ],
    "exposed-modules": [],
    "dependencies": {
        "elm-lang/core": "4.0.0 <= v < 5.0.0",
        "elm-lang/html": "1.0.0 <= v < 2.0.0",
        "evancz/elm-http": "3.0.1 <= v < 4.0.0",
        "evancz/elm-markdown": "3.0.0 <= v < 4.0.0"
    },
    "elm-version": "0.17.0 <= v < 0.18.0"
}
```

The only changes should be in the `dependencies` and `elm-version` fields where you need to update constraints. The easiest way to get this all set up is to update `elm-version` by hand, and then remove everything from `dependencies` so you can install the dependencies you still need one at a time with `elm package install`.


## Updating Syntax

The major syntax changes are:




  

    feature
    0.16
    0.17
  


  

    module declaration
    
module Queue (..) where

    
module Queue exposing (..)

  




This is a super easy change, so we will add a link to an auto-upgrade tool here when one exists.


## `Action` is now `Msg`

The Elm Architecture tutorial uses the term `Action` for the data that gets fed into your `update` function. This is a silly name. So in 0.17 the standard name is *message*.

```elm
-- 0.16
type Action = Increment | Decrement

-- 0.17
type Msg = Increment | Decrement
```

The idea is that your app is receiving *messages* from the user, from servers, from the browser, etc. Your app then reacts to these messages in the `update` function.


## No More `Signal.Address`

The most common thing in your code will probably be that `Signal.Address` no longer exists. Here is a before and after of upgrading some typical `view` code.

```elm
-- 0.16
view : Signal.Address Action -> Model -> Html
view address model =
  div []
    [ button [ onClick address Decrement ] [ text "-" ]
    , div [ countStyle ] [ text (toString model) ]
    , button [ onClick address Increment ] [ text "+" ]
    ]

-- 0.17
view : Model -> Html Msg
view model =
  div []
    [ button [ onClick Decrement ] [ text "-" ]
    , div [ countStyle ] [ text (toString model) ]
    , button [ onClick Increment ] [ text "+" ]
    ]
```

This change is pretty simple. Any occurance of `address` just gets deleted. In the types, you see the addresses removed, and `Html` becomes `Html Msg`. You can read `Html Msg` as "an HTML node that can produce messages of type `Msg`". This change makes addresses unnecessary and makes it much clearer what kind of messages can be produced by a particular block of HTML.

The `Signal.forwardTo` function is replaced by `Html.App.map`. So you may need to make changes like this:

```elm
-- 0.16
view : Signal.Address Action -> Model -> Html
view address model =
  div []
    [ Counter.view (Signal.forwardTo address Top) model.topCounter
    , Counter.view (Signal.forwardTo address Bottom) model.bottomCounter
    , button [ onClick address Reset ] [ text "RESET" ]
    ]

-- 0.17
view : Model -> Html Msg
view model =
  div []
    [ map Top (Counter.view model.topCounter)
    , map Bottom (Counter.view model.bottomCounter)
    , button [ onClick Reset ] [ text "RESET" ]
    ]
```

These changes are nice for a couple really good reasons:

  - Addresses were consistently one of the things that new folks found most confusing.
  - It allows the `elm-lang/virtual-dom` implementation to be more efficient with `lazy`
  - It uses a normal `map` instead of some unfamiliar API.

You can see more examples of the new HTML API [here](https://evancz.gitbooks.io/an-introduction-to-elm/content/architecture/user_input/index.html).


## `Effects` is now `Cmd`

If you are working with HTTP or anything, you are probably using `evancz/elm-effects` and have your `update` function returning `Effects` values. That library was a successful experiment, so it has been folded into `elm-lang/core` and given a name that works better in the context of Elm 0.17.

The changes are basically a simple rename:

```elm
-- 0.16
update : Action -> Model -> (Model, Effects Action)
update action model =
  case action of
    RequestMore ->
      (model, getRandomGif model.topic)

    NewGif maybeUrl ->
      ( Model model.topic (Maybe.withDefault model.gifUrl maybeUrl)
      , Effects.none
      )

-- 0.17
update : Msg -> Model -> (Model, Cmd Msg)
update msg model =
  case msg of
    RequestMore ->
      ( model, getRandomGif model.topic )

    NewGif maybeUrl ->
      ( Model model.topic (Maybe.withDefault model.gifUrl maybeUrl)
      , Cmd.none
      )
```

The `Cmd` stuff lives in `elm-lang/core` in `Platform.Cmd`. It is imported by default with `import Platform.Cmd as Cmd exposing (Cmd)` to make it easier to use.

Again, very easy changes. The key goal of 0.17 was to manage effects in a nicer way, so in making these facilities more complete, the term `Effects` became very ambiguous. You should read more about this in the updated Elm Architecture Tutorial which has [a section all about effects](https://evancz.gitbooks.io/an-introduction-to-elm/content/architecture/effects/index.html).


## `StartApp` is now `Html.App`

The `evancz/start-app` package was an experiment to help people get productive with Elm more quickly. It meant that newcomers could get really far with Elm without knowing a ton about signals, and it has been very effective. With 0.17, it has been folded in to `elm-lang/html` in the `Html.App` module.

Upgrading looks like this:

```elm
-- 0.16 ---------------------------------------
import StartApp
import Task

app =
  StartApp.start
    { init = init, update = update, view = view, inputs = [] }

main =
  app.html

port tasks : Signal (Task.Task Never ())
port tasks =
  app.tasks

-- 0.17 ---------------------------------------
import Html.App as Html

main =
  Html.program
    { init = init, update = update, view = view, subscriptions = \_ -> Sub.none }
```

The type of `main` has changed from `Signal Html` to `Program flags`. The main value is a program that knows exactly how it needs to be set up. All that will be handled by Elm, so you no longer need to specially hook tasks up to a port or anything.


## Upgrading Ports

Talking to JavaScript still uses ports. It is pretty similar, but adapted to fit nicely with commands and subscriptions.

Here is the change for *outgoing* ports:

```elm
-- 0.16
port focus : Signal String
port focus =
  ...

-- 0.17
port focus : String -> Cmd msg
```

Instead of hooking up a signal, you have a function that can create commands. So you just call `focus : String -> Cmd msg` from anywhere in your app and the command is processed like all the others.

And here is the change for *incoming* ports:

```elm
type User = { name : String, age : Int }

-- 0.16
port users : Signal User

-- 0.17
port users : (User -> msg) -> Sub msg
```

Instead of getting a signal to route to the right place, we now can create subscriptions to incoming ports. So wherever you need to know about users, you just subscribe to it.

You should definitely read more about this [here](https://evancz.gitbooks.io/an-introduction-to-elm/content/interop/javascript.html).


## JavaScript Interop

The style of initializing Elm programs in JS has also changed slightly.



  

    Initialize
    0.16
    0.17
  


  

    Embed
    
Elm.embed(Elm.Main, someNode);

    
Elm.Main.embed(someNode);

  


  

    Fullscreen
    
Elm.fullscreen(Elm.Main);

    
Elm.Main.fullscreen();

  

  
  

    Worker
    
Elm.worker(Elm.Main);

    
Elm.Main.worker();

  





## Next Steps

From here, I would highly recommend looking through [guide.elm-lang.org](http://guide.elm-lang.org/), particularly the sections on [The Elm Architecture](http://guide.elm-lang.org/architecture/index.html). This will help you get a feel for 0.17.


================================================
FILE: docs/upgrade-instructions/0.18.md
================================================
# Upgrading to 0.18

Like always, not that much has really changed. To make the process as smooth as possible, this document outlines all the things you will want to do to use 0.18.

  - [Update `elm-package.json`](#update-elm-packagejson)
  - [List Ranges](#list-ranges)
  - [No More Primes](#no-more-primes)
  - [Backticks and `andThen`](#backticks-and-andthen)
  - [Renamed Functions in Core](#renamed-functions-in-core)
  - [Package Changes](#package-changes)

A lot of this can be done automatically with [`elm-upgrade`](https://github.com/avh4/elm-upgrade#elm-upgrade), so check it out after reading through this document!


## Update elm-package.json

So the first thing you want to do is update your `elm-package.json` file. The only tricky thing is that the HTTP package moved:

  - `evancz/elm-http` => [`elm-lang/http`](http://package.elm-lang.org/packages/elm-lang/http/latest)

From there, here is an `elm-package.json` that has been properly updated:

```json
{
    "version": "1.0.0",
    "summary": "let people do a cool thing in a fun way",
    "repository": "https://github.com/user/project.git",
    "license": "BSD3",
    "source-directories": [
        "src"
    ],
    "exposed-modules": [],
    "dependencies": {
        "elm-lang/core": "5.0.0 <= v < 6.0.0",
        "elm-lang/html": "2.0.0 <= v < 3.0.0",
        "elm-lang/http": "1.0.0 <= v < 2.0.0",
        "evancz/elm-markdown": "3.0.1 <= v < 4.0.0"
    },
    "elm-version": "0.18.0 <= v < 0.19.0"
}
```

The only changes should be in the `dependencies` and `elm-version` fields where you need to update constraints.

The easiest way to get this all set up is to use [`elm-upgrade`](https://github.com/avh4/elm-upgrade#elm-upgrade), but you can also:

  - Update `elm-version` by hand.
  - Remove everything from `dependencies` by hand.
  - Install what you need with `elm-package install elm-lang/core` one-by-one.


## List Ranges

The `[1..5]` syntax has been removed.

So replace any occurance of `[1..9]` with `List.range 1 9`.


## No More Primes

You are not allowed to have primes in variable names, so things like `type'` are renamed to `type_`.


## Backticks and `andThen`

Elm used to let you take normal functions and use them as infix operators. This is most notable in the case of `andThen` which is pretty much the only function that used this feature. You will want to make the following updates to your code:

```elm
-- old

andThenIn17 : Result String Int
andThenIn17 =
  String.toInt "1234"
    `Result.andThen` \year -> isValidYear year

-- andThen : Result x a -> (a -> Result x b) -> Result x b


-- new

andThenIn18 : Result String Int
andThenIn18 =
  String.toInt "1234"
    |> Result.andThen (\year -> isValidYear year)

-- andThen : (a -> Result x b) -> Result x a -> Result x b
```

Notice that the backtick style is replaced by pipelining. The `onError` function has been flipped in the same way, so if you are working with tasks you may say something like this in 0.18:

```elm
type Msg = NewText String | DidNotLoad

tasksIn18 : Task x Msg
tasksIn18 =
  Http.toTask (Http.getString "http://example.com/war-and-peace")
    |> Task.andThen (\fullText -> Task.succeed (NewText fullText))
    |> Task.onError (\error -> Task.succeed DidNotLoad)
```

This also means that `andThen` and `onError` group together much better than in the infix style.

**This change should be happening across the entire Elm ecosystem as package authors upgrade to 0.18.**


## Renamed Functions in Core

A couple functions have been removed or renamed.

  - [`Json.Decode`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Json-Decode)
    - `objectN` becomes `mapN` (Note: `object1` becomes `map`) 
    - `tupleN` becomes `mapN` with `index`
    - `(:=)` becomes `field`
    - `andThen` args flip

  - [`Bitwise`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Bitwise)
    - `shiftLeft` becomes `shiftLeftBy` and args flip
    - `shiftRight` becomes `shiftRightBy` and args flip
    - `shiftRightLogical` becomes `shiftRightZfBy` and args flip

  - [`Task`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Task)
    - `andThen` args flip
    - `onError` args flip
    - Removed `perform : (x -> msg) -> (a -> msg) -> Task x a -> Cmd msg`
    - Added  `perform : (a -> msg) -> Task Never a -> Cmd msg`
    - Added  `attempt : (Result x a -> msg) -> Task x a -> Cmd msg`
    - Removed `toMaybe` and `toResult` in favor of using `onError` directly

  - [`Result`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Result)
    - Renamed `formatError` to `mapError` to match names in `Task`
    - `andThen` args flip

  - [`Maybe`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Maybe)
    - `andThen` args flip
    - Removed `oneOf`

  - [`Random`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Random)
    - `andThen` args flip

  - [`Tuple`](http://package.elm-lang.org/packages/elm-lang/core/5.0.0/Tuple)
    - `Basics.fst` becomes `Tuple.first`
    - `Basics.snd` becomes `Tuple.second`


## Package Changes

The following packages have changed a little bit:

  - [`elm-lang/html`](http://package.elm-lang.org/packages/elm-lang/html/latest) collapsed `Html.App` into `Html`. So you need to remove any `import Html.App` imports and refer to `Html.program` instead.

  - [`elm-lang/http`](http://package.elm-lang.org/packages/elm-lang/http/latest) was redone to be easier and have more features. It now supports tracking progress and rate-limiting HTTP requests. It should be pretty easy to upgrade to the new stuff, but if you have a complex `Task` that chains many requests, you will want to use the `Http.toTask` function to keep that code working the same.

  - [`elm-lang/navigation`](http://package.elm-lang.org/packages/elm-lang/navigation/latest) no longer has its own concept of a `Parser`. You just turn a `Navigation.Location` into a message and it is fed into your normal `update` function. This means `Navigation.program` is now much closer to `Html.program` so this should simplify things a bit.

  - [`evancz/url-parser`](http://package.elm-lang.org/packages/evancz/url-parser/latest) is pretty much the same, but works better and is friendlier. New things include:
    - You can use `` to parse query parameters.
    - Some bugs about parsing leading and trailing slashes are fixed.
    - The parser backtracks, always finding a valid parse of the URL if one exists.
    - You can use `parsePath` to parse a `Navigation.Location` directly.

In all cases, the packages have become simpler and easier to use. The actual changes did not seem to be too serious as I upgraded `elm-lang.org` and `package.elm-lang.org` and all the examples I control.


================================================
FILE: docs/upgrade-instructions/0.19.0.md
================================================
# Upgrading to 0.19

To make the process as smooth as possible, this document outlines all the things you need to do to upgrade to 0.19.

- [Command Line](#command-line)
- [`elm.json`](#elmjson)
- [Changes](#changes)
- [`--optimize`](#--optimize)
- [Compiler Performance](#compiler-performance)
- [Parse Errors](#parse-errors)
- [Stricter Record Update Syntax](#stricter-record-update-syntax)
- [Removed User-Defined Operators](#removed-user-defined-operators)

> **Note:** You can try out [`elm-upgrade`](https://github.com/avh4/elm-upgrade#elm-upgrade--) which automates some of the 0.18 to 0.19 changes. It is also in an alpha stage, and Aaron has said it makes sense to talk things through [here](https://github.com/avh4/elm-upgrade/issues).





## Command Line

There is now just one `elm` binary at the command line. The terminal commands are now:

```bash
# 0.19         # 0.18
elm make       # elm-make
elm repl       # elm-repl
elm reactor    # elm-reactor
elm install    # elm-package install
elm publish    # elm-package publish
elm bump       # elm-package bump
elm diff       # elm-package diff
```






## `elm.json`

`elm-package.json` becomes `elm.json` which is specialized for applications and packages. For example, it helps you lock your dependencies in applications and get broad dependency ranges in packages.

See the full outlines here:

  - `elm.json` for [applications](https://github.com/elm/compiler/blob/master/docs/elm.json/application.md)
  - `elm.json` for [packages](https://github.com/elm/compiler/blob/master/docs/elm.json/package.md)

Both are quite similar to the `elm-package.json` format, and `elm-upgrade` can help you with this.





## Changes

#### Functions Changed

- `String.toInt : String -> Maybe Int` (not `Result` anymore)
- `String.toFloat : String -> Maybe Float` (not `Result` anymore)
- `Basics.toString` becomes [`Debug.toString`](https://package.elm-lang.org/packages/elm/core/latest/Debug#toString), [`String.fromInt`](https://package.elm-lang.org/packages/elm/core/latest/String#fromInt), and [`String.fromFloat`](https://package.elm-lang.org/packages/elm/core/latest/String#fromFloat).
- `Basics.rem 451 10` becomes [`remainderBy 10 451`](https://package.elm-lang.org/packages/elm/core/latest/Basics#remainderBy)
- `451 % 10` becomes [`modBy 10 451`](https://package.elm-lang.org/packages/elm/core/latest/Basics#modBy)
- `(,)` becomes [`Tuple.pair`](https://package.elm-lang.org/packages/elm/core/latest/Tuple#pair)
- `style : List (String, String) -> Attribute msg` becomes `String -> String -> Attribute msg`
- `Html.beginnerProgram` becomes [`Browser.sandbox`](https://package.elm-lang.org/packages/elm/browser/latest/Browser#sandbox).
- `Html.program` becomes [`Browser.element`](https://package.elm-lang.org/packages/elm/browser/latest/Browser#element) and [`Browser.document`](https://package.elm-lang.org/packages/elm/browser/latest/Browser#document).


#### Modules Moved

- `Json.Encode` and `Json.Decode` moved to [`elm/json`](https://package.elm-lang.org/packages/elm/json/latest)
- `Time` and `Date` moved to [`elm/time`](https://package.elm-lang.org/packages/elm/time/latest/) with a significantly improved API
- `Random` moved to [`elm/random`](https://package.elm-lang.org/packages/elm/random/latest/) with a better implementation and a few new functions
- `Regex` moved to [`elm/regex`](https://package.elm-lang.org/packages/elm/regex/latest) with a much clearer README


#### Packages Moved

- `elm-lang/*` moved to `elm/*`
- `evancz/url-parser` moved to [`elm/url`](https://package.elm-lang.org/packages/elm/url/latest) with a simpler and more flexible API
- `elm-tools/elm-parser` moved to [`elm/parser`](https://package.elm-lang.org/packages/elm/parser/latest) with speed boost when compiling with the `--optimize` flag
- [`elm/browser`](https://package.elm-lang.org/packages/elm/browser/latest) combines and simplifies the following 0.18 packages:
  - `elm-lang/navigation` with smoother APIs
  - `elm-lang/dom` with ability to get node positions and dimensions.
  - `elm-lang/mouse` with decoders
  - `elm-lang/window`
  - `elm-lang/keyboard` uses decoders like [this](https://github.com/elm/browser/blob/master/notes/keyboard.md)
  - `elm-lang/page-visibility`
  - `elm-lang/animation-frame`


#### Functions Removed

- `uncurry`
- `curry`
- `flip`
- `(!)`

Prefer named helper functions in these cases.




## `--optimize`

You can now compile with `elm make --optimize` which enables things like:

- Reliable field name shortening in compiled assets
- Unbox things like `type Height = Height Float` to just be a float at runtime
- Unbox `Char` values
- Use more compact names for `type` constructors in compiled assets.

Some of these optimizations require "forgetting information" that is useful while debugging, so the `Debug` module becomes unavailable when you add the `--optimize` flag. The idea being that you want to be shipping code with this flag (like `-O2` in C) but not compiling with it all day in development.





## Compiler Performance

I did a bunch of performance optimizations for the compiler itself. For example:

- I rewrote the parser to be very significantly faster (partly by allocating very little!)
- I revamped how type inference looks up the type of foreign variables to be `O(1)` rather than `O(log(n))`
- I redid how code is generated to allow DCE with declarations as the level of granuality
- Packages are downloaded once per user and saved in `~/.elm/`
- Packages are built once for any given set of dependencies, so they do not contribute to build times of fresh projects.

Point is, the compiler is very significantly faster!






## Parse Errors

Part of rewriting the parser was making nicer parse errors. Many people only really see them when getting started, and rather than saying "man, these are terrible" they think "man, programming is hard" leading to a big underreporting of quality issues here. Anyway, please explore that a bit and see if you run into anything odd!





## Stricter Record Update Syntax

It used to be possible for `{ r | x = v }` to change the type of field `x`. This is no longer possible. This greatly improves the quality of error messages in many cases.

You can still change the type of a field, but you must reconstruct the record with the record literal syntax, or with a record constructor.

The idea is that 99.9% of uses get a much better experience with type errors, whereas 0.1% of uses become somewhat more verbose. As someone who had a bit of code that changed record types, I have found this to be a really excellent trade.





## Removed User-Defined Operators

It is no longer possible to define custom operators. For example, someone defined:

```elm
(|-~->) : (a -> a1_1 -> a3) -> (a2 -> a1_1) -> a -> a2 -> a3
```

They are still able to define that function, but it will need a human readable name that explains what it is meant to do. The reasoning behind this decision is outlined in detail in [this document](https://gist.github.com/evancz/769bba8abb9ddc3bf81d69fa80cc76b1).





## Notes:

- `toString` — A relatively common bug was to show an `Int` in the UI, and then later that value changes to something else. `toString` would just show wrong information until someone noticed. The new `String.fromInt` and `String.fromFloat` ensure that cannot happen. Furthermore, more elaborate types almost certainly need localization or internationalization, which should be handled differently anyway.


================================================
FILE: docs/upgrade-instructions/0.19.1.md
================================================
# Upgrading to 0.19.1

**There are no language changes**, so once you swap to `"elm-version": "0.19.1"` in your `elm.json`, most users should be able to proceed without any further code changes. **You may run into a handful of bugfixes though!** These cases are outlined below!





## Improvements

- Parse error message quality (like [this](https://github.com/elm/error-message-catalog/issues/255) and [this](https://github.com/elm/error-message-catalog/issues/225))
- Faster compilation, especially for incremental compiles
- Uses filelocks so that cached files are not corrupted when plugins run `elm make` multiple times on the same project at the same time. (Still worth avoiding that though!)
- More intuitive multiline declarations in REPL
- Various bug fixes (e.g. `--debug`, `x /= 0`, `type Height = Height Float` in `--optimize`)





## Detectable Bug Fixes

There are three known cases where code that compiled with 0.19.0 will not compile with 0.19.1 due to bug fixes:


### 1. Ambiguous Imports

Say you have an import like this:

```elm
import Html exposing (min)
import Regex exposing (never)

x = min
y = never
```

These should be reported as ambiguous usages since the names are also exposed by `Basics`, but there was a regression in 0.19.0 described [here](https://github.com/elm/compiler/issues/1945) such that they weren't caught in specific circumstances.

The fix is to use a qualified name like `Html.min` or `Regex.never` to make it unambiguous.

We found a couple instances of this in packages and have submitted PRs to the relevant authors in August 2019. You may run into this in your own code as well.

For more details on why this is considered a regression, check out the details [here](https://github.com/elm/compiler/issues/1945#issuecomment-507871919) or try it in 0.18.0 to see how it worked before.


### 2. Tabs in Comments

The 0.19.0 binaries did not catch tab characters in comments. The new parser is better at checking for tabs, so it will object when it finds these.

Again, we found this in some packages and reached out to the relevant authors with PRs so patches would be published before the 0.19.1 release.


### 3. Port Module with no Ports

If you have any files that start with:

```elm
port module Main exposing (..)
```

But they do not actually have any `port` declarations, the 0.19.1 binary will ask you to switch to a normal module declaration like `module Main exposing (..)`


================================================
FILE: docs/upgrade-instructions/earlier.md
================================================

# 0.16

Read all about it at these links:

  * http://elm-lang.org/blog/compilers-as-assistants
  * https://github.com/elm-lang/elm-platform/blob/master/upgrade-docs/0.16.md


# 0.15

### Improve Import Syntax

The changes in 0.14 meant that people were seeing pretty long import sections,
sometimes with two lines for a single module to bring it in qualified and to
expose some unqualified values. The new syntax is like this:

```elm
import List
  -- Just bring `List` into scope, allowing you to say `List.map`,
  -- `List.filter`, etc.

import List exposing (map, filter)
  -- Bring `List` into scope, but also bring in `map` and `filter`
  -- without any prefix.

import List exposing (..)
  -- Bring `List` into scope, and bring in all the values in the
  -- module without a prefix.

import List as L
  -- Bring `L` into scope, but not `List`. This lets you say `L.map`,
  -- `L.filter`, etc.

import List as L exposing (map, filter)
  -- Bring `L` into scope along with unqualified versions of `map`
  -- and `filter`.

import List as L exposing (..)
  -- Bring in all the values unqualified and qualified with `L`.
```

This means you are doing more with each import, writing less overall. It also
makes the default imports more comprehensive because you now can refer to
`List` and `Result` without importing them explicitly as they are in the
defaults.

### Revise Port Syntax

One common confusion with the `port` syntax is that the only difference
between incoming ports and outgoing ports is whether the type annotation comes
with a definition. To make things a bit clearer, we are using the keywords
`foreign input` and `foreign output`.

```elm
foreign input dbResults : Stream String

foreign output dbRequests : Stream String
foreign output dbRequests =
    Stream.map toRequest userNames
```

### Input / Output

The biggest change in 0.15 is the addition of tasks, allowing us to represent
arbitrary effects in Elm in a safe way. This parallels how ports work, so we
are trying to draw attention to that in syntax. First addition is a way to
create new inputs to an Elm program.

```elm
input actions : Input Action
```

This creates a `Input` that is made up of an `Address` you can send messages to
and a `Stream` of those messages. This is similar to a `foreign input` except
there we use the name as the address. The second addition is a way to run
tasks.

```elm
output Stream.map toRequest userNames
```

This lets us turn tasks into effects in the world. Sometimes it is useful to
pipe the results of these tasks back into Elm. For that, we have the third and
final addition.

```elm
input results : Stream (Result Http.Error String)
input results from
    Stream.map toRequest userNames
```

# 0.14.1

Modify default import of `List` to expose `(::)` as well.


# 0.14

### Breaking Changes

  * Keyword `data` renamed to `type`
  * Keyword `type` renamed to `type alias`


# 0.13

### Improvements:

  * Type aliases in port types 
  * Add Keyboard.alt and Keyboard.meta
  * Add Debug.crash, Debug.watch, Debug.watchSummary, and Debug.trace
  * Add List.indexedMap and List.filterMap
  * Add Maybe.map
  * Add Basics.negate
  * Add (>>) to Basics as in F#
  * Add --bundle-runtime flag which creates stand-alone Elm programs
  * Error on ambiguious use of imported variables
  * Replace dependency on Pandoc with cheapskate+kate
  * Better architecture for compiler. Uses types to make compilation pipeline
    safer, setting things up for giving programmatic access to the AST to
    improve editor and IDE support.

### Breaking Changes:

  * Rename (.) to (<<) as in F#
  * Rename Basics.id to Basics.identity
  * Rename Basics.div to (//)
  * Rename Basics.mod to (%)
  * Remove Maybe.justs for (List.filterMap identity)
  * Remove List.and for (List.foldl (&&) True)
  * Remove List.or  for (List.foldl (||) False)
  * Unambiguous syntax for importing ADTs and type aliases
  * sqrt and logBase both only work on Floats now

# 0.12.3

  * Minor changes to support webgl as a separate library
  * Switch from HSV to HSL
  * Programmatic access to colors with toHsl and toRgb

# 0.12.1

### Improvements:

  * New Array library (thanks entirely to @Xashili)
  * Json.Value can flow through ports
  * Improve speed and stack usage in List library (thanks to @maxsnew)
  * Add Dict.filter and Dict.partition (thanks to @hdgarrood)

### Breaking Changes:

  * Revamp Json library, simpler with better names
  * Revamp JavaScript.Experimental library to have slightly better names
  * Remove JavaScript library which was made redundant by ports

# 0.12

### Breaking Changes:

  * Overhaul Graphics.Input library (inspired by Spiros Eliopoulos and Jeff Smitts)
  * Overhaul Text library to accomodate new Graphics.Input.Field
    library and make the API more consistent overall
  * Overhaul Regex library (inspired by Attila Gazso)
  * Change syntax for "import open List" to "import List (..)"
  * Improved JSON format for types generated by elm-doc
  * Remove problematic Mouse.isClicked signal
  * Revise the semantics of keepWhen and dropWhen to only update when
    the filtered signal changes (thanks Max New and Janis Voigtländer)

### Improvements:

  * Add Graphics.Input.Field for customizable text fields
  * Add Trampoline library (thanks to @maxsnew and @timthelion) 
  * Add Debug library (inspired by @timthelion)
  * Drastically improved performance on markdown parsing (thanks to @Dandandan) 
  * Add Date.fromTime function
  * Use pointer-events to detect hovers on layered elements (thanks to @Xashili)
  * Fix bugs in Bitwise library
  * Fix bug when exporting Maybe values through ports

# 0.11

  * Ports, a new FFI that is more general and much nicer to use
  * Basic compiler tests (thanks to Max New)

# 0.10.1

  * sort, sortBy, sortWith (thanks to Max Goldstein)
  * elm-repl
  * Bitwise library
  * Regex library
  * Improve Transform2D library (thanks to Michael Søndergaard)

# 0.10

  * Native strings
  * Tango colors
  * custom precedence and associativity for infix operators
  * elm-doc released with new documentation format
  * Realiasing in type errors
  * Rename Matrix2D => Transform2D
  * Add Random.floatList (thank you Max GoldStein)
  * Fix remove function in Dict (thank you Max New)
  * Start using language-ecmascript for JS generation
  * Make compatable with cabal-1.18 (thank you Justin Leitgeb)
  * All functions with 10+ arguments (thanks to Max New)

# 0.9.1

  * Allow custom precedence and associativity for user-defined infix ops
  * Realias types before printing
  * Switch to Tango color scheme, adding a bunch of nice colors
  * add the greyscale function for easily producing greys
  * Check the type of main
  * Fix miscellaneous bugs in type checker
  * Switch name of Matrix2D to Transform2D

# 0.9

Build Improvements:
  * Major speed improvements to type-checker
  * Type-checker should catch _all_ type errors now
  * Module-level compilation, only re-compile if necessary
  * Import types and type aliases between modules
  * Intermediate files are generated to avoid unneeded recompilation
    and shorten compile time. These files go in ElmFiles/ by default
  * Generated files are placed in ElmFiles/ by default, replicating
    the directory structure of your source code.

Error Messages:
  * Cross-module type errors
  * Errors for undefined values
  * Pretty printing of expressions and types
 
Syntax:
  * Pattern matching on literals
  * Pattern aliases with `as` (Andrew)
  * Unary negation
  * Triple-quoted multi-line strings
  * Type annotations in let expressions (Andrew)
  * Record Constructors
  * Record type aliases can be closed on the zeroth column
  * (,,) syntax in types
  * Allow infix op definitions without args: (*) = add
  * Unparenthesized if, let, case, lambda at end of binary expressions

elm-server:
  * Build multi-module projects
  * Report all errors in browser

Libraries:
  * Detect hovering over any Element
  * Set alpha of arbitrary forms in collages
  * Switch Text.height to use px instead of em

Bug Fixes:
  * Many bug fixes for collage, especially when rendering Elements.

Website:
  * Hot-swapping
  * Much faster page load with pre-compiled Elm files (Max New)




forgot to fill this in again...


# 0.7.2

* Add a WebSockets library.
* Add support for the mathematical looking operator for function composition (U+2218).


forgot to fill this in for a while...


# 0.5.0

* Add Dict, Set, and Automaton libraries!

* Add (,,) notation for creating tuples.

* Redo HTTP library, allowing any kind of request and more flexibility.

* Remove the library prefixes `Data.`, `Graphics.`, and `Signal.` because
  they were more confusing than helpful.

* Better type error reporting for ambiguous uses of variables and for
  variables in aliased modules.

* Add `readInt` and `readFloat` functions.
* Add `complement` function to compute complementary colors.
* Ensure that `String` is treated as an alias of `[Char]`.

* Fix bug in pattern parsing. `A B _ _` was parsed as `A (B _ _)`.
* Make pattern matching a bit more compact in generated code.
* Make generated JS more readable.

* The Haskell API exports the absolute path to the Elm runtime
  system (with the corresponding version number). This makes it easier
  to run Elm programs with less setup.



# 0.4.0

This version is all about graphics: nicer API with more features and major
efficiency improvements. I am really excited about this release!

* Add native Markdown support. You can now embed markdown directly in .elm files
  and it is used as an `Element`. Syntax is `[markdown| ... |]` where `...` is
  formatted as described [here](http://daringfireball.net/projects/markdown/).
  Content can span multiple lines too.

* Drastically improve the `collage` interface. You can now move, rotate, and scale
  the following forms:
  - Elements (any Element you want can be turned into a Form with `toForm`)
  - Images
  - Shapes (shapes can be textured now too)
  - Lines
  This will make it way easier to make games in Elm. Games can now include text,
  gifs, videos, and any other Element you can think of.

* Add `--minify` flag, to minify JS code.

* Significantly improve performance of pattern matching.

* Compiler performs beta-reduction in some simple cases.

* The rendering section of the Elm runtume-system (RTS) has been totally rewritten,
  making screen refreshes use fewer cycles, less memory, and cause less garbage-collection.



# 0.3.6

* Add JSON library.

* Type-error messages improved. Gives better context for error, making them
  easier to find. Better messages for runtime errors as well (errors that
  the type checker cannot find yet).

* Add Comparable super-type which allows the comparision of any values
  of type {Int,Float,Char,String}. Now possible to make Set and Map libraries.

* Parser now handles decimal numbers.

* Added many new functions for manipulating numbers:
  - truncate, round, floor, ceiling :: Float -> Int
  - toFloat :: Int -> Float
  - (^) :: Number -> Number -> Number
  - e :: Float

* Foreign import/export statements no longer have to preceed all other
  variable and datatype definitions. They can be mixed in, making things
  a bit more readable/natural.

* Bug fixes:
  - The `toText` function did not escape strings properly
  - Correct `castJSTupleToTupleN` family of functions
  - `foldr1` took the leftmost element as the base case instead of the rightmost
  - Fix minor display issue in latest version of Chrome.
  - Fix behavior of [ lo .. hi ] syntax (now [4..0] == [], not [0]).



# 0.3.5

* Add JavaScript event interface. Allows Elm to import and export JS values
  and events. This makes it possible to import and export Elements, so users
  can use JS techniques and libraries if necessary. Conversion between JS
  and Elm values happens with functions from here:
    http://localhost:8000/docs/Foreign/JavaScript.elm
    http://localhost:8000/docs/Foreign/JavaScript/Experimental.elm

* Add new flags to help with JavaScript event interface.

* Add three built-in event listeners (elm_title, elm_log, elm_redirect) that
  make it possible to make some common/simple imperative actions without
  having to worry about writing the JS yourself. For example:
        foreign export jsevent "elm_title"
            title :: Signal JSString
  will update the page's title to the current value of the title signal.
  Empty strings are ignored. "elm_redirect" and "elm_log" events work much
  the same way, except that "elm_log" does not skip empty strings.

* Add new Signal functions:
    count       :: Signal a -> Signal Int
    keepIf      :: (a -> Bool) -> a -> Signal a -> Signal a
    dropIf      :: (a -> Bool) -> a -> Signal a -> Signal a
    keepWhen    :: Signal Bool -> a -> Signal a -> Signal a
    dropWhen    :: Signal Bool -> a -> Signal a -> Signal a
    dropRepeats :: Signal a -> Signal a
    sampleOn    :: Signal a -> Signal b -> Signal b
    clicks      :: Signal ()
  The keep and drop functions make it possible to filter events, which
  was not possible in prior releases. More documentation:
  http://elm-lang.org/docs/Signal/Signal.elm

* Add examples of JS event interface and new signal functions:
  https://github.com/evancz/Elm/tree/master/Examples/elm-js

* Use more compressed format for strings. Should make strings 10-12 times
  more space efficient than in previous releases. Anecdotal evidence:
  Elm's home page is now 70% of its previous size.

* Add new function to Data.List:
    last :: [a] -> a

* Fix parenthesization bug with binary operators.



# 0.3.0

### Major Changes (Read this part!)

* Add a basic module system.
* Elm's JavaScript runtime is now distributed with the elm package.
  Previously it was available for download as an unversioned JavaScript
  file (elm-mini.js). It is now installed with the elm compiler as
  elm-runtime-0.3.0.js. Be sure to serve the Elm runtime system that matches
  the version of the compiler used to generate JavaScript. When working
  locally, the compiler will automatically use your local copy of this file.
* BREAKING CHANGE: rgb and rgba (in the color module) now take their red,
  green, and blue components as integers between 0 and 255 inclusive.
* Improve error messages for parse errors and runtime errors.


### New Functions and Other Additions

* Add support for keyboard events: Keyboard.Raw
* Add buttons in Signal.Input:
  button :: String -> (Element, Signal Bool)
* Add new basic element (an empty rectangle, good for adding spaces):
  rectangle :: Int -> Int -> Element
* Add (an awkwardly named) way to display right justified text: rightedText
* Add two basic libraries: Data.Char and Data.Maybe
* Add some new colors: magenta, yellow, cyan, gray, grey
* Add functions to Data.List module: take, drop
* Add functions to Prelude (the default imports):
  fst, snd, curry, uncurry, and a bunch of list functions
* Add --make, --separate-js, and --only-js flags to help compile
  with the new module system.


================================================
FILE: elm.cabal
================================================

Name: elm
Version: 0.19.1

Synopsis:
    The `elm` command line interface.

Description:
    This includes commands like `elm make`, `elm repl`, and many others
    for helping make Elm developers happy and productive.

Homepage: https://elm-lang.org

License: BSD3
License-file: LICENSE

Author:     Evan Czaplicki
Maintainer: info@elm-lang.org
Copyright:  Copyright (c) 2011-present, Evan Czaplicki

Category: Compiler, Language

Cabal-version: >=1.9
Build-type: Simple

source-repository head
    type:     git
    location: git://github.com/elm/compiler.git


Flag dev {
  Description: Turn off optimization and make warnings errors
  Default: False
}


Executable elm
        ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg -A128m" -Wall -Werror
        -- add -eventlog for (elm make src/Main.elm +RTS -l; threadscope elm.eventlog)
        -- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/

    Hs-Source-Dirs:
        compiler/src
        builder/src
        terminal/impl
        terminal/src

    other-extensions:
        TemplateHaskell

    Main-Is:
        Main.hs

    other-modules:
        Bump
        Develop
        Diff
        Init
        Install
        Make
        Publish
        Repl

        -- terminal args
        Terminal
        Terminal.Chomp
        Terminal.Error
        Terminal.Helpers
        Terminal.Internal

        -- from terminal/
        Develop.Generate.Help
        Develop.Generate.Index
        Develop.StaticFiles
        Develop.StaticFiles.Build

        -- from builder/
        Build
        BackgroundWriter
        Deps.Bump
        Deps.Diff
        Deps.Registry
        Deps.Solver
        Deps.Website
        File
        Generate
        Http
        Reporting
        Reporting.Exit
        Reporting.Exit.Help
        Reporting.Task
        Stuff

        -- Elm things
        Elm.Outline
        Elm.Details
        --
        Elm.Compiler.Imports
        Elm.Compiler.Type
        Elm.Compiler.Type.Extract
        Elm.Constraint
        Elm.Docs
        Elm.Float
        Elm.Interface
        Elm.Kernel
        Elm.Licenses
        Elm.Magnitude
        Elm.ModuleName
        Elm.Package
        Elm.String
        Elm.Version

        -- data structures
        Data.Bag
        Data.Index
        Data.Map.Utils
        Data.Name
        Data.NonEmptyList
        Data.OneOrMore
        Data.Utf8

        -- json
        Json.Decode
        Json.Encode
        Json.String

        -- from compiler/
        AST.Canonical
        AST.Optimized
        AST.Source
        AST.Utils.Binop
        AST.Utils.Shader
        AST.Utils.Type
        Canonicalize.Effects
        Canonicalize.Environment
        Canonicalize.Environment.Dups
        Canonicalize.Environment.Foreign
        Canonicalize.Environment.Local
        Canonicalize.Expression
        Canonicalize.Module
        Canonicalize.Pattern
        Canonicalize.Type
        Compile
        Generate.Html
        Generate.JavaScript
        Generate.JavaScript.Builder
        Generate.JavaScript.Expression
        Generate.JavaScript.Functions
        Generate.JavaScript.Name
        Generate.Mode
        Nitpick.Debug
        Nitpick.PatternMatches
        Optimize.Case
        Optimize.DecisionTree
        Optimize.Expression
        Optimize.Module
        Optimize.Names
        Optimize.Port
        Parse.Declaration
        Parse.Expression
        Parse.Keyword
        Parse.Module
        Parse.Number
        Parse.Pattern
        Parse.Shader
        Parse.Space
        Parse.String
        Parse.Symbol
        Parse.Type
        Parse.Variable
        Parse.Primitives
        Reporting.Annotation
        Reporting.Doc
        Reporting.Error
        Reporting.Error.Canonicalize
        Reporting.Error.Docs
        Reporting.Error.Import
        Reporting.Error.Json
        Reporting.Error.Main
        Reporting.Error.Pattern
        Reporting.Error.Syntax
        Reporting.Error.Type
        Reporting.Render.Code
        Reporting.Render.Type
        Reporting.Render.Type.Localizer
        Reporting.Report
        Reporting.Result
        Reporting.Suggest
        Reporting.Warning
        Type.Constrain.Expression
        Type.Constrain.Module
        Type.Constrain.Pattern
        Type.Error
        Type.Instantiate
        Type.Occurs
        Type.Solve
        Type.Type
        Type.Unify
        Type.UnionFind
        Paths_elm

    Build-depends:
        ansi-terminal,
        ansi-wl-pprint < 1,
        base,
        binary,
        bytestring,
        containers,
        directory,
        edit-distance,
        file-embed,
        filelock,
        filepath,
        ghc-prim,
        haskeline,
        HTTP,
        http-client,
        http-client-tls,
        http-types,
        language-glsl,
        mtl,
        network,
        parsec,
        process,
        raw-strings-qq,
        scientific,
        SHA,
        snap-core,
        snap-server,
        template-haskell,
        time,
        unordered-containers,
        utf8-string,
        vector,
        zip-archive


================================================
FILE: hints/bad-recursion.md
================================================

# Hints for Bad Recursion

There are two problems that will lead you here, both of them pretty tricky:

  1. [**No Mutation**](#no-mutation) — Defining values in Elm is slightly different than defining values in languages like JavaScript.

  2. [**Tricky Recursion**](#tricky-recursion) — Sometimes you need to define recursive values when creating generators, decoders, and parsers. A common case is a JSON decoder a discussion forums where a comment may have replies, which may have replies, which may have replies, etc.


## No Mutation

Languages like JavaScript let you “reassign” variables. When you say `x = x + 1` it means: whatever `x` was pointing to, have it point to `x + 1` instead. This is called *mutating* a variable. All values are immutable in Elm, so reassigning variables does not make any sense! Okay, so what *should* `x = x + 1` mean in Elm?

Well, what does it mean with functions? In Elm, we write recursive functions like this:

```elm
factorial : Int -> Int
factorial n =
  if n <= 0 then 1 else n * factorial (n - 1)
```

One cool thing about Elm is that whenever you see `factorial 3`, you can always replace that expression with `if 3 <= 0 then 1 else 3 * factorial (3 - 1)` and it will work exactly the same. So when Elm code gets evaluated, we will keep expanding `factorial` until the `if` produces a 1. At that point, we are done expanding and move on.

The thing that surprises newcomers is that recursion works the same way with values too. So take the following definition:

```elm
x = x + 1
```

We are actually defining `x` in terms of itself. So it would expand out to `x = ... + 1 + 1 + 1 + 1`, trying to add one to `x` an infinite number of times! This means your program would just run forever, endlessly expanding `x`. In practice, this means the page freezes and the computer starts to get kind of warm. No good! We can detect cases like this with the compiler, so we give an error at compile time so this does not happen in the wild.

The fix is usually to just give the new value a new name. So you could rewrite it to:

```elm
x1 = x + 1
```

Now `x` is the old value and `x1` is the new value. Again, one cool thing about Elm is that whenever you see a `factorial 3` you can safely replace it with its definition. Well, the same is true of values. Wherever I see `x1`, I can replace it with `x + 1`. Thanks to the way definitions work in Elm, this is always safe!


## Tricky Recursion

Now, there are some cases where you *do* want a recursive value. Say you are building a website with comments and replies. You may define a comment like this:

```elm
type alias Comment =
  { message : String
  , upvotes : Int
  , downvotes : Int
  , responses : Responses
  }

type Responses =
  Responses (List Comment)
```

You may have run into this definition in the [hints for recursive aliases](recursive-alias.md)! Anyway, once you have comments, you may want to turn them into JSON to send back to your server or to store in your database or whatever. So you will probably write some code like this:

```elm
import Json.Decode as Decode exposing (Decoder)

decodeComment : Decoder Comment
decodeComment =
  Decode.map4 Comment
    (Decode.field "message" Decode.string)
    (Decode.field "upvotes" Decode.int)
    (Decode.field "downvotes" Decode.int)
    (Decode.field "responses" decodeResponses)

-- PROBLEM
decodeResponses : Decoder Responses
decodeResponses =
  Decode.map Responses (Decode.list decodeComment)
```

The problem is that now `decodeComment` is defined in terms of itself! To know what `decodeComment` is, I need to expand `decodeResponses`. To know what `decodeResponses` is, I need to expand `decodeComment`. This loop will repeat endlessly!

In this case, the trick is to use `Json.Decode.lazy` which delays the evaluation of a decoder until it is needed. So the valid definition would look like this:

```elm
import Json.Decode as Decode exposing (Decoder)

decodeComment : Decoder Comment
decodeComment =
  Decode.map4 Comment
    (Decode.field "message" Decode.string)
    (Decode.field "upvotes" Decode.int)
    (Decode.field "downvotes" Decode.int)
    (Decode.field "responses" decodeResponses)

-- SOLUTION
decodeResponses : Decoder Responses
decodeResponses =
  Decode.map Responses (Decode.list (Decode.lazy (\_ -> decodeComment)))
```

Notice that in `decodeResponses`, we hide `decodeComment` behind an anonymous function. Elm cannot evaluate an anonymous function until it is given arguments, so it allows us to delay evaluation until it is needed. If there are no comments, we will not need to expand it!

This saves us from expanding the value infinitely. Instead we only expand the value if we need to.

> **Note:** The same kind of logic can be applied to tasks, random value generators, and parsers. Use `lazy` or `andThen` to make sure a recursive value is only expanded if needed.


## Understanding “Bad Recursion”

The compiler tries to detect bad recursion, but how does it know the difference between good and bad situations? Writing `factorial` is fine, but writing `x = x + 1` is not. One version of `decodeComment` was bad, but the other was fine. What is the rule?

**Elm will allow recursive definitions as long as there is at least one lambda before you get back to yourself.** So if we write `factorial` without any pretty syntax, it looks like this:

```elm
factorial =
  \n -> if n <= 0 then 1 else n * factorial (n - 1)
```

There is technically a lambda between the definition and the use, so it is okay! The same is true with the good version of `decodeComment`. There is a lambda between the definition and the use. As long as there is a lambda before you get back to yourself, the compiler will let it through.

**This rule is nice, but it does not catch everything.** It is pretty easy to write a definition where the recursion is hidden behind a lambda, but it still immediately expands forever:

```elm
x =
  (\_ -> x) () + 1
```

This follows the rules, but it immediately expands until our program runs out of stack space. It leads to a runtime error as soon as you start your program. It is nice to fail fast, but why not have the compiler detect this as well? It turns out this is much harder than it sounds!

This is called [the halting problem](https://en.wikipedia.org/wiki/Halting_problem) in computer science. Computational theorists were asking:

> Can we determine if a program will finish running (i.e. halt) or if it will continue to run forever?

It turns out that Alan Turing wrote a proof in 1936 showing that (1) in some cases you just have to check by running the program and (2) this check will take forever for programs that do not halt!

**So we cannot solve the halting problem *in general*, but our simple rule about lambdas can detect the majority of bad cases *in practice*.**


================================================
FILE: hints/comparing-custom-types.md
================================================
# Comparing Custom Types

The built-in comparison operators work on a fixed set of types, like `Int` and `String`. That covers a lot of cases, but what happens when you want to compare custom types?

This page aims to catalog these scenarios and offer alternative paths that can get you unstuck.


## Wrapped Types

It is common to try to get some extra type safety by creating really simple custom types:

```elm
type Id = Id Int
type Age = Age Int

type Comment = Comment String
type Description = Description String
```

By wrapping the primitive values like this, the type system can now help you make sure that you never mix up a `Id` and an `Age`. Those are different types! This trick is extra cool because it has no runtime cost in `--optimize` mode. The compiler can just use an `Int` or `String` directly when you use that flag!

The problem arises when you want to use a `Id` as a key in a dictionary. This is a totally reasonable thing to do, but the current version of Elm cannot handle this scenario.

Instead of creating a `Dict Id Info` type, one thing you can do is create a custom data structure like this:

```elm
module User exposing (Id, Table, empty, get, add)

import Dict exposing (Dict)


-- USER

type Id = Id Int


-- TABLE

type Table info =
  Table Int (Dict Int info)

empty : Table info
empty =
  Table 0 Dict.empty

get : Id -> Table info -> Maybe info
get (Id id) (Table _ dict) =
  Dict.get id dict

add : info -> Table info -> (Table info, Id)
add info (Table nextId dict) =
  ( Table (nextId + 1) (Dict.insert nextId info dict)
  , Id nextId
  )
```

There are a couple nice things about this approach:

1. The only way to get a new `User.Id` is to `add` information to a `User.Table`.
2. All the operations on a `User.Table` are explicit. Does it make sense to remove users? To merge two tables together? Are there any special details to consider in those cases? This will always be captured explicitly in the interface of the `User` module.
3. If you ever want to switch the internal representation from `Dict` to `Array` or something else, it is no problem. All the changes will be within the `User` module.

So while this approach is not as convenient as using a `Dict` directly, it has some benefits of its own that can be helpful in some cases.


## Enumerations to Ints

Say you need to define a `trafficLightToInt` function:

```elm
type TrafficLight = Green | Yellow | Red

trafficLightToInt : TrafficLight -> Int
trafficLightToInt trafficLight =
  ???
```

We have heard that some people would prefer to use a dictionary for this sort of thing. That way you do not need to write the numbers yourself, they can be generated such that you never have a typo.

I would recommend using a `case` expression though:

```elm
type TrafficLight = Green | Yellow | Red

trafficLightToInt : TrafficLight -> Int
trafficLightToInt trafficLight =
  case trafficLight of
    Green  -> 1
    Yellow -> 2
    Red    -> 3
```

This is really straight-forward while avoiding questions like “is `Green` less than or greater than `Red`?”


## Something else?

If you have some other situation, please tell us about it [here](https://github.com/elm/error-message-catalog/issues). That is a log of error messages that can be improved, and we can use the particulars of your scenario to add more advice on this page!


================================================
FILE: hints/comparing-records.md
================================================
# Comparing Records

The built-in comparison operators work on a fixed set of types, like `Int` and `String`. That covers a lot of cases, but what happens when you want to compare records?

This page aims to catalog these scenarios and offer alternative paths that can get you unstuck.


## Sorting Records

Say we want a `view` function that can show a list of students sorted by different characteristics.

We could create something like this:

```elm
import Html exposing (..)

type alias Student =
  { name : String
  , age : Int
  , gpa : Float
  }

type Order = Name | Age | GPA

viewStudents : Order -> List Student -> Html msg
viewStudents order students =
  let
    orderlyStudents =
      case order of
        Name -> List.sortBy .name students
        Age -> List.sortBy .age students
        GPA -> List.sortBy .gpa students
  in
  ul [] (List.map viewStudent orderlyStudents)

viewStudent : Student -> Html msg
viewStudent student =
  li [] [ text student.name ]
```

If you are worried about the performance of changing the order or updating information about particular students, you can start using the [`Html.Lazy`](https://package.elm-lang.org/packages/elm/html/latest/Html-Lazy) and [`Html.Keyed`](https://package.elm-lang.org/packages/elm/html/latest/Html-Keyed) modules. The updated code would look something like this:

```elm
import Html exposing (..)
import Html.Lazy exposing (lazy)
import Html.Keyed as Keyed

type Order = Name | Age | GPA

type alias Student =
  { name : String
  , age : Int
  , gpa : Float
  }

viewStudents : Order -> List Student -> Html msg
viewStudents order students =
  let
    orderlyStudents =
      case order of
        Name -> List.sortBy .name students
        Age -> List.sortBy .age students
        GPA -> List.sortBy .gpa students
  in
  Keyed.ul [] (List.map viewKeyedStudent orderlyStudents)

viewKeyedStudent : Student -> (String, Html msg)
viewKeyedStudent student =
  ( student.name, lazy viewStudent student )

viewStudent : Student -> Html msg
viewStudent student =
  li [] [ text student.name ]
```

By using `Keyed.ul` we help the renderer move the DOM nodes around based on their key. This makes it much cheaper to reorder a bunch of students. And by using `lazy` we help the renderer skip a bunch of work. If the `Student` is the same as last time, the render can skip over it.

> **Note:** Some people are skeptical of having logic like this in `view` functions, but I think the alternative (maintaining sort order in your `Model`) has some serious downsides. Say a colleague is adding a message to `Add` students, but they do not know about the sort order rules needed for presentation. Bug! So in this alternate design, you must diligently test your `update` function to make sure that no message disturbs the sort order. This is bound to lead to bugs over time!
>
> With all the optimizations possible with `Html.Lazy` and `Html.Keyed`, I would always be inclined to work on optimizing my `view` functions rather than making my `update` functions more complicated and error prone.


## Something else?

If you have some other situation, please tell us about it [here](https://github.com/elm/error-message-catalog/issues). That is a log of error messages that can be improved, and we can use the particulars of your scenario to add more advice on this page!


================================================
FILE: hints/implicit-casts.md
================================================

# Implicit Casts

Many languages automatically convert from `Int` to `Float` when they think it is necessary. This conversion is often called an [implicit cast](https://en.wikipedia.org/wiki/Type_conversion).

Languages that will add in implicit casts for addition include:

  - JavaScript
  - Python
  - Ruby
  - C
  - C++
  - C#
  - Java
  - Scala

These languages generally agree that an `Int` may be implicitly cast to a `Float` when necessary. So everyone is doing it, why not Elm?!

## Type Inference + Implicit Casts

Elm comes from the ML-family of languages. Languages in the ML-family that **never** do implicit casts include:

  - Standard ML
  - OCaml
  - Elm
  - F#
  - Haskell

Why would so many languages from this lineage require explicit conversions though?

Well, we have to go back to the 1970s for some background. J. Roger Hindley and Robin Milner independently discovered an algorithm that could _efficiently_ figure out the type of everything in your program without any type annotations. Type Inference! Every ML-family language has some variation of this algorithm at the center of its design.

For decades, the problem was that nobody could figure out how to combine type inference with implicit casts AND make the resulting algorithm efficient enough for daily use. As far as I know, Scala was the first widely known language to figure out how to combine these two things! Its creator, Martin Odersky did a lot of work on combining type inference and subtyping to make this possible.

So for any ML-family language designed before Scala, it is safe to assume that implicit conversions just was not an option. Okay, but what about Elm?! It comes after Scala, so why not do it like them?!

  1. You pay performance cost to mix type inference and implicit conversions. At least as far as anyone knows, it defeats an optimization that is crucial to getting _reliably_ good performance. It is fine in most cases, but it can be a real issue in very large code bases.

  2. Based on experience reports from Scala users, it seemed like the convenience was not worth the hidden cost. Yes, you can convert `n` in `(n + 1.5)` and everything is nice, but when you are in larger programs that are sparsely annotated, it can be quite difficult to figure out what is going on.

This user data may be confounded by the fact that Scala allows quite extensive conversions, not just from `Int` to `Float`, but I think it is worth taking seriously nonetheless. So it is _possible_, but it has tradeoffs.


## Conclusion

First, based on the landscape of design possibilities, it seems like requiring _explicit_ conversions is a pretty nice balance. We can have type inference, it can produce friendly error messages, the algorithm is snappy, and an unintended implicit cast will not flow hundreds of lines before manifesting to the user.

Second, Elm very much favors explicit code, so this also fits in with the overall spirit of the language and libraries.

I hope that clarifies why you have to add those `toFloat` and `round` functions! It definitely can take some getting used to, but there are tons of folks who get past that acclimation period and really love the tradeoffs!


================================================
FILE: hints/import-cycles.md
================================================

# Import Cycles

What is an import cycle? In practice you may see it if you create two modules with interrelated `User` and `Comment` types like this:

```elm
module Comment exposing (..)

import User

type alias Comment =
  { comment : String
  , author : User.User
  }
```

```elm
module User exposing (..)

import Comment

type alias User =
  { name : String
  , comments : List Comment.Comment
  }
```

Notice that to compile `Comment` we need to `import User`. And notice that to compile `User` we need to `import Comment`. We need both to compile either!

Now this is *possible* if the compiler figures out any module cycles and puts them all in one big file to compile them together. That seems fine in our small example, but imagine we have a cycle of 20 modules. If you change *one* of them, you must now recompile *all* of them. In a large code base, this causes extremely long compile times. It is also very hard to disentangle them in practice, so you just end up with slow builds. That is your life now.

The thing is that you can always write the code *without* cycles by shuffling declarations around, and the resulting code is often much clearer.


# How to Break Cycles

There are quite a few ways to break our `Comment` and `User` cycle from above, so let’s go through four useful strategies. The first one is by far the most common solution!


## 1. Combine the Modules

One approach is to just combine the two modules. If we check out the resulting code, we have actually revealed a problem in how we are representing our data:

```elm
module BadCombination1 exposing (..)

type alias Comment =
  { comment : String
  , author : User
  }

type alias User =
  { name : String
  , comments : List Comment
  }
```

Notice that the `Comment` type alias is defined in terms of the `User` type alias and vice versa. Having recursive type aliases like this does not work! That problem is described in depth [here](recursive-alias.md), but the quick takeaway is that one `type alias` needs to become a `type` to break the recursion. So let’s try again:

```elm
module BadCombination2 exposing (..)

type alias Comment =
  { comment : String
  , author : User
  }

type alias User =
  { name : String
  , comments : AllUserComments
  }

type AllUserComments = AllUserComments (List Comment)
```

Okay, now we have broken the recursion, but we need to ask ourselves, how are we going to actually instantiate these `Comment` and `User` types that we have described. A `Comment` will always have an author, and that `User` will always refer back to the `Comment`. So we seem to want cyclic data here. If we were in JavaScript we might instantiate all the comments in one pass, and then go back through and mutate the users to point to all the relevant comments. In other words, we need *mutation* to create this cyclic data!

All values are immutable in Elm, so we need to use a more functional strategy. One common approach is to use unique identifiers. Instead of referring directly to “the user object” we can refer to a user ID:

```elm
module GoodCombination exposing (..)

import Dict

type alias Comment =
  { comment : String
  , author : UserId
  }

type alias UserId = String

type alias AllComments =
  Dict.Dict UserId (List Comment)
```

Now in this world, we do not even have cycles in our types anymore! That means we can actually break these out into separate modules again:

```elm
module Comment exposing (..)

import Dict
import User

type alias Comment =
  { comment : String
  , author : User.Id
  }

type alias AllComments =
  Dict.Dict User.Id (List Comment)
```

```elm
module User exposing (..)

type alias Id = String
```

So now we are back to the two modules we wanted, but we have data structures that are going to work much better in a functional language like Elm! **This is the common approach, and it is what you hope will happen!**


## 2. Make a New Module

Now say there are actually a ton of functions and values in the `Comment` and `User` modules. Combining them into one does not seem like a good strategy. Instead you can create a *third* module that just has the shared types and functions. Let’s pretend we call that third module `GoodCombination`. So rather than having `Comment` and `User` depend on each other, they now both depend on `GoodCombination`. We broke our cycle!

**This strategy is less common.** You generally want to keep the core `type` of a module with all the functions that act upon it directly, so separating a `type` from everything else is a bad sign. So maybe there is a `User` module that contains a bunch of helper functions, but you *use* all those helper functions in a bunch of other modules that interact with users in various ways. In that scenario, it is still more sophisticated than “just throw the types in a module together” and hope it turns out alright.


## 3. Use Type Variables

Another way to avoid module cycles is to be more generic in how you represent your data:

```elm
module Comment exposing (..)

type alias Comment author =
  { comment : String
  , author : author
  }
```

```elm
module User exposing (..)

type alias User comment =
  { name : String
  , comments : List comment
  }
```

Notice that `Comment` and `User` no longer need to import each other! Instead, whenever we use these modules, we need to fill in the type variable. So we may import both `Comment` and `User` and try to combine them into a `Comment (User (Comment (User ...)))`. Gah, we ran into the recursive type alias thing again!

So this strategy fails pretty badly with our particular example. The code is more complicated and it still does not work! So **this strategy is rarely useful**, but when it works, it can simplify things quite a lot.


## 4. Hiding Implementation Details in Packages

This gets a little bit trickier when you are creating a package like `elm-lang/parser` which is built around the `Parser` type.

That package has a couple exposed modules: `Parser`, `Parser.LanguageKit`, and `Parser.LowLevel`. All of these modules want access to the internal details of the `Parser` type, but we do not want to ever expose those internal details to the *users* of this package. So where should the `Parser` type live?!

Usually you know which module should expose the type for the best public API. In this case, it makes sense for it to live in the `Parser` module. The way to manage this is to create a `Parser.Internal` module with a definition like:

```elm
module Parser.Internal exposing (..)

type Parser a =
  Parser ...
```

Now we can `import Parser.Internal` and use it in any of the modules in our package. The trick is that we never expose the `Parser.Internal` module to the *users* of our package. We can see what is inside, but they cannot! Then in the `Parser` module we can say:

```elm
module Parser exposing (..)

import Parser.Internal as Internal

type alias Parser a =
  Internal.Parser a
```

So now folks see a `Parser` type exposed by the `Parser` module, and it is the one that is used throughout all the modules in the package. Do not screw up your data representation to avoid this trick! I think we can improve how this appears in documentation, but overall this is the best way to go.

Now again, this strategy is particularly useful in packages. It is not as worthwhile in application code.


================================================
FILE: hints/imports.md
================================================

# Hints for Imports

When getting started with Elm, it is pretty common to have questions about how the `import` declarations work exactly. These questions usually arise when you start playing with the `Html` library so we will focus on that.





## `import`

An Elm file is called a **module**. To access code in other files, you need to `import` it!

So say you want to use the [`div`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#div) function from the [`elm-lang/html`](http://package.elm-lang.org/packages/elm-lang/html/latest) package. The simplest way is to import it like this:

```elm
import Html

main =
  Html.div [] []
```

After saying `import Html` we can refer to anything inside that module as long as it is *qualified*. This works for:

  - **Values** — we can refer to `Html.text`, `Html.h1`, etc.
  - **Types** — We can refer to [`Attribute`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#Attribute) as `Html.Attribute`.

So if we add a type annotation to `main` it would look like this:

```elm
import Html

main : Html.Html msg
main =
  Html.div [] []
```

We are referring to the [`Html`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html#Html) type, using its *qualified* name `Html.Html`. This can feel weird at first, but it starts feeling natural quite quickly!

> **Note:** Modules do not contain other modules. So the `Html` module *does not* contain the `Html.Attributes` module. Those are separate names that happen to have some overlap. So if you say `import Html` you *do not* get access to `Html.Attributes.style`. You must `import Html.Attributes` module separately.





## `as`

It is best practice to always use *qualified* names, but sometimes module names are so long that it becomes unwieldy. This is common for the `Html.Attributes` module. We can use the `as` keyword to help with this:

```elm
import Html
import Html.Attributes as A

main =
  Html.div [ A.style "color" "red" ] [ Html.text "Hello!" ]
```

Saying `import Html.Attributes as A` lets us refer to any value or type in `Html.Attributes` as long as it is qualified with an `A`. So now we can refer to [`style`](http://package.elm-lang.org/packages/elm-lang/html/latest/Html-Attributes#style) as `A.style`.





## `exposing`

In quick drafts, maybe you want to use *unqualified* names. You can do that with the `exposing` keyword like this:

```elm
import Html exposing (..)
import Html.Attributes exposing (style)

main : Html msg
main =
  div [ style "color" "red" ] [ text "Hello!" ]
```

Saying `import Html exposing (..)` means I can refer to any value or type from the `Html` module without qualification. Notice that I use the `Html` type, the `div` function, and the `text` function without qualification in the example above.

> **Note:** It seems neat to expose types and values directly, but it can get out of hand. Say you `import` ten modules `exposing` all of their content. It quickly becomes difficult to figure out what is going on in your code. “Wait, where is this function from?” And then trying to sort through all the imports to find it. Point is, use `exposing (..)` sparingly!

Saying `import Html.Attributes exposing (style)` is a bit more reasonable. It means I can refer to the `style` function without qualification, but that is it. You are still importing the `Html.Attributes` module like normal though, so you would say `Html.Attributes.class` or `Html.Attributes.id` to refer to other values and types from that module.





## `as` and `exposing`

There is one last way to import a module. You can combine `as` and `exposing` to try to get a nice balance of qualified names:

```elm
import Html exposing (Html, div, text)
import Html.Attributes as A exposing (style)

main : Html msg
main =
  div [ A.class "greeting", style "color" "red" ] [ text "Hello!" ]
```

Notice that I refer to `A.class` which is qualified and `style` which is unqualified.





## Default Imports

We just learned all the variations of the `import` syntax in Elm. You will use some version of that syntax to `import` any module you ever write.

It would be the best policy to make it so every module in the whole ecosystem works this way. We thought so in the past at least, but there are some modules that are so commonly used that the Elm compiler automatically adds the imports to every file. These default imports include:

```elm
import Basics exposing (..)
import List exposing (List, (::))
import Maybe exposing (Maybe(..))
import Result exposing (Result(..))
import String
import Tuple

import Debug

import Platform exposing (Program)
import Platform.Cmd as Cmd exposing (Cmd)
import Platform.Sub as Sub exposing (Sub)
```

You can think of these imports being at the top of any module you write.

One could argue that `Maybe` is so fundamental to how we handle errors in Elm code that it is *basically* part of the language. One could also argue that it is extraordinarily annoying to have to import `Maybe` once you get past your first couple weeks with Elm. Either way, we know that default imports are not ideal in some sense, so we have tried to keep the default imports as minimal as possible.

> **Note:** Elm performs dead code elimination, so if you do not use something from a module, it is not included in the generated code. So if you `import` a module with hundreds of functions, you do not need to worry about the size of your assets. You will only get what you use!


================================================
FILE: hints/infinite-type.md
================================================

# Hints for Infinite Types

Infinite types are probably the trickiest kind of bugs to track down. **Writing down type annotations is usually the fastest way to figure them out.** Let's work through an example to get a feel for how these errors usually work though!


## Example

A common way to get an infinite type error is very small typos. For example, do you see the problem in the following code?

```elm
incrementNumbers list =
  List.map incrementNumbers list

incrementNumber n =
  n + 1
```

The issue is that `incrementNumbers` calls itself, not the `incrementNumber` function defined below. So there is an extra `s` in this program! Let's focus on that:

```elm
incrementNumbers list =
  List.map incrementNumbers list -- BUG extra `s` makes this self-recursive
```

Now the compiler does not know that anything is wrong yet. It just tries to figure out the types like normal. It knows that `incrementNumbers` is a function. The definition uses `List.map` so we can deduce that `list : List t1` and the result of this function call should be some other `List t2`. This also means that `incrementNumbers : List t1 -> List t2`.

The issue is that `List.map` uses `incrementNumbers` on `list`! That means that each element of `list` (which has type `t1`) must be fed into `incrementNumbers` (which takes `List t1`)

That means that `t1 = List t1`, which is an infinite type! If we start expanding this, we get `List (List (List (List (List ...))))` out to infinity!

The point is mainly that we are in a confusing situation. The types are confusing. This explanation is confusing. The compiler is confused. It is a bad time. But luckily, the more type annotations you add, the better chance there is that you and the compiler can figure things out! So say we change our definition to:

```elm
incrementNumbers : List Int -> List Int
incrementNumbers list =
  List.map incrementNumbers list -- STILL HAS BUG
```

Now we are going to get a pretty normal type error. Hey, you said that each element in the `list` is an `Int` but I cannot feed that into a `List Int -> List Int` function! Something like that.

In summary, the root issue is often some small typo, and the best way out is to start adding type annotations on everything!


================================================
FILE: hints/init.md
================================================

# Creating an Elm project

The main goal of `elm init` is to get you to this page!

It just creates an `elm.json` file and a `src/` directory for your code.


## What is `elm.json`?

This file describes your project. It lists all of the packages you depend upon, so it will say the particular version of [`elm/core`](https://package.elm-lang.org/packages/elm/core/latest/) and [`elm/html`](https://package.elm-lang.org/packages/elm/html/latest/) that you are using. It makes builds reproducible! You can read a bit more about it [here](https://github.com/elm/compiler/blob/master/docs/elm.json/application.md).

You should generally not edit it by hand. It is better to add new dependencies with commands like `elm install elm/http` or `elm install elm/json`.


## What goes in `src/`?

This is where all of your Elm files live. It is best to start with a file called `src/Main.elm`. As you work through [the official guide](https://guide.elm-lang.org/), you can put the code examples in that `src/Main.elm` file.


## How do I compile it?

Run `elm reactor` in your project. Now you can go to [`http://localhost:8000`](http://localhost:8000) and browse through all the files in your project. If you navigate to `.elm` files, it will compile them for you!

If you want to do things more manually, you can run `elm make src/Main.elm` and it will produce an `index.html` file that you can look at in your browser.


## How do I structure my directories?

Many folks get anxious about their project structure. “If I get it wrong, I am doomed!” This anxiety makes sense in languages where refactoring is risky, but Elm is not one of those languages!

So we recommend that newcomers staying in one file until you get into the 600 to 1000 range. Push out of your comfort zone. Having the experience of being fine in large files will help you understand the boundaries in Elm, rather than just defaulting to the boundaries you learned in another language.

The talk [The Life of a File](https://youtu.be/XpDsk374LDE) gets into this a lot more. The advice about building modules around a specific [custom type](https://guide.elm-lang.org/types/custom_types.html) is particularly important! You will see that emphasized a lot as you work through the official guide.


## How do I write tests?

Elm will catch a bunch of errors statically, and I think it is worth skipping tests at first to get a feeling for when tests will actually help you _in Elm_.

From there, we have a great testing package called [`elm-explorations/test`](https://github.com/elm-explorations/test) that can help you out! It is particularly helpful for teams working on a large codebase. When you are editing code you have never seen before, tests can capture additional details and constraints that are not otherwise apparent!


## How do I start fancier projects?

I wanted `elm init` to generate as little code as possible. It is mainly meant to get you to this page! If you would like a more elaborate starting point, I recommend starting projects with commands like these:

```bash
git clone https://github.com/evancz/elm-todomvc.git
git clone https://github.com/rtfeldman/elm-spa-example.git
```

The idea is that Elm projects should be so simple that nobody needs a tool to generate a bunch of stuff. This also captures the fact that project structure _should_ evolve organically as your application develops, never ending up exactly the same as other projects.

But if you have something particular you want, I recommend creating your own starter recipe and using `git clone` when you start new projects. That way (1) you can get exactly what you want and (2) we do not end up with a complex `elm init` that ends up being confusing for beginners!


================================================
FILE: hints/missing-patterns.md
================================================

# Hints for Missing Patterns

Elm checks to make sure that all possible inputs to a function or `case` are handled. This gives us the guarantee that no Elm code is ever going to crash because data had an unexpected shape.

There are a couple techniques for making this work for you in every scenario.


## The danger of wildcard patterns

A common scenario is that you want to add a tag to a custom type that is used in a bunch of places. For example, maybe you are working different variations of users in a chat room:

```elm
type User
  = Regular String Int
  | Anonymous

toName : User -> String
toName user =
  case user of
    Regular name _ ->
      name

    _ ->
      "anonymous"
```

Notice the wildcard pattern in `toName`. This will hurt us! Say we add a `Visitor String` variant to `User` at some point. Now we have a bug that visitor names are reported as `"anonymous"`, and the compiler cannot help us!

So instead, it is better to explicitly list all possible variants, like this:

```elm
type User
  = Regular String Int
  | Visitor String
  | Anonymous

toName : User -> String
toName user =
  case user of
    Regular name _ ->
      name

    Anonymous ->
      "anonymous"
```

Now the compiler will say "hey, what should `toName` do when it sees a `Visitor`?" This is a tiny bit of extra work, but it is very worth it!


## I want to go fast!

Imagine that the `User` type appears in 20 or 30 functions across your project. When we add a `Visitor` variant, the compiler points out all the places that need to be updated. That is very convenient, but in a big project, maybe you want to get through it extra quickly.

In that case, it can be helpful to use [`Debug.todo`](https://package.elm-lang.org/packages/elm-lang/core/latest/Debug#todo) to leave some code incomplete:

```elm
type User
  = Regular String Int
  | Visitor String
  | Anonymous

toName : User -> String
toName user =
  case user of
    Regular name _ ->
      name

    Visitor _ ->
      Debug.todo "give the visitor name"

    Anonymous ->
      "anonymous"

-- and maybe a bunch of other things
```

In this case it is easier to just write the implementation, but the point is that on more complex functions, you can put things off a bit.

The Elm compiler is actually aware of `Debug.todo` so when it sees it in a `case` like this, it will crash with a bunch of helpful information. It will tell you:

  1. The name of the module that contains the code.
  2. The line numbers of the `case` containing the TODO.
  3. The particular value that led to this TODO.

From that information you have a pretty good idea of what went wrong and can go fix it.

I tend to use `Debug.todo` as the message when my goal is to go quick because it makes it easy to go and find all remaining todos in my code before a release.


## A list that definitely is not empty

This can come up from time to time, but Elm **will not** let you write code like this:

```elm
last : List a -> a
last list =
  case list of
    [x] ->
        x

    _ :: rest ->
        last rest
```

This is no good. It does not handle the empty list. There are two ways to handle this. One is to make the function return a `Maybe` like this:

```elm
last : List a -> Maybe a
last list =
  case list of
    [] ->
        Nothing

    [x] ->
        Just x

    _ :: rest ->
        last rest
```

This is nice because it lets users know that there might be a failure, so they can recover from it however they want.

The other option is to “unroll the list” one level to ensure that no one can ever provide an empty list in the first place:

```elm
last : a -> List a -> a
last first rest =
  case rest of
    [] ->
      first

    newFirst :: newRest ->
      last newFirst newRest
```

By demanding the first element of the list as an argument, it becomes impossible to call this function if you have an empty list!

This “unroll the list” trick is quite useful. I recommend using it directly, not through some external library. It is nothing special. Just a useful idea!


================================================
FILE: hints/optimize.md
================================================

# How to optimize Elm code

When you are serving a website, there are two kinds of optimizations you want to do:

1. **Asset Size** — How can we send as few bits as possible?
2. **Performance** — How can those bits run as quickly as possible?

It turns out that Elm does really well on both! We have [very small assets](https://elm-lang.org/news/small-assets-without-the-headache) and [very fast code](https://elm-lang.org/news/blazing-fast-html-round-two) when compared to the popular alternatives.

Okay, but how do we get those numbers?


## Instructions

Step one is to compile with the `--optimize` flag. This does things like shortening record field names and unboxing values.

Step two is to call `uglifyjs` with a bunch of special flags. The flags unlock optimizations that are unreliable in normal JS code, but because Elm does not have side-effects, they work fine for us!

Putting those together, here is how I would optimize `src/Main.elm` with two terminal commands:

```bash
elm make src/Main.elm --optimize --output=elm.js
uglifyjs elm.js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output elm.min.js
```

After this you will have an `elm.js` and a significantly smaller `elm.min.js` file!

**Note 1:** `uglifyjs` is called twice there. First to `--compress` and second to `--mangle`. This is necessary! Otherwise `uglifyjs` will ignore our `pure_funcs` flag.

**Note 2:** If the `uglifyjs` command is not available in your terminal, you can run the command `npm install uglify-js --global` to download it. You probably already have `npm` from getting `elm repl` working, but if not, it is bundled with [nodejs](https://nodejs.org/).

## Scripts

It is hard to remember all that, so it is probably a good idea to write a script that does it.

I would maybe want to run `./optimize.sh src/Main.elm` and get out `elm.js` and `elm.min.js`, so on Mac or Linux, I would make a script called `optimize.sh` like this:

```bash
#!/bin/sh

set -e

js="elm.js"
min="elm.min.js"

elm make --optimize --output=$js $@

uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min

echo "Initial size: $(cat $js | wc -c) bytes  ($js)"
echo "Minified size:$(cat $min | wc -c) bytes  ($min)"
echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes"
```

It also prints out all the asset sizes for you! Your server should be configured to gzip the assets it sends, so the last line is telling you how many bytes would _actually_ get sent to the user.

Again, the important commands are `elm` and `uglifyjs` which work on any platform, so it should not be too tough to do something similar on Windows.



================================================
FILE: hints/port-modules.md
================================================

# No Ports in Packages

The package ecosystem is one of the most important parts of Elm. Right now, our ecosystem has some compelling benefits:

  - There are many obvious default packages that work well.
  - Adding dependencies cannot introduce runtime exceptions.
  - Patch changes cannot lead to surprise build failures.

These are really important factors if you want to *quickly* create *reliable* applications. The Elm community thinks this is valuable.

Other communities think that the *number* of packages is a better measure of ecosystem health. That is a fine metric to use, but it is not the one we use for Elm. We would rather have 50 great packages than 100k packages of wildly varying quality.


## So what about ports?

Imagine you install a new package that claims to support `localStorage`. You get it set up, working through any compile errors. You run it, but it does not seem to work! After trying to figure it out for hours, you realize there is some poorly documented `port` to hook up...

Okay, now you need to hook up some JavaScript code. Is that JS file in the Elm package? Or is it on `npm`? Wait, what version on `npm` though? And is this patch version going to work as well? Also, how does this file fit into my build process? And assuming we get through all that, maybe the `port` has the same name as one of the ports in your project. Or it clashes with a `port` name in another package.

**Suddenly adding dependencies is much more complicated and risky!** An experienced developer would always check for ports up front, spending a bunch of time manually classifying unacceptable packages. Most people would not know to do that and learn all the pitfalls through personal experience, ultimately spending even *more* time than the person who defensively checks to avoid these issues.

So “ports in packages” would impose an enormous cost on application developers, and in the end, we would have a less reliable package ecosystem overall.


## Conclusion

Our wager with the Elm package ecosystem is that it is better to get a package *right* than to get it *right now*. So while we could use “ports in packages” as a way to get twenty `localStorage` packages of varying quality *right now*, we are choosing not to go that route. Instead we ask that developers use ports directly in their application code, getting the same result a different way.

Now this may not be the right choice for your particular project, and that is okay! We will be expanding our core libraries over time, as explained [here](https://github.com/elm-lang/projects/blob/master/roadmap.md#where-is-the-localstorage-package), and we hope you will circle back later to see if Elm has grown into a better fit!

If you have more questions about this choice or what it means for your application, please come ask in [the Elm slack](http://elmlang.herokuapp.com/). Folks are friendly and happy to help out! Chances are that a `port` in your application will work great for your case once you learn more about how they are meant to be used.


================================================
FILE: hints/recursive-alias.md
================================================

# Hints for Recursive Type Aliases

At the root of this issue is the distinction between a `type` and a `type alias`.


## What is a type alias?

When you create a type alias, you are just creating a shorthand to refer to an existing type. So when you say the following:

```elm
type alias Time = Float

type alias Degree = Float

type alias Weight = Float
```

You have not created any *new* types, you just made some alternate names for `Float`. You can write down things like this and it'll work fine:

```elm
add : Time -> Degree -> Weight
add time degree =
  time + degree
```

This is kind of a weird way to use type aliases though. The typical usage would be for records, where you do not want to write out the whole thing every time. Stuff like this:

```elm
type alias Person =
  { name : String
  , age : Int
  , height : Float
  }
```

It is much easier to write down `Person` in a type, and then it will just expand out to the underlying type when the compiler checks the program.


## Recursive type aliases?

Okay, so let's say you have some type that may contain itself. In Elm, a common example of this is a comment that might have subcomments:

```elm
type alias Comment =
  { message : String
  , upvotes : Int
  , downvotes : Int
  , responses : List Comment
  }
```

Now remember that type *aliases* are just alternate names for the real type. So to make `Comment` into a concrete type, the compiler would start expanding it out.

```elm
  { message : String
  , upvotes : Int
  , downvotes : Int
  , responses :
      List
        { message : String
        , upvotes : Int
        , downvotes : Int
        , responses :
            List
              { message : String
              , upvotes : Int
              , downvotes : Int
              , responses : List ...
              }
        }
  }
```

The compiler cannot deal with values like this. It would just keep expanding forever.


## Recursive types!

In cases where you want a recursive type, you need to actually create a brand new type. This is what the `type` keyword is for. A simple example of this can be seen when defining a linked list:

```elm
type List
    = Empty
    | Node Int List
```

No matter what, the type of `Node n xs` is going to be `List`. There is no expansion to be done. This means you can represent recursive structures with types that do not explode into infinity.

So let's return to wanting to represent a `Comment` that may have responses. There are a couple ways to do this:


### Obvious, but kind of annoying

```elm
type Comment =
   Comment
      { message : String
      , upvotes : Int
      , downvotes : Int
      , responses : List Comment
      }
```

Now let's say you want to register an upvote on a comment:

```elm
upvote : Comment -> Comment
upvote (Comment comment) =
  Comment { comment | upvotes = 1 + comment.upvotes }
```

It is kind of annoying that we now have to unwrap and wrap the record to do anything with it.


### Less obvious, but nicer

```elm
type alias Comment =
  { message : String
  , upvotes : Int
  , downvotes : Int
  , responses : Responses
  }

type Responses = Responses (List Comment)
```

In this world, we introduce the `Responses` type to capture the recursion, but `Comment` is still an alias for a record. This means the `upvote` function looks nice again:

```elm
upvote : Comment -> Comment
upvote comment =
  { comment | upvotes = 1 + comment.upvotes }
```

So rather than having to unwrap a `Comment` to do *anything* to it, you only have to do some unwrapping in the cases where you are doing something recursive. In practice, this means you will do less unwrapping which is nice.


## Mutually recursive type aliases

It is also possible to build type aliases that are *mutually* recursive. That might be something like this:

```elm
type alias Comment =
  { message : String
  , upvotes : Int
  , downvotes : Int
  , responses : Responses
  }

type alias Responses =
  { sortBy : SortBy
  , responses : List Comment
  }

type SortBy = Time | Score | MostResponses
```

When you try to expand `Comment` you have to expand `Responses` which needs to expand `Comment` which needs to expand `Responses`, etc.

So this is just a fancy case of a self-recursive type alias. The solution is the same. Somewhere in that cycle, you need to define an actual `type` to end the infinite expansion.


================================================
FILE: hints/repl.md
================================================

# REPL

The REPL lets you interact with Elm values and functions in your terminal.


## Use

You can type in expressions, definitions, custom types, and module imports using normal Elm syntax.

```elm
> 1 + 1
2 : number

> "hello" ++ "world"
"helloworld" : String
```

The same can be done with definitions and custom types:

```elm
> fortyTwo = 42
42 : number

> increment n = n + 1
 : number -> number

> increment 41
42 : number

> factorial n =
|   if n < 1 then
|     1
|   else
|     n * factorial (n-1)
|
 : number -> number

> factorial 5
120 : number

> type User
|   = Regular String
|   | Visitor String
|

> case Regular "Tom" of
|   Regular name -> "Hey again!"
|   Visitor name -> "Nice to meet you!"
|
"Hey again!" : String
```

When you run `elm repl` in a project with an [`elm.json`](https://github.com/elm/compiler/blob/master/docs/elm.json/application.md) file, you can import any module available in the project. So if your project has an `elm/html` dependency, you could say:

```elm
> import Html exposing (Html)

> Html.text "hello"
 : Html msg

> Html.text
 : String -> Html msg
```

If you create a module in your project named `MyThing` in your project, you can say `import MyThing` in the REPL as well. Any module that is accessible in your project should be accessible in the REPL.


## Exit

To exit the REPL, you can type `:exit`.

You can also press `ctrl-d` or `ctrl-c` on some platforms.


================================================
FILE: hints/shadowing.md
================================================

# Variable Shadowing

Variable shadowing is when you define the same variable name twice in an ambiguous way. Here is a pretty reasonable use of shadowing:

```elm
viewName : Maybe String -> Html msg
viewName name =
  case name of
    Nothing ->
      ...

    Just name ->
      ...
```

I define a `name` with type `Maybe String` and then in that second branch, I define a `name` that is a `String`. Now that there are two `name` values, it is not 100% obvious which one you want in that second branch.

Most linters produce warnings on variable shadowing, so Elm makes “best practices” the default. Just rename the first one to `maybeName` and move on.

This choice is relatively uncommon in programming languages though, so I want to provide the reasoning behind it.


## The Cost of Shadowing

The code snippet from above is the best case scenario for variable shadowing. It is pretty clear really. But that is because it is a fake example. It does not even compile.

In a large module that is evolving over time, this is going to cause bugs in a very predictable way. You will have two definitions, separated by hundreds of lines. For example:

```elm
name : String
name =
  "Tom"

-- hundreds of lines

viewName : String -> Html msg
viewName name =
  ... name ... name ... name ...
```

Okay, so the `viewName` function has an argument `name` and it uses it three times. Maybe the `viewName` function is 50 lines long in total, so those uses are not totally easy to see. This is fine so far, but say your colleague comes along five months later and wants to support first and last names. They refactor the code like this:

```elm
viewName : String -> String -> Html msg
viewName firstName lastName =
  ... name ... name ... name ...
```

The code compiles, but it does not work as intended. They forgot to change all the uses of `name`, and because it shadows the top-level `name` value, it always shows up as `"Tom"`. It is a simple mistake, but it is always the last thing I think of.

> Is the data being fetched properly? Let me log all of the JSON requests. Maybe the JSON decoders are messed up? Hmm. Maybe someone is transforming the name in a bad way at some point? Let me check my `update` code.

Basically, a bunch of time gets wasted on something that could easily be detected by the compiler. But this bug is rare, right?


## Aggregate Cost

Thinking of a unique and helpful name takes some extra time. Maybe 30 seconds. But it means that:

  1. Your code is easier to read and understand later on. So you spend 30 seconds once `O(1)` rather than spending 10 seconds each time someone reads that code in the future `O(n)`.

  2. The tricky shadowing bug described above is impossible. Say there is a 5% chance that any given edit produces a shadowing bug, and that resolving that shadowing bug takes one hour. That means the expected time for each edit increases by three minutes.

If you are still skeptical, I encourage you can play around with the number of edits, time costs, and probabilities here. When shadowing is not allowed, the resulting overhead for the entire lifetime of the code is the 30 seconds it takes to pick a better name, so that is what you need to beat!


## Summary

Without shadowing, the code easier to read and folks spend less time on pointless debugging. The net outcome is that folks have more time to make something wonderful with Elm!


================================================
FILE: hints/tuples.md
================================================

# From Tuples to Records

The largest tuple possible in Elm has three entries. Once you get to four, it is best to make a record with named entries.

For example, it is _conceivable_ to represent a rectangle as four numbers like `(10,10,100,100)` but it would be more self-documenting to use a record like this:

```elm
type alias Rectangle =
  { x : Float
  , y : Float
  , width : Float
  , height : Float
  }
```

Now it is clear that the dimensions should be `Float` values. It is also clear that we are not using the convention of specifying the top-left and bottom-right corners. It could be clearer about whether the `x` and `y` is the point in the top-left or in the middle though!

Anyway, using records like this also gives you access to syntax like `rect.x`, `.x`, and `{ rect | x = 40 }`. It is not clear how to design features like that for arbitrarily sized tuples, so we did not. We already have a way, and it is more self-documenting!


================================================
FILE: hints/type-annotations.md
================================================

# Hints for Type Annotation Problems

At the root of this kind of issue is always the fact that a type annotation in your code does not match the corresponding definition. Now that may mean that the type annotation is "wrong" or it may mean that the definition is "wrong". The compiler cannot figure out your intent, only that there is some mismatch.

This document is going to outline the various things that can go wrong and show some examples.


## Annotation vs. Definition

The most common issue is with user-defined type variables that are too general. So let's say you have defined a function like this:

```elm
addPair : (a, a) -> a
addPair (x, y) =
  x + y
```

The issue is that the type annotation is saying "I will accept a tuple containing literally *anything*" but the definition is using `(+)` which requires things to be numbers. So the compiler is going to infer that the true type of the definition is this:

```elm
addPair : (number, number) -> number
```

So you will probably see an error saying "I cannot match `a` with `number`" which is essentially saying, you are trying to provide a type annotation that is **too general**. You are saying `addPair` accepts anything, but in fact, it can only handle numbers.

In cases like this, you want to go with whatever the compiler inferred. It is good at figuring this kind of stuff out ;)


## Annotation vs. Itself

It is also possible to have a type annotation that clashes with itself. This is probably more rare, but someone will run into it eventually. Let's use another version of `addPair` with problems:

```elm
addPair : (Int, Int) -> number
addPair (x, y) =
  x + y
```

In this case the annotation says we should get a `number` out, but because we were specific about the inputs being `Int`, the output should also be an `Int`.


## Annotation vs. Internal Annotation

A quite tricky case is when an outer type annotation clashes with an inner type annotation. Here is an example of this:

```elm
filter : (a -> Bool) -> List a -> List a
filter isOkay list =
  let
    keepIfOkay : a -> Maybe a
    keepIfOkay x =
      if isOkay x then Just x else Nothing
  in
    List.filterMap keepIfOkay list
```

This case is very unfortunate because all the type annotations are correct, but there is a detail of how type inference works right now that **user-defined type variables are not shared between annotations**. This can lead to probably the worst type error messages we have because the problem here is that `a` in the outer annotation does not equal `a` in the inner annotation.

For now the best route is to leave off the inner annotation. It is unfortunate, and hopefully we will be able to do a nicer thing in future releases.


================================================
FILE: installers/README.md
================================================
# Installing Elm

The normal path is to work through [the guide](https://guide.elm-lang.org/) until you need to install, but you can skip to installation directly by going [here](https://guide.elm-lang.org/install/terminal.html).





## Installing Multiple Versions

The secret is that Elm is just a single executable file. If you are developing a project in `~/Desktop/project/` you can download this file into that directory and run commands like `~/Desktop/project/elm make src/Main.elm` or `./elm make src/Main.elm`. You just run the local copy of the executable file!

The instructions for [Mac][mac] and [Linux][lin] explain how to do this in more detail. You can follow the same steps on Windows, but you need to do each step by hand. (E.g. download the file through your browser rather than with a terminal command.)

[mac]: https://github.com/elm/compiler/blob/master/installers/mac/README.md
[lin]: https://github.com/elm/compiler/blob/master/installers/linux/README.md




## Installing Previous Versions

The past binaries for Mac, Linux, and Windows are hosted [here](https://github.com/elm/compiler/releases).

You can download the executable files directly and use them locally.





## Uninstall

- [Mac](https://github.com/elm/compiler/blob/master/installers/mac/README.md#uninstall)
- [Linux](https://github.com/elm/compiler/blob/master/installers/linux/README.md#uninstall)
- [Windows](https://github.com/elm/compiler/blob/master/installers/win/README.md#uninstall)


================================================
FILE: installers/linux/Dockerfile
================================================
# Based initially on https://gist.github.com/rlefevre/1523f47e75310e28eee243c9c5651ac9
#
# Build Linux x64 binary from elm compiler top-level directory:
# $ docker build -t elm -f installers/linux/Dockerfile .
#
# Retrieve elm Linux binary:
# $ docker cp $(docker create elm):/usr/local/bin/elm DESTINATION_DIRECTORY
#
# Delete docker elm image:
# $ docker rmi elm
#
# Display all images:
# $ docker images -a
#
# Delete all unused docker images:
# $ docker system prune -a

# Use Alpine 3.11 with GHC 8.6.5
FROM alpine:3.11

# Install packages required to build elm
RUN apk add --no-cache ghc cabal wget musl-dev zlib-dev zlib-static ncurses-dev ncurses-static

WORKDIR /elm

# Import source code
COPY builder builder
COPY compiler compiler
COPY reactor reactor
COPY terminal terminal
COPY cabal.config elm.cabal LICENSE ./

# Build statically linked elm binary
RUN cabal new-update
RUN cabal new-build --ghc-option=-optl=-static --ghc-option=-split-sections
RUN cp ./dist-newstyle/build/x86_64-linux/ghc-*/elm-*/x/elm/build/elm/elm /usr/local/bin/elm

# Remove debug symbols to optimize the binary size
RUN strip -s /usr/local/bin/elm


================================================
FILE: installers/linux/README.md
================================================
# Install Instructions

The pre-compiled binary for Linux works on a very wide range of distributions.

It should be possible to install it by running the following commands in your terminal:

```bash
# Move to your Desktop so you can see what is going on easier.
#
cd ~/Desktop/

# Download the 0.19.1 binary for Linux.
#
# +-----------+----------------------+
# | FLAG      | MEANING              |
# +-----------+----------------------+
# | -L        | follow redirects     |
# | -o elm.gz | name the file elm.gz |
# +-----------+----------------------+
#
curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-linux-64-bit.gz

# There should now be a file named `elm.gz` on your Desktop.
#
# The downloaded file is compressed to make it faster to download.
# This next command decompresses it, replacing `elm.gz` with `elm`.
#
gunzip elm.gz

# There should now be a file named `elm` on your Desktop!
#
# Every file has "permissions" about whether it can be read, written, or executed.
# So before we use this file, we need to mark this file as executable:
#
chmod +x elm

# The `elm` file is now executable. That means running `~/Desktop/elm --help`
# should work. Saying `./elm --help` works the same.
#
# But we want to be able to say `elm --help` without specifying the full file
# path every time. We can do this by moving the `elm` binary to one of the
# directories listed in your `PATH` environment variable:
#
sudo mv elm /usr/local/bin/

# Now it should be possible to run the `elm` binary just by saying its name!
#
elm --help
```




## Wait, what is the `PATH` variable?

When you run a command like `elm make src/Main.elm`, your computer starts by trying to find an executable file called `elm`.

The `PATH` is the list of directories that get searched. You can see these directories by running:

```bash
echo $PATH
```

This prints `/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin` on my computer. The directories are separated by a `:` so there are five possibilities listed here.

When I run `elm make src/Main.elm`, my terminal starts by searching these five directories for an executable file named `elm`. It finds `/usr/local/bin/elm` and then runs `/usr/local/bin/elm make src/Main.elm` with whatever arguments I gave.

So the `PATH` environment variable is a convention that allows you to refer to a specific executable file without knowing exactly where it lives on your computer. This is actually how all "terminal commands" work! Commands like `ls` are really executable files that live in directories listed in your `PATH` variable.

So the point of running `sudo mv elm /usr/local/bin/` is to turn the `elm` binary into a terminal command, allowing us to call it just like `ls` and `cd`.

**Note:** Why do we need to use `sudo` for that one command? Imagine if some program was able to add executables named `ls` or `cd` to `/usr/local/bin` that did something tricky and unexpected. That would be a security problem! Many distributions make this scenario less likely by requiring special permissions to modify the `/usr/local/bin/` directory.





## Uninstall

The following commands should remove everything:

```bash
# Remove the `elm` executable.
#
sudo rm /usr/local/bin/elm

# Remove any cached files. The files here reduce compile times when
# starting new projects and make it possible to work offline in more
# cases. No need to keep it around if you are uninstalling though!
#
rm -r ~/.elm/
```

If you have any Elm projects still on your computer, you can remove their `elm-stuff/` directories as well.



================================================
FILE: installers/mac/Distribution.xml
================================================


    Elm
    
    
    
    
    
    
    
    
        
    
    
        
    
    binaries.pkg



================================================
FILE: installers/mac/README.md
================================================
# Install Instructions

The easiest way to install is to to use [the Mac installer](https://github.com/elm/compiler/releases/download/0.19.1/installer-for-mac.pkg)!

But it is also possible to install by running the following commands in your terminal:

```bash
# Move to your Desktop so you can see what is going on easier.
#
cd ~/Desktop/

# Download the 0.19.1 binary for Linux.
#
# +-----------+----------------------+
# | FLAG      | MEANING              |
# +-----------+----------------------+
# | -L        | follow redirects     |
# | -o elm.gz | name the file elm.gz |
# +-----------+----------------------+
#
curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-mac-64-bit.gz

# There should now be a file named `elm.gz` on your Desktop.
#
# The downloaded file is compressed to make it faster to download.
# This next command decompresses it, replacing `elm.gz` with `elm`.
#
gunzip elm.gz

# There should now be a file named `elm` on your Desktop!
#
# Every file has "permissions" about whether it can be read, written, or executed.
# So before we use this file, we need to mark this file as executable:
#
chmod +x elm

# The `elm` file is now executable. That means running `~/Desktop/elm --help`
# should work. Saying `./elm --help` works the same.
#
# But we want to be able to say `elm --help` without specifying the full file
# path every time. We can do this by moving the `elm` binary to one of the
# directories listed in your `PATH` environment variable:
#
sudo mv elm /usr/local/bin/

# Now it should be possible to run the `elm` binary just by saying its name!
#
elm --help
```




## What is the `PATH` variable?

When you run a command like `elm make src/Main.elm`, your computer starts by trying to find an executable file called `elm`.

The `PATH` is the list of directories that get searched. You can see these directories by running:

```bash
echo $PATH
```

This prints `/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin` on my computer. The directories are separated by a `:` so there are five possibilities listed here.

When I run `elm make src/Main.elm`, my terminal starts by searching these five directories for an executable file named `elm`. It finds `/usr/local/bin/elm` and then runs `/usr/local/bin/elm make src/Main.elm` with whatever arguments I gave.

So the `PATH` environment variable is a convention that allows you to refer to a specific executable file without knowing exactly where it lives on your computer. This is actually how all "terminal commands" work! Commands like `ls` are really executable files that live in directories listed in your `PATH` variable.

So the point of running `sudo mv elm /usr/local/bin/` is to turn the `elm` binary into a terminal command, allowing us to call it just like `ls` and `cd`.

**Note:** Why do we need to use `sudo` for that one command? Imagine if some program was able to add executables named `ls` or `cd` to `/usr/local/bin` that did something tricky and unexpected. That would be a security problem! Many distributions make this scenario less likely by requiring special permissions to modify the `/usr/local/bin/` directory.





## Uninstall

The following commands should remove everything:

```bash
# Remove the `elm` executable.
#
sudo rm /usr/local/bin/elm

# Remove any cached files. The files here reduce compile times when
# starting new projects and make it possible to work offline in more
# cases. No need to keep it around if you are uninstalling though!
#
rm -r ~/.elm/
```

If you have any Elm projects still on your computer, you can remove their `elm-stuff/` directories as well.



================================================
FILE: installers/mac/Resources/en.lproj/conclusion.rtf
================================================
{\rtf1\ansi\ansicpg1252\cocoartf2509
\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fmodern\fcharset0 CourierNewPSMT;}
{\colortbl;\red255\green255\blue255;}
{\*\expandedcolortbl;;}
\paperw11900\paperh16840\margl1440\margr1440\vieww11180\viewh8400\viewkind0
\pard\tx720\tx1440\tx2160\tx2880\tx3600\tx4320\tx5040\tx5760\tx6480\tx7200\tx7920\tx8640\pardirnatural\partightenfactor0

\f0\fs28 \cf0 Try opening the terminal and running commands like:\
\

\f1 elm init\
elm make src/Main.elm --optimize\
elm repl
\f0 \
\
Check out {\field{\*\fldinst{HYPERLINK "https://guide.elm-lang.org/"}}{\fldrslt this tutorial}} for more advice!}

================================================
FILE: installers/mac/Resources/en.lproj/welcome.rtf
================================================
{\rtf1\ansi\ansicpg1252\cocoartf2509
\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fmodern\fcharset0 CourierNewPSMT;}
{\colortbl;\red255\green255\blue255;}
{\*\expandedcolortbl;;}
\paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0
\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural\partightenfactor0

\f0\fs28 \cf0 Thank you for trying out Elm!\
\
This installer makes 
\f1 elm
\f0  available in your terminal.}

================================================
FILE: installers/mac/helper-scripts/elm-startup.sh
================================================
#!/bin/sh

open 'http://guide.elm-lang.org'


================================================
FILE: installers/mac/helper-scripts/uninstall.sh
================================================
#!/bin/sh

set -e

echo "Warning: You are about to remove all Elm executables!"

installdir=/usr/local/bin

for bin in elm elm-compiler elm-get elm-reactor elm-repl elm-doc elm-server elm-package elm-make
do
	if [ -f $installdir/$bin ]; then
		sudo rm -f $installdir/$bin
	fi
	if [ -f $installdir/$bin-unwrapped ]; then
		sudo rm -f $installdir/$bin-unwrapped
	fi

done

sharedir=/usr/local/share/elm
sudo rm -rf $sharedir


================================================
FILE: installers/mac/make-installer.sh
================================================
#!/bin/sh
# Run the following command to create an installer:
#
#     bash make-installer.sh
#



#### SETUP ####

set -e

# Create directory structure for new pkgs
pkg_root=$(mktemp -d -t package-artifacts)
pkg_binaries=$pkg_root
pkg_scripts=$pkg_root/Scripts

mkdir -p $pkg_binaries
mkdir -p $pkg_scripts

usr_binaries=/usr/local/bin


#### BUILD ASSETS ####

cp ../../dist/build/elm/elm $pkg_binaries/elm

cp $(pwd)/preinstall $pkg_scripts
cp $(pwd)/postinstall $pkg_scripts

pkgbuild \
    --sign "Developer ID Installer: " \
    --identifier org.elm-lang.binary \
    --install-location $usr_binaries \
    --scripts $pkg_scripts \
    --filter 'Scripts.*' \
    --root $pkg_root \
    binaries.pkg


#### BUNDLE ASSETS ####

rm -f installer-for-mac.pkg

productbuild \
    --sign "Developer ID Installer: " \
    --identifier org.elm-lang.installer \
    --distribution Distribution.xml \
    --package-path . \
    --resources Resources \
    installer-for-mac.pkg


#### CLEAN UP ####

rm binaries.pkg
rm -rf $pkg_root


#### BEGIN NOTARIZATION ####

xcrun altool \
    --notarize-app \
    --primary-bundle-id "org.elm-lang.installer" \
    --username "" \
    --password "@keychain:Developer-altool" \
    --file "installer-for-mac.pkg"

# From https://scriptingosx.com/2019/09/notarize-a-command-line-tool/
#
#### Check on notarization:
#
# xcrun altool \
#     --notarization-info "" \
#     --username "" \
#     --password "@keychain:Developer-altool"
#
#
#### Staple Notarization:
#
# xcrun stapler staple installer-for-mac.pkg


================================================
FILE: installers/mac/postinstall
================================================
#!/bin/sh

set -ex

echo "$(date)" > /tmp/elm-installer.log


================================================
FILE: installers/mac/preinstall
================================================
#!/bin/sh

set -e

installdir=/usr/local/bin

for bin in elm elm-compiler elm-package elm-reactor elm-repl
do
	if [ -f $installdir/$bin ]; then
		sudo rm -f $installdir/$bin
	fi
	if [ -f $installdir/$bin-unwrapped ]; then
		sudo rm -f $installdir/$bin-unwrapped
	fi
done

sharedir=/usr/local/share/elm
sudo rm -rf $sharedir


================================================
FILE: installers/npm/.gitignore
================================================
node_modules/
packages/*/elm
packages/*/elm.exe


================================================
FILE: installers/npm/.npmignore
================================================
README.md
.gitignore
.git


================================================
FILE: installers/npm/PUBLISHING.md
================================================
# Publishing

Here's how to update the `npm` installer.

## 0. Overview

- There is one _main npm package_ called `elm`.
- Then there is one _binary npm package_ for each platform, called for example `@elm_binaries/darwin_arm64`.

The binary packages declare which OS and CPU they are compatible with. For example:

```json
  "os": [ "darwin" ],
  "cpu": [ "arm64" ]
```

The main npm package depend on the binary packages via [optional dependencies](https://docs.npmjs.com/cli/v9/configuring-npm/package-json#optionaldependencies):

```json
    "@elm_binaries/darwin_arm64": "0.19.1-0",
    "@elm_binaries/darwin_x64": "0.19.1-0",
    "@elm_binaries/linux_arm64": "0.19.1-0",
    ...
```

When installing, `npm` fetches the metadata for all the optional dependencies and only installs the one with a matching OS and CPU. If none of them match, `npm` still considers the install successful. However, the main npm package contains an install script that gives a helpful error.


## 1. GitHub Release

Create a [GitHub Release](https://github.com/elm/compiler/releases) with the following files:

1. `binary-for-mac-64-bit.gz`
2. `binary-for-mac-arm-64-bit.gz`
3. `binary-for-linux-64-bit.gz`
4. `binary-for-linux-arm-64-bit.gz`
5. `binary-for-windows-64-bit.gz`

Create each of these by running the `elm` executable for each platform through `gzip elm`.


## 2. Put the binaries in place

Put the above files at:

1. `packages/darwin_arm64/elm`
2. `packages/darwin_x64/elm`
3. `packages/linux_x64/elm`
4. `packages/linux_arm64/elm`
5. `packages/win32_x64/elm.exe` (Note the `.exe` file extension!)

(They are ignored by git.)


## 3. Publish the binary packages

Repeat this for all the packages mentioned in the previous section. This uses `packages/darwin_arm64` as an example.

1. Go to the folder: `cd packages/darwin_arm64`
2. Double-check that you put the right binary in the right package: `file elm`
3. Double-check that the file is executable: `ls -l elm`
4. In `package.json` of the binary package, bump the version for example to `"0.19.1-2"`.
5. In `package.json` of the main npm package, update `"optionalDependencies"` to point to the bumped version. For example: `"@elm_binaries/darwin_arm64": "0.19.1-2"`
6. Publish the package: `npm publish --access=public`

   `--access=public` is needed because scoped packages are private by default.



Notes about the versions of the binary packages

- End users never have to think about them. They only need to think about the version of the main npm package.

- The binary packages can have different versions. One can have `"0.19.1-0"` while another is at `"0.19.1-1"`. This is useful if you mess up publishing one platform: Then you can bump just that one and re-release, instead of having to re-release _all_ platforms.

- The version of the main npm package is not related to the versions of the binary packages – they’re all independent. So the main npm package can be at `"0.19.1-6"` while the binary packages have suffixes like `-0`, `-1` and `-9`. (They all share the `0.19.1` prefix though to make things more understandable!)

- The main npm package pins the versions of the binary packages _exactly_ – no version ranges.
  - This means that installing `elm@0.19.1-6` installs the exact same bytes in two years as today.
  - The `package.json` of each binary package says which OS and CPU it works for. `binary.js` in the main npm package has code that deals with OS and CPU too, so the main npm package needs to install binary packages with known OS and CPU declarations.

- There is no need to use `beta` suffixes for the binary packages. Just bump the number suffix and point to it in a beta release of the main npm package. As mentioned above:
  - Already published versions of the main npm package depend on exact versions of the binary packages, so they won’t accidentally start downloading beta versions.
  - End users only see the version of the main npm package.





## 4. Try a beta release

In `package.json`, bump the version to `"0.19.2-beta"`.

Double-check that `"optionalDependencies"` is in sync with the binary packages.

```bash
npm publish --tag beta
```

To test that it works, run these commands:

```bash
npm dist-tags ls elm
npm install elm@beta --ignore-scripts
```

The `latest` tag should not be changed, and there should be an additional `beta` tag.

Try this on Windows, Linux, and Mac.


## 5. Publish final release

Remove the `-beta` suffix from the version in `package.json`. Then run:

```bash
npm publish
```


## 6. Tag the `latest-0.19.1` version

Many compiler releases have needed multiple `npm` publications. Maybe something does not work on Windows or some dependency becomes insecure. Normal `npm` problems.

The convention for each Elm release is to create a tag the latest one.

```bash
npm dist-tag add elm@0.19.1-3 latest-0.19.1
```

That way people who want a specific version can point to `latest-0.19.1` or `latest-0.18.0` instead of knowing the particular names of all the various publications.

You can read more about dist-tags [here](https://docs.npmjs.com/cli/dist-tag).



================================================
FILE: installers/npm/README.md
================================================
# Elm Installer

[Elm](https://elm-lang.org) is a functional programming language that compiles to JavaScript.

Head over to [The Official Guide](https://guide.elm-lang.org/) to start learning Elm!





## What is this package for?

For normal installs, I reccomend using the instructions [here](https://guide.elm-lang.org/install/elm.html) instead. This package is only for people who enjoy using `npm` even when it is not necessary, or for people who want to use `npm` for certain scenarios such as:

**Multiple versions**

People using Elm at work may use different versions of Elm in different projects. They can run `npm install elm@latest-0.19.1` in each project and use the binary at `./node_modules/.bin/elm` for compilation.

**Continuous integration**

The `npm` installer works for this, but there are faster and more reliable options:

1. You can download `elm` directly from GitHub with [this script](https://github.com/elm/compiler/blob/master/installers/linux/README.md). This allows you to skip `npm` entirely.
2. Many continuous integration have ways to cache files ([example](https://docs.travis-ci.com/user/caching/)) to make builds faster and more reliable. This is the ideal setup.

That said, it works to use the `npm` installer on CI if you prefer that option.





## Install Locally

The following command should download the latest Elm 0.19.1 binary:

```
npm install elm@latest-0.19.1
```

You should be able to run `./node_modules/bin/elm --version` within your project and see `0.19.1`. Now you can compile with `./node_modules/bin/elm make src/Main.elm` and not disrupt other packages.

Use `npm install elm@latest-0.19.0` or `npm install elm@latest-0.18.0` for earlier versions.

**Note:** The `latest-X.Y.Z` convention is used in case we need to publish patches for the `npm` installer within a given Elm release. For example, say `npm` decides that some transitive dependency is not secure. Nothing is changing about Elm or the binaries, but we need to publish a new `npm` installer that fixes this issue.



================================================
FILE: installers/npm/bin/elm
================================================
#!/usr/bin/env node

var child_process = require('child_process');


// Some npm users enable --ignore-scripts (a good security measure) so
// they do not run the post-install hook and install.js does not run.
// Instead they will run this script.
//
// On Mac and Linux, we hard link the elm executable into the exact same
// location as this file. Since npm uses symlinks on these platforms,
// that means that the first run will invoke this file and subsequent
// runs will call the elm binary directly.
//
// On Windows, our binary file must be named elm.exe for it to run properly.
// Instead of symlinks, npm creates two files:
//
//   - node_modules/.bin/elm (a bash file)
//   - node_modules/.bin/elm.cmd (a batch file)
//
// Both files specifically invoke `node` to run the file listed at package.bin,
// so there is no way around instantiating node for no reason on Windows.


var binaryPath = require('../binary.js')();
child_process
	.spawn(binaryPath, process.argv.slice(2), { stdio: 'inherit' })
	.on('exit', process.exit);


================================================
FILE: installers/npm/binary.js
================================================
var fs = require('fs');
var package = require('./package.json');
var path = require('path');



// MAIN
//
// This function is used by install.js and by the bin/elm backup that gets
// called when --ignore-scripts is enabled.


module.exports = function()
{
	// figure out package of binary
	var version = package.version.replace(/^(\d+\.\d+\.\d+).*$/, '$1'); // turn '1.2.3-alpha' into '1.2.3'
	var subPackageName = '@elm_binaries/' + process.platform + '_' + process.arch;

	verifyPlatform(version, subPackageName);

	var fileName = process.platform === 'win32' ? 'elm.exe' : 'elm';

	try
	{
		var subBinaryPath = require.resolve(subPackageName + '/' + fileName);
	}
	catch (error)
	{
		if (error && error.code === 'MODULE_NOT_FOUND')
		{
			exitFailure(version, missingSubPackageHelp(subPackageName));
		}
		else
		{
			exitFailure(version, 'I had trouble requiring the binary package for your platform (' + subPackageName + '):\n\n' + error);
		}
	}

	// Yarn 2 and later ("Berry") always invokes `node` (regardless of configuration)
	// so we cannot do any optimizations there
	var isYarnBerry = /\byarn\/(?!1\.)/.test(process.env.npm_config_user_agent || "");

	// as mentioned in bin/elm we cannot do any optimizations on Windows
	if (process.platform === 'win32' || isYarnBerry)
	{
		return subBinaryPath;
	}

	// figure out where to put the binary
	var binaryPath = path.resolve(__dirname, package.bin.elm);
	var tmpPath = binaryPath + '.tmp';

	// optimize by replacing the JS bin/elm with the native binary directly
	try
	{
		// atomically replace the file with a hard link to the binary
		fs.linkSync(subBinaryPath, tmpPath);
		fs.renameSync(tmpPath, binaryPath);
	}
	catch (error)
	{
		exitFailure(version, 'I had some trouble writing file to disk. It is saying:\n\n' + error);
	}

	return binaryPath;
}



// VERIFY PLATFORM


function verifyPlatform(version, subPackageName)
{
	if (subPackageName in package.optionalDependencies) return;

	var situation = process.platform + '_' + process.arch;
	console.error(
		'-- ERROR -----------------------------------------------------------------------\n\n'
		+ 'I am detecting that your computer (' + situation + ') may not be compatible with any\n'
		+ 'of the official pre-built binaries.\n\n'
		+ 'I recommend against using the npm installer for your situation. Check out the\n'
		+ 'alternative installers at https://github.com/elm/compiler/releases/tag/' + version + '\n'
		+ 'to see if there is something that will work better for you.\n\n'
		+ 'From there I recommend asking for guidance on Slack or Discourse to find someone\n'
		+ 'who can help with your specific situation.\n\n'
		+ '--------------------------------------------------------------------------------\n'
	);
	process.exit(1);
}



// EXIT FAILURE


function exitFailure(version, message)
{
	console.error(
		'-- ERROR -----------------------------------------------------------------------\n\n'
		+ message
		+ '\n\nNOTE: You can avoid npm entirely by downloading directly from:\n'
		+ 'https://github.com/elm/compiler/releases/tag/' + version + '\n'
		+ 'All this package does is distribute a file from there.\n\n'
		+ '--------------------------------------------------------------------------------\n'
	);
	process.exit(1);
}



// MISSING SUB PACKAGE HELP


function missingSubPackageHelp(subPackageName)
{
	return (
		'I tried to get `elm` from ' + subPackageName + ', but something went wrong.\n'
		+ 'This can happen if you use the "--omit=optional" or "--no-optional" npm flag, or\n'
		+ 'if your "node_modules" folder was copied over from a different computer (or VM).\n'
	);
}


================================================
FILE: installers/npm/install.js
================================================
require('./binary.js')();


================================================
FILE: installers/npm/package.json
================================================
{
  "name": "elm",
  "version": "0.19.1-6",
  "description": "Installer for Elm: just downloads the binary into node_modules",
  "license": "BSD-3-Clause",
  "repository": {
    "type": "git",
    "url": "https://github.com/elm/compiler.git"
  },
  "homepage": "https://github.com/elm/compiler/tree/master/installers/npm",
  "bugs": "https://github.com/elm/compiler/issues",
  "author": {
    "name": "Evan Czaplicki",
    "email": "evan@elm-lang.org",
    "url": "https://github.com/evancz"
  },
  "engines": {
    "node": ">=7.0.0"
  },
  "scripts": {
    "install": "node install.js"
  },
  "files": [
    "install.js",
    "binary.js",
    "bin",
    "bin/elm"
  ],
  "keywords": [
    "bin",
    "binary",
    "binaries",
    "elm",
    "install",
    "installer"
  ],
  "bin": { "elm": "bin/elm" },
  "optionalDependencies": {
    "@elm_binaries/darwin_arm64": "0.19.1-0",
    "@elm_binaries/darwin_x64": "0.19.1-0",
    "@elm_binaries/linux_x64": "0.19.1-0",
    "@elm_binaries/win32_x64": "0.19.1-0"
  }
}


================================================
FILE: installers/npm/packages/darwin_arm64/README.md
================================================
# Elm Binary for macOS (arm64)

Some people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`npm install elm`](https://www.npmjs.com/package/elm) a bit faster and a bit more reliable. It is not intended for direct use!

If you do not need to use `npm`, the official binaries are published via [GitHub releases](https://github.com/elm/compiler/releases) with installation instructions.


================================================
FILE: installers/npm/packages/darwin_arm64/package.json
================================================
{
  "name": "@elm_binaries/darwin_arm64",
  "version": "0.19.1-0",
  "description": "Download the Elm binary for macOS (arm64)",
  "repository": "https://github.com/elm/compiler",
  "license": "BSD-3-Clause",
  "os": [ "darwin" ],
  "cpu": [ "arm64" ]
}


================================================
FILE: installers/npm/packages/darwin_x64/README.md
================================================
# Elm Binary for macOS (x64)

Some people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`npm install elm`](https://www.npmjs.com/package/elm) a bit faster and a bit more reliable. It is not intended for direct use!

If you do not need to use `npm`, the official binaries are published via [GitHub releases](https://github.com/elm/compiler/releases) with installation instructions.


================================================
FILE: installers/npm/packages/darwin_x64/package.json
================================================
{
  "name": "@elm_binaries/darwin_x64",
  "version": "0.19.1-0",
  "description": "Download the Elm binary for macOS (x64)",
  "repository": "https://github.com/elm/compiler",
  "license": "BSD-3-Clause",
  "os": [ "darwin" ],
  "cpu": [ "x64" ]
}


================================================
FILE: installers/npm/packages/linux_arm64/README.md
================================================
# Elm Binary for Linux (arm64)

Some people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`npm install elm`](https://www.npmjs.com/package/elm) a bit faster and a bit more reliable. It is not intended for direct use!

If you do not need to use `npm`, the official binaries are published via [GitHub releases](https://github.com/elm/compiler/releases) with installation instructions.


================================================
FILE: installers/npm/packages/linux_arm64/package.json
================================================
{
  "name": "@elm_binaries/linux_arm64",
  "version": "0.19.1-0",
  "description": "Download the Elm binary for Linux (arm64)",
  "repository": "https://github.com/elm/compiler",
  "license": "BSD-3-Clause",
  "os": [ "linux" ],
  "cpu": [ "arm64" ]
}


================================================
FILE: installers/npm/packages/linux_x64/README.md
================================================
# Elm Binary for Linux (x64)

Some people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`npm install elm`](https://www.npmjs.com/package/elm) a bit faster and a bit more reliable. It is not intended for direct use!

If you do not need to use `npm`, the official binaries are published via [GitHub releases](https://github.com/elm/compiler/releases) with installation instructions.


================================================
FILE: installers/npm/packages/linux_x64/package.json
================================================
{
  "name": "@elm_binaries/linux_x64",
  "version": "0.19.1-0",
  "description": "Download the Elm binary for Linux (x64)",
  "repository": "https://github.com/elm/compiler",
  "license": "BSD-3-Clause",
  "os": [ "linux" ],
  "cpu": [ "x64" ]
}


================================================
FILE: installers/npm/packages/win32_x64/README.md
================================================
# Elm Binary for Windows (x64)

Some people install [Elm](https://elm-lang.org/) with `npm`. This package helps make [`npm install elm`](https://www.npmjs.com/package/elm) a bit faster and a bit more reliable. It is not intended for direct use!

If you do not need to use `npm`, the official binaries are published via [GitHub releases](https://github.com/elm/compiler/releases) with installation instructions.


================================================
FILE: installers/npm/packages/win32_x64/package.json
================================================
{
  "name": "@elm_binaries/win32_x64",
  "version": "0.19.1-0",
  "description": "Download the Elm binary for Windows (x64)",
  "repository": "https://github.com/elm/compiler",
  "license": "BSD-3-Clause",
  "os": [ "win32" ],
  "cpu": [ "x64" ]
}


================================================
FILE: installers/npm/troubleshooting.md
================================================
# Troubleshooting

I very highly recommend asking for help on [the Elm slack](https://elmlang.herokuapp.com).

There are a lot of things that can go wrong when installing software, and it can really help to have a second pair of eyes on your situation!

This document goes through a couple options that may help you out.





## Can you skip npm entirely?

The most reliable way to get Elm installed using the official installers for Mac and Windows [here][download].

You can also download the binaries directly. On Linux, you could do it in the terminal like this:

```bash
cd ~/Desktop/
curl -L -o elm.gz https://github.com/elm/compiler/releases/download/0.19.1/binary-for-linux-64-bit.gz
gunzip elm.gz                # unzip the file
chmod +x elm                 # make the file executable
sudo mv elm /usr/local/bin/  # put the executable in a directory likely to be listed in your PATH variable
```

If these exact commands do not work for you, you can try to do the same thing by hand.

Read the section below on `PATH` variables if you are not sure what that is!

[download]: https://github.com/elm/compiler/releases/tag/0.19.1





## Do you need to use npm for some reason?

The company running npm has a list of common troubleshooting situations [here](https://npm.community/c/support/troubleshooting), but it may be better to just try to find your specific case on Stack Overflow. Often there are permissions issues where you may need to use `sudo` with some command.

### Firewalls

Some companies have a firewall.

These companies usually have set the `HTTP_PROXY` or `HTTPS_PROXY` environment variable on your computer. This is more common with Windows computers.

The result is that the requests for npm packages are being sent to a "proxy server" where they monitor traffic. Maybe they rule out certain domains, maybe they check data when it comes back from the actual URL, etc.

It is probably best to ask someone about the situation on this, but you can test things out by temporarily using an alternate `HTTPS_PROXY` value with something like this:

```
# Mac and Linux
HTTPS_PROXY=http://proxy.example.com npm install -g elm

# Windows
set HTTPS_PROXY=http://proxy.example.com
npm install -g elm
```

Check out [this document](https://docs.npmjs.com/cli/using-npm/config/) for more information on how environment variables like [NO_PROXY](https://docs.npmjs.com/cli/using-npm/config#noproxy), [HTTP_PROXY](https://docs.npmjs.com/cli/using-npm/config#proxy), and [HTTPS_PROXY](https://docs.npmjs.com/cli/using-npm/config#https-proxy) are handled by npm.





## Do you know what a `PATH` variable is?

When you run a command like `elm make src/Main.elm`, your computer starts by trying to find a file called `elm`.

The `PATH` is a list of directories to search within. On Mac and Linux, you can see these directories by running:

```
$ echo $PATH
/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin:/usr/local/git/bin
```

The are separated by `:` for some reason. So running `elm make src/Main.elm` starts by searching the `PATH` for files named `elm`. On my computer, it finds `/usr/local/bin/elm` and then can actually run the command.

Is `elm` in one of the directories listed in your `PATH` variable? I recommend asking for help if you are in this scenario and unsure how to proceed.


================================================
FILE: installers/win/CreateInternetShortcut.nsh
================================================
!macro CreateInternetShortcut FILENAME URL ICONFILE ICONINDEX
WriteINIStr "${FILENAME}.url" "InternetShortcut" "URL" "${URL}"
WriteINIStr "${FILENAME}.url" "InternetShortcut" "IconFile" "${ICONFILE}"
WriteINIStr "${FILENAME}.url" "InternetShortcut" "IconIndex" "${ICONINDEX}"
!macroend

================================================
FILE: installers/win/Nsisfile.nsi
================================================
; Elm Installer

;--------------------------------
;Includes

  !Include "FileFunc.nsh"
  !Include "LogicLib.nsh"
  !Include "MUI2.nsh"
  !Include "WordFunc.nsh"
  !Include "CreateInternetShortcut.nsh"

;--------------------------------
;Defines

  !Define PRODUCT_DIR_REG_KEY "Software\Elm\Elm\${PLATFORM_VERSION}"
  !Define FILES_SOURCE_PATH "files"
  !Define INST_DAT "inst.dat"
  !Define UNINST_DAT "uninst.dat"

;--------------------------------
;Variables

  Var START_MENU_FOLDER

;--------------------------------
;General settings

  ;Name and file
  Name "Elm ${PLATFORM_VERSION}"
  OutFile "Elm-${PLATFORM_VERSION}.exe"

  ;Default install dir
  InstallDir "$PROGRAMFILES\Elm\${PLATFORM_VERSION}"
  InstallDirRegKey HKLM "${PRODUCT_DIR_REG_KEY}" ""

  ;Icon
  !Define MUI_ICON "logo.ico"
  !Define MUI_UNICON "logo.ico"

  ;Request application privileges for Windows Vista
  RequestExecutionLevel highest

  ;Best available compression
  SetCompressor /SOLID lzma

  ;Install types
  InstType "Standard"
  InstType "Portable (just unpack the files)"

;--------------------------------
;Macros

!macro CheckAdmin thing
UserInfo::GetAccountType
pop $0
${If} $0 != "admin" ;Require admin rights on NT4+
    MessageBox MB_YESNO "It is recommended to run this ${thing} as administrator. Do you want to quit and restart the ${thing} manually with elevated privileges?" IDNO CheckAdminDone
    SetErrorLevel 740 ;ERROR_ELEVATION_REQUIRED
    Quit
${EndIf}
CheckAdminDone:
!macroend

;--------------------------------
;Callbacks

Function .onInit
  !insertmacro CheckAdmin "installer"
  SetShellVarContext all
FunctionEnd

Function un.onInit
  !insertmacro CheckAdmin "uninstaller"
  SetShellVarContext all
FunctionEnd

Function LaunchLink
  ExecShell "open" "https://guide.elm-lang.org"
FunctionEnd

;--------------------------------
;Interface Settings

  !define MUI_ABORTWARNING

;--------------------------------
;Pages

  !Define MUI_WELCOMEFINISHPAGE_BITMAP "welcome.bmp"
  !insertmacro MUI_PAGE_WELCOME
  ;!insertmacro MUI_PAGE_LICENSE "LICENSE"
  !insertmacro MUI_PAGE_DIRECTORY

  !Define MUI_COMPONENTSPAGE_NODESC
  !insertmacro MUI_PAGE_COMPONENTS

  ;Start Menu Folder Page Configuration
  !Define MUI_PAGE_HEADER_SUBTEXT \
  "Choose a Start Menu folder for the Elm ${PLATFORM_VERSION} shortcuts."
  !Define MUI_STARTMENUPAGE_TEXT_TOP \
  "Select the Start Menu folder in which you would like to create Elm shortcuts. You can also enter a name to create a new folder."
  !Define MUI_STARTMENUPAGE_REGISTRY_ROOT "HKLM"
  !Define MUI_STARTMENUPAGE_REGISTRY_KEY "${PRODUCT_DIR_REG_KEY}"
  !Define MUI_STARTMENUPAGE_REGISTRY_VALUENAME "Start Menu Folder"
  !Define MUI_STARTMENUPAGE_DEFAULTFOLDER "Elm ${PLATFORM_VERSION}"
  !insertmacro MUI_PAGE_STARTMENU StartMenuPage $START_MENU_FOLDER
  !insertmacro MUI_PAGE_INSTFILES
  !define MUI_FINISHPAGE_RUN
  !define MUI_FINISHPAGE_RUN_FUNCTION "LaunchLink"
  !define MUI_FINISHPAGE_RUN_TEXT "Open tutorial on how to use Elm"
  !insertmacro MUI_PAGE_FINISH

  !insertmacro MUI_UNPAGE_WELCOME
  !insertmacro MUI_UNPAGE_CONFIRM
  !insertmacro MUI_UNPAGE_INSTFILES
  !insertmacro MUI_UNPAGE_FINISH

;--------------------------------
;Languages

  !insertmacro MUI_LANGUAGE "English"

;--------------------------------
;Installer Sections

Section "Base components" SecMain

  SectionIn 1 2
  ; Make this section mandatory
  SectionIn RO

  !Include ${INST_DAT}

SectionEnd

SectionGroup "Update system settings" SecGr

;Section "Associate with .elm files" SecAssoc
;
;  SectionIn 1
;
;  ; File associations
;  WriteRegStr HKCR ".elm" "" "elm"
;  WriteRegStr HKCR "elm" "" "Elm Source File"
;  WriteRegStr HKCR "elm\DefaultIcon" "" "$INSTDIR\file.ico"
;  WriteRegStr HKCR "elm\shell\open\command" "" '"$INSTDIR\bin\elm.exe" "%1"'
;
;  ;Remember that we registered associations
;  WriteRegDWORD HKLM "${PRODUCT_DIR_REG_KEY}" Assocs 0x1
;
;SectionEnd

Section "Update the PATH environment variable" SecPath

  SectionIn 1

  ; Update PATH
  ; First, remove any older version
  ExecWait '"$SYSDIR\wscript.exe" //E:vbscript "$INSTDIR\removefrompath.vbs" "$PROGRAMFILES\Elm"'
  ; Then add to the PATH
  ExecWait '"$SYSDIR\wscript.exe" //E:vbscript "$INSTDIR\updatepath.vbs" "$INSTDIR\bin"'
  SetShellVarContext current

  ; Update environment variables
  SendMessage ${HWND_BROADCAST} ${WM_SETTINGCHANGE} 0 "STR:Environment" /TIMEOUT=5000

SectionEnd

Section "Store Elm's location in registry" SecElmLoc

  SectionIn 1

  ; (copied from the GHC installer).
  ;WriteRegStr HKCU "Software\Elm\ghc-${GHC_VERSION}" "InstallDir" "$INSTDIR"
  WriteRegStr HKCU "Software\Elm" "InstallDir" "$INSTDIR"

SectionEnd

Section "Create uninstaller" SecAddRem

  SectionIn 1
  SectionIn RO

  ; Add uninstall information to Add/Remove Programs
  WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" \
  "DisplayName" "Elm ${PLATFORM_VERSION}"
  WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" \
  "UninstallString" "$\"$INSTDIR\Uninstall.exe$\""
  WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" \
  "DisplayIcon" "$INSTDIR\logo.ico"
  WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}" \
  "Publisher" "elm-lang.org"

  ;Create uninstaller
  WriteUninstaller "$INSTDIR\Uninstall.exe"

  ; This is needed for uninstaller to work
  WriteRegStr HKLM "${PRODUCT_DIR_REG_KEY}" "" "$INSTDIR\Uninstall.exe"
  WriteRegStr HKLM "${PRODUCT_DIR_REG_KEY}" "InstallDir" "$INSTDIR"

SectionEnd

SectionGroupEnd

;Section "-StartMenu" StartMenu
;  SectionIn 1 2
;
;  ; Add start menu shortcuts
;
;  !insertmacro MUI_STARTMENU_WRITE_BEGIN StartMenuPage
;
;    ;Create shortcuts
;    CreateDirectory "$SMPROGRAMS\$START_MENU_FOLDER"
;    !insertmacro CreateInternetShortcut \
;    "$SMPROGRAMS\$START_MENU_FOLDER\${HACKAGE_SHORTCUT_TEXT}" \
;    "http://hackage.haskell.org" \
;    "$INSTDIR\icons\hackage.ico" "0"
;  !insertmacro MUI_STARTMENU_WRITE_END
;
;SectionEnd

;--------------------------------
;Uninstaller Section

Section "Uninstall"

  ; Update PATH
  ExecWait '"$SYSDIR\wscript.exe" //E:vbscript "$INSTDIR\removefrompath.vbs" "$PROGRAMFILES\Elm"'
  SetShellVarContext current

  !Include ${UNINST_DAT}

  Delete "$INSTDIR\Uninstall.exe"
  RMDir $INSTDIR

  ;Since we install to '$PF\Elm\$PLATFORM_VERSION', we
  ;should also try to delete '$PF\Elm' if it is empty.
  ${GetParent} $INSTDIR $R0
  RMDir $R0

  ; Delete start menu shortcuts
  ;!insertmacro MUI_STARTMENU_GETFOLDER StartMenuPage $START_MENU_FOLDER

  ;Delete "$SMPROGRAMS\$START_MENU_FOLDER\${HACKAGE_SHORTCUT_TEXT}.url"
  ;RMDir "$SMPROGRAMS\$START_MENU_FOLDER\"

  ; Delete registry keys

  ReadRegDWORD $0 HKLM "${PRODUCT_DIR_REG_KEY}" Assocs

  ${If} $0 = 0x1
    DeleteRegValue HKCR ".elm" ""
    DeleteRegKey HKCR "elm\DefaultIcon"
  ${EndIf}

  DeleteRegKey HKCU "Software\Elm"
  DeleteRegKey HKLM "${PRODUCT_DIR_REG_KEY}"
  DeleteRegKey /IfEmpty HKCU Software\Elm
  DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Elm-${PLATFORM_VERSION}"

  ; Update environment variables
  SendMessage ${HWND_BROADCAST} ${WM_SETTINGCHANGE} 0 "STR:Environment" /TIMEOUT=5000

SectionEnd


================================================
FILE: installers/win/README.md
================================================
# Installing on Windows

The installer for Windows is available [here](https://guide.elm-lang.org/install.html).





## Uninstall

First run the `C:\Program Files (x86)\Elm\0.19\uninstall.exe` file. This will remove Elm stuff from your `PATH`.

Then remove the whole `C:\Users\\AppData\Roaming\elm` directory. Elm caches some packages and build artifacts to reduce compile times and to help you work offline. Getting rid of this directory will clear that information out!




## Building the Windows installer

You will need the [NSIS installer](http://nsis.sourceforge.net/Download) to be installed.

Once everything is installed, run something like this command:

    make_installer.cmd 0.19.0

It will build an installer called `Elm-0.19.0-setup.exe`.


================================================
FILE: installers/win/make_installer.cmd
================================================

set version=%1

mkdir files
mkdir files\bin

xcopy ..\..\dist\build\elm\elm.exe files\bin /s /e
xcopy updatepath.vbs files

if EXIST "%ProgramFiles%\NSIS" (
    set nsis="%ProgramFiles%\NSIS\makensis.exe"
) else (
    set nsis="%ProgramFiles(x86)%\NSIS\makensis.exe"
)

%nsis% /DPLATFORM_VERSION=%version% Nsisfile.nsi

rd /s /q files


================================================
FILE: installers/win/removefrompath.vbs
================================================
Set WshShell = CreateObject("WScript.Shell")
' Make sure there is no trailing slash at the end of elmBasePath
elmBasePath = WScript.Arguments(0)
'const PathRegKey = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path"
const PathRegKey = "HKCU\Environment\Path"

on error resume next
path = WshShell.RegRead(PathRegKey)
if err.number = 0 then
	Set regEx = New RegExp
	elmBasePath = Replace(Replace(Replace(elmBasePath, "\", "\\"), "(", "\("), ")", "\)")
	regEx.Pattern = elmBasePath & "\\\d+\.\d+(\.\d+|)\\bin(;|)"
	regEx.Global = True
	newPath = regEx.Replace(path, "")
	Call WshShell.RegWrite(PathRegKey, newPath, "REG_EXPAND_SZ")
end if
on error goto 0


================================================
FILE: installers/win/updatepath.vbs
================================================
Set WshShell = CreateObject("WScript.Shell")
elmPath = WScript.Arguments(0)
'const PathRegKey = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path"
const PathRegKey = "HKCU\Environment\Path"

on error resume next
path = WshShell.RegRead(PathRegKey)
if err.number <> 0 then
	path = ""
end if
on error goto 0

newPath = elmPath & ";" & path
Call WshShell.RegWrite(PathRegKey, newPath, "REG_EXPAND_SZ")


================================================
FILE: reactor/assets/styles.css
================================================
@charset "UTF-8";


/* FONTS */

@font-face {
  font-family: 'Source Code Pro';
  font-style: normal;
  font-weight: 400;
  src: local('Source Code Pro'), local('SourceCodePro-Regular'), url(/_elm/source-code-pro.ttf) format('truetype');
}

@font-face {
  font-family: 'Source Sans Pro';
  font-style: normal;
  font-weight: 400;
  src: local('Source Sans Pro'), local('SourceSansPro-Regular'), url(/_elm/source-sans-pro.ttf) format('truetype');
}


/* GENERIC STUFF */

html, head, body {
  margin: 0;
  height: 100%;
}

body {
  font-family: 'Source Sans Pro', 'Trebuchet MS', 'Lucida Grande', 'Bitstream Vera Sans', 'Helvetica Neue', sans-serif;
  color: #293c4b;
}

a {
  color: #60B5CC;
  text-decoration: none;
}

a:hover {
  text-decoration: underline;
}


/* INDEX */

.header {
  width: 100%;
  background-color: #60B5CC;
  height: 8px;
}

.content {
  width: 960px;
  margin-left: auto;
  margin-right: auto;
}


/* COLUMNS */

.left-column {
  float: left;
  width: 600px;
  padding-bottom: 80px;
}

.right-column {
  float: right;
  width: 300px;
  padding-bottom: 80px;
}


/* BOXES */

.box {
  border: 1px solid #c7c7c7;
  border-radius: 5px;
  margin-bottom: 40px;
}

.box-header {
  display: block;
  overflow: hidden;
  padding: 7px 12px;
  background-color: #fafafa;
  text-align: center;
  border-radius: 5px;
}

.box-item {
  display: block;
  overflow: hidden;
  padding: 7px 12px;
  border-top: 1px solid #e1e1e1;
}

.box-footer {
  display: block;
  overflow: hidden;
  padding: 2px 12px;
  border-top: 1px solid #e1e1e1;
  text-align: center;
  background-color: #fafafa;
  height: 16px;
}


/* ICONS */

.icon {
  display: inline-block;
  vertical-align: middle;
  padding-right: 0.5em;
}


/* PAGES */

.page-name {
  float: left;
}

.page-size {
  float: right;
  color: #293c4b;
}

.page-size:hover {
  color: #60B5CC;
}


/* WAITING */

.waiting {
  width: 100%;
  height: 100%;
  display: flex;
  flex-direction: column;
  justify-content: center;
  align-items: center;
  color: #9A9A9A;
}


/* NOT FOUND */

.not-found {
  width: 100%;
  height: 100%;
  display: flex;
  flex-direction: column;
  justify-content: center;
  align-items: center;
  background-color: #F5F5F5;
  color: #9A9A9A;
}


================================================
FILE: reactor/check.py
================================================
#!/usr/bin/env python

import os
import sys


## FIGURE OUT NEW MODIFICATION TIME

def mostRecentModification(directory):
	mostRecent = 0

	for dirpath, dirs, files in os.walk(directory):
		for f in files:
			lastModified = os.path.getmtime(dirpath + '/' + f)
			mostRecent = max(int(lastModified), mostRecent)

	return mostRecent


srcTime = mostRecentModification('ui/src')
assetTime = mostRecentModification('ui/assets')
mostRecent = max(srcTime, assetTime)


## FIGURE OUT OLD MODIFICATION TIME

with open('ui/last-modified', 'a') as handle:
	pass


prevMostRecent = 0


with open('ui/last-modified', 'r+') as handle:
	line = handle.read()
	prevMostRecent = int(line) if line else 0


## TOUCH FILES IF NECESSARY

if mostRecent > prevMostRecent:
	print "+------------------------------------------------------------+"
	print "| Some ui/ code changed. Touching src/Reactor/StaticFiles.hs |"
	print "| to trigger a recompilation of the Template Haskell stuff.  |"
	print "+------------------------------------------------------------+"
	os.utime('src/Reactor/StaticFiles.hs', None)
	with open('ui/last-modified', 'w') as handle:
		handle.write(str(mostRecent))


================================================
FILE: reactor/elm.json
================================================
{
    "type": "application",
    "source-directories": [
        "src"
    ],
    "elm-version": "0.19.1",
    "dependencies": {
        "direct": {
            "elm/browser": "1.0.1",
            "elm/core": "1.0.2",
            "elm/html": "1.0.0",
            "elm/http": "2.0.0",
            "elm/json": "1.1.2",
            "elm/project-metadata-utils": "1.0.0",
            "elm/svg": "1.0.1",
            "elm-explorations/markdown": "1.0.0"
        },
        "indirect": {
            "elm/bytes": "1.0.7",
            "elm/file": "1.0.1",
            "elm/parser": "1.1.0",
            "elm/time": "1.0.0",
            "elm/url": "1.0.0",
            "elm/virtual-dom": "1.0.2"
        }
    },
    "test-dependencies": {
        "direct": {},
        "indirect": {}
    }
}


================================================
FILE: reactor/src/Deps.elm
================================================
module Deps exposing (main)


import Browser
import Browser.Dom as Dom
import Dict exposing (Dict)
import Elm.Constraint as Constraint exposing (Constraint)
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import Html.Keyed as Keyed
import Html.Lazy exposing (..)
import Http
import Json.Decode as D
import Json.Encode as E
import Svg
import Svg.Attributes as S
import Task



-- MAIN


main =
  Browser.document
    { init = init
    , view = view
    , update = update
    , subscriptions = \_ -> Sub.none
    }



-- MODEL


type alias Model =
  { status : Status
  , id : Int
  -- queries
  , search : Search
  , registry : Registry
  -- history
  , past : List Change
  , future : List Change
  , origin : Origin
  }



-- STATUS


type Status
  = Failure Checkpoint (List Change)
  | Waiting Checkpoint (List Change)
  | Success Checkpoint


type alias Checkpoint =
  { direct : Dict String Bounds
  , indirect : Dict String Bounds
  }


type Bounds
  = New Version NewBounds
  | Old Version Version OldBounds


type NewBounds
  = NAny
  | NCustom Constraint


type OldBounds
  = OLocked
  | OPatch
  | OMinor
  | OMajor
  | OAny
  | OCustom Constraint



-- CHANGES


type Change
  = MassLock
  | MassPatch
  | MassMinor
  | MassMajor
  | AddDirect String
  | TweakOldDirect String OldBounds
  | TweakNewDirect String NewBounds
  | TweakOldIndirect String OldBounds
  | TweakNewIndirect String NewBounds
  | DeleteDirect String
  | DeleteIndirect String



-- PREVIEW


type alias Preview =
  { direct : Dict String PBounds
  , indirect : Dict String PBounds
  }


type PBounds
  = PNew (Maybe Version) NewBounds
  | POld Version Version OldBounds


toPreview : Origin -> Checkpoint -> List Change -> Preview
toPreview origin checkpoint changes =
  let
    toPreviewBounds _ bounds =
      case bounds of
        New vsn nb     -> PNew (Just vsn) nb
        Old old new ob -> POld old new ob

    start =
      { direct   = Dict.map toPreviewBounds checkpoint.direct
      , indirect = Dict.map toPreviewBounds checkpoint.indirect
      }
  in
  List.foldr (step origin) start changes


step : Origin -> Change -> Preview -> Preview
step origin change preview =
  case change of
    MassLock ->
      massChange OLocked preview

    MassPatch ->
      massChange OPatch preview

    MassMinor ->
      massChange OMinor preview

    MassMajor ->
      massChange OMajor preview

    AddDirect pkg ->
      let
        pBound =
          case Dict.get pkg origin.direct of
            Just vsn -> POld vsn vsn OLocked
            Nothing ->
              case Dict.get pkg origin.indirect of
                Just vsn -> POld vsn vsn OLocked
                Nothing -> PNew Nothing NAny
      in
      { direct = Dict.insert pkg pBound preview.direct
      , indirect = Dict.remove pkg preview.indirect
      }

    TweakOldDirect pkg oldBounds ->
      { direct = Dict.update pkg (alterOld oldBounds) preview.direct
      , indirect = preview.indirect
      }

    TweakNewDirect pkg newBounds ->
      { direct = Dict.update pkg (alterNew newBounds) preview.direct
      , indirect = preview.indirect
      }

    TweakOldIndirect pkg oldBounds ->
      { direct = preview.direct
      , indirect = Dict.update pkg (alterOld oldBounds) preview.indirect
      }

    TweakNewIndirect pkg newBounds ->
      { direct = preview.direct
      , indirect = Dict.update pkg (alterNew newBounds) preview.indirect
      }

    DeleteDirect pkg ->
      { direct = Dict.remove pkg preview.direct
      , indirect = preview.indirect
      }

    DeleteIndirect pkg ->
      { direct = preview.direct
      , indirect = Dict.remove pkg preview.indirect
      }


massChange : OldBounds -> Preview -> Preview
massChange oldBounds preview =
  let
    changeBounds _ bounds =
      case bounds of
        PNew vsn newBounds -> PNew vsn newBounds
        POld old new _ -> POld old new oldBounds
  in
  { direct   = Dict.map changeBounds preview.direct
  , indirect = Dict.map changeBounds preview.indirect
  }


alterOld : OldBounds -> Maybe PBounds -> Maybe PBounds
alterOld ob maybeBounds =
  case maybeBounds of
    Nothing ->
      Nothing

    Just bounds ->
      case bounds of
        PNew vsn nb    -> Just (PNew vsn nb)
        POld old new _ -> Just (POld old new ob)


alterNew : NewBounds -> Maybe PBounds -> Maybe PBounds
alterNew nb maybeBounds =
  case maybeBounds of
    Nothing ->
      Nothing

    Just bounds ->
      case bounds of
        PNew vsn _      -> Just (PNew vsn nb)
        POld old new ob -> Just (POld old new ob)



-- INIT


init : () -> (Model, Cmd Msg)
init () =
  let
    origin = startTODO
    chkp = toInitialCheckpoint origin
  in
  await chkp []
    { status = Waiting chkp []
    , id = 0
    , search = { query = "", focus = Nothing }
    , registry = registryTODO
    , past = []
    , future = []
    , origin = origin
    }


type alias Origin =
  { direct : Dict String Version
  , indirect : Dict String Version
  }


startTODO : Origin
startTODO =
  { direct =
      Dict.fromList
        [ ("elm/browser", Version 1 0 1)
        , ("elm/core", Version 1 0 2)
        , ("elm/html", Version 1 0 0)
        , ("elm/http", Version 2 0 0)
        , ("elm/json", Version 1 1 2)
        , ("elm/project-metadata-utils", Version 1 0 0)
        , ("elm/svg", Version 1 0 1)
        , ("elm-explorations/markdown", Version 1 0 0)
        ]
  , indirect =
      Dict.fromList
        [ ("elm/parser", Version 1 1 0)
        , ("elm/time", Version 1 0 0)
        , ("elm/url", Version 1 0 0)
        , ("elm/virtual-dom", Version 1 0 2)
        ]
  }



-- CHECKPOINTS


toInitialCheckpoint : Origin -> Checkpoint
toInitialCheckpoint origin =
  { direct   = Dict.map (\_ v -> Old v v OLocked) origin.direct
  , indirect = Dict.map (\_ v -> Old v v OLocked) origin.indirect
  }


toCheckpoint : Dict String Version -> Preview -> Maybe Checkpoint
toCheckpoint solution preview =
  let
    direct   = Dict.foldr (addBound solution) Dict.empty preview.direct
    indirect = Dict.foldr (addBound solution) Dict.empty preview.indirect
  in
  if Dict.size direct == Dict.size preview.direct then
    Just (Checkpoint direct indirect)
  else
    Nothing


addBound : Dict String Version -> String -> PBounds -> Dict String Bounds -> Dict String Bounds
addBound solution pkg bounds dict =
  case Dict.get pkg solution of
    Nothing ->
      dict

    Just new ->
      case bounds of
        PNew _ newBounds ->
          Dict.insert pkg (New new newBounds) dict

        POld old _ oldBounds ->
          Dict.insert pkg (Old old new oldBounds) dict



-- UPDATE


type Msg
  = NoOp
  | Commit Change
  | Undo
  | Redo
  | GotSolution Int (Result Http.Error (Dict String Version))
  | SearchTouched SearchMsg


update : Msg -> Model -> (Model, Cmd Msg)
update msg model =
  case Debug.log "msg" msg of
    NoOp ->
      ( model, Cmd.none )

    Commit latest ->
      let (checkpoint, changes) = getCheckpoint model.status in
      await checkpoint (latest::changes) { model | future = [] }

    Undo ->
      case getCheckpoint model.status of
        (checkpoint, latest :: previous) ->
          await checkpoint previous { model | future = latest :: model.future }

        (_, []) ->
          case model.past of
            [] -> ( model, Cmd.none )

            latest :: previous ->
              await (toInitialCheckpoint model.origin) previous
                { model | past = [], future = latest :: model.future }

    Redo ->
      case model.future of
        [] ->
          ( model, Cmd.none )

        next :: nexterer ->
          let (checkpoint, changes) = getCheckpoint model.status in
          await checkpoint (next::changes) { model | future = nexterer }

    GotSolution id result ->
      if model.id /= id then
        ( model, Cmd.none )
      else
        let
          (oldCheckpoint, changes) = getCheckpoint model.status
        in
        case result of
          Err _ ->
            ( { model | status = Failure oldCheckpoint changes }, Cmd.none )

          Ok solution ->
            case toCheckpoint solution (toPreview model.origin oldCheckpoint changes) of
              Nothing ->
                ( { model | status = Failure oldCheckpoint changes }
                , Cmd.none
                )

              Just newCheckpoint ->
                ( { model
                      | status = Success newCheckpoint
                      , past = changes ++ model.past
                  }
                , Cmd.none
                )

    SearchTouched searchMsg ->
      case updateSearch model.registry searchMsg model.search of
        SNone ->
          ( model, Cmd.none )

        SUpdate newSearch ->
          ( { model | search = newSearch }
          , Cmd.none
          )

        SManualBlur newSearch ->
          ( { model | search = newSearch }
          , Task.attempt (\_ -> NoOp) (Dom.blur searchDepsID)
          )

        SAdd name ->
          let (checkpoint, changes) = getCheckpoint model.status in
          await checkpoint (AddDirect name :: changes)
            { model
                | search = { query = "", focus = Nothing }
                , future = []
            }


getCheckpoint : Status -> (Checkpoint, List Change)
getCheckpoint status =
  case status of
    Failure chkp cs -> (chkp, cs)
    Waiting chkp cs -> (chkp, cs)
    Success chkp    -> (chkp, [])


await : Checkpoint -> List Change -> Model -> (Model, Cmd Msg)
await checkpoint changes model =
  let
    id = model.id + 1
    preview = toPreview model.origin checkpoint changes
  in
  (
    { model
        | status = Waiting checkpoint changes
        , id = id
    }
  ,
    Http.post
      { url = "/elm-stuff/solve"
      , body =
          Http.jsonBody <|
            E.object
              [ ("direct", E.dict identity encodeConstraint preview.direct)
              , ("indirect", E.dict identity encodeConstraint preview.indirect)
              ]
      , expect = Http.expectJson (GotSolution id) solutionDecoder
      }
  )



-- VIEW


view : Model -> Browser.Document Msg
view model =
  { title = "elm.json"
  , body =
      [ span
          [ style "width" "calc(100% - 500px - 2em)"
          , style "position" "fixed"
          , style "top" "0"
          , style "left" "0"
          , style "bottom" "0"
          , style "overflow-x" "hidden"
          , style "overflow-y" "scroll"
          , style "filter" "blur(4px)"
          , style "white-space" "pre"
          , style "font-family" "monospace"
          ]
          [ text elmJson
          ]
      , viewEditPanel model
      ]
  }


viewEditPanel : Model -> Html Msg
viewEditPanel model =
  div
    [ style "width" "500px"
    , style "position" "fixed"
    , style "top" "0"
    , style "right" "0"
    , style "bottom" "0"
    , style "overflow-y" "scroll"
    , style "background-color" "white"
    , style "padding" "1em"
    ]
    [ node "style" [] [ text styles ]
    , div
        [ style "display" "flex"
        , style "justify-content" "space-between"
        ]
        [ viewMassUpdates
        , lazy3 viewUndoRedo model.status model.past model.future
        ]
    , div
        [ style "display" "flex"
        , style "justify-content" "space-between"
        , style "align-items" "center"
        ]
        [ h2 [] [ text "Dependencies" ]
        , Html.map SearchTouched <|
            lazy4 viewSearch searchDepsID "Package Search" model.registry model.search
        ]
    , lazy2 viewStatus model.origin model.status
    ]


viewMassUpdates : Html Msg
viewMassUpdates =
  div []
    [ text "Mass Updates: "
    , activeButton (Commit MassLock ) (text "LOCK")
    , activeButton (Commit MassPatch) (text "PATCH")
    , activeButton (Commit MassMinor) (text "MINOR")
    , activeButton (Commit MassMajor) (text "MAJOR")
    ]


viewUndoRedo : Status -> List Change -> List Change -> Html Msg
viewUndoRedo status past future =
  let
    hasNoPast =
      List.isEmpty past &&
      case status of
        Failure _ cs -> List.isEmpty cs
        Waiting _ cs -> List.isEmpty cs
        Success _    -> True

    hasNoFuture =
      List.isEmpty future
  in
  div []
    [ if hasNoPast   then inactiveButton undoIcon else activeButton Undo undoIcon
    , if hasNoFuture then inactiveButton redoIcon else activeButton Redo redoIcon
    ]


activeButton : msg -> Html msg -> Html msg
activeButton msg content =
  button [ class "button", onClick msg ] [ content ]


inactiveButton : Html msg -> Html msg
inactiveButton content =
  button [ class "button-inactive" ] [ content ]



-- VIEW STATUS


viewStatus : Origin -> Status -> Html Msg
viewStatus origin status =
  let
    (directs, indirects) = viewStatusRows origin status
  in
  div []
    [ viewTable "Direct"   <| Dict.toList directs
    , viewTable "Indirect" <| Dict.toList indirects
    ]


viewStatusRows : Origin -> Status -> (Dict String (Html Msg), Dict String (Html Msg))
viewStatusRows origin status =
  case status of
    Failure checkpoint changes ->
      let preview = toPreview origin checkpoint changes in
      ( Dict.map (lazy2 viewWaitingRow) preview.direct
      , Dict.map (lazy2 viewWaitingRow) preview.indirect
      )

    Waiting checkpoint changes ->
      let preview = toPreview origin checkpoint changes in
      ( Dict.map (lazy2 viewWaitingRow) preview.direct
      , Dict.map (lazy2 viewWaitingRow) preview.indirect
      )

    Success checkpoint ->
      ( Dict.map (lazy2 viewSuccessRow) checkpoint.direct
      , Dict.map (lazy2 viewSuccessRow) checkpoint.indirect
      )


viewSuccessRow : String -> Bounds -> Html Msg
viewSuccessRow pkg bounds =
  case bounds of
    New version newBounds ->
      viewRow pkg (RowNew version)

    Old old new oldBounds ->
      viewRow pkg (RowOld old new)


viewWaitingRow : String -> PBounds -> Html Msg
viewWaitingRow pkg bounds =
  case bounds of
    PNew vsn newBounds ->
      viewRow pkg (RowNewGuess vsn)

    POld old new oldBounds ->
      viewRow pkg (RowOldGuess old new)



-- VIEW TABLE


viewTable : String -> List (String, Html Msg) -> Html Msg
viewTable title rows =
  table [ style "padding-bottom" "1em" ]
    [ viewColgroup
    , thead [] [ tr [] [ td [ class "table-title" ] [ text title ] ] ]
    , Keyed.node "tbody" [] rows
    ]


viewColgroup : Html msg
viewColgroup =
  colgroup []
    [ col [ style "width" "350px" ] []
    , col [ style "width" "50px" ] []
    , col [ style "width" "50px" ] []
    , col [ style "width" "50px" ] []
    ]


type RowInfo
  = RowNew Version
  | RowOld Version Version
  | RowNewGuess (Maybe Version)
  | RowOldGuess Version Version


viewRow : String -> RowInfo -> Html msg
viewRow pkg info =
  case info of
    RowNew vsn ->
      viewRowHelp pkg (text "") (text "") (viewVersion "black" vsn)

    RowNewGuess Nothing ->
      viewRowHelp pkg (text "") (text "") (text "")

    RowNewGuess (Just v) ->
      viewRowHelp pkg (text "") (text "") (viewVersion "#eeeeee" v)

    RowOld old new ->
      if old == new
      then viewRowHelp pkg (text "") (text "") (viewVersion "#cccccc" new)
      else viewRowHelp pkg (viewVersion "#cccccc" old) (viewArrow "#cccccc") (viewVersion "black" new)

    RowOldGuess old new  ->
      if old == new
      then viewRowHelp pkg (text "") (text "") (viewVersion "#eeeeee" new)
      else viewRowHelp pkg (viewVersion "#eeeeee" old) (viewArrow "#eeeeee") (viewVersion "#eeeeee" new)


viewRowHelp : String -> Html msg -> Html msg -> Html msg -> Html msg
viewRowHelp pkg oldHtml arrowHtml newHtml =
  tr []
    [ td [ style "font-family" "monospace" ] [ text pkg ]
    , td [ style "text-align" "right"      ] [ oldHtml ]
    , td [ style "text-align" "center"     ] [ arrowHtml ]
    , td [                                 ] [ newHtml ]
    ]


viewVersion : String -> Version -> Html msg
viewVersion color (Version x y z) =
  span
    [ style "font-family" "monospace"
    , style "color" color
    , style "transition" "color 1s"
    ]
    [ text (v2s x y z)
    ]


viewArrow : String -> Html msg
viewArrow color =
  span
    [ style "color" color
    , style "transition" "color 1s"
    ]
    [ text "→"
    ]



-- REGISTRY


type alias Registry = Dict String (List Char)


toRegistry : List String -> Registry
toRegistry packages =
  Dict.fromList (List.map (\n -> (n, toSearchChars n)) packages)


toSearchChars : String -> List Char
toSearchChars string =
  String.toList (String.toLower string)


registryTODO : Registry
registryTODO =
  toRegistry
    [ "elm-explorations/test"
    , "elm-explorations/markdown"
    , "elm/browser"
    , "elm/bytes"
    , "elm/core"
    , "elm/file"
    , "elm/html"
    , "elm/http"
    , "elm/json"
    , "elm/project-metadata-utils"
    , "elm/svg"
    , "elm/parser"
    , "elm/time"
    , "elm/url"
    , "elm/virtual-dom"
    ]



-- SEARCH


type alias Search =
  { query : String
  , focus : Maybe Int
  }


type SearchMsg
  = SChanged String
  | SUp
  | SDown
  | SFocus
  | SBlur
  | SEscape
  | SEnter
  | SClickAdd
  | SClickMatch String


type SearchNext
  = SNone
  | SUpdate Search
  | SManualBlur Search
  | SAdd String


updateSearch : Registry -> SearchMsg -> Search -> SearchNext
updateSearch registry msg search =
  case msg of
    SChanged query ->
      SUpdate { query = query, focus = Just 0 }

    SUp ->
      let
        newFocus = Maybe.map (\n -> Basics.max 0 (n - 1)) search.focus
      in
      SUpdate { search | focus = newFocus }

    SDown ->
      let
        numMatches = List.length (getBestMatches search.query registry)
        newFocus = Maybe.map (\n -> Basics.min numMatches (n + 1)) search.focus
      in
      SUpdate { search | focus = newFocus }

    SFocus ->
      SUpdate { search | focus = Just 0 }

    SBlur ->
      SUpdate { search | focus = Nothing }

    SEscape ->
      SManualBlur { search | focus = Nothing }

    SEnter ->
      case search.focus of
        Nothing ->
          SNone

        Just 0 ->
          if Dict.member search.query registry
          then SAdd search.query
          else SNone

        Just n ->
          case getMatch n (getBestMatches search.query registry) of
            Just match -> SUpdate { query = match, focus = Just 0 }
            Nothing -> SNone

    SClickAdd ->
      if Dict.member search.query registry
      then SAdd search.query
      else SNone

    SClickMatch match ->
      SUpdate { query = match, focus = Just 0 }


getMatch : Int -> List (Int, String) -> Maybe String
getMatch n matches =
  case matches of
    [] ->
      Nothing

    (_, match) :: worseMatches ->
      if n <= 0 then
        Nothing
      else if n == 1 then
        Just match
      else
        getMatch (n-1) worseMatches



-- VIEW SEARCH


searchDepsID : String
searchDepsID = "search-deps"


searchTestID : String
searchTestID = "search-test"


viewSearch : String -> String -> Registry -> Search -> Html SearchMsg
viewSearch searchID ghostText registry search =
  div [ style "position" "relative" ]
    [ lazy3 viewSearchQuery searchID ghostText search.query
    , lazy2 viewSearchAdd search.query registry
    , lazy3 viewSearchMatches search.query search.focus registry
    ]


viewSearchAdd : String -> Registry -> Html SearchMsg
viewSearchAdd query registry =
  if Dict.member query registry then
    activeButton SClickAdd (text "Add")
  else
    inactiveButton (text "Add")


viewSearchMatches : String -> Maybe Int -> Registry -> Html SearchMsg
viewSearchMatches query focus registry =
  case focus of
    Nothing ->
      text ""

    Just n ->
      if String.isEmpty query
      then text ""
      else
        case getBestMatches query registry of
          [] ->
            text ""

          bestMatches ->
            div [ class "search-matches" ] <|
              List.indexedMap (viewSearchMatch (n-1)) bestMatches


viewSearchMatch : Int -> Int -> (Int, String) -> Html SearchMsg
viewSearchMatch target actual (_, name) =
  div
    [ class "search-match"
    , classList [("search-match-focused", target == actual)]
    , onClick (SClickMatch name)
    ]
    [ div [ style "padding" "0.5em 1em" ] [ text name ]
    ]



-- VIEW SEARCH QUERY


viewSearchQuery : String -> String -> String -> Html SearchMsg
viewSearchQuery searchID ghostText query =
  input
    [ type_ "text"
    , id searchID
    , placeholder ghostText
    , autocomplete False
    , class "search-input"
    , value query
    , onInput SChanged
    , on "keydown" keyDecoder
    , onFocus SFocus
    , onBlur SBlur
    ]
    []


keyDecoder : D.Decoder SearchMsg
keyDecoder =
  let
    check up down enter escape value =
      if value == up then
        D.succeed SUp
      else if value == down then
        D.succeed SDown
      else if value == enter then
        D.succeed SEnter
      else if value == escape then
        D.succeed SEscape
      else
        D.fail "not up or down"
  in
  D.oneOf
    [ D.field "key" D.string
        |> D.andThen (check "ArrowUp" "ArrowDown" "Enter" "Escape")
    , D.field "keyCode" D.int
        |> D.andThen (check 38 40 13 27)
    ]



-- MATCHES


getBestMatches : String -> Registry -> List (Int, String)
getBestMatches query registry =
  Dict.foldl (addMatch (toSearchChars query)) [] registry


addMatch : List Char -> String -> List Char -> List (Int, String) -> List (Int, String)
addMatch queryChars targetName targetChars bestMatches =
  case distance 0 queryChars targetChars of
    Nothing ->
      bestMatches

    Just dist ->
      insert 4 targetName dist bestMatches


insert : Int -> String -> Int -> List (Int, String) -> List (Int, String)
insert limit name dist bestMatches =
  if limit <= 0 then
    bestMatches
  else
    case bestMatches of
      [] ->
        [ (dist, name) ]

      ((bestDist, bestName) as best) :: worseMatches ->
        if dist < bestDist then
          (dist, name) :: List.take (limit - 1) bestMatches
        else
          best :: insert (limit - 1) name dist worseMatches


distance : Int -> List Char -> List Char -> Maybe Int
distance dist queryChars targetChars =
  case queryChars of
    [] ->
      case dist + List.length targetChars of
        0 -> Nothing
        n -> Just n

    qc :: qcs ->
      case targetChars of
        [] ->
          Nothing

        tc :: tcs ->
          if qc == tc then
            distance dist qcs tcs
          else
            distance (dist + 1) queryChars tcs



-- ICONS


undoIcon : Html msg
undoIcon =
  icon "M255.545 8c-66.269.119-126.438 26.233-170.86 68.685L48.971 40.971C33.851 25.851 8 36.559 8 57.941V192c0 13.255 10.745 24 24 24h134.059c21.382 0 32.09-25.851 16.971-40.971l-41.75-41.75c30.864-28.899 70.801-44.907 113.23-45.273 92.398-.798 170.283 73.977 169.484 169.442C423.236 348.009 349.816 424 256 424c-41.127 0-79.997-14.678-110.63-41.556-4.743-4.161-11.906-3.908-16.368.553L89.34 422.659c-4.872 4.872-4.631 12.815.482 17.433C133.798 479.813 192.074 504 256 504c136.966 0 247.999-111.033 248-247.998C504.001 119.193 392.354 7.755 255.545 8z"


redoIcon : Html msg
redoIcon =
  icon "M256.455 8c66.269.119 126.437 26.233 170.859 68.685l35.715-35.715C478.149 25.851 504 36.559 504 57.941V192c0 13.255-10.745 24-24 24H345.941c-21.382 0-32.09-25.851-16.971-40.971l41.75-41.75c-30.864-28.899-70.801-44.907-113.23-45.273-92.398-.798-170.283 73.977-169.484 169.442C88.764 348.009 162.184 424 256 424c41.127 0 79.997-14.678 110.629-41.556 4.743-4.161 11.906-3.908 16.368.553l39.662 39.662c4.872 4.872 4.631 12.815-.482 17.433C378.202 479.813 319.926 504 256 504 119.034 504 8.001 392.967 8 256.002 7.999 119.193 119.646 7.755 256.455 8z"


unlockIcon : Html msg
unlockIcon =
  icon "M423.5 0C339.5.3 272 69.5 272 153.5V224H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48h-48v-71.1c0-39.6 31.7-72.5 71.3-72.9 40-.4 72.7 32.1 72.7 72v80c0 13.3 10.7 24 24 24h32c13.3 0 24-10.7 24-24v-80C576 68 507.5-.3 423.5 0z"


lockIcon : Html msg
lockIcon =
  icon "M400 224h-24v-72C376 68.2 307.8 0 224 0S72 68.2 72 152v72H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48zm-104 0H152v-72c0-39.7 32.3-72 72-72s72 32.3 72 72v72z"


icon : String -> Html msg
icon path =
  div
    [ style "display" "inline-flex"
    , style "align-self" "center"
    , style "top" ".125em"
    , style "position" "relative"
    ]
    [ Svg.svg
        [ S.viewBox "0 0 512 512"
        , S.width "1em"
        , S.height "1em"
        ]
        [ Svg.path
            [ S.fill "currentColor"
            , S.d path
            ]
            []
        ]
    ]



-- VERSIONS


type Version =
  Version Int Int Int



-- ENCODE CONSTRAINTS


encodeConstraint : PBounds -> E.Value
encodeConstraint bounds =
  case bounds of
    POld (Version x y z) _ oldBounds ->
      case oldBounds of
        OLocked   -> E.string <| v2s x y z ++ " <= v < " ++ v2s x y (z + 1)
        OPatch    -> E.string <| v2s x y z ++ " <= v < " ++ v2s x y max16
        OMinor    -> E.string <| v2s x y z ++ " <= v < " ++ v2s x max16 0
        OMajor    -> E.string <| v2s x y z ++ " <= v < " ++ v2s max16 0 0
        OAny      -> encodeAny
        OCustom c -> Constraint.encode c

    PNew _ newBounds ->
      case newBounds of
        NAny      -> encodeAny
        NCustom c -> Constraint.encode c


encodeAny : E.Value
encodeAny =
  E.string <| v2s 1 0 0 ++ " <= v <= " ++ v2s max16 max16 max16


max16 : Int
max16 =
  65535


v2s : Int -> Int -> Int -> String
v2s major minor patch =
  String.fromInt major ++ "." ++ String.fromInt minor ++ "." ++ String.fromInt patch



-- DECODE SOLUTION


solutionDecoder : D.Decoder (Dict String Version)
solutionDecoder =
  D.dict versionDecoder


versionDecoder : D.Decoder Version
versionDecoder =
  let
    toVersion str =
      case fromString str of
        Just vsn -> D.succeed vsn
        Nothing -> D.fail "invalid version number"
  in
  D.andThen toVersion D.string


fromString : String -> Maybe Version
fromString string =
  case List.map String.toInt (String.split "." string) of
    [Just major, Just minor, Just patch] ->
      fromStringHelp major minor patch

    _ ->
      Nothing


fromStringHelp : Int -> Int -> Int -> Maybe Version
fromStringHelp major minor patch =
  if major >= 0 && minor >= 0 && patch >= 0 then
    Just (Version major minor patch)
  else
    Nothing



-- TODO delete everything below here


styles : String
styles = """
body {
  font-family: sans-serif;
  font-size: 16px;
  background-color: #cccccc;
}
.search-input {
  padding: 0.5em 1em;
  border: 1px solid #cccccc;
  border-radius: 2px;
}
.search-matches {
  position: absolute;
  top: 100%;
  left: 0;
  right: 0;
  background-color: white;
}
.search-match {
  border-left: 1px solid #cccccc;
  border-right: 1px solid #cccccc;
  border-bottom: 1px solid #cccccc;
}
.search-match:hover {
  background-color: #eeeeee;
  cursor: pointer;
}
.search-match-focused {
  background-color: #60B5CC !important;
  border-color: #60B5CC;
  color: white;
}
.button {
  padding: 0.5em 1em;
  border: 1px solid #60B5CC;
  background-color: white;
  border-radius: 2px;
  color: #60B5CC;
}
.button:hover {
  color: white;
  background-color: #60B5CC;
}
.button:active {
  color: white;
  border-color: #5A6378;
  background-color: #5A6378;
}
.button-inactive {
  padding: 0.5em 1em;
  border: 1px solid #cccccc;
  background-color: white;
  border-radius: 2px;
  color: #cccccc;
}
.table-title {
  text-transform: uppercase;
  color: #cccccc;
  font-size: .75em;
}
"""


elmJson : String
elmJson = """
{
    "type": "application",
    "source-directories": [
        "src"
    ],
    "elm-version": "0.19.0",
    "dependencies": {
        "direct": {
            "elm/browser": "1.0.1",
            "elm/core": "1.0.2",
            "elm/html": "1.0.0",
            "elm/http": "2.0.0",
            "elm/json": "1.1.2",
            "elm/project-metadata-utils": "1.0.0",
            "elm/svg": "1.0.1",
            "elm-explorations/markdown": "1.0.0"
        },
        "indirect": {
            "elm/bytes": "1.0.7",
            "elm/file": "1.0.1",
            "elm/parser": "1.1.0",
            "elm/time": "1.0.0",
            "elm/url": "1.0.0",
            "elm/virtual-dom": "1.0.2"
        }
    },
    "test-dependencies": {
        "direct": {},
        "indirect": {}
    }
}
"""


================================================
FILE: reactor/src/Errors.elm
================================================
module Errors exposing (main)


import Browser
import Char
import Html exposing (..)
import Html.Attributes exposing (..)
import String
import Json.Decode as D
import Elm.Error as Error



-- MAIN


main =
  Browser.document
    { init = \flags -> (D.decodeValue Error.decoder flags, Cmd.none)
    , update = \_ exit -> (exit, Cmd.none)
    , view = view
    , subscriptions = \_ -> Sub.none
    }



-- VIEW


view : Result D.Error Error.Error -> Browser.Document msg
view result =
  { title = "Problem!"
  , body =
      case result of
        Err err ->
          [ text (D.errorToString err) ]

        Ok error ->
          [ viewError error ]
  }


viewError : Error.Error -> Html msg
viewError error =
  div
    [ style "width" "100%"
    , style "min-height" "100%"
    , style "display" "flex"
    , style "flex-direction" "column"
    , style "align-items" "center"
    , style "background-color" "rgb(39, 40, 34)"
    , style "color" "rgb(233, 235, 235)"
    , style "font-family" "monospace"
    ]
    [ div
        [ style "display" "block"
        , style "white-space" "pre-wrap"
        , style "background-color" "black"
        , style "padding" "2em"
        ]
        (viewErrorHelp error)
    ]


viewErrorHelp : Error.Error -> List (Html msg)
viewErrorHelp error =
  case error of
    Error.GeneralProblem { path, title, message } ->
      viewHeader title path :: viewMessage message

    Error.ModuleProblems badModules ->
      viewBadModules badModules



-- VIEW HEADER


viewHeader : String -> Maybe String -> Html msg
viewHeader title maybeFilePath =
  let
    left = "-- " ++ title ++ " "
    right =
      case maybeFilePath of
        Nothing ->
          ""
        Just filePath ->
          " " ++ filePath
  in
  span [ style "color" "rgb(51,187,200)" ] [ text (fill left right ++ "\n\n") ]


fill : String -> String -> String
fill left right =
  left ++ String.repeat (80 - String.length left - String.length right) "-" ++ right



-- VIEW BAD MODULES


viewBadModules : List Error.BadModule -> List (Html msg)
viewBadModules badModules =
  case badModules of
    [] ->
      []

    [badModule] ->
      [viewBadModule badModule]

    a :: b :: cs ->
      viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs)


viewBadModule : Error.BadModule -> Html msg
viewBadModule { path, problems } =
  span [] (List.map (viewProblem path) problems)


viewProblem : String -> Error.Problem -> Html msg
viewProblem filePath problem =
  span [] (viewHeader problem.title (Just filePath) :: viewMessage problem.message)


viewSeparator : String -> String -> Html msg
viewSeparator before after =
  span [ style "color" "rgb(211,56,211)" ]
    [ text <|
        String.padLeft 80 ' ' (before ++ "  ↑    ") ++ "\n" ++
        "====o======================================================================o====\n" ++
        "    ↓  " ++ after ++ "\n\n\n"
    ]



-- VIEW MESSAGE


viewMessage : List Error.Chunk -> List (Html msg)
viewMessage chunks =
  case chunks of
    [] ->
      [ text "\n\n\n" ]

    chunk :: others ->
      let
        htmlChunk =
          case chunk of
            Error.Unstyled string ->
              text string

            Error.Styled style string ->
              span (styleToAttrs style) [ text string ]
      in
      htmlChunk :: viewMessage others


styleToAttrs : Error.Style -> List (Attribute msg)
styleToAttrs { bold, underline, color } =
  addBold bold <| addUnderline underline <| addColor color []


addBold : Bool -> List (Attribute msg) -> List (Attribute msg)
addBold bool attrs =
  if bool then
    style "font-weight" "bold" :: attrs
  else
    attrs


addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg)
addUnderline bool attrs =
  if bool then
    style "text-decoration" "underline" :: attrs
  else
    attrs


addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg)
addColor maybeColor attrs =
  case maybeColor of
    Nothing ->
      attrs

    Just color ->
      style "color" (colorToCss color) :: attrs


colorToCss : Error.Color -> String
colorToCss color =
  case color of
    Error.Red -> "rgb(194,54,33)"
    Error.RED -> "rgb(252,57,31)"
    Error.Magenta -> "rgb(211,56,211)"
    Error.MAGENTA -> "rgb(249,53,248)"
    Error.Yellow -> "rgb(173,173,39)"
    Error.YELLOW -> "rgb(234,236,35)"
    Error.Green -> "rgb(37,188,36)"
    Error.GREEN -> "rgb(49,231,34)"
    Error.Cyan -> "rgb(51,187,200)"
    Error.CYAN -> "rgb(20,240,240)"
    Error.Blue -> "rgb(73,46,225)"
    Error.BLUE -> "rgb(88,51,255)"
    Error.White -> "rgb(203,204,205)"
    Error.WHITE -> "rgb(233,235,235)"
    Error.Black -> "rgb(0,0,0)"
    Error.BLACK -> "rgb(129,131,131)"


================================================
FILE: reactor/src/Index/Icon.elm
================================================
module Index.Icon exposing
  ( home
  , image
  , file
  , gift
  , folder
  , package
  , plus
  , lookup
  )

import Dict
import Html exposing (Html)
import Svg exposing (..)
import Svg.Attributes exposing (class, width, height, viewBox, d, fill)



-- ICON


icon : String -> String -> String -> Html msg
icon color size pathString =
  svg
    [ class "icon"
    , width size
    , height size
    , viewBox "0 0 1792 1792"
    ]
    [ path [ fill color, d pathString ] []
    ]



-- NECESSARY ICONS


home : Html msg
home =
  icon "#babdb6" "36px" "M1472 992v480q0 26-19 45t-45 19h-384v-384h-256v384h-384q-26 0-45-19t-19-45v-480q0-1 .5-3t.5-3l575-474 575 474q1 2 1 6zm223-69l-62 74q-8 9-21 11h-3q-13 0-21-7l-692-577-692 577q-12 8-24 7-13-2-21-11l-62-74q-8-10-7-23.5t11-21.5l719-599q32-26 76-26t76 26l244 204v-195q0-14 9-23t23-9h192q14 0 23 9t9 23v408l219 182q10 8 11 21.5t-7 23.5z"


image : Html msg
image =
  icon "#babdb6" "16px" "M1596 380q28 28 48 76t20 88v1152q0 40-28 68t-68 28h-1344q-40 0-68-28t-28-68v-1600q0-40 28-68t68-28h896q40 0 88 20t76 48zm-444-244v376h376q-10-29-22-41l-313-313q-12-12-41-22zm384 1528v-1024h-416q-40 0-68-28t-28-68v-416h-768v1536h1280zm-128-448v320h-1024v-192l192-192 128 128 384-384zm-832-192q-80 0-136-56t-56-136 56-136 136-56 136 56 56 136-56 136-136 56z"


file : Html msg
file =
  icon "#babdb6" "16px" "M1596 380q28 28 48 76t20 88v1152q0 40-28 68t-68 28h-1344q-40 0-68-28t-28-68v-1600q0-40 28-68t68-28h896q40 0 88 20t76 48zm-444-244v376h376q-10-29-22-41l-313-313q-12-12-41-22zm384 1528v-1024h-416q-40 0-68-28t-28-68v-416h-768v1536h1280zm-1024-864q0-14 9-23t23-9h704q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64zm736 224q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h704zm0 256q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h704z"


gift : Html msg
gift =
  icon "#babdb6" "16px" "M1056 1356v-716h-320v716q0 25 18 38.5t46 13.5h192q28 0 46-13.5t18-38.5zm-456-844h195l-126-161q-26-31-69-31-40 0-68 28t-28 68 28 68 68 28zm688-96q0-40-28-68t-68-28q-43 0-69 31l-125 161h194q40 0 68-28t28-68zm376 256v320q0 14-9 23t-23 9h-96v416q0 40-28 68t-68 28h-1088q-40 0-68-28t-28-68v-416h-96q-14 0-23-9t-9-23v-320q0-14 9-23t23-9h440q-93 0-158.5-65.5t-65.5-158.5 65.5-158.5 158.5-65.5q107 0 168 77l128 165 128-165q61-77 168-77 93 0 158.5 65.5t65.5 158.5-65.5 158.5-158.5 65.5h440q14 0 23 9t9 23z"


folder : Html msg
folder =
  icon "#babdb6" "16px" "M1728 608v704q0 92-66 158t-158 66h-1216q-92 0-158-66t-66-158v-960q0-92 66-158t158-66h320q92 0 158 66t66 158v32h672q92 0 158 66t66 158z"


package : Html msg
package =
  icon "#babdb6" "16px" "M1088 832q0-26-19-45t-45-19h-256q-26 0-45 19t-19 45 19 45 45 19h256q26 0 45-19t19-45zm576-192v960q0 26-19 45t-45 19h-1408q-26 0-45-19t-19-45v-960q0-26 19-45t45-19h1408q26 0 45 19t19 45zm64-448v256q0 26-19 45t-45 19h-1536q-26 0-45-19t-19-45v-256q0-26 19-45t45-19h1536q26 0 45 19t19 45z"


plus : Html msg
plus =
  icon "#babdb6" "16px" "M1600 736v192q0 40-28 68t-68 28h-416v416q0 40-28 68t-68 28h-192q-40 0-68-28t-28-68v-416h-416q-40 0-68-28t-28-68v-192q0-40 28-68t68-28h416v-416q0-40 28-68t68-28h192q40 0 68 28t28 68v416h416q40 0 68 28t28 68z"



-- LOOKUP


lookup : String -> Html msg
lookup fileName =
  let
    extension =
      getExtension fileName
  in
    Maybe.withDefault file (Dict.get extension extensionIcons)


extensionIcons : Dict.Dict String (Html msg)
extensionIcons =
  Dict.fromList
    [ ("jpg" , image)
    , ("jpeg", image)
    , ("png" , image)
    , ("gif" , image)
    ]


getExtension : String -> String
getExtension str =
  getExtensionHelp (String.split "." str)


getExtensionHelp : List String -> String
getExtensionHelp segments =
  case segments of
    [] ->
      ""

    [ext] ->
      String.toLower ext

    _ :: rest ->
      getExtensionHelp rest


================================================
FILE: reactor/src/Index/Navigator.elm
================================================
module Index.Navigator exposing (view)


import Html exposing (..)
import Html.Attributes exposing (..)
import Index.Icon as Icon



-- VIEW


view : String -> List String -> Html msg
view root dirs =
  div
    [ style "font-size" "2em"
    , style "padding" "20px 0"
    , style "display" "flex"
    , style "align-items" "center"
    , style "height" "40px"
    ]
    (makeLinks root dirs "" [])


makeLinks : String -> List String -> String -> List (Html msg) -> List (Html msg)
makeLinks root dirs oldPath revAnchors =
  case dirs of
    dir :: otherDirs ->
      let
        newPath =
          oldPath ++ "/" ++ dir

        anchor =
          a [ href newPath ] [ text dir ]
      in
        makeLinks root otherDirs newPath (anchor :: revAnchors)

    [] ->
      let
        home =
          a [ href "/"
            , title root
            , style "display" "inherit"
            ]
            [ Icon.home
            ]
      in
        case revAnchors of
          [] ->
            [home]

          lastAnchor :: otherRevAnchors ->
            home :: slash :: List.foldl addSlash [lastAnchor] otherRevAnchors


addSlash : Html msg -> List (Html msg) -> List (Html msg)
addSlash front back =
  front :: slash :: back


slash : Html msg
slash =
  span [ style "padding" "0 8px" ] [ text "/" ]


================================================
FILE: reactor/src/Index/Skeleton.elm
================================================
module Index.Skeleton exposing
  ( box
  , readmeBox
  )

import Html exposing (..)
import Html.Attributes exposing (..)
import Markdown

import Index.Icon as Icon



-- VIEW BOXES


type alias BoxArgs msg =
  { title : String
  , items : List (List (Html msg))
  , footer : Maybe (String, String)
  }


box : BoxArgs msg -> Html msg
box { title, items, footer } =
  let
    realItems =
      List.map (div [ class "box-item" ]) items
  in
    boxHelp title realItems footer


readmeBox : String -> Html msg
readmeBox markdown =
  let
    readme =
      Markdown.toHtml [ class "box-item" ] markdown
  in
    boxHelp "README" [readme] Nothing


boxHelp : String -> List (Html msg) -> Maybe (String, String) -> Html msg
boxHelp boxTitle items footer =
  div [ class "box" ] <|
    div [ class "box-header" ] [ text boxTitle ]
    :: items
    ++ [ boxFooter footer ]


boxFooter : Maybe (String, String) -> Html msg
boxFooter maybeFooter =
  case maybeFooter of
    Nothing ->
      text ""

    Just (path, description) ->
      a [ href path
        , title description
        ]
        [ div [ class "box-footer" ] [ Icon.plus ]
        ]


================================================
FILE: reactor/src/Index.elm
================================================
module Index exposing (main)


import Browser
import Dict
import Html exposing (..)
import Html.Attributes exposing (class, href, src, style, title)
import Json.Decode as D

import Elm.License as License
import Elm.Package as Package
import Elm.Project as Project
import Elm.Version as Version

import Index.Icon as Icon
import Index.Navigator as Navigator
import Index.Skeleton as Skeleton



-- MAIN


main : Program D.Value Model Never
main =
  Browser.document
    { init = \flags -> (D.decodeValue decoder flags, Cmd.none)
    , update = \_ model -> (model, Cmd.none)
    , subscriptions = \_ -> Sub.none
    , view = view
    }



-- FLAGS


type alias Flags =
  { root : String
  , pwd : List String
  , dirs : List String
  , files : List File
  , readme : Maybe String
  , project : Maybe Project.Project
  , exactDeps : Dict.Dict String Version.Version
  }


type alias File =
  { name : String
  , runnable : Bool
  }



-- DECODER


decoder : D.Decoder Flags
decoder =
  D.map7 Flags
    (D.field "root" D.string)
    (D.field "pwd" (D.list D.string))
    (D.field "dirs" (D.list D.string))
    (D.field "files" (D.list fileDecoder))
    (D.field "readme" (D.nullable D.string))
    (D.field "outline" (D.nullable Project.decoder))
    (D.field "exactDeps" (D.dict Version.decoder))


fileDecoder : D.Decoder File
fileDecoder =
  D.map2 File
    (D.field "name" D.string)
    (D.field "runnable" D.bool)



-- MODEL


type alias Model =
  Result D.Error Flags



-- VIEW


view : Model -> Browser.Document msg
view model =
  case model of
    Err error ->
      { title = "???"
      , body =
          [ text (D.errorToString error)
          ]
      }

    Ok { root, pwd, dirs, files, readme, project, exactDeps } ->
      { title = String.join "/" ("~" :: pwd)
      , body =
          [ header [ class "header" ] []
          , div [ class "content" ]
              [ Navigator.view root pwd
              , viewLeftColumn dirs files readme
              , viewRightColumn exactDeps project
              , div [ style "clear" "both" ] []
              ]
          ]
      }


viewLeftColumn : List String -> List File -> Maybe String -> Html msg
viewLeftColumn dirs files readme =
  section [ class "left-column" ]
    [ viewFiles dirs files
    , viewReadme readme
    ]


viewRightColumn : ExactDeps -> Maybe Project.Project -> Html msg
viewRightColumn exactDeps maybeProject =
  section [ class "right-column" ] <|
    case maybeProject of
      Nothing ->
        []

      Just project ->
        [ viewProjectSummary project
        , viewDeps exactDeps project
        , viewTestDeps exactDeps project
        ]


-- VIEW README


viewReadme : Maybe String -> Html msg
viewReadme readme =
  case readme of
    Nothing ->
      text ""

    Just markdown ->
      Skeleton.readmeBox markdown



-- VIEW FILES


viewFiles : List String -> List File -> Html msg
viewFiles dirs files =
  Skeleton.box
    { title = "File Navigation"
    , items =
        List.filterMap viewDir (List.sort dirs)
        ++
        List.filterMap viewFile (List.sortBy .name files)
    , footer = Nothing
    }


viewDir : String -> Maybe (List (Html msg))
viewDir dir =
  if String.startsWith "." dir || dir == "elm-stuff" then
    Nothing
  else
    Just [ a [ href dir ] [ Icon.folder, text dir ] ]


viewFile : File -> Maybe (List (Html msg))
viewFile {name} =
  if String.startsWith "." name then
    Nothing
  else
    Just [ a [ href name ] [ Icon.lookup name, text name ] ]



-- VIEW PAGE SUMMARY


viewProjectSummary : Project.Project -> Html msg
viewProjectSummary project =
  case project of
    Project.Application info ->
      Skeleton.box
        { title = "Source Directories"
        , items = List.map (\dir -> [text dir]) info.dirs
        , footer = Nothing
        }
        -- TODO show estimated bundle size here

    Project.Package info ->
      Skeleton.box
        { title = "Package Info"
        , items =
            [ [ text ("Name: " ++ Package.toString info.name) ]
            , [ text ("Version: " ++ Version.toString info.version) ]
            , [ text ("License: " ++ License.toString info.license) ]
            ]
        , footer = Nothing
        }



-- VIEW DEPENDENCIES


type alias ExactDeps =
  Dict.Dict String Version.Version


viewDeps : ExactDeps -> Project.Project -> Html msg
viewDeps exactDeps project =
  let
    dependencies =
      case project of
        Project.Application info ->
          List.map viewVersion info.depsDirect

        Project.Package info ->
          List.map (viewConstraint exactDeps) info.deps
  in
  Skeleton.box
    { title = "Dependencies"
    , items = dependencies
    , footer = Nothing -- TODO Just ("/_elm/dependencies", "Add more dependencies?")
    }


viewTestDeps : ExactDeps -> Project.Project -> Html msg
viewTestDeps exactDeps project =
  let
    dependencies =
      case project of
        Project.Application info ->
          List.map viewVersion info.testDepsDirect

        Project.Package info ->
          List.map (viewConstraint exactDeps) info.testDeps
  in
  Skeleton.box
    { title = "Test Dependencies"
    , items = dependencies
    , footer = Nothing -- TODO Just ("/_elm/test-dependencies", "Add more test dependencies?")
    }


viewVersion : (Package.Name, Version.Version) -> List (Html msg)
viewVersion (pkg, version) =
  [ div [ style "float" "left" ]
      [ Icon.package
      , a [ href (toPackageUrl pkg version) ] [ text (Package.toString pkg) ]
      ]
  , div [ style "float" "right" ] [ text (Version.toString version) ]
  ]


viewConstraint : ExactDeps -> (Package.Name, constraint) -> List (Html msg)
viewConstraint exactDeps (pkg, _) =
  case Dict.get (Package.toString pkg) exactDeps of
    Just vsn ->
      viewVersion (pkg, vsn)

    Nothing ->
      [ div [ style "float" "left" ]
          [ Icon.package
          , text (Package.toString pkg)
          ]
      , div [ style "float" "right" ] [ text "???" ]
      ]


toPackageUrl : Package.Name -> Version.Version -> String
toPackageUrl name version =
  "https://package.elm-lang.org/packages/"
  ++ Package.toString name ++ "/" ++ Version.toString version


================================================
FILE: reactor/src/NotFound.elm
================================================
module NotFound exposing (main)


import Browser
import Html exposing (..)
import Html.Attributes exposing (..)



main : Program () () ()
main =
  Browser.document
    { init = \_ -> ((), Cmd.none)
    , update = \_ _ -> ((), Cmd.none)
    , subscriptions = \_ -> Sub.none
    , view = \_ -> page
    }


page : Browser.Document ()
page =
  { title = "Page not found"
  , body =
      [ div [ class "not-found" ]
          [ div [ style "font-size" "12em" ] [ text "404" ]
          , div [ style "font-size" "3em" ] [ text "Page not found" ]
          ]
      ]
  }

================================================
FILE: reactor/src/mock.txt
================================================
# Dependency Explorer

Mass Updates: | RESET | PATCH | MINOR | MAJOR |

⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣿⣇  ←→

DEPENDENCIES

  DIRECT
  NoRedInk/elm-json-decode-pipeline     1.0.0  →  3.0.0      (MAJOR)
  elm/browser                           1.0.0  →  1.0.2      (MINOR)
  elm/core                              1.0.0  →  1.0.5      (CUSTOM: 1.0.0 <= v < 2.0.0)
  elm/html                              1.0.0  →  6.0.2      (ANY)
  elm/http                              1.0.0  →  1.0.0      (LOCKED)
  elm/json                              1.0.0  →  1.0.0      (LOCKED)
  elm/time                              1.0.0  →  1.0.0      (LOCKED)
  elm/url                               1.0.0  →  1.0.0      (LOCKED)
  elm-explorations/markdown             1.0.0  →  1.0.0      (LOCKED)
  rtfeldman/elm-iso8601-date-strings    1.1.0  →             (REMOVE)
  ADD

  INDIRECT
  elm/parser                            1.0.0  →  1.0.0      (LOCKED)
  elm/virtual-dom                       1.0.0  →  1.0.0      (LOCKED)

TEST DEPENDENCIES

  DIRECT
  elm-explorations/test                 1.0.0  →  1.0.0      (LOCKED)
  ADD

  INDIRECT
  elm/random                            1.0.0  →  1.0.0      (LOCKED)


================================================
FILE: roadmap.md
================================================
# Roadmap

If you like what you see now, that's pretty much what Elm is going to be for a while.

I'm currently doing some exploratory work with compiler techniques and targets, but it is still too early to tell which parts of that might work out. I know many readers take "exploring X" as a promise that "X will definitely happen", so I want to be careful in setting expectations low since there is still so much uncertainty in the work. So while there is no real news to share at this point, I can give some expectations about future stability of Elm:

**If this exploratory work goes well**, even in the wildest version of success, I wouldn't expect the language or core packages to change very much. Maybe two or three years down the line it could reveal something that'd be good to fix up, but I don't really foresee notable changes right now.

**If this exploratory work does not work out**, I have some more conservative projects that are good ideas that I want to circle back to at some point. Things like:

- add a constrained type variable `eq` to get rid of the runtime error for `(==)` on functions
- try to integrate `elm test` so it can run only tests that changed
- try to get `elm format` using the latest parsing infrastructure so it's not a perf bottleneck during development anymore
- do another round on perf because I have one last idea that can squeeze out a bit more speed

These are all nice quality of life things, but with 0.19.0 and 0.19.1 taking so long, I got pretty burnt out on "incremental improvements that are good ideas, but take a very long time and aren't very exciting to non-Elm users." Without getting too into the details, I really needed to change things up before returning to these particular ideas.

If someone has a security issue from the compiler or core libraries, please DM me about it on the Elm Slack. Outside of security issues, I think capacity for more discretionary changes will increase once the lessons from the compiler explorations become more clear. Hopefully the discussion [here](https://discourse.elm-lang.org/t/costs-funding-in-open-source-languages/5722) clarifies the thinking on these capacity questions a bit.






**Taking a step back**, I have found that working in this looser style has produced a high baseline of quality, and I think that is an important part of Elm. For example, all the error message work in Elm began as a project to implement the `--report=json` flag. That work happened to reveal some cool ideas on improving error messages, and if I had been using a rigid roadmap, I might have skipped those ideas to meet the publicly-stated arbitrary deadline. We'd have a clearer roadmap, but error messages no different than other type-inferred languages.

So I think having more flexibility in planning is a competitive advantage for Elm in certain ways, but it is obviously a trade off that does not work for everyone. If someone needs more certainty, I generally recommend looking into other languages to see if they have a balance that works better for their needs. For example, languages made by big corporations are generally "less risky" on things like this, but I think you see the fruits of that kind of process in the design decisions as well. Trade offs!

Anyway, like I said at the beginning, if you like what you see now, that's what it's going to be for a while. Even in the best case scenario with my current explorations!

I hope this is helpful information, and I hope you have a good experience with Elm, even if you ultimately find a different language that works better for you!


================================================
FILE: terminal/impl/Terminal/Chomp.hs
================================================
{-# LANGUAGE GADTs, Rank2Types #-}
module Terminal.Chomp
  ( chomp
  )
  where


import qualified Data.List as List

import Terminal.Error
import Terminal.Internal



-- CHOMP INTERFACE


chomp :: Maybe Int -> [String] -> Args args -> Flags flags -> ( IO [String], Either Error (args, flags) )
chomp maybeIndex strings args flags =
  let
    (Chomper flagChomper) =
      chompFlags flags

    ok suggest chunks flagValue =
      fmap (flip (,) flagValue) <$> chompArgs suggest chunks args

    err suggest flagError =
      ( addSuggest (return []) suggest, Left (BadFlag flagError) )
  in
  flagChomper (toSuggest maybeIndex) (toChunks strings) ok err


toChunks :: [String] -> [Chunk]
toChunks strings =
  zipWith Chunk [ 1 .. length strings ] strings


toSuggest :: Maybe Int -> Suggest
toSuggest maybeIndex =
  case maybeIndex of
    Nothing ->
      NoSuggestion

    Just index ->
      Suggest index



-- CHOMPER


newtype Chomper x a =
  Chomper (
    forall result.
      Suggest
      -> [Chunk]
      -> (Suggest -> [Chunk] -> a -> result)
      -> (Suggest -> x -> result)
      -> result
  )


data Chunk =
  Chunk
    { _index :: Int
    , _chunk :: String
    }


data Suggest
  = NoSuggestion
  | Suggest Int
  | Suggestions (IO [String])


makeSuggestion :: Suggest -> (Int -> Maybe (IO [String])) -> Suggest
makeSuggestion suggest maybeUpdate =
  case suggest of
    NoSuggestion ->
      suggest

    Suggestions _ ->
      suggest

    Suggest index ->
      maybe suggest Suggestions (maybeUpdate index)



-- ARGS


chompArgs :: Suggest -> [Chunk] -> Args a -> (IO [String], Either Error a)
chompArgs suggest chunks (Args completeArgsList) =
  chompArgsHelp suggest chunks completeArgsList [] []


chompArgsHelp :: Suggest -> [Chunk] -> [CompleteArgs a] -> [Suggest] -> [(CompleteArgs a, ArgError)] -> (IO [String], Either Error a)
chompArgsHelp suggest chunks completeArgsList revSuggest revArgErrors =
  case completeArgsList of
    [] ->
      ( foldl addSuggest (return []) revSuggest
      , Left (BadArgs (reverse revArgErrors))
      )

    completeArgs : others ->
      case chompCompleteArgs suggest chunks completeArgs of
        (s1, Left argError) ->
          chompArgsHelp suggest chunks others (s1:revSuggest) ((completeArgs,argError):revArgErrors)

        (s1, Right value) ->
          ( addSuggest (return []) s1
          , Right value
          )


addSuggest :: IO [String] -> Suggest -> IO [String]
addSuggest everything suggest =
  case suggest of
    NoSuggestion ->
      everything

    Suggest _ ->
      everything

    Suggestions newStuff ->
      (++) <$> newStuff <*> everything



-- COMPLETE ARGS


chompCompleteArgs :: Suggest -> [Chunk] -> CompleteArgs a -> (Suggest, Either ArgError a)
chompCompleteArgs suggest chunks completeArgs =
  let
    numChunks = length chunks
  in
  case completeArgs of
    Exactly requiredArgs ->
      chompExactly suggest chunks (chompRequiredArgs numChunks requiredArgs)

    Optional requiredArgs parser ->
      chompOptional suggest chunks (chompRequiredArgs numChunks requiredArgs) parser

    Multiple requiredArgs parser ->
      chompMultiple suggest chunks (chompRequiredArgs numChunks requiredArgs) parser


chompExactly :: Suggest -> [Chunk] -> Chomper ArgError a -> (Suggest, Either ArgError a)
chompExactly suggest chunks (Chomper chomper) =
  let
    ok s cs value =
      case map _chunk cs of
        [] -> (s, Right value)
        es -> (s, Left (ArgExtras es))

    err s argError =
      (s, Left argError)
  in
  chomper suggest chunks ok err


chompOptional :: Suggest -> [Chunk] -> Chomper ArgError (Maybe a -> b) -> Parser a -> (Suggest, Either ArgError b)
chompOptional suggest chunks (Chomper chomper) parser =
  let
    ok s1 cs func =
      case cs of
        [] ->
          (s1, Right (func Nothing))

        Chunk index string : others ->
          case tryToParse s1 parser index string of
            (s2, Left expectation) ->
              (s2, Left (ArgBad string expectation))

            (s2, Right value) ->
              case map _chunk others of
                [] -> (s2, Right (func (Just value)))
                es -> (s2, Left (ArgExtras es))

    err s1 argError =
      (s1, Left argError)
  in
  chomper suggest chunks ok err


chompMultiple :: Suggest -> [Chunk] -> Chomper ArgError ([a] -> b) -> Parser a -> (Suggest, Either ArgError b)
chompMultiple suggest chunks (Chomper chomper) parser =
  let
    err s1 argError =
      (s1, Left argError)
  in
  chomper suggest chunks (chompMultipleHelp parser []) err


chompMultipleHelp :: Parser a -> [a] -> Suggest -> [Chunk] -> ([a] -> b) -> (Suggest, Either ArgError b)
chompMultipleHelp parser revArgs suggest chunks func =
  case chunks of
    [] ->
      (suggest, Right (func (reverse revArgs)))

    Chunk index string : otherChunks ->
      case tryToParse suggest parser index string of
        (s1, Left expectation) ->
          (s1, Left (ArgBad string expectation))

        (s1, Right arg) ->
          chompMultipleHelp parser (arg:revArgs) s1 otherChunks func



-- REQUIRED ARGS


chompRequiredArgs :: Int -> RequiredArgs a -> Chomper ArgError a
chompRequiredArgs numChunks args =
  case args of
    Done value ->
      return value

    Required funcArgs argParser ->
      do  func <- chompRequiredArgs numChunks funcArgs
          arg <- chompArg numChunks argParser
          return (func arg)


chompArg :: Int -> Parser a -> Chomper ArgError a
chompArg numChunks parser@(Parser singular _ _ _ toExamples) =
  Chomper $ \suggest chunks ok err ->
    case chunks of
      [] ->
        let
          newSuggest = makeSuggestion suggest (suggestArg parser numChunks)
          theError = ArgMissing (Expectation singular (toExamples ""))
        in
        err newSuggest theError

      Chunk index string : otherChunks ->
        case tryToParse suggest parser index string of
          (newSuggest, Left expectation) ->
            err newSuggest (ArgBad string expectation)

          (newSuggest, Right arg) ->
            ok newSuggest otherChunks arg


suggestArg :: Parser a -> Int -> Int -> Maybe (IO [String])
suggestArg (Parser _ _ _ toSuggestions _) numChunks targetIndex =
  if numChunks <= targetIndex then
    Just (toSuggestions "")
  else
    Nothing



-- PARSER


tryToParse :: Suggest -> Parser a -> Int -> String -> (Suggest, Either Expectation a)
tryToParse suggest (Parser singular _ parse toSuggestions toExamples) index string =
  let
    newSuggest =
      makeSuggestion suggest $ \targetIndex ->
        if index == targetIndex then Just (toSuggestions string) else Nothing

    outcome =
      case parse string of
        Nothing ->
          Left (Expectation singular (toExamples string))

        Just value ->
          Right value
  in
  (newSuggest, outcome)



-- FLAGS


chompFlags :: Flags a -> Chomper FlagError a
chompFlags flags =
  do  value <- chompFlagsHelp flags
      checkForUnknownFlags flags
      return value


chompFlagsHelp :: Flags a -> Chomper FlagError a
chompFlagsHelp flags =
  case flags of
    FDone value ->
      return value

    FMore funcFlags argFlag ->
      do  func <- chompFlagsHelp funcFlags
          arg <- chompFlag argFlag
          return (func arg)



-- FLAG


chompFlag :: Flag a -> Chomper FlagError a
chompFlag flag =
  case flag of
    OnOff flagName _ ->
      chompOnOffFlag flagName

    Flag flagName parser _ ->
      chompNormalFlag flagName parser


chompOnOffFlag :: String -> Chomper FlagError Bool
chompOnOffFlag flagName =
  Chomper $ \suggest chunks ok err ->
    case findFlag flagName chunks of
      Nothing ->
        ok suggest chunks False

      Just (FoundFlag before value after) ->
        case value of
          DefNope ->
            ok suggest (before ++ after) True

          Possibly chunk ->
            ok suggest (before ++ chunk : after) True

          Definitely _ string ->
            err suggest (FlagWithValue flagName string)


chompNormalFlag :: String -> Parser a -> Chomper FlagError (Maybe a)
chompNormalFlag flagName parser@(Parser singular _ _ _ toExamples) =
  Chomper $ \suggest chunks ok err ->
    case findFlag flagName chunks of
      Nothing ->
        ok suggest chunks Nothing

      Just (FoundFlag before value after) ->
        let
          attempt index string =
            case tryToParse suggest parser index string of
              (newSuggest, Left expectation) ->
                err newSuggest (FlagWithBadValue flagName string expectation)

              (newSuggest, Right flagValue) ->
                ok newSuggest (before ++ after) (Just flagValue)
        in
        case value of
          Definitely index string ->
            attempt index string

          Possibly (Chunk index string) ->
            attempt index string

          DefNope ->
            err suggest (FlagWithNoValue flagName (Expectation singular (toExamples "")))



-- FIND FLAG


data FoundFlag =
  FoundFlag
    { _before :: [Chunk]
    , _value :: Value
    , _after :: [Chunk]
    }


data Value
  = Definitely Int String
  | Possibly Chunk
  | DefNope


findFlag :: String -> [Chunk] -> Maybe FoundFlag
findFlag flagName chunks =
  findFlagHelp [] ("--" ++ flagName) ("--" ++ flagName ++ "=") chunks


findFlagHelp :: [Chunk] -> String -> String -> [Chunk] -> Maybe FoundFlag
findFlagHelp revPrev loneFlag flagPrefix chunks =
  let
    succeed value after =
      Just (FoundFlag (reverse revPrev) value after)

    deprefix string =
      drop (length flagPrefix) string
  in
  case chunks of
    [] ->
      Nothing

    chunk@(Chunk index string) : rest ->
      if List.isPrefixOf flagPrefix string then
        succeed (Definitely index (deprefix string)) rest

      else if string /= loneFlag then
        findFlagHelp (chunk:revPrev) loneFlag flagPrefix rest

      else
        case rest of
          [] ->
            succeed DefNope []

          argChunk@(Chunk _ potentialArg) : restOfRest ->
            if List.isPrefixOf "-" potentialArg then
              succeed DefNope rest
            else
              succeed (Possibly argChunk) restOfRest



-- CHECK FOR UNKNOWN FLAGS


checkForUnknownFlags :: Flags a -> Chomper FlagError ()
checkForUnknownFlags flags =
  Chomper $ \suggest chunks ok err ->
    case filter startsWithDash chunks of
      [] ->
        ok suggest chunks ()

      unknownFlags@(Chunk _ unknownFlag : _) ->
        err
          (makeSuggestion suggest (suggestFlag unknownFlags flags))
          (FlagUnknown unknownFlag flags)


suggestFlag :: [Chunk] -> Flags a -> Int -> Maybe (IO [String])
suggestFlag unknownFlags flags targetIndex =
  case unknownFlags of
    [] ->
      Nothing

    Chunk index string : otherUnknownFlags ->
      if index == targetIndex then
        Just (return (filter (List.isPrefixOf string) (getFlagNames flags [])))
      else
        suggestFlag otherUnknownFlags flags targetIndex


startsWithDash :: Chunk -> Bool
startsWithDash (Chunk _ string) =
  List.isPrefixOf "-" string


getFlagNames :: Flags a -> [String] -> [String]
getFlagNames flags names =
  case flags of
    FDone _ ->
      "--help" : names

    FMore subFlags flag ->
      getFlagNames subFlags (getFlagName flag : names)


getFlagName :: Flag a -> String
getFlagName flag =
  case flag of
    Flag name _ _ ->
      "--" ++ name

    OnOff name _ ->
      "--" ++ name



-- CHOMPER INSTANCES


instance Functor (Chomper x) where
  fmap func (Chomper chomper) =
    Chomper $ \i w ok err ->
      let
        ok1 s1 cs1 value =
          ok s1 cs1 (func value)
      in
      chomper i w ok1 err


instance Applicative (Chomper x) where
  pure value =
    Chomper $ \ss cs ok _ ->
      ok ss cs value

  (<*>) (Chomper funcChomper) (Chomper argChomper) =
    Chomper $ \s cs ok err ->
      let
        ok1 s1 cs1 func =
          let
            ok2 s2 cs2 value =
              ok s2 cs2 (func value)
          in
          argChomper s1 cs1 ok2 err
      in
      funcChomper s cs ok1 err


instance Monad (Chomper x) where
  return = pure

  (>>=) (Chomper aChomper) callback =
    Chomper $ \s cs ok err ->
      let
        ok1 s1 cs1 a =
          case callback a of
            Chomper bChomper -> bChomper s1 cs1 ok err
      in
      aChomper s cs ok1 err


================================================
FILE: terminal/impl/Terminal/Error.hs
================================================
{-# OPTIONS_GHC -fno-warn-x-partial #-}
{-# LANGUAGE GADTs, OverloadedStrings #-}
module Terminal.Error
  ( Error(..)
  , ArgError(..)
  , FlagError(..)
  , Expectation(..)
  , exitWithHelp
  , exitWithError
  , exitWithUnknown
  , exitWithOverview
  )
  where


import qualified Data.List as List
import qualified Data.Maybe as Maybe
import GHC.IO.Handle (hIsTerminalDevice)
import qualified System.Environment as Env
import qualified System.Exit as Exit
import qualified System.FilePath as FP
import System.IO (hPutStrLn, stderr)
import qualified Text.PrettyPrint.ANSI.Leijen as P

import Reporting.Suggest as Suggest
import Terminal.Internal



-- ERROR


data Error where
  BadArgs :: [(CompleteArgs a, ArgError)] -> Error
  BadFlag :: FlagError -> Error


data ArgError
  = ArgMissing Expectation
  | ArgBad String Expectation
  | ArgExtras [String]


data FlagError where
  FlagWithValue :: String -> String -> FlagError
  FlagWithBadValue :: String -> String -> Expectation -> FlagError
  FlagWithNoValue :: String -> Expectation -> FlagError
  FlagUnknown :: String -> Flags a -> FlagError


data Expectation =
  Expectation
    { _type :: String
    , _examples :: IO [String]
    }



-- EXIT


exitSuccess :: [P.Doc] -> IO a
exitSuccess =
  exitWith Exit.ExitSuccess


exitFailure :: [P.Doc] -> IO a
exitFailure =
  exitWith (Exit.ExitFailure 1)


exitWith :: Exit.ExitCode -> [P.Doc] -> IO a
exitWith code docs =
  do  isTerminal <- hIsTerminalDevice stderr
      let adjust = if isTerminal then id else P.plain
      P.displayIO stderr $ P.renderPretty 1 80 $
        adjust $ P.vcat $ concatMap (\d -> [d,""]) docs
      hPutStrLn stderr ""
      Exit.exitWith code


getExeName :: IO String
getExeName =
  FP.takeFileName <$> Env.getProgName


stack :: [P.Doc] -> P.Doc
stack docs =
  P.vcat $ List.intersperse "" docs


reflow :: String -> P.Doc
reflow string =
  P.fillSep $ map P.text $ words string



-- HELP


exitWithHelp :: Maybe String -> String -> P.Doc -> Args args -> Flags flags -> IO a
exitWithHelp maybeCommand details example (Args args) flags =
  do  command <- toCommand maybeCommand
      exitSuccess $
        [ reflow details
        , P.indent 4 $ P.cyan $ P.vcat $ map (argsToDoc command) args
        , example
        ]
        ++
          case flagsToDocs flags [] of
            [] ->
              []

            docs@(_:_) ->
              [ "You can customize this command with the following flags:"
              , P.indent 4 $ stack docs
              ]


toCommand :: Maybe String -> IO String
toCommand maybeCommand =
  do  exeName <- getExeName
      return $
        case maybeCommand of
          Nothing ->
            exeName

          Just command ->
            exeName ++ " " ++ command


argsToDoc :: String -> CompleteArgs a -> P.Doc
argsToDoc command args =
  case args of
    Exactly required ->
      argsToDocHelp command required []

    Multiple required (Parser _ plural _ _ _) ->
      argsToDocHelp command required ["zero or more " ++ plural]

    Optional required (Parser singular _ _ _ _) ->
      argsToDocHelp command required ["optional " ++ singular]


argsToDocHelp :: String -> RequiredArgs a -> [String] -> P.Doc
argsToDocHelp command args names =
  case args of
    Done _ ->
      P.hang 4 $ P.hsep $ map P.text $
        command : map toToken names

    Required others (Parser singular _ _ _ _) ->
      argsToDocHelp command others (singular : names)


toToken :: String -> String
toToken string =
  "<" ++ map (\c -> if c == ' ' then '-' else c) string ++ ">"


flagsToDocs :: Flags flags -> [P.Doc] -> [P.Doc]
flagsToDocs flags docs =
  case flags of
    FDone _ ->
      docs

    FMore more flag ->
      let
        flagDoc =
          P.vcat $
            case flag of
              Flag name (Parser singular _ _ _ _) description ->
                [ P.dullcyan $ P.text $ "--" ++ name ++ "=" ++ toToken singular
                , P.indent 4 $ reflow description
                ]

              OnOff name description ->
                [ P.dullcyan $ P.text $ "--" ++ name
                , P.indent 4 $ reflow description
                ]
      in
      flagsToDocs more (flagDoc:docs)



-- OVERVIEW


exitWithOverview :: P.Doc -> P.Doc -> [Command] -> IO a
exitWithOverview intro outro commands =
  do  exeName <- getExeName
      exitSuccess
        [ intro
        , "The most common commands are:"
        , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) commands
        , "There are a bunch of other commands as well though. Here is a full list:"
        , P.indent 4 $ P.dullcyan $ toCommandList exeName commands
        , "Adding the --help flag gives a bunch of additional details about each one."
        , outro
        ]


toSummary :: String -> Command -> Maybe P.Doc
toSummary exeName (Command name summary _ _ (Args args) _ _) =
  case summary of
    Uncommon ->
      Nothing

    Common summaryString ->
      Just $
        P.vcat
          [ P.cyan $ argsToDoc (exeName ++ " " ++ name) (head args)
          , P.indent 4 $ reflow summaryString
          ]


toCommandList :: String -> [Command] -> P.Doc
toCommandList exeName commands =
  let
    names = map toName commands
    width = maximum (map length names)

    toExample name =
      P.text $ exeName ++ " " ++ name ++ replicate (width - length name) ' ' ++ " --help"
  in
  P.vcat (map toExample names)



-- UNKNOWN


exitWithUnknown :: String -> [String] -> IO a
exitWithUnknown unknown knowns =
  let
    nearbyKnowns =
      takeWhile (\(r,_) -> r <= 3) (Suggest.rank unknown id knowns)

    suggestions =
      case map toGreen (map snd nearbyKnowns) of
        [] ->
          []

        [nearby] ->
          ["Try",nearby,"instead?"]

        [a,b] ->
          ["Try",a,"or",b,"instead?"]

        abcs@(_:_:_:_) ->
          ["Try"] ++ map (<> ",") (init abcs) ++ ["or",last abcs,"instead?"]
  in
  do  exeName <- getExeName
      exitFailure
        [ P.fillSep $ ["There","is","no",toRed unknown,"command."] ++ suggestions
        , reflow $ "Run `" ++ exeName ++ "` with no arguments to get more hints."
        ]



-- ERROR TO DOC


exitWithError :: Error -> IO a
exitWithError err =
  exitFailure =<<
    case err of
      BadFlag flagError ->
        flagErrorToDocs flagError

      BadArgs argErrors ->
        case argErrors of
          [] ->
            return
              [ reflow $ "I was not expecting any arguments for this command."
              , reflow $ "Try removing them?"
              ]

          [(_args, argError)] ->
            argErrorToDocs argError

          _:_:_ ->
            argErrorToDocs $ head $ List.sortOn toArgErrorRank (map snd argErrors)


toArgErrorRank :: ArgError -> Int -- lower is better
toArgErrorRank err =
  case err of
    ArgBad _ _   -> 0
    ArgMissing _ -> 1
    ArgExtras _  -> 2


toGreen :: String -> P.Doc
toGreen str =
  P.green (P.text str)


toYellow :: String -> P.Doc
toYellow str =
  P.yellow (P.text str)


toRed :: String -> P.Doc
toRed str =
  P.red (P.text str)



-- ARG ERROR TO DOC


argErrorToDocs :: ArgError -> IO [P.Doc]
argErrorToDocs argError =
  case argError of
    ArgMissing (Expectation tipe makeExamples) ->
      do  examples <- makeExamples
          return
            [ P.fillSep
                ["The","arguments","you","have","are","fine,","but","in","addition,","I","was"
                ,"expecting","a",toYellow (toToken tipe),"value.","For","example:"
                ]
            , P.indent 4 $ P.green $ P.vcat $ map P.text examples
            ]

    ArgBad string (Expectation tipe makeExamples) ->
      do  examples <- makeExamples
          return
            [ "I am having trouble with this argument:"
            , P.indent 4 $ toRed string
            , P.fillSep $
                ["It","is","supposed","to","be","a"
                ,toYellow (toToken tipe),"value,","like"
                ] ++ if length examples == 1 then ["this:"] else ["one","of","these:"]
            , P.indent 4 $ P.green $ P.vcat $ map P.text examples
            ]

    ArgExtras extras ->
      let
        (these, them) =
          case extras of
            [_] -> ("this argument", "it")
            _ -> ("these arguments", "them")
      in
      return
        [ reflow $ "I was not expecting " ++ these ++ ":"
        , P.indent 4 $ P.red $ P.vcat $ map P.text extras
        , reflow $ "Try removing " ++ them ++ "?"
        ]



-- FLAG ERROR TO DOC


flagErrorHelp :: String -> String -> [P.Doc] -> IO [P.Doc]
flagErrorHelp summary original explanation =
  return $
    [ reflow summary
    , P.indent 4 (toRed original)
    ]
    ++ explanation


flagErrorToDocs :: FlagError -> IO [P.Doc]
flagErrorToDocs flagError =
  case flagError of
    FlagWithValue flagName value ->
      flagErrorHelp
        "This on/off flag was given a value:"
        ("--" ++ flagName ++ "=" ++ value)
        [ "An on/off flag either exists or not. It cannot have an equals sign and value.\n\
          \Maybe you want this instead?"
        , P.indent 4 $ toGreen $ "--" ++ flagName
        ]

    FlagWithNoValue flagName (Expectation tipe makeExamples) ->
      do  examples <- makeExamples
          flagErrorHelp
            "This flag needs more information:"
            ("--" ++ flagName)
            [ P.fillSep ["It","needs","a",toYellow (toToken tipe),"like","this:"]
            , P.indent 4 $ P.vcat $ map toGreen $
                case take 4 examples of
                  [] ->
                    ["--" ++ flagName ++ "=" ++ toToken tipe]

                  _:_ ->
                    map (\example -> "--" ++ flagName ++ "=" ++ example) examples
            ]

    FlagWithBadValue flagName badValue (Expectation tipe makeExamples) ->
      do  examples <- makeExamples
          flagErrorHelp
            "This flag was given a bad value:"
            ("--" ++ flagName ++ "=" ++ badValue)
            [ P.fillSep $
                ["I","need","a","valid",toYellow (toToken tipe),"value.","For","example:"
                ]
            , P.indent 4 $ P.vcat $ map toGreen $
                case take 4 examples of
                  [] ->
                    ["--" ++ flagName ++ "=" ++ toToken tipe]

                  _:_ ->
                    map (\example -> "--" ++ flagName ++ "=" ++ example) examples
            ]

    FlagUnknown unknown flags ->
      flagErrorHelp
        "I do not recognize this flag:"
        unknown
        (
          let unknownName = takeWhile ('=' /=) (dropWhile ('-' ==) unknown) in
          case getNearbyFlags unknownName flags [] of
            [] ->
              []

            [thisOne] ->
              [ P.fillSep ["Maybe","you","want",P.green thisOne,"instead?"]
              ]

            suggestions ->
              [ P.fillSep ["Maybe","you","want","one","of","these","instead?"]
              , P.indent 4 $ P.green $ P.vcat suggestions
              ]
        )


getNearbyFlags :: String -> Flags a -> [(Int, String)] -> [P.Doc]
getNearbyFlags unknown flags unsortedFlags =
  case flags of
    FMore more flag ->
      getNearbyFlags unknown more (getNearbyFlagsHelp unknown flag : unsortedFlags)

    FDone _ ->
      map P.text $ map snd $ List.sortOn fst $
        case filter (\(d,_) -> d < 3) unsortedFlags of
          [] ->
            unsortedFlags

          nearbyUnsortedFlags ->
            nearbyUnsortedFlags


getNearbyFlagsHelp :: String -> Flag a -> (Int, String)
getNearbyFlagsHelp unknown flag =
  case flag of
    OnOff flagName _ ->
      ( Suggest.distance unknown flagName
      , "--" ++ flagName
      )

    Flag flagName (Parser singular _ _ _ _) _ ->
      ( Suggest.distance unknown flagName
      , "--" ++ flagName ++ "=" ++ toToken singular
      )


================================================
FILE: terminal/impl/Terminal/Helpers.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Terminal.Helpers
  ( version
  , elmFile
  , package
  )
  where


import qualified Data.ByteString.UTF8 as BS_UTF8
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Utf8 as Utf8
import qualified System.FilePath as FP

import Terminal (Parser(..))
import qualified Deps.Registry as Registry
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified Parse.Primitives as P
import qualified Stuff
import qualified Reporting.Suggest as Suggest



-- VERSION


version :: Parser V.Version
version =
  Parser
    { _singular = "version"
    , _plural = "versions"
    , _parser = parseVersion
    , _suggest = suggestVersion
    , _examples = return . exampleVersions
    }


parseVersion :: String -> Maybe V.Version
parseVersion chars =
  case P.fromByteString V.parser (,) (BS_UTF8.fromString chars) of
    Right vsn -> Just vsn
    Left _    -> Nothing


suggestVersion :: String -> IO [String]
suggestVersion _ =
  return []


exampleVersions :: String -> [String]
exampleVersions chars =
  let
    chunks = map Utf8.toChars (Utf8.split 0x2E {-.-} (Utf8.fromChars chars))
    isNumber cs = not (null cs) && all Char.isDigit cs
  in
  if all isNumber chunks then
    case chunks of
      [x]     -> [ x ++ ".0.0" ]
      [x,y]   -> [ x ++ "." ++ y ++ ".0" ]
      x:y:z:_ -> [ x ++ "." ++ y ++ "." ++ z ]
      _       -> ["1.0.0", "2.0.3"]

  else
    ["1.0.0", "2.0.3"]



-- ELM FILE


elmFile :: Parser FilePath
elmFile =
  Parser
    { _singular = "elm file"
    , _plural = "elm files"
    , _parser = parseElmFile
    , _suggest = \_ -> return []
    , _examples = exampleElmFiles
    }


parseElmFile :: String -> Maybe FilePath
parseElmFile chars =
  if FP.takeExtension chars == ".elm" then
    Just chars
  else
    Nothing


exampleElmFiles :: String -> IO [String]
exampleElmFiles _ =
  return ["Main.elm","src/Main.elm"]



-- PACKAGE


package :: Parser Pkg.Name
package =
  Parser
    { _singular = "package"
    , _plural = "packages"
    , _parser = parsePackage
    , _suggest = suggestPackages
    , _examples = examplePackages
    }


parsePackage :: String -> Maybe Pkg.Name
parsePackage chars =
  case P.fromByteString Pkg.parser (,) (BS_UTF8.fromString chars) of
    Right pkg -> Just pkg
    Left _    -> Nothing


suggestPackages :: String -> IO [String]
suggestPackages given =
  do  cache <- Stuff.getPackageCache
      maybeRegistry <- Registry.read cache
      return $
        case maybeRegistry of
          Nothing ->
            []

          Just (Registry.Registry _ versions) ->
            filter (List.isPrefixOf given) $
              map Pkg.toChars (Map.keys versions)


examplePackages :: String -> IO [String]
examplePackages given =
  do  cache <- Stuff.getPackageCache
      maybeRegistry <- Registry.read cache
      return $
        case maybeRegistry of
          Nothing ->
            [ "elm/json"
            , "elm/http"
            , "elm/random"
            ]

          Just (Registry.Registry _ versions) ->
            map Pkg.toChars $ take 4 $
              Suggest.sort given Pkg.toChars (Map.keys versions)


================================================
FILE: terminal/impl/Terminal/Internal.hs
================================================
{-# LANGUAGE GADTs #-}
module Terminal.Internal
  ( Command(..)
  , toName
  , Summary(..)
  , Flags(..)
  , Flag(..)
  , Parser(..)
  , Args(..)
  , CompleteArgs(..)
  , RequiredArgs(..)
  )
  where


import Text.PrettyPrint.ANSI.Leijen (Doc)



-- COMMAND


data Command where
  Command
    :: String
    -> Summary
    -> String
    -> Doc
    -> Args args
    -> Flags flags
    -> (args -> flags -> IO ())
    -> Command


toName :: Command -> String
toName (Command name _ _ _ _ _ _) =
  name



{-| The information that shows when you run the executable with no arguments.
If you say it is `Common`, you need to tell people what it does. Try to keep
it to two or three lines. If you say it is `Uncommon` you can rely on `Details`
for a more complete explanation.
-}
data Summary = Common String | Uncommon



-- FLAGS


data Flags a where
  FDone :: a -> Flags a
  FMore :: Flags (a -> b) -> Flag a -> Flags b


data Flag a where
  Flag :: String -> Parser a -> String -> Flag (Maybe a)
  OnOff :: String -> String -> Flag Bool



-- PARSERS


data Parser a =
  Parser
    { _singular :: String
    , _plural :: String
    , _parser :: String -> Maybe a
    , _suggest :: String -> IO [String]
    , _examples :: String -> IO [String]
    }



-- ARGS


newtype Args a =
  Args [CompleteArgs a]


data CompleteArgs args where
  Exactly  :: RequiredArgs args -> CompleteArgs args
  Multiple :: RequiredArgs ([a] -> args) -> Parser a -> CompleteArgs args
  Optional :: RequiredArgs (Maybe a -> args) -> Parser a -> CompleteArgs args


data RequiredArgs a where
  Done :: a -> RequiredArgs a
  Required :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b


================================================
FILE: terminal/impl/Terminal.hs
================================================
{-# OPTIONS_GHC -fno-warn-x-partial #-}
module Terminal
  ( app
  , Command(..)
  , Summary(..)
  , Flags, noFlags, flags, (|--)
  , Flag, flag, onOff
  , Parser(..)
  , Args, noArgs, required, optional, zeroOrMore, oneOrMore, oneOf
  , require0, require1, require2, require3, require4, require5
  , RequiredArgs, args, exactly, (!), (?), (...)
  )
  where


import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified System.Directory as Dir
import qualified System.Environment as Env
import qualified System.Exit as Exit
import qualified System.FilePath as FP
import System.FilePath (())
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.IO (hPutStr, hPutStrLn, stdout)
import qualified Text.PrettyPrint.ANSI.Leijen as P
import qualified Text.Read as Read

import qualified Elm.Version as V
import Terminal.Internal
import qualified Terminal.Chomp as Chomp
import qualified Terminal.Error as Error



-- COMMAND


_command :: String -> P.Doc -> Args args -> Flags flags -> (args -> flags -> IO ()) -> IO ()
_command details example args_ flags_ callback =
  do  setLocaleEncoding utf8
      argStrings <- Env.getArgs
      case argStrings of
        ["--version"] ->
          do  hPutStrLn stdout (V.toChars V.compiler)
              Exit.exitSuccess

        chunks ->
          if elem "--help" chunks then
            Error.exitWithHelp Nothing details example args_ flags_

          else
            case snd $ Chomp.chomp Nothing chunks args_ flags_ of
              Right (argsValue, flagValue) ->
                callback argsValue flagValue

              Left err ->
                Error.exitWithError err



-- APP


app :: P.Doc -> P.Doc -> [Command] -> IO ()
app intro outro commands =
  do  setLocaleEncoding utf8
      argStrings <- Env.getArgs
      case argStrings of
        [] ->
          Error.exitWithOverview intro outro commands

        ["--help"] ->
          Error.exitWithOverview intro outro commands

        ["--version"] ->
          do  hPutStrLn stdout (V.toChars V.compiler)
              Exit.exitSuccess

        command : chunks ->
          do  case List.find (\cmd -> toName cmd == command) commands of
                Nothing ->
                  Error.exitWithUnknown command (map toName commands)

                Just (Command _ _ details example args_ flags_ callback) ->
                  if elem "--help" chunks then
                    Error.exitWithHelp (Just command) details example args_ flags_

                  else
                    case snd $ Chomp.chomp Nothing chunks args_ flags_ of
                      Right (argsValue, flagsValue) ->
                        callback argsValue flagsValue

                      Left err ->
                        Error.exitWithError err



-- AUTO-COMPLETE


_maybeAutoComplete :: [String] -> (Int -> [String] -> IO [String]) -> IO ()
_maybeAutoComplete argStrings getSuggestions =
  if length argStrings /= 3 then
    return ()
  else
    do  maybeLine <- Env.lookupEnv "COMP_LINE"
        case maybeLine of
          Nothing ->
            return ()

          Just line ->
            do  (index, chunks) <- getCompIndex line
                suggestions <- getSuggestions index chunks
                hPutStr stdout (unlines suggestions)
                Exit.exitFailure


getCompIndex :: String -> IO (Int, [String])
getCompIndex line =
  do  maybePoint <- Env.lookupEnv "COMP_POINT"
      case Read.readMaybe =<< maybePoint of
        Nothing ->
          do  let chunks = words line
              return (length chunks, chunks)

        Just point ->
          let
            groups = List.groupBy grouper (zip line [0..])
            rawChunks = drop 1 (filter (all (not . isSpace . fst)) groups)
          in
          return
            ( findIndex 1 point rawChunks
            , map (map fst) rawChunks
            )


grouper :: (Char, Int) -> (Char, Int) -> Bool
grouper (c1, _) (c2, _) =
  isSpace c1 == isSpace c2


isSpace :: Char -> Bool
isSpace char =
  char == ' ' || char == '\t' || char == '\n'


findIndex :: Int -> Int -> [[(Char,Int)]] -> Int
findIndex index point chunks =
  case chunks of
    [] ->
      index

    chunk:cs ->
      let
        lo = snd (head chunk)
        hi = snd (last chunk)
      in
      if point < lo then
        0
      else if point <= hi + 1 then
        index
      else
        findIndex (index + 1) point cs


_complexSuggest :: [Command] -> Int -> [String] -> IO [String]
_complexSuggest commands index strings =
  case strings of
    [] ->
      return (map toName commands)

    command : chunks ->
      if index == 1 then
        return (filter (List.isPrefixOf command) (map toName commands))
      else
        case List.find (\cmd -> toName cmd == command) commands of
          Nothing ->
            return []

          Just (Command _ _ _ _ args_ flags_ _) ->
            fst $ Chomp.chomp (Just (index-1)) chunks args_ flags_



-- FLAGS


{-|-}
noFlags :: Flags ()
noFlags =
  FDone ()


{-|-}
flags :: a -> Flags a
flags =
  FDone


{-|-}
(|--) :: Flags (a -> b) -> Flag a -> Flags b
(|--) =
  FMore



-- FLAG


{-|-}
flag :: String -> Parser a -> String -> Flag (Maybe a)
flag =
  Flag


{-|-}
onOff :: String -> String -> Flag Bool
onOff =
  OnOff



-- FANCY ARGS


{-|-}
args :: a -> RequiredArgs a
args =
  Done


{-|-}
exactly :: RequiredArgs a -> Args a
exactly requiredArgs =
  Args [Exactly requiredArgs]


{-|-}
(!) :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b
(!) =
  Required


{-|-}
(?) :: RequiredArgs (Maybe a -> b) -> Parser a -> Args b
(?) requiredArgs optionalArg =
  Args [Optional requiredArgs optionalArg]


{-|-}
(...) :: RequiredArgs ([a] -> b) -> Parser a -> Args b
(...) requiredArgs repeatedArg =
  Args [Multiple requiredArgs repeatedArg]


{-|-}
oneOf :: [Args a] -> Args a
oneOf listOfArgs =
  Args (concatMap (\(Args a) -> a) listOfArgs)



-- SIMPLE ARGS


{-|-}
noArgs :: Args ()
noArgs =
  exactly (args ())


{-|-}
required :: Parser a -> Args a
required parser =
  require1 id parser


{-|-}
optional :: Parser a -> Args (Maybe a)
optional parser =
  args id ? parser


{-|-}
zeroOrMore :: Parser a -> Args [a]
zeroOrMore parser =
  args id ... parser


{-|-}
oneOrMore :: Parser a -> Args (a, [a])
oneOrMore parser =
  args (,) ! parser ... parser


{-|-}
require0 :: args -> Args args
require0 value =
  exactly (args value)


{-|-}
require1 :: (a -> args) -> Parser a -> Args args
require1 func a =
  exactly (args func ! a)


{-|-}
require2 :: (a -> b -> args) -> Parser a -> Parser b -> Args args
require2 func a b =
  exactly (args func ! a ! b)


{-|-}
require3 :: (a -> b -> c -> args) -> Parser a -> Parser b -> Parser c -> Args args
require3 func a b c =
  exactly (args func ! a ! b ! c)


{-|-}
require4 :: (a -> b -> c -> d -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Args args
require4 func a b c d =
  exactly (args func ! a ! b ! c ! d)


{-|-}
require5 :: (a -> b -> c -> d -> e -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Args args
require5 func a b c d e =
  exactly (args func ! a ! b ! c ! d ! e)



-- SUGGEST FILES


{-| Helper for creating custom `Parser` values. It will suggest directories and
file names:

    suggestFiles []             -- suggests any file
    suggestFiles ["elm"]        -- suggests only .elm files
    suggestFiles ["js","html"]  -- suggests only .js and .html files

Notice that you can limit the suggestion by the file extension! If you need
something more elaborate, you can implement a function like this yourself that
does whatever you need!
-}
_suggestFiles :: [String] -> String -> IO [String]
_suggestFiles extensions string =
  let
    (dir, start) =
      FP.splitFileName string
  in
  do  content <- Dir.getDirectoryContents dir
      Maybe.catMaybes
        <$> traverse (isPossibleSuggestion extensions start dir) content


isPossibleSuggestion :: [String] -> String -> FilePath -> FilePath -> IO (Maybe FilePath)
isPossibleSuggestion extensions start dir path =
  if List.isPrefixOf start path then
    do  isDir <- Dir.doesDirectoryExist (dir  path)
        return $
          if isDir then
            Just (path ++ "/")
          else if isOkayExtension path extensions then
            Just path
          else
            Nothing
  else
    return Nothing


isOkayExtension :: FilePath -> [String] -> Bool
isOkayExtension path extensions =
  null extensions || elem (FP.takeExtension path) extensions



================================================
FILE: terminal/src/Bump.hs
================================================
{-# OPTIONS_GHC -fno-warn-x-partial #-}
{-# LANGUAGE OverloadedStrings #-}
module Bump
  ( run
  )
  where


import qualified Data.List as List
import qualified Data.NonEmptyList as NE

import qualified BackgroundWriter as BW
import qualified Build
import qualified Deps.Bump as Bump
import qualified Deps.Diff as Diff
import qualified Deps.Registry as Registry
import qualified Elm.Details as Details
import qualified Elm.Docs as Docs
import qualified Elm.Magnitude as M
import qualified Elm.Outline as Outline
import qualified Elm.Version as V
import qualified Http
import Reporting.Doc ((<+>))
import qualified Reporting
import qualified Reporting.Doc as D
import qualified Reporting.Exit as Exit
import qualified Reporting.Exit.Help as Help
import qualified Reporting.Task as Task
import qualified Stuff



-- RUN


run :: () -> () -> IO ()
run () () =
  Reporting.attempt Exit.bumpToReport $
    Task.run (bump =<< getEnv)



-- ENV


data Env =
  Env
    { _root :: FilePath
    , _cache :: Stuff.PackageCache
    , _manager :: Http.Manager
    , _registry :: Registry.Registry
    , _outline :: Outline.PkgOutline
    }


getEnv :: Task.Task Exit.Bump Env
getEnv =
  do  maybeRoot <- Task.io $ Stuff.findRoot
      case maybeRoot of
        Nothing ->
          Task.throw Exit.BumpNoOutline

        Just root ->
          do  cache <- Task.io $ Stuff.getPackageCache
              manager <- Task.io $ Http.getManager
              registry <- Task.eio Exit.BumpMustHaveLatestRegistry $ Registry.latest manager cache
              outline <- Task.eio Exit.BumpBadOutline $ Outline.read root
              case outline of
                Outline.App _ ->
                  Task.throw Exit.BumpApplication

                Outline.Pkg pkgOutline ->
                  return $ Env root cache manager registry pkgOutline



-- BUMP


bump :: Env -> Task.Task Exit.Bump ()
bump env@(Env root _ _ registry outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
  case Registry.getVersions pkg registry of
    Just knownVersions ->
      let
        bumpableVersions =
          map (\(old, _, _) -> old) (Bump.getPossibilities knownVersions)
      in
      if elem vsn bumpableVersions
      then suggestVersion env
      else
        Task.throw $ Exit.BumpUnexpectedVersion vsn $
          map head (List.group (List.sort bumpableVersions))

    Nothing ->
      Task.io $ checkNewPackage root outline



-- CHECK NEW PACKAGE


checkNewPackage :: FilePath -> Outline.PkgOutline -> IO ()
checkNewPackage root outline@(Outline.PkgOutline _ _ _ version _ _ _ _) =
  do  putStrLn Exit.newPackageOverview
      if version == V.one
        then
          putStrLn "The version number in elm.json is correct so you are all set!"
        else
          changeVersion root outline V.one $
            "It looks like the version in elm.json has been changed though!\n\
            \Would you like me to change it back to "
            <> D.fromVersion V.one <> "? [Y/n] "



-- SUGGEST VERSION


suggestVersion :: Env -> Task.Task Exit.Bump ()
suggestVersion (Env root cache manager _ outline@(Outline.PkgOutline pkg _ _ vsn _ _ _ _)) =
  do  oldDocs <- Task.eio (Exit.BumpCannotFindDocs pkg vsn) (Diff.getDocs cache manager pkg vsn)
      newDocs <- generateDocs root outline
      let changes = Diff.diff oldDocs newDocs
      let newVersion = Diff.bump changes vsn
      Task.io $ changeVersion root outline newVersion $
        let
          old = D.fromVersion vsn
          new = D.fromVersion newVersion
          mag = D.fromChars $ M.toChars (Diff.toMagnitude changes)
        in
        "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
        <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
        <> "\n"
        <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "


generateDocs :: FilePath -> Outline.PkgOutline -> Task.Task Exit.Bump Docs.Documentation
generateDocs root (Outline.PkgOutline _ _ _ _ exposed _ _ _) =
  do  details <-
        Task.eio Exit.BumpBadDetails $ BW.withScope $ \scope ->
          Details.load Reporting.silent scope root

      case Outline.flattenExposed exposed of
        [] ->
          Task.throw $ Exit.BumpNoExposed

        e:es ->
          Task.eio Exit.BumpBadBuild $
            Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es)



-- CHANGE VERSION


changeVersion :: FilePath -> Outline.PkgOutline -> V.Version -> D.Doc -> IO ()
changeVersion root outline targetVersion question =
  do  approved <- Reporting.ask question
      if not approved
        then
          putStrLn "Okay, I did not change anything!"

        else
          do  Outline.write root $ Outline.Pkg $
                outline { Outline._pkg_version = targetVersion }

              Help.toStdout $
                "Version changed to "
                <> D.green (D.fromVersion targetVersion)
                <> "!\n"


================================================
FILE: terminal/src/Develop/Generate/Help.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Develop.Generate.Help
  ( makePageHtml
  , makeCodeHtml
  )
  where


import qualified Data.ByteString.Builder as B
import qualified Data.Name as Name
import Text.RawString.QQ (r)

import qualified Json.Encode as Encode



-- PAGES


makePageHtml :: Name.Name -> Maybe Encode.Value -> B.Builder
makePageHtml moduleName maybeFlags =
  [r|


  
  
  





|]



-- CODE


makeCodeHtml :: FilePath -> B.Builder -> B.Builder
makeCodeHtml title code =
  [r|


  
  |] <> B.stringUtf8 title <> [r|
  
  
  
  



|] <> code <> [r|



|]


================================================
FILE: terminal/src/Develop/Generate/Index.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Develop.Generate.Index
  ( generate
  )
  where


import Control.Monad (filterM)
import qualified Data.ByteString.Builder as B
import qualified Data.List as List
import qualified Data.Map as Map
import qualified System.Directory as Dir
import System.FilePath ((), splitDirectories, takeExtension)

import qualified BackgroundWriter as BW
import qualified Develop.Generate.Help as Help
import qualified Elm.Details as Details
import qualified Elm.Outline as Outline
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified Json.Encode as E
import Json.Encode ((==>))
import qualified Reporting
import qualified Stuff



-- GENERATE


generate :: FilePath -> IO B.Builder
generate pwd =
  do  flags <- getFlags pwd
      return $ Help.makePageHtml "Index" (Just (encode flags))



-- FLAGS


data Flags =
  Flags
    { _root :: FilePath
    , _pwd :: [String]
    , _dirs :: [FilePath]
    , _files :: [File]
    , _readme :: Maybe String
    , _outline :: Maybe Outline.Outline
    , _exactDeps :: Map.Map Pkg.Name V.Version
    }


data File =
  File
    { _path :: FilePath
    , _runnable :: Bool
    }



-- GET FLAGS


getFlags :: FilePath -> IO Flags
getFlags pwd =
  do  contents <- Dir.getDirectoryContents pwd
      root <- Dir.getCurrentDirectory
      dirs <- getDirs pwd contents
      files <- getFiles pwd contents
      readme <- getReadme pwd
      outline <- getOutline
      exactDeps <- getExactDeps outline
      return $
        Flags
          { _root = root
          , _pwd = dropWhile ("." ==) (splitDirectories pwd)
          , _dirs = dirs
          , _files = files
          , _readme = readme
          , _outline = outline
          , _exactDeps = exactDeps
          }



-- README


getReadme :: FilePath -> IO (Maybe String)
getReadme dir =
  do  let readmePath = dir  "README.md"
      exists <- Dir.doesFileExist readmePath
      if exists
        then Just <$> readFile readmePath
        else return Nothing



-- GET DIRECTORIES


getDirs :: FilePath -> [FilePath] -> IO [FilePath]
getDirs pwd contents =
  filterM (Dir.doesDirectoryExist . (pwd )) contents



-- GET FILES


getFiles :: FilePath -> [FilePath] -> IO [File]
getFiles pwd contents =
  do  paths <- filterM (Dir.doesFileExist . (pwd )) contents
      mapM (toFile pwd) paths


toFile :: FilePath -> FilePath -> IO File
toFile pwd path =
  if takeExtension path == ".elm" then
    do  source <- readFile (pwd  path)
        let hasMain = List.isInfixOf "\nmain " source
        return (File path hasMain)
  else
    return (File path False)



-- GET OUTLINE


getOutline :: IO (Maybe Outline.Outline)
getOutline =
  do  maybeRoot <- Stuff.findRoot
      case maybeRoot of
        Nothing ->
          return Nothing

        Just root ->
          do  result <- Outline.read root
              case result of
                Left _        -> return Nothing
                Right outline -> return (Just outline)



-- GET EXACT DEPS


-- TODO revamp how `elm reactor` works so that this can go away.
-- I am trying to "just get it working again" at this point though.
--
getExactDeps :: Maybe Outline.Outline -> IO (Map.Map Pkg.Name V.Version)
getExactDeps maybeOutline =
  case maybeOutline of
    Nothing ->
      return Map.empty

    Just outline ->
      case outline of
        Outline.App _ ->
          return Map.empty

        Outline.Pkg _ ->
          do  maybeRoot <- Stuff.findRoot
              case maybeRoot of
                Nothing ->
                  return Map.empty

                Just root ->
                  BW.withScope $ \scope ->
                  do  result <- Details.load Reporting.silent scope root
                      case result of
                        Left _ ->
                          return Map.empty

                        Right (Details.Details _ validOutline _ _ _ _) ->
                          case validOutline of
                            Details.ValidApp _ ->
                              return Map.empty

                            Details.ValidPkg _ _ solution ->
                              return solution



-- ENCODE


encode :: Flags -> E.Value
encode (Flags root pwd dirs files readme outline exactDeps) =
  E.object
    [ "root" ==> encodeFilePath root
    , "pwd" ==> E.list encodeFilePath pwd
    , "dirs" ==> E.list encodeFilePath dirs
    , "files" ==> E.list encodeFile files
    , "readme" ==> maybe E.null E.chars readme
    , "outline" ==> maybe E.null Outline.encode outline
    , "exactDeps" ==> E.dict Pkg.toJsonString V.encode exactDeps
    ]


encodeFilePath :: FilePath -> E.Value
encodeFilePath filePath =
  E.chars filePath


encodeFile :: File -> E.Value
encodeFile (File path hasMain) =
  E.object
    [ "name" ==> encodeFilePath path
    , "runnable" ==> E.bool hasMain
    ]


================================================
FILE: terminal/src/Develop/Socket.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Develop.Socket (watchFile) where

import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (SomeException, catch)
import qualified Data.ByteString.Char8 as BS
import qualified Network.WebSockets as WS
import qualified System.FSNotify.Devel as Notify
import qualified System.FSNotify as Notify



watchFile :: FilePath -> WS.PendingConnection -> IO ()
watchFile watchedFile pendingConnection =
  do  connection <- WS.acceptRequest pendingConnection

      Notify.withManager $ \mgmt ->
        do  stop <- Notify.treeExtAny mgmt "." ".elm" print
            tend connection
            stop


tend :: WS.Connection -> IO ()
tend connection =
  let
    pinger :: Integer -> IO a
    pinger n =
      do  threadDelay (5 * 1000 * 1000)
          WS.sendPing connection (BS.pack (show n))
          pinger (n + 1)

    receiver :: IO ()
    receiver =
      do  _ <- WS.receiveDataMessage connection
          receiver

    shutdown :: SomeException -> IO ()
    shutdown _ =
      return ()
  in
    do  _pid <- forkIO (receiver `catch` shutdown)
        pinger 1 `catch` shutdown


================================================
FILE: terminal/src/Develop/StaticFiles/Build.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Develop.StaticFiles.Build
  ( readAsset
  , buildReactorFrontEnd
  )
  where


import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as LBS
import qualified Data.NonEmptyList as NE
import qualified System.Directory as Dir
import System.FilePath (())

import qualified BackgroundWriter as BW
import qualified Build
import qualified Elm.Details as Details
import qualified Generate
import qualified Reporting
import qualified Reporting.Exit as Exit
import qualified Reporting.Task as Task



-- ASSETS


readAsset :: FilePath -> IO BS.ByteString
readAsset path =
  BS.readFile ("reactor"  "assets"  path)



-- BUILD REACTOR ELM


buildReactorFrontEnd :: IO BS.ByteString
buildReactorFrontEnd =
  BW.withScope $ \scope ->
  Dir.withCurrentDirectory "reactor" $
  do  root <- Dir.getCurrentDirectory
      runTaskUnsafe $
        do  details    <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root
            artifacts  <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details paths
            javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.prod root details artifacts
            return (LBS.toStrict (B.toLazyByteString javascript))


paths :: NE.List FilePath
paths =
  NE.List
    ("src"  "NotFound.elm")
    [ "src"  "Errors.elm"
    , "src"  "Index.elm"
    ]


runTaskUnsafe :: Task.Task Exit.Reactor a -> IO a
runTaskUnsafe task =
  do  result <- Task.run task
      case result of
        Right a ->
          return a

        Left exit ->
          do  Exit.toStderr (Exit.reactorToReport exit)
              error
                "\n--------------------------------------------------------\
                \\nError in Develop.StaticFiles.Build.buildReactorFrontEnd\
                \\nCompile with `elm make` directly to figure it out faster\
                \\n--------------------------------------------------------\
                \\n"


================================================
FILE: terminal/src/Develop/StaticFiles.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Develop.StaticFiles
  ( lookup
  , cssPath
  , elmPath
  , waitingPath
  )
  where

import Prelude hiding (lookup)
import qualified Data.ByteString as BS
import Data.FileEmbed (bsToExp)
import qualified Data.HashMap.Strict as HM
import Language.Haskell.TH (runIO)
import System.FilePath (())

import qualified Develop.StaticFiles.Build as Build



-- FILE LOOKUP


type MimeType =
  BS.ByteString


lookup :: FilePath -> Maybe (BS.ByteString, MimeType)
lookup path =
  HM.lookup path dict


dict :: HM.HashMap FilePath (BS.ByteString, MimeType)
dict =
  HM.fromList
    [ faviconPath  ==> (favicon , "image/x-icon")
    , elmPath      ==> (elm     , "application/javascript")
    , cssPath      ==> (css     , "text/css")
    , codeFontPath ==> (codeFont, "font/ttf")
    , sansFontPath ==> (sansFont, "font/ttf")
    ]


(==>) :: a -> b -> (a,b)
(==>) a b =
  (a, b)



-- PATHS


faviconPath :: FilePath
faviconPath =
  "favicon.ico"


waitingPath :: FilePath
waitingPath =
  "_elm"  "waiting.gif"


elmPath :: FilePath
elmPath =
  "_elm"  "elm.js"


cssPath :: FilePath
cssPath =
  "_elm"  "styles.css"


codeFontPath :: FilePath
codeFontPath =
  "_elm"  "source-code-pro.ttf"


sansFontPath :: FilePath
sansFontPath =
  "_elm"  "source-sans-pro.ttf"



-- ELM


elm :: BS.ByteString
elm =
  $(bsToExp =<< runIO Build.buildReactorFrontEnd)



-- CSS


css :: BS.ByteString
css =
  $(bsToExp =<< runIO (Build.readAsset "styles.css"))



-- FONTS


codeFont :: BS.ByteString
codeFont =
  $(bsToExp =<< runIO (Build.readAsset "source-code-pro.ttf"))


sansFont :: BS.ByteString
sansFont =
  $(bsToExp =<< runIO (Build.readAsset "source-sans-pro.ttf"))



-- IMAGES


favicon :: BS.ByteString
favicon =
  $(bsToExp =<< runIO (Build.readAsset "favicon.ico"))


================================================
FILE: terminal/src/Develop.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Develop
  ( Flags(..)
  , run
  )
  where


import Control.Applicative ((<|>))
import Control.Monad (guard)
import Control.Monad.Trans (MonadIO(liftIO))
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString as BS
import qualified Data.HashMap.Strict as HashMap
import qualified Data.NonEmptyList as NE
import qualified System.Directory as Dir
import System.FilePath as FP
import Snap.Core hiding (path)
import Snap.Http.Server
import Snap.Util.FileServe

import qualified BackgroundWriter as BW
import qualified Build
import qualified Elm.Details as Details
import qualified Develop.Generate.Help as Help
import qualified Develop.Generate.Index as Index
import qualified Develop.StaticFiles as StaticFiles
import qualified Generate.Html as Html
import qualified Generate
import qualified Reporting
import qualified Reporting.Exit as Exit
import qualified Reporting.Task as Task
import qualified Stuff



-- RUN THE DEV SERVER


data Flags =
  Flags
    { _port :: Maybe Int
    }


run :: () -> Flags -> IO ()
run () (Flags maybePort) =
  do  let port = maybe 8000 id maybePort
      putStrLn $ "Go to http://localhost:" ++ show port ++ " to see your project dashboard."
      httpServe (config port) $
        serveFiles
        <|> serveDirectoryWith directoryConfig "."
        <|> serveAssets
        <|> error404


config :: Int -> Config Snap a
config port =
  setVerbose False $ setPort port $
    setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig



-- INDEX


directoryConfig :: MonadSnap m => DirectoryConfig m
directoryConfig =
  fancyDirectoryConfig
    { indexFiles = []
    , indexGenerator = \pwd ->
        do  modifyResponse $ setContentType "text/html;charset=utf-8"
            writeBuilder =<< liftIO (Index.generate pwd)
    }



-- NOT FOUND


error404 :: Snap ()
error404 =
  do  modifyResponse $ setResponseStatus 404 "Not Found"
      modifyResponse $ setContentType "text/html;charset=utf-8"
      writeBuilder $ Help.makePageHtml "NotFound" Nothing



-- SERVE FILES


serveFiles :: Snap ()
serveFiles =
  do  path <- getSafePath
      guard =<< liftIO (Dir.doesFileExist path)
      serveElm path <|> serveFilePretty path



-- SERVE FILES + CODE HIGHLIGHTING


serveFilePretty :: FilePath -> Snap ()
serveFilePretty path =
  let
    possibleExtensions =
      getSubExts (takeExtensions path)
  in
    case mconcat (map lookupMimeType possibleExtensions) of
      Nothing ->
        serveCode path

      Just mimeType ->
        serveFileAs mimeType path


getSubExts :: String -> [String]
getSubExts fullExtension =
  if null fullExtension then
    []
  else
    fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))


serveCode :: String -> Snap ()
serveCode path =
  do  code <- liftIO (BS.readFile path)
      modifyResponse (setContentType "text/html")
      writeBuilder $
        Help.makeCodeHtml ('~' : '/' : path) (B.byteString code)



-- SERVE ELM


serveElm :: FilePath -> Snap ()
serveElm path =
  do  guard (takeExtension path == ".elm")
      modifyResponse (setContentType "text/html")
      result <- liftIO $ compile path
      case result of
        Right builder ->
          writeBuilder builder

        Left exit ->
          writeBuilder $ Help.makePageHtml "Errors" $ Just $
            Exit.toJson $ Exit.reactorToReport exit


compile :: FilePath -> IO (Either Exit.Reactor B.Builder)
compile path =
  do  maybeRoot <- Stuff.findRoot
      case maybeRoot of
        Nothing ->
          return $ Left $ Exit.ReactorNoOutline

        Just root ->
          BW.withScope $ \scope -> Stuff.withRootLock root $ Task.run $
            do  details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent scope root
                artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromPaths Reporting.silent root details (NE.List path [])
                javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts
                let (NE.List name _) = Build.getRootNames artifacts
                return $ Html.sandwich name javascript



-- SERVE STATIC ASSETS


serveAssets :: Snap ()
serveAssets =
  do  path <- getSafePath
      case StaticFiles.lookup path of
        Nothing ->
          pass

        Just (content, mimeType) ->
          do  modifyResponse (setContentType (mimeType <> ";charset=utf-8"))
              writeBS content



-- MIME TYPES


lookupMimeType :: FilePath -> Maybe BS.ByteString
lookupMimeType ext =
  HashMap.lookup ext mimeTypeDict


(==>) :: a -> b -> (a,b)
(==>) a b =
  (a, b)


mimeTypeDict :: HashMap.HashMap FilePath BS.ByteString
mimeTypeDict =
  HashMap.fromList
    [ ".asc"     ==> "text/plain"
    , ".asf"     ==> "video/x-ms-asf"
    , ".asx"     ==> "video/x-ms-asf"
    , ".avi"     ==> "video/x-msvideo"
    , ".bz2"     ==> "application/x-bzip"
    , ".css"     ==> "text/css"
    , ".dtd"     ==> "text/xml"
    , ".dvi"     ==> "application/x-dvi"
    , ".gif"     ==> "image/gif"
    , ".gz"      ==> "application/x-gzip"
    , ".htm"     ==> "text/html"
    , ".html"    ==> "text/html"
    , ".ico"     ==> "image/x-icon"
    , ".jpeg"    ==> "image/jpeg"
    , ".jpg"     ==> "image/jpeg"
    , ".js"      ==> "text/javascript"
    , ".json"    ==> "application/json"
    , ".m3u"     ==> "audio/x-mpegurl"
    , ".mov"     ==> "video/quicktime"
    , ".mp3"     ==> "audio/mpeg"
    , ".mp4"     ==> "video/mp4"
    , ".mpeg"    ==> "video/mpeg"
    , ".mpg"     ==> "video/mpeg"
    , ".ogg"     ==> "application/ogg"
    , ".otf"     ==> "font/otf"
    , ".pac"     ==> "application/x-ns-proxy-autoconfig"
    , ".pdf"     ==> "application/pdf"
    , ".png"     ==> "image/png"
    , ".qt"      ==> "video/quicktime"
    , ".sfnt"    ==> "font/sfnt"
    , ".sig"     ==> "application/pgp-signature"
    , ".spl"     ==> "application/futuresplash"
    , ".svg"     ==> "image/svg+xml"
    , ".swf"     ==> "application/x-shockwave-flash"
    , ".tar"     ==> "application/x-tar"
    , ".tar.bz2" ==> "application/x-bzip-compressed-tar"
    , ".tar.gz"  ==> "application/x-tgz"
    , ".tbz"     ==> "application/x-bzip-compressed-tar"
    , ".text"    ==> "text/plain"
    , ".tgz"     ==> "application/x-tgz"
    , ".ttf"     ==> "font/ttf"
    , ".txt"     ==> "text/plain"
    , ".wav"     ==> "audio/x-wav"
    , ".wax"     ==> "audio/x-ms-wax"
    , ".webm"    ==> "video/webm"
    , ".webp"    ==> "image/webp"
    , ".wma"     ==> "audio/x-ms-wma"
    , ".wmv"     ==> "video/x-ms-wmv"
    , ".woff"    ==> "font/woff"
    , ".woff2"   ==> "font/woff2"
    , ".xbm"     ==> "image/x-xbitmap"
    , ".xml"     ==> "text/xml"
    , ".xpm"     ==> "image/x-xpixmap"
    , ".xwd"     ==> "image/x-xwindowdump"
    , ".zip"     ==> "application/zip"
    ]


================================================
FILE: terminal/src/Diff.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Diff
  ( Args(..)
  , run
  )
  where


import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Name as Name
import qualified Data.NonEmptyList as NE

import qualified BackgroundWriter as BW
import qualified Build
import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..))
import qualified Deps.Diff as DD
import qualified Deps.Registry as Registry
import qualified Elm.Compiler.Type as Type
import qualified Elm.Details as Details
import qualified Elm.Docs as Docs
import qualified Elm.Magnitude as M
import qualified Elm.Outline as Outline
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified Http
import qualified Reporting
import Reporting.Doc ((<+>))
import qualified Reporting.Doc as D
import qualified Reporting.Exit as Exit
import qualified Reporting.Exit.Help as Help
import qualified Reporting.Render.Type.Localizer as L
import qualified Reporting.Task as Task
import qualified Stuff



-- RUN


data Args
  = CodeVsLatest
  | CodeVsExactly V.Version
  | LocalInquiry V.Version V.Version
  | GlobalInquiry Pkg.Name V.Version V.Version


run :: Args -> () -> IO ()
run args () =
  Reporting.attempt Exit.diffToReport $
    Task.run $
      do  env <- getEnv
          diff env args



-- ENVIRONMENT


data Env =
  Env
    { _maybeRoot :: Maybe FilePath
    , _cache :: Stuff.PackageCache
    , _manager :: Http.Manager
    , _registry :: Registry.Registry
    }


getEnv :: Task Env
getEnv =
  do  maybeRoot <- Task.io $ Stuff.findRoot
      cache     <- Task.io $ Stuff.getPackageCache
      manager   <- Task.io $ Http.getManager
      registry  <- Task.eio Exit.DiffMustHaveLatestRegistry $ Registry.latest manager cache
      return (Env maybeRoot cache manager registry)



-- DIFF


type Task a =
  Task.Task Exit.Diff a


diff :: Env -> Args -> Task ()
diff env@(Env _ _ _ registry) args =
  case args of
    GlobalInquiry name v1 v2 ->
      case Registry.getVersions' name registry of
        Right vsns ->
          do  oldDocs <- getDocs env name vsns (min v1 v2)
              newDocs <- getDocs env name vsns (max v1 v2)
              writeDiff oldDocs newDocs

        Left suggestions ->
          Task.throw $ Exit.DiffUnknownPackage name suggestions

    LocalInquiry v1 v2 ->
      do  (name, vsns) <- readOutline env
          oldDocs <- getDocs env name vsns (min v1 v2)
          newDocs <- getDocs env name vsns (max v1 v2)
          writeDiff oldDocs newDocs

    CodeVsLatest ->
      do  (name, vsns) <- readOutline env
          oldDocs <- getLatestDocs env name vsns
          newDocs <- generateDocs env
          writeDiff oldDocs newDocs

    CodeVsExactly version ->
      do  (name, vsns) <- readOutline env
          oldDocs <- getDocs env name vsns version
          newDocs <- generateDocs env
          writeDiff oldDocs newDocs



-- GET DOCS


getDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Docs.Documentation
getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version =
  if latest == version || elem version previous
  then Task.eio (Exit.DiffDocsProblem version) $ DD.getDocs cache manager name version
  else Task.throw $ Exit.DiffUnknownVersion name version (latest:previous)


getLatestDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> Task Docs.Documentation
getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) =
  Task.eio (Exit.DiffDocsProblem latest) $ DD.getDocs cache manager name latest



-- READ OUTLINE


readOutline :: Env -> Task (Pkg.Name, Registry.KnownVersions)
readOutline (Env maybeRoot _ _ registry) =
  case maybeRoot of
    Nothing ->
      Task.throw $ Exit.DiffNoOutline

    Just root ->
      do  result <- Task.io $ Outline.read root
          case result of
            Left err ->
              Task.throw $ Exit.DiffBadOutline err

            Right outline ->
              case outline of
                Outline.App _ ->
                  Task.throw $ Exit.DiffApplication

                Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) ->
                  case Registry.getVersions pkg registry of
                    Just vsns -> return (pkg, vsns)
                    Nothing   -> Task.throw Exit.DiffUnpublished



-- GENERATE DOCS


generateDocs :: Env -> Task Docs.Documentation
generateDocs (Env maybeRoot _ _ _) =
  case maybeRoot of
    Nothing ->
      Task.throw $ Exit.DiffNoOutline

    Just root ->
      do  details <-
            Task.eio Exit.DiffBadDetails $ BW.withScope $ \scope ->
              Details.load Reporting.silent scope root

          case Details._outline details of
            Details.ValidApp _ ->
              Task.throw $ Exit.DiffApplication

            Details.ValidPkg _ exposed _ ->
              case exposed of
                [] ->
                  Task.throw $ Exit.DiffNoExposed

                e:es ->
                  Task.eio Exit.DiffBadBuild $
                    Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es)



-- WRITE DIFF


writeDiff :: Docs.Documentation -> Docs.Documentation -> Task ()
writeDiff oldDocs newDocs =
  let
    changes = DD.diff oldDocs newDocs
    localizer = L.fromNames (Map.union oldDocs newDocs)
  in
  Task.io $ Help.toStdout $ toDoc localizer changes <> "\n"



-- TO DOC


toDoc :: L.Localizer -> PackageChanges -> D.Doc
toDoc localizer changes@(PackageChanges added changed removed) =
  if null added && Map.null changed && null removed then
    "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
  else
    let
      magDoc =
        D.fromChars (M.toChars (DD.toMagnitude changes))

      header =
        "This is a" <+> D.green magDoc <+> "change."

      addedChunk =
        if null added then [] else
          [ Chunk "ADDED MODULES" M.MINOR $
              D.vcat $ map D.fromName added
          ]

      removedChunk =
        if null removed then [] else
          [ Chunk "REMOVED MODULES" M.MAJOR $
              D.vcat $ map D.fromName removed
          ]

      chunks =
        addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
    in
      D.vcat (header : "" : map chunkToDoc chunks)


data Chunk =
  Chunk
    { _title :: String
    , _magnitude :: M.Magnitude
    , _details :: D.Doc
    }


chunkToDoc :: Chunk -> D.Doc
chunkToDoc (Chunk title magnitude details) =
  let
    header =
      "----" <+> D.fromChars title <+> "-" <+> D.fromChars (M.toChars magnitude) <+> "----"
  in
    D.vcat
      [ D.dullcyan header
      , ""
      , D.indent 4 details
      , ""
      , ""
      ]


changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
  let
    magnitude =
      DD.moduleChangeMagnitude changes

    (unionAdd, unionChange, unionRemove) =
      changesToDocTriple (unionToDoc localizer) unions

    (aliasAdd, aliasChange, aliasRemove) =
      changesToDocTriple (aliasToDoc localizer) aliases

    (valueAdd, valueChange, valueRemove) =
      changesToDocTriple (valueToDoc localizer) values

    (binopAdd, binopChange, binopRemove) =
      changesToDocTriple (binopToDoc localizer) binops
  in
    Chunk (Name.toChars name) magnitude $
      D.vcat $ List.intersperse "" $ Maybe.catMaybes $
        [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
        , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
        , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
        ]


changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
changesToDocTriple entryToDoc (Changes added changed removed) =
  let
    indented (name, value) =
      D.indent 4 (entryToDoc name value)

    diffed (name, (oldValue, newValue)) =
      D.vcat
        [ "  - " <> entryToDoc name oldValue
        , "  + " <> entryToDoc name newValue
        , ""
        ]
  in
    ( map indented (Map.toList added)
    , map diffed   (Map.toList changed)
    , map indented (Map.toList removed)
    )


changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
changesToDoc categoryName unions aliases values binops =
  if null unions && null aliases && null values && null binops then
    Nothing

  else
    Just $ D.vcat $
      D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values


unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
unionToDoc localizer name (Docs.Union _ tvars ctors) =
  let
    setup =
      "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)

    ctorDoc (ctor, tipes) =
      typeDoc localizer (Type.Type ctor tipes)
  in
    D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))


aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
  let
    declaration =
      "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
  in
    D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])


valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
valueToDoc localizer name (Docs.Value _ tipe) =
  D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]


binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
    "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
  where
    details =
      "    (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"

    assoc =
      case associativity of
        Docs.Left  -> "left"
        Docs.Non   -> "non"
        Docs.Right -> "right"


typeDoc :: L.Localizer -> Type.Type -> D.Doc
typeDoc localizer tipe =
  Type.toDoc localizer Type.None tipe


================================================
FILE: terminal/src/Init.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Init
  ( run
  )
  where


import Prelude hiding (init)
import qualified Data.Map as Map
import qualified Data.NonEmptyList as NE
import qualified System.Directory as Dir

import qualified Deps.Solver as Solver
import qualified Elm.Constraint as Con
import qualified Elm.Outline as Outline
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified Reporting
import qualified Reporting.Doc as D
import qualified Reporting.Exit as Exit



-- RUN


run :: () -> () -> IO ()
run () () =
  Reporting.attempt Exit.initToReport $
  do  exists <- Dir.doesFileExist "elm.json"
      if exists
        then return (Left Exit.InitAlreadyExists)
        else
          do  approved <- Reporting.ask question
              if approved
                then init
                else
                  do  putStrLn "Okay, I did not make any changes!"
                      return (Right ())


question :: D.Doc
question =
  D.stack
    [ D.fillSep
        ["Hello!"
        ,"Elm","projects","always","start","with","an",D.green "elm.json","file."
        ,"I","can","create","them!"
        ]
    , D.reflow
        "Now you may be wondering, what will be in this file? How do I add Elm files to\
        \ my project? How do I see it in the browser? How will my code grow? Do I need\
        \ more directories? What about tests? Etc."
    , D.fillSep
        ["Check","out",D.cyan (D.fromChars (D.makeLink "init"))
        ,"for","all","the","answers!"
        ]
    , "Knowing all that, would you like me to create an elm.json file now? [Y/n]: "
    ]



-- INIT


init :: IO (Either Exit.Init ())
init =
  do  eitherEnv <- Solver.initEnv
      case eitherEnv of
        Left problem ->
          return (Left (Exit.InitRegistryProblem problem))

        Right (Solver.Env cache _ connection registry) ->
          do  result <- Solver.verify cache connection registry defaults
              case result of
                Solver.Err exit ->
                  return (Left (Exit.InitSolverProblem exit))

                Solver.NoSolution ->
                  return (Left (Exit.InitNoSolution (Map.keys defaults)))

                Solver.NoOfflineSolution ->
                  return (Left (Exit.InitNoOfflineSolution (Map.keys defaults)))

                Solver.Ok details ->
                  let
                    solution = Map.map (\(Solver.Details vsn _) -> vsn) details
                    directs = Map.intersection solution defaults
                    indirects = Map.difference solution defaults
                  in
                  do  Dir.createDirectoryIfMissing True "src"
                      Outline.write "." $ Outline.App $
                        Outline.AppOutline V.compiler (NE.List (Outline.RelativeSrcDir "src") []) directs indirects Map.empty Map.empty
                      putStrLn "Okay, I created it. Now read that link!"
                      return (Right ())


defaults :: Map.Map Pkg.Name Con.Constraint
defaults =
  Map.fromList
    [ (Pkg.core, Con.anything)
    , (Pkg.browser, Con.anything)
    , (Pkg.html, Con.anything)
    ]


================================================
FILE: terminal/src/Install.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Install
  ( Args(..)
  , run
  )
  where


import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as Map

import qualified BackgroundWriter as BW
import qualified Deps.Solver as Solver
import qualified Deps.Registry as Registry
import qualified Elm.Constraint as C
import qualified Elm.Details as Details
import qualified Elm.Package as Pkg
import qualified Elm.Outline as Outline
import qualified Elm.Version as V
import qualified Reporting
import Reporting.Doc ((<+>))
import qualified Reporting.Doc as D
import qualified Reporting.Exit as Exit
import qualified Reporting.Task as Task
import qualified Stuff



-- RUN


data Args
  = NoArgs
  | Install Pkg.Name


run :: Args -> () -> IO ()
run args () =
  Reporting.attempt Exit.installToReport $
    do  maybeRoot <- Stuff.findRoot
        case maybeRoot of
          Nothing ->
            return (Left Exit.InstallNoOutline)

          Just root ->
            case args of
              NoArgs ->
                do  elmHome <- Stuff.getElmHome
                    return (Left (Exit.InstallNoArgs elmHome))

              Install pkg ->
                Task.run $
                  do  env <- Task.eio Exit.InstallBadRegistry $ Solver.initEnv
                      oldOutline <- Task.eio Exit.InstallBadOutline $ Outline.read root
                      case oldOutline of
                        Outline.App outline ->
                          do  changes <- makeAppPlan env pkg outline
                              attemptChanges root env oldOutline V.toChars changes

                        Outline.Pkg outline ->
                          do  changes <- makePkgPlan env pkg outline
                              attemptChanges root env oldOutline C.toChars changes



-- ATTEMPT CHANGES


data Changes vsn
  = AlreadyInstalled
  | PromoteTest Outline.Outline
  | PromoteIndirect Outline.Outline
  | Changes (Map.Map Pkg.Name (Change vsn)) Outline.Outline


type Task = Task.Task Exit.Install


attemptChanges :: FilePath -> Solver.Env -> Outline.Outline -> (a -> String) -> Changes a -> Task ()
attemptChanges root env oldOutline toChars changes =
  case changes of
    AlreadyInstalled ->
      Task.io $ putStrLn "It is already installed!"

    PromoteIndirect newOutline ->
      attemptChangesHelp root env oldOutline newOutline $
        D.vcat
         [ D.fillSep
            ["I","found","it","in","your","elm.json","file,"
            ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."
            ]
         , D.fillSep
            ["Should","I","move","it","into",D.green "\"direct\""
            ,"dependencies","for","more","general","use?","[Y/n]: "
            ]
         ]

    PromoteTest newOutline ->
      attemptChangesHelp root env oldOutline newOutline $
        D.vcat
         [ D.fillSep
            ["I","found","it","in","your","elm.json","file,"
            ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."
            ]
         , D.fillSep
            ["Should","I","move","it","into",D.green "\"dependencies\""
            ,"for","more","general","use?","[Y/n]: "
            ]
         ]

    Changes changeDict newOutline ->
      let
        widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict
        changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict
      in
      attemptChangesHelp root env oldOutline newOutline $ D.vcat $
        [ "Here is my plan:"
        , viewChangeDocs changeDocs
        , ""
        , "Would you like me to update your elm.json accordingly? [Y/n]: "
        ]


attemptChangesHelp :: FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> D.Doc -> Task ()
attemptChangesHelp root env oldOutline newOutline question =
  Task.eio Exit.InstallBadDetails $
  BW.withScope $ \scope ->
  do  approved <- Reporting.ask question
      if approved
        then
          do  Outline.write root newOutline
              result <- Details.verifyInstall scope root env newOutline
              case result of
                Left exit ->
                  do  Outline.write root oldOutline
                      return (Left exit)

                Right () ->
                  do  putStrLn "Success!"
                      return (Right ())
        else
          do  putStrLn "Okay, I did not change anything!"
              return (Right ())



-- MAKE APP PLAN


makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version)
makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
  if Map.member pkg direct then
    return AlreadyInstalled

  else
    -- is it already indirect?
    case Map.lookup pkg indirect of
      Just vsn ->
        return $ PromoteIndirect $ Outline.App $
          outline
            { Outline._app_deps_direct = Map.insert pkg vsn direct
            , Outline._app_deps_indirect = Map.delete pkg indirect
            }

      Nothing ->
        -- is it already a test dependency?
        case Map.lookup pkg testDirect of
          Just vsn ->
            return $ PromoteTest $ Outline.App $
              outline
                { Outline._app_deps_direct = Map.insert pkg vsn direct
                , Outline._app_test_direct = Map.delete pkg testDirect
                }

          Nothing ->
            -- is it already an indirect test dependency?
            case Map.lookup pkg testIndirect of
              Just vsn ->
                return $ PromoteTest $ Outline.App $
                  outline
                    { Outline._app_deps_direct = Map.insert pkg vsn direct
                    , Outline._app_test_indirect = Map.delete pkg testIndirect
                    }

              Nothing ->
                -- finally try to add it from scratch
                case Registry.getVersions' pkg registry of
                  Left suggestions ->
                    case connection of
                      Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
                      Solver.Offline  -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)

                  Right _ ->
                    do  result <- Task.io $ Solver.addToApp cache connection registry pkg outline
                        case result of
                          Solver.Ok (Solver.AppSolution old new app) ->
                            return (Changes (detectChanges old new) (Outline.App app))

                          Solver.NoSolution ->
                            Task.throw (Exit.InstallNoOnlineAppSolution pkg)

                          Solver.NoOfflineSolution ->
                            Task.throw (Exit.InstallNoOfflineAppSolution pkg)

                          Solver.Err exit ->
                            Task.throw (Exit.InstallHadSolverTrouble exit)



-- MAKE PACKAGE PLAN


makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint)
makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps test _) =
  if Map.member pkg deps then
    return AlreadyInstalled
  else
    -- is already in test dependencies?
    case Map.lookup pkg test of
      Just con ->
        return $ PromoteTest $ Outline.Pkg $
          outline
            { Outline._pkg_deps = Map.insert pkg con deps
            , Outline._pkg_test_deps = Map.delete pkg test
            }

      Nothing ->
        -- try to add a new dependency
        case Registry.getVersions' pkg registry of
          Left suggestions ->
            case connection of
              Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
              Solver.Offline  -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)

          Right (Registry.KnownVersions _ _) ->
            do  let old = Map.union deps test
                let cons = Map.insert pkg C.anything old
                result <- Task.io $ Solver.verify cache connection registry cons
                case result of
                  Solver.Ok solution ->
                    let
                      (Solver.Details vsn _) = solution ! pkg

                      con = C.untilNextMajor vsn
                      new = Map.insert pkg con old
                      changes = detectChanges old new
                      news = Map.mapMaybe keepNew changes
                    in
                    return $ Changes changes $ Outline.Pkg $
                      outline
                        { Outline._pkg_deps = addNews (Just pkg) news deps
                        , Outline._pkg_test_deps = addNews Nothing news test
                        }

                  Solver.NoSolution ->
                    Task.throw (Exit.InstallNoOnlinePkgSolution pkg)

                  Solver.NoOfflineSolution ->
                    Task.throw (Exit.InstallNoOfflinePkgSolution pkg)

                  Solver.Err exit ->
                    Task.throw (Exit.InstallHadSolverTrouble exit)


addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint
addNews pkg new old =
  Map.merge
    Map.preserveMissing
    (Map.mapMaybeMissing (\k c -> if Just k == pkg then Just c else Nothing))
    (Map.zipWithMatched (\_ _ n -> n))
    old
    new



-- CHANGES


data Change a
  = Insert a
  | Change a a
  | Remove a


detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)
detectChanges old new =
  Map.merge
    (Map.mapMissing (\_ v -> Remove v))
    (Map.mapMissing (\_ v -> Insert v))
    (Map.zipWithMaybeMatched keepChange)
    old
    new


keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
keepChange _ old new =
  if old == new then
    Nothing
  else
    Just (Change old new)


keepNew :: Change a -> Maybe a
keepNew change =
  case change of
    Insert a ->
      Just a

    Change _ a ->
      Just a

    Remove _ ->
      Nothing



-- VIEW CHANGE DOCS


data ChangeDocs =
  Docs
    { _doc_inserts :: [D.Doc]
    , _doc_changes :: [D.Doc]
    , _doc_removes :: [D.Doc]
    }


viewChangeDocs :: ChangeDocs -> D.Doc
viewChangeDocs (Docs inserts changes removes) =
  D.indent 2 $ D.vcat $ concat $
    [ viewNonZero "Add:"    inserts
    , viewNonZero "Change:" changes
    , viewNonZero "Remove:" removes
    ]


viewNonZero :: String -> [D.Doc] -> [D.Doc]
viewNonZero title entries =
  if null entries then
    []
  else
    [ ""
    , D.fromChars title
    , D.indent 2 (D.vcat entries)
    ]



-- VIEW CHANGE


addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs
addChange toChars widths name change (Docs inserts changes removes) =
  case change of
    Insert new ->
      Docs (viewInsert toChars widths name new : inserts) changes removes

    Change old new ->
      Docs inserts (viewChange toChars widths name old new : changes) removes

    Remove old ->
      Docs inserts changes (viewRemove toChars widths name old : removes)


viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
viewInsert toChars (Widths nameWidth leftWidth _) name new =
  viewName nameWidth name <+> pad leftWidth (toChars new)


viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc
viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =
  D.hsep
    [ viewName nameWidth name
    , pad leftWidth (toChars old)
    , "=>"
    , pad rightWidth (toChars new)
    ]


viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
viewRemove toChars (Widths nameWidth leftWidth _) name old =
  viewName nameWidth name <+> pad leftWidth (toChars old)


viewName :: Int -> Pkg.Name -> D.Doc
viewName width name =
  D.fill (width + 3) (D.fromPackage name)


pad :: Int -> String -> D.Doc
pad width string =
  D.fromChars (replicate (width - length string) ' ') <> D.fromChars string



-- WIDTHS


data Widths =
  Widths
    { _name :: !Int
    , _left :: !Int
    , _right :: !Int
    }


widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths
widen toChars pkg change (Widths name left right) =
  let
    toLength a =
      length (toChars a)

    newName =
      max name (length (Pkg.toChars pkg))
  in
    case change of
      Insert new ->
        Widths newName (max left (toLength new)) right

      Change old new ->
        Widths newName (max left (toLength old)) (max right (toLength new))

      Remove old ->
        Widths newName (max left (toLength old)) right


================================================
FILE: terminal/src/Main.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Main
  ( main
  )
  where


import Prelude hiding (init)
import qualified Data.List as List
import qualified Text.PrettyPrint.ANSI.Leijen as P
import Text.Read (readMaybe)

import qualified Elm.Version as V
import Terminal
import Terminal.Helpers

import qualified Bump
import qualified Develop
import qualified Diff
import qualified Init
import qualified Install
import qualified Make
import qualified Publish
import qualified Repl



-- MAIN


main :: IO ()
main =
  Terminal.app intro outro
    [ repl
    , init
    , reactor
    , make
    , install
    , bump
    , diff
    , publish
    ]


intro :: P.Doc
intro =
  P.vcat
    [ P.fillSep
        ["Hi,","thank","you","for","trying","out"
        ,P.green "Elm"
        ,P.green (P.text (V.toChars V.compiler)) <> "."
        ,"I hope you like it!"
        ]
    , ""
    , P.black "-------------------------------------------------------------------------------"
    , P.black "I highly recommend working through  to get started."
    , P.black "It teaches many important concepts, including how to use `elm` in the terminal."
    , P.black "-------------------------------------------------------------------------------"
    ]


outro :: P.Doc
outro =
  P.fillSep $ map P.text $ words $
    "Be sure to ask on the Elm slack if you run into trouble! Folks are friendly and\
    \ happy to help out. They hang out there because it is fun, so be kind to get the\
    \ best results!"



-- INIT


init :: Terminal.Command
init =
  let
    summary =
      "Start an Elm project. It creates a starter elm.json file and\
      \ provides a link explaining what to do from there."

    details =
      "The `init` command helps start Elm projects:"

    example =
      reflow
        "It will ask permission to create an elm.json file, the one thing common\
        \ to all Elm projects. It also provides a link explaining what to do from there."
  in
  Terminal.Command "init" (Common summary) details example noArgs noFlags Init.run



-- REPL


repl :: Terminal.Command
repl =
  let
    summary =
      "Open up an interactive programming session. Type in Elm expressions\
      \ like (2 + 2) or (String.length \"test\") and see if they equal four!"

    details =
      "The `repl` command opens up an interactive programming session:"

    example =
      reflow
        "Start working through  to learn how to use this!\
        \ It has a whole chapter that uses the REPL for everything, so that is probably\
        \ the quickest way to get started."

    replFlags =
      flags Repl.Flags
        |-- flag "interpreter" interpreter "Path to a alternate JS interpreter, like node or nodejs."
        |-- onOff "no-colors" "Turn off the colors in the REPL. This can help if you are having trouble reading the values. Some terminals use a custom color scheme that diverges significantly from the standard ANSI colors, so another path may be to pick a more standard color scheme."
  in
  Terminal.Command "repl" (Common summary) details example noArgs replFlags Repl.run


interpreter :: Parser String
interpreter =
  Parser
    { _singular = "interpreter"
    , _plural = "interpreters"
    , _parser = Just
    , _suggest = \_ -> return []
    , _examples = \_ -> return ["node","nodejs"]
    }



-- REACTOR


reactor :: Terminal.Command
reactor =
  let
    summary =
      "Compile code with a click. It opens a file viewer in your browser, and\
      \ when you click on an Elm file, it compiles and you see the result."

    details =
      "The `reactor` command starts a local server on your computer:"

    example =
      reflow
        "After running that command, you would have a server at \
        \ that helps with development. It shows your files like a file viewer. If you\
        \ click on an Elm file, it will compile it for you! And you can just press\
        \ the refresh button in the browser to recompile things."

    reactorFlags =
      flags Develop.Flags
        |-- flag "port" port_ "The port of the server (default: 8000)"
  in
  Terminal.Command "reactor" (Common summary) details example noArgs reactorFlags Develop.run


port_ :: Parser Int
port_ =
  Parser
    { _singular = "port"
    , _plural = "ports"
    , _parser = readMaybe
    , _suggest = \_ -> return []
    , _examples = \_ -> return ["3000","8000"]
    }



-- MAKE


make :: Terminal.Command
make =
  let
    details =
      "The `make` command compiles Elm code into JS or HTML:"

    example =
      stack
        [ reflow
            "For example:"
        , P.indent 4 $ P.green "elm make src/Main.elm"
        , reflow
            "This tries to compile an Elm file named src/Main.elm, generating an index.html\
            \ file if possible."
        ]

    makeFlags =
      flags Make.Flags
        |-- onOff "debug" "Turn on the time-travelling debugger. It allows you to rewind and replay events. The events can be imported/exported into a file, which makes for very precise bug reports!"
        |-- onOff "optimize" "Turn on optimizations to make code smaller and faster. For example, the compiler renames record fields to be as short as possible and unboxes values to reduce allocation."
        |-- flag "output" Make.output "Specify the name of the resulting JS file. For example --output=assets/elm.js to generate the JS at assets/elm.js or --output=/dev/null to generate no output at all!"
        |-- flag "report" Make.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!"
        |-- flag "docs" Make.docsFile "Generate a JSON file of documentation for a package. Eventually it will be possible to preview docs with `reactor` because it is quite hard to deal with these JSON files directly."
  in
  Terminal.Command "make" Uncommon details example (zeroOrMore elmFile) makeFlags Make.run



-- INSTALL


install :: Terminal.Command
install =
  let
    details =
      "The `install` command fetches packages from  for\
      \ use in your project:"

    example =
      stack
        [ reflow
            "For example, if you want to get packages for HTTP and JSON, you would say:"
        , P.indent 4 $ P.green $ P.vcat $
              [ "elm install elm/http"
              , "elm install elm/json"
              ]
        , reflow
            "Notice that you must say the AUTHOR name and PROJECT name! After running those\
            \ commands, you could say `import Http` or `import Json.Decode` in your code."
        , reflow
            "What if two projects use different versions of the same package? No problem!\
            \ Each project is independent, so there cannot be conflicts like that!"
        ]

    installArgs =
      oneOf
        [ require0 Install.NoArgs
        , require1 Install.Install package
        ]
  in
  Terminal.Command "install" Uncommon details example installArgs noFlags Install.run



-- PUBLISH


publish :: Terminal.Command
publish =
  let
    details =
      "The `publish` command publishes your package on \
      \ so that anyone in the Elm community can use it."

    example =
      stack
        [ reflow
            "Think hard if you are ready to publish NEW packages though!"
        , reflow
            "Part of what makes Elm great is the packages ecosystem. The fact that\
            \ there is usually one option (usually very well done) makes it way\
            \ easier to pick packages and become productive. So having a million\
            \ packages would be a failure in Elm. We do not need twenty of\
            \ everything, all coded in a single weekend."
        , reflow
            "So as community members gain wisdom through experience, we want\
            \ them to share that through thoughtful API design and excellent\
            \ documentation. It is more about sharing ideas and insights than\
            \ just sharing code! The first step may be asking for advice from\
            \ people you respect, or in community forums. The second step may\
            \ be using it at work to see if it is as nice as you think. Maybe\
            \ it ends up as an experiment on GitHub only. Point is, try to be\
            \ respectful of the community and package ecosystem!"
        , reflow
            "Check out  for guidance on how to create great packages!"
        ]
  in
  Terminal.Command "publish" Uncommon details example noArgs noFlags Publish.run



-- BUMP


bump :: Terminal.Command
bump =
  let
    details =
      "The `bump` command figures out the next version number based on API changes:"

    example =
      reflow
        "Say you just published version 1.0.0, but then decided to remove a function.\
        \ I will compare the published API to what you have locally, figure out that\
        \ it is a MAJOR change, and bump your version number to 2.0.0. I do this with\
        \ all packages, so there cannot be MAJOR changes hiding in PATCH releases in Elm!"
  in
  Terminal.Command "bump" Uncommon details example noArgs noFlags Bump.run



-- DIFF


diff :: Terminal.Command
diff =
  let
    details =
      "The `diff` command detects API changes:"

    example =
      stack
        [ reflow
            "For example, to see what changed in the HTML package between\
            \ versions 1.0.0 and 2.0.0, you can say:"
        , P.indent 4 $ P.green $ "elm diff elm/html 1.0.0 2.0.0"
        , reflow
            "Sometimes a MAJOR change is not actually very big, so\
            \ this can help you plan your upgrade timelines."
        ]

    diffArgs =
      oneOf
        [ require0 Diff.CodeVsLatest
        , require1 Diff.CodeVsExactly version
        , require2 Diff.LocalInquiry version version
        , require3 Diff.GlobalInquiry package version version
        ]
  in
  Terminal.Command "diff" Uncommon details example diffArgs noFlags Diff.run



-- HELPERS


stack :: [P.Doc] -> P.Doc
stack docs =
  P.vcat $ List.intersperse "" docs


reflow :: String -> P.Doc
reflow string =
  P.fillSep $ map P.text $ words string


================================================
FILE: terminal/src/Make.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Make
  ( Flags(..)
  , Output(..)
  , ReportType(..)
  , run
  , reportType
  , output
  , docsFile
  )
  where


import qualified Data.ByteString.Builder as B
import qualified Data.Maybe as Maybe
import qualified Data.NonEmptyList as NE
import qualified System.Directory as Dir
import qualified System.FilePath as FP

import qualified AST.Optimized as Opt
import qualified BackgroundWriter as BW
import qualified Build
import qualified Elm.Details as Details
import qualified Elm.ModuleName as ModuleName
import qualified File
import qualified Generate
import qualified Generate.Html as Html
import qualified Reporting
import qualified Reporting.Exit as Exit
import qualified Reporting.Task as Task
import qualified Stuff
import Terminal (Parser(..))



-- FLAGS


data Flags =
  Flags
    { _debug :: Bool
    , _optimize :: Bool
    , _output :: Maybe Output
    , _report :: Maybe ReportType
    , _docs :: Maybe FilePath
    }


data Output
  = JS FilePath
  | Html FilePath
  | DevNull


data ReportType
  = Json



-- RUN


type Task a = Task.Task Exit.Make a


run :: [FilePath] -> Flags -> IO ()
run paths flags@(Flags _ _ _ report _) =
  do  style <- getStyle report
      maybeRoot <- Stuff.findRoot
      Reporting.attemptWithStyle style Exit.makeToReport $
        case maybeRoot of
          Just root -> runHelp root paths style flags
          Nothing   -> return $ Left $ Exit.MakeNoOutline


runHelp :: FilePath -> [FilePath] -> Reporting.Style -> Flags -> IO (Either Exit.Make ())
runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) =
  BW.withScope $ \scope ->
  Stuff.withRootLock root $ Task.run $
  do  desiredMode <- getMode debug optimize
      details <- Task.eio Exit.MakeBadDetails (Details.load style scope root)
      case paths of
        [] ->
          do  exposed <- getExposed details
              buildExposed style root details maybeDocs exposed

        p:ps ->
          do  artifacts <- buildPaths style root details (NE.List p ps)
              case maybeOutput of
                Nothing ->
                  case getMains artifacts of
                    [] ->
                      return ()

                    [name] ->
                      do  builder <- toBuilder root details desiredMode artifacts
                          generate style "index.html" (Html.sandwich name builder) (NE.List name [])

                    name:names ->
                      do  builder <- toBuilder root details desiredMode artifacts
                          generate style "elm.js" builder (NE.List name names)

                Just DevNull ->
                  return ()

                Just (JS target) ->
                  case getNoMains artifacts of
                    [] ->
                      do  builder <- toBuilder root details desiredMode artifacts
                          generate style target builder (Build.getRootNames artifacts)

                    name:names ->
                      Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)

                Just (Html target) ->
                  do  name <- hasOneMain artifacts
                      builder <- toBuilder root details desiredMode artifacts
                      generate style target (Html.sandwich name builder) (NE.List name [])



-- GET INFORMATION


getStyle :: Maybe ReportType -> IO Reporting.Style
getStyle report =
  case report of
    Nothing -> Reporting.terminal
    Just Json -> return Reporting.json


getMode :: Bool -> Bool -> Task DesiredMode
getMode debug optimize =
  case (debug, optimize) of
    (True , True ) -> Task.throw Exit.MakeCannotOptimizeAndDebug
    (True , False) -> return Debug
    (False, False) -> return Dev
    (False, True ) -> return Prod


getExposed :: Details.Details -> Task (NE.List ModuleName.Raw)
getExposed (Details.Details _ validOutline _ _ _ _) =
  case validOutline of
    Details.ValidApp _ ->
      Task.throw Exit.MakeAppNeedsFileNames

    Details.ValidPkg _ exposed _ ->
      case exposed of
        [] -> Task.throw Exit.MakePkgNeedsExposing
        m:ms -> return (NE.List m ms)



-- BUILD PROJECTS


buildExposed :: Reporting.Style -> FilePath -> Details.Details -> Maybe FilePath -> NE.List ModuleName.Raw -> Task ()
buildExposed style root details maybeDocs exposed =
  let
    docsGoal = maybe Build.IgnoreDocs Build.WriteDocs maybeDocs
  in
  Task.eio Exit.MakeCannotBuild $
    Build.fromExposed style root details docsGoal exposed


buildPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> Task Build.Artifacts
buildPaths style root details paths =
  Task.eio Exit.MakeCannotBuild $
    Build.fromPaths style root details paths



-- GET MAINS


getMains :: Build.Artifacts -> [ModuleName.Raw]
getMains (Build.Artifacts _ _ roots modules) =
  Maybe.mapMaybe (getMain modules) (NE.toList roots)


getMain :: [Build.Module] -> Build.Root -> Maybe ModuleName.Raw
getMain modules root =
  case root of
    Build.Inside name ->
      if any (isMain name) modules
      then Just name
      else Nothing

    Build.Outside name _ (Opt.LocalGraph maybeMain _ _) ->
      case maybeMain of
        Just _  -> Just name
        Nothing -> Nothing


isMain :: ModuleName.Raw -> Build.Module -> Bool
isMain targetName modul =
  case modul of
    Build.Fresh name _ (Opt.LocalGraph maybeMain _ _) ->
      Maybe.isJust maybeMain && name == targetName

    Build.Cached name mainIsDefined _ ->
      mainIsDefined && name == targetName



-- HAS ONE MAIN


hasOneMain :: Build.Artifacts -> Task ModuleName.Raw
hasOneMain (Build.Artifacts _ _ roots modules) =
  case roots of
    NE.List root [] -> Task.mio Exit.MakeNoMain (return $ getMain modules root)
    NE.List _ (_:_) -> Task.throw Exit.MakeMultipleFilesIntoHtml



-- GET MAINLESS


getNoMains :: Build.Artifacts -> [ModuleName.Raw]
getNoMains (Build.Artifacts _ _ roots modules) =
  Maybe.mapMaybe (getNoMain modules) (NE.toList roots)


getNoMain :: [Build.Module] -> Build.Root -> Maybe ModuleName.Raw
getNoMain modules root =
  case root of
    Build.Inside name ->
      if any (isMain name) modules
      then Nothing
      else Just name

    Build.Outside name _ (Opt.LocalGraph maybeMain _ _) ->
      case maybeMain of
        Just _  -> Nothing
        Nothing -> Just name



-- GENERATE


generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task ()
generate style target builder names =
  Task.io $
    do  Dir.createDirectoryIfMissing True (FP.takeDirectory target)
        File.writeBuilder target builder
        Reporting.reportGenerate style names target



-- TO BUILDER


data DesiredMode = Debug | Dev | Prod


toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder
toBuilder root details desiredMode artifacts =
  Task.mapError Exit.MakeBadGenerate $
    case desiredMode of
      Debug -> Generate.debug root details artifacts
      Dev   -> Generate.dev   root details artifacts
      Prod  -> Generate.prod  root details artifacts



-- PARSERS


reportType :: Parser ReportType
reportType =
  Parser
    { _singular = "report type"
    , _plural = "report types"
    , _parser = \string -> if string == "json" then Just Json else Nothing
    , _suggest = \_ -> return ["json"]
    , _examples = \_ -> return ["json"]
    }


output :: Parser Output
output =
  Parser
    { _singular = "output file"
    , _plural = "output files"
    , _parser = parseOutput
    , _suggest = \_ -> return []
    , _examples = \_ -> return [ "elm.js", "index.html", "/dev/null" ]
    }


parseOutput :: String -> Maybe Output
parseOutput name
  | isDevNull name      = Just DevNull
  | hasExt ".html" name = Just (Html name)
  | hasExt ".js"   name = Just (JS name)
  | otherwise           = Nothing


docsFile :: Parser FilePath
docsFile =
  Parser
    { _singular = "json file"
    , _plural = "json files"
    , _parser = \name -> if hasExt ".json" name then Just name else Nothing
    , _suggest = \_ -> return []
    , _examples = \_ -> return ["docs.json","documentation.json"]
    }


hasExt :: String -> String -> Bool
hasExt ext path =
  FP.takeExtension path == ext && length path > length ext


isDevNull :: String -> Bool
isDevNull name =
  name == "/dev/null" || name == "NUL" || name == "$null"


================================================
FILE: terminal/src/Publish.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Publish
  ( run
  )
  where


import Control.Exception (bracket_)
import Control.Monad (void)
import qualified Data.List as List
import qualified Data.NonEmptyList as NE
import qualified Data.Utf8 as Utf8
import qualified System.Directory as Dir
import qualified System.Exit as Exit
import System.FilePath (())
import qualified System.Info as Info
import qualified System.IO as IO
import qualified System.Process as Process

import qualified BackgroundWriter as BW
import qualified Build
import qualified Deps.Bump as Bump
import qualified Deps.Diff as Diff
import qualified Deps.Registry as Registry
import qualified Deps.Website as Website
import qualified Elm.Details as Details
import qualified Elm.Docs as Docs
import qualified Elm.Magnitude as M
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.String as Json
import qualified Reporting
import Reporting.Doc ((<+>))
import qualified Reporting.Doc as D
import qualified Reporting.Exit as Exit
import qualified Reporting.Exit.Help as Help
import qualified Reporting.Task as Task
import qualified Stuff



-- RUN


-- TODO mandate no "exposing (..)" in packages to make
-- optimization to skip builds in Elm.Details always valid


run :: () -> () -> IO ()
run () () =
  Reporting.attempt Exit.publishToReport $
    Task.run $ publish =<< getEnv



-- ENV


data Env =
  Env
    { _root :: FilePath
    , _cache :: Stuff.PackageCache
    , _manager :: Http.Manager
    , _registry :: Registry.Registry
    , _outline :: Outline.Outline
    }


getEnv :: Task.Task Exit.Publish Env
getEnv =
  do  root <- Task.mio Exit.PublishNoOutline $ Stuff.findRoot
      cache <- Task.io $ Stuff.getPackageCache
      manager <- Task.io $ Http.getManager
      registry <- Task.eio Exit.PublishMustHaveLatestRegistry $ Registry.latest manager cache
      outline <- Task.eio Exit.PublishBadOutline $ Outline.read root
      return $ Env root cache manager registry outline



-- PUBLISH


publish ::  Env -> Task.Task Exit.Publish ()
publish env@(Env root _ manager registry outline) =
  case outline of
    Outline.App _ ->
      Task.throw Exit.PublishApplication

    Outline.Pkg (Outline.PkgOutline pkg summary _ vsn exposed _ _ _) ->
      do  let maybeKnownVersions = Registry.getVersions pkg registry

          reportPublishStart pkg vsn maybeKnownVersions

          if noExposed  exposed then Task.throw Exit.PublishNoExposed else return ()
          if badSummary summary then Task.throw Exit.PublishNoSummary else return ()

          verifyReadme root
          verifyLicense root
          docs <- verifyBuild root
          verifyVersion env pkg vsn docs maybeKnownVersions
          git <- getGit
          commitHash <- verifyTag git manager pkg vsn
          verifyNoChanges git commitHash vsn
          zipHash <- verifyZip env pkg vsn

          Task.io $ putStrLn ""
          register manager pkg vsn docs commitHash zipHash
          Task.io $ putStrLn "Success!"



-- VERIFY SUMMARY


badSummary :: Json.String -> Bool
badSummary summary =
  Json.isEmpty summary || Outline.defaultSummary == summary


noExposed :: Outline.Exposed -> Bool
noExposed exposed =
  case exposed of
    Outline.ExposedList modules ->
      null modules

    Outline.ExposedDict chunks ->
      all (null . snd) chunks



-- VERIFY README


verifyReadme :: FilePath -> Task.Task Exit.Publish ()
verifyReadme root =
  reportReadmeCheck $
  do  let readmePath = root  "README.md"
      exists <- File.exists readmePath
      case exists of
        False ->
          return (Left Exit.PublishNoReadme)

        True ->
          do  size <- IO.withFile readmePath IO.ReadMode IO.hFileSize
              if size < 300
                then return (Left Exit.PublishShortReadme)
                else return (Right ())



-- VERIFY LICENSE


verifyLicense :: FilePath -> Task.Task Exit.Publish ()
verifyLicense root =
  reportLicenseCheck $
  do  let licensePath = root  "LICENSE"
      exists <- File.exists licensePath
      if exists
        then return (Right ())
        else return (Left Exit.PublishNoLicense)



-- VERIFY BUILD


verifyBuild :: FilePath -> Task.Task Exit.Publish Docs.Documentation
verifyBuild root =
  reportBuildCheck $ BW.withScope $ \scope ->
    Task.run $
    do  details@(Details.Details _ outline _ _ _ _) <-
          Task.eio Exit.PublishBadDetails $
            Details.load Reporting.silent scope root

        exposed <-
          case outline of
            Details.ValidApp _          -> Task.throw Exit.PublishApplication
            Details.ValidPkg _ []     _ -> Task.throw Exit.PublishNoExposed
            Details.ValidPkg _ (e:es) _ -> return (NE.List e es)

        Task.eio Exit.PublishBuildProblem $
          Build.fromExposed Reporting.silent root details Build.KeepDocs exposed


-- GET GIT


newtype Git =
  Git { _run :: [String] -> IO Exit.ExitCode }


getGit :: Task.Task Exit.Publish Git
getGit =
  do  maybeGit <- Task.io $ Dir.findExecutable "git"
      case maybeGit of
        Nothing ->
          Task.throw Exit.PublishNoGit

        Just git ->
          return $ Git $ \args ->
            let
              process =
                (Process.proc git args)
                  { Process.std_in  = Process.CreatePipe
                  , Process.std_out = Process.CreatePipe
                  , Process.std_err = Process.CreatePipe
                  }
            in
            Process.withCreateProcess process $ \_ _ _ handle ->
              Process.waitForProcess handle



-- VERIFY GITHUB TAG


verifyTag :: Git -> Http.Manager -> Pkg.Name -> V.Version -> Task.Task Exit.Publish String
verifyTag git manager pkg vsn =
  reportTagCheck vsn $
  do  -- https://stackoverflow.com/questions/1064499/how-to-list-all-git-tags
      exitCode <- _run git [ "show", "--name-only", V.toChars vsn, "--" ]
      case exitCode of
        Exit.ExitFailure _ ->
          return $ Left (Exit.PublishMissingTag vsn)

        Exit.ExitSuccess ->
          let url = toTagUrl pkg vsn in
          Http.get manager url [Http.accept "application/json"] (Exit.PublishCannotGetTag vsn) $ \body ->
            case D.fromByteString commitHashDecoder body of
              Right hash ->
                return $ Right hash

              Left _ ->
                return $ Left (Exit.PublishCannotGetTagData vsn url body)


toTagUrl :: Pkg.Name -> V.Version -> String
toTagUrl pkg vsn =
  "https://api.github.com/repos/" ++ Pkg.toUrl pkg ++ "/git/refs/tags/" ++ V.toChars vsn


commitHashDecoder :: D.Decoder e String
commitHashDecoder =
  Utf8.toChars <$>
    D.field "object" (D.field "sha" D.string)



-- VERIFY NO LOCAL CHANGES SINCE TAG


verifyNoChanges :: Git -> String -> V.Version -> Task.Task Exit.Publish ()
verifyNoChanges git commitHash vsn =
  reportLocalChangesCheck $
  do  -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
      exitCode <- _run git [ "diff-index", "--quiet", commitHash, "--" ]
      case exitCode of
        Exit.ExitSuccess   -> return $ Right ()
        Exit.ExitFailure _ -> return $ Left (Exit.PublishLocalChanges vsn)



-- VERIFY THAT ZIP BUILDS / COMPUTE HASH


verifyZip :: Env -> Pkg.Name -> V.Version -> Task.Task Exit.Publish Http.Sha
verifyZip (Env root _ manager _ _) pkg vsn =
  withPrepublishDir root $ \prepublishDir ->
    do  let url = toZipUrl pkg vsn

        (sha, archive) <-
          reportDownloadCheck $
            Http.getArchive manager url
              Exit.PublishCannotGetZip
              (Exit.PublishCannotDecodeZip url)
              (return . Right)

        Task.io $ File.writePackage prepublishDir archive

        reportZipBuildCheck $
          Dir.withCurrentDirectory prepublishDir $
            verifyZipBuild prepublishDir

        return sha


toZipUrl :: Pkg.Name -> V.Version -> String
toZipUrl pkg vsn =
  "https://github.com/" ++ Pkg.toUrl pkg ++ "/zipball/" ++ V.toChars vsn ++ "/"


withPrepublishDir :: FilePath -> (FilePath -> Task.Task x a) -> Task.Task x a
withPrepublishDir root callback =
  let
    dir = Stuff.prepublishDir root
  in
  Task.eio id $
    bracket_
      (Dir.createDirectoryIfMissing True dir)
      (Dir.removeDirectoryRecursive dir)
      (Task.run (callback dir))


verifyZipBuild :: FilePath -> IO (Either Exit.Publish ())
verifyZipBuild root =
  BW.withScope $ \scope -> Task.run $
  do  details@(Details.Details _ outline _ _ _ _) <-
        Task.eio Exit.PublishZipBadDetails $
          Details.load Reporting.silent scope root

      exposed <-
        case outline of
          Details.ValidApp _          -> Task.throw Exit.PublishZipApplication
          Details.ValidPkg _ []     _ -> Task.throw Exit.PublishZipNoExposed
          Details.ValidPkg _ (e:es) _ -> return (NE.List e es)

      _ <- Task.eio Exit.PublishZipBuildProblem $
        Build.fromExposed Reporting.silent root details Build.KeepDocs exposed

      return ()



-- VERIFY VERSION


data GoodVersion
  = GoodStart
  | GoodBump V.Version M.Magnitude


verifyVersion :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Maybe Registry.KnownVersions -> Task.Task Exit.Publish ()
verifyVersion env pkg vsn newDocs publishedVersions =
  reportSemverCheck vsn $
    case publishedVersions of
      Nothing ->
        if vsn == V.one
        then return $ Right GoodStart
        else return $ Left $ Exit.PublishNotInitialVersion vsn

      Just knownVersions@(Registry.KnownVersions latest previous) ->
        if vsn == latest || elem vsn previous
        then return $ Left $ Exit.PublishAlreadyPublished vsn
        else verifyBump env pkg vsn newDocs knownVersions


verifyBump :: Env -> Pkg.Name -> V.Version -> Docs.Documentation -> Registry.KnownVersions -> IO (Either Exit.Publish GoodVersion)
verifyBump (Env _ cache manager _ _) pkg vsn newDocs knownVersions@(Registry.KnownVersions latest _) =
  case List.find (\(_ ,new, _) -> vsn == new) (Bump.getPossibilities knownVersions) of
    Nothing ->
      return $ Left $
        Exit.PublishInvalidBump vsn latest

    Just (old, new, magnitude) ->
      do  result <- Diff.getDocs cache manager pkg old
          case result of
            Left dp ->
              return $ Left $ Exit.PublishCannotGetDocs old new dp

            Right oldDocs ->
              let
                changes = Diff.diff oldDocs newDocs
                realNew = Diff.bump changes old
              in
              if new == realNew
              then return $ Right $ GoodBump old magnitude
              else
                return $ Left $
                  Exit.PublishBadBump old new magnitude realNew (Diff.toMagnitude changes)



-- REGISTER PACKAGES


register :: Http.Manager -> Pkg.Name -> V.Version -> Docs.Documentation -> String -> Http.Sha -> Task.Task Exit.Publish ()
register manager pkg vsn docs commitHash sha =
  let
    url =
      Website.route "/register"
        [ ("name", Pkg.toChars pkg)
        , ("version", V.toChars vsn)
        , ("commit-hash", commitHash)
        ]
  in
  Task.eio Exit.PublishCannotRegister $
    Http.upload manager url
      [ Http.filePart "elm.json" "elm.json"
      , Http.jsonPart "docs.json" "docs.json" (Docs.encode docs)
      , Http.filePart "README.md" "README.md"
      , Http.stringPart "github-hash" (Http.shaToChars sha)
      ]



-- REPORTING


reportPublishStart :: Pkg.Name -> V.Version -> Maybe Registry.KnownVersions -> Task.Task x ()
reportPublishStart pkg vsn maybeKnownVersions =
  Task.io $
  case maybeKnownVersions of
    Nothing ->
      putStrLn $ Exit.newPackageOverview ++ "\nI will now verify that everything is in order...\n"

    Just _ ->
      putStrLn $ "Verifying " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " ...\n"



-- REPORTING PHASES


reportReadmeCheck :: IO (Either x a) -> Task.Task x a
reportReadmeCheck =
  reportCheck
    "Looking for README.md"
    "Found README.md"
    "Problem with your README.md"


reportLicenseCheck :: IO (Either x a) -> Task.Task x a
reportLicenseCheck =
  reportCheck
    "Looking for LICENSE"
    "Found LICENSE"
    "Problem with your LICENSE"


reportBuildCheck :: IO (Either x a) -> Task.Task x a
reportBuildCheck =
  reportCheck
    "Verifying documentation..."
    "Verified documentation"
    "Problem with documentation"


reportSemverCheck :: V.Version -> IO (Either x GoodVersion) -> Task.Task x ()
reportSemverCheck version work =
  let
    vsn = V.toChars version

    waiting = "Checking semantic versioning rules. Is " ++ vsn ++ " correct?"
    failure = "Version " ++ vsn ++ " is not correct!"
    success result =
      case result of
        GoodStart ->
          "All packages start at version " ++ V.toChars V.one

        GoodBump oldVersion magnitude ->
          "Version number " ++ vsn ++ " verified ("
          ++ M.toChars magnitude ++ " change, "
          ++ V.toChars oldVersion ++ " => " ++ vsn ++ ")"
  in
  void $ reportCustomCheck waiting success failure work


reportTagCheck :: V.Version -> IO (Either x a) -> Task.Task x a
reportTagCheck vsn =
  reportCheck
    ("Is version " ++ V.toChars vsn ++ " tagged on GitHub?")
    ("Version " ++ V.toChars vsn ++ " is tagged on GitHub")
    ("Version " ++ V.toChars vsn ++ " is not tagged on GitHub!")


reportDownloadCheck :: IO (Either x a) -> Task.Task x a
reportDownloadCheck =
  reportCheck
    "Downloading code from GitHub..."
    "Code downloaded successfully from GitHub"
    "Could not download code from GitHub!"


reportLocalChangesCheck :: IO (Either x a) -> Task.Task x a
reportLocalChangesCheck =
  reportCheck
    "Checking for uncommitted changes..."
    "No uncommitted changes in local code"
    "Your local code is different than the code tagged on GitHub"


reportZipBuildCheck :: IO (Either x a) -> Task.Task x a
reportZipBuildCheck =
  reportCheck
    "Verifying downloaded code..."
    "Downloaded code compiles successfully"
    "Cannot compile downloaded code!"


reportCheck :: String -> String -> String -> IO (Either x a) -> Task.Task x a
reportCheck waiting success failure work =
  reportCustomCheck waiting (\_ -> success) failure work


reportCustomCheck :: String -> (a -> String) -> String -> IO (Either x a) -> Task.Task x a
reportCustomCheck waiting success failure work =
  let
    putFlush doc =
      Help.toStdout doc >> IO.hFlush IO.stdout

    padded message =
      message ++ replicate (length waiting - length message) ' '
  in
  Task.eio id $
  do  putFlush $ "  " <> waitingMark <+> D.fromChars waiting
      result <- work
      putFlush $
        case result of
          Right a -> "\r  " <> goodMark <+> D.fromChars (padded (success a) ++ "\n")
          Left _  -> "\r  " <> badMark  <+> D.fromChars (padded failure ++ "\n\n")

      return result


-- MARKS


goodMark :: D.Doc
goodMark =
  D.green $ if isWindows then "+" else "●"


badMark :: D.Doc
badMark =
  D.red $ if isWindows then "X" else "✗"


waitingMark :: D.Doc
waitingMark =
  D.dullyellow $ if isWindows then "-" else "→"


isWindows :: Bool
isWindows =
  Info.os == "mingw32"


================================================
FILE: terminal/src/Repl.hs
================================================
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Repl
  ( Flags(..)
  , run
  --
  , Lines(..)
  , Input(..)
  , Prefill(..)
  , CategorizedInput(..)
  , categorize
  --
  , State(..)
  , Output(..)
  , toByteString
  )
  where


import Prelude hiding (lines, read)
import Control.Applicative ((<|>))
import Control.Monad.Trans (lift, liftIO)
import qualified Control.Monad.State.Strict as State
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.UTF8 as BS_UTF8
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Name as N
import qualified System.Console.Haskeline as Repl
import qualified System.Directory as Dir
import qualified System.Exit as Exit
import System.FilePath (())
import qualified System.IO as IO
import qualified System.Process as Proc

import qualified AST.Source as Src
import qualified BackgroundWriter as BW
import qualified Build
import qualified Elm.Constraint as C
import qualified Elm.Details as Details
import qualified Elm.Licenses as Licenses
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 Generate
import qualified Parse.Expression as PE
import qualified Parse.Declaration as PD
import qualified Parse.Module as PM
import qualified Parse.Primitives as P
import qualified Parse.Space as PS
import qualified Parse.Type as PT
import qualified Parse.Variable as PV
import Parse.Primitives (Row, Col)
import qualified Reporting
import qualified Reporting.Annotation as A
import Reporting.Doc ((<+>))
import qualified Reporting.Doc as D
import qualified Reporting.Error.Syntax as ES
import qualified Reporting.Exit as Exit
import qualified Reporting.Render.Code as Code
import qualified Reporting.Report as Report
import qualified Reporting.Task as Task
import qualified Stuff



-- RUN


data Flags =
  Flags
    { _maybeInterpreter :: Maybe FilePath
    , _noColors :: Bool
    }


run :: () -> Flags -> IO ()
run () flags =
  do  printWelcomeMessage
      settings <- initSettings
      env <- initEnv flags
      let looper = Repl.runInputT settings (Repl.withInterrupt (loop env initialState))
      exitCode <- State.evalStateT looper initialState
      Exit.exitWith exitCode



-- WELCOME


printWelcomeMessage :: IO ()
printWelcomeMessage =
  let
    vsn = V.toChars V.compiler
    title = "Elm" <+> D.fromChars vsn
    dashes = replicate (70 - length vsn) '-'
  in
  D.toAnsi IO.stdout $
    D.vcat
      [ D.black "----" <+> D.dullcyan title <+> D.black (D.fromChars dashes)
      , D.black $ D.fromChars $ "Say :help for help and :exit to exit! More at " <> D.makeLink "repl"
      , D.black "--------------------------------------------------------------------------------"
      , D.empty
      ]



-- ENV


data Env =
  Env
    { _root :: FilePath
    , _interpreter :: FilePath
    , _ansi :: Bool
    }


initEnv :: Flags -> IO Env
initEnv (Flags maybeAlternateInterpreter noColors) =
  do  root <- getRoot
      interpreter <- getInterpreter maybeAlternateInterpreter
      return $ Env root interpreter (not noColors)



-- LOOP


data Outcome
  = Loop State
  | End Exit.ExitCode


type M =
  State.StateT State IO


loop :: Env -> State -> Repl.InputT M Exit.ExitCode
loop env state =
  do  input <- Repl.handleInterrupt (return Skip) read
      outcome <- liftIO (eval env state input)
      case outcome of
        Loop state ->
          do  lift (State.put state)
              loop env state

        End exitCode ->
          return exitCode



-- READ


data Input
  = Import ModuleName.Raw BS.ByteString
  | Type N.Name BS.ByteString
  | Port
  | Decl N.Name BS.ByteString
  | Expr BS.ByteString
  --
  | Reset
  | Exit
  | Skip
  | Help (Maybe String)


read :: Repl.InputT M Input
read =
  do  maybeLine <- Repl.getInputLine "> "
      case maybeLine of
        Nothing ->
          return Exit

        Just chars ->
          let
            lines = Lines (stripLegacyBackslash chars) []
          in
          case categorize lines of
            Done input -> return input
            Continue p -> readMore lines p


readMore :: Lines -> Prefill -> Repl.InputT M Input
readMore previousLines prefill =
  do  input <- Repl.getInputLineWithInitial "| " (renderPrefill prefill, "")
      case input of
        Nothing ->
          return Skip

        Just chars ->
          let
            lines = addLine (stripLegacyBackslash chars) previousLines
          in
          case categorize lines of
            Done input -> return input
            Continue p -> readMore lines p


-- For compatibility with 0.19.0 such that readers of "Programming Elm" by @jfairbank
-- can get through the REPL section successfully.
--
-- TODO: remove stripLegacyBackslash in next MAJOR release
--
stripLegacyBackslash :: [Char] -> [Char]
stripLegacyBackslash chars =
  case chars of
    [] ->
      []

    _:_ ->
      if last chars == '\\'
      then init chars
      else chars


data Prefill
  = Indent
  | DefStart N.Name


renderPrefill :: Prefill -> String
renderPrefill lineStart =
  case lineStart of
    Indent ->
      "  "

    DefStart name ->
      N.toChars name ++ " "



-- LINES


data Lines =
  Lines
    { _prevLine :: String
    , _revLines :: [String]
    }


addLine :: [Char] -> Lines -> Lines
addLine line (Lines x xs) =
  Lines line (x:xs)


isBlank :: Lines -> Bool
isBlank (Lines prev rev) =
  null rev && all (==' ') prev


isSingleLine :: Lines -> Bool
isSingleLine (Lines _ rev) =
  null rev


endsWithBlankLine :: Lines -> Bool
endsWithBlankLine (Lines prev _) =
  all (==' ') prev


linesToByteString :: Lines -> BS_UTF8.ByteString
linesToByteString (Lines prev rev) =
  BS_UTF8.fromString (unlines (reverse (prev:rev)))


getFirstLine :: Lines -> String
getFirstLine (Lines x xs) =
  case xs of
    []   -> x
    y:ys -> getFirstLine (Lines y ys)




-- CATEGORIZE INPUT


data CategorizedInput
  = Done Input
  | Continue Prefill


categorize :: Lines -> CategorizedInput
categorize lines
  | isBlank lines                    = Done Skip
  | startsWithColon lines            = Done (toCommand lines)
  | startsWithKeyword "import" lines = attemptImport lines
  | otherwise                        = attemptDeclOrExpr lines


attemptImport :: Lines -> CategorizedInput
attemptImport lines =
  let
    src = linesToByteString lines
    parser = P.specialize (\_ _ _ -> ()) PM.chompImport
  in
  case P.fromByteString parser (\_ _ -> ()) src of
    Right (Src.Import (A.At _ name) _ _) ->
      Done (Import name src)

    Left () ->
      ifFail lines (Import "ERR" src)


ifFail :: Lines -> Input -> CategorizedInput
ifFail lines input =
  if endsWithBlankLine lines
  then Done input
  else Continue Indent


ifDone :: Lines -> Input -> CategorizedInput
ifDone lines input =
  if isSingleLine lines || endsWithBlankLine lines
  then Done input
  else Continue Indent


attemptDeclOrExpr :: Lines -> CategorizedInput
attemptDeclOrExpr lines =
  let
    src = linesToByteString lines
    exprParser = P.specialize (toExprPosition src) PE.expression
    declParser = P.specialize (toDeclPosition src) PD.declaration
  in
  case P.fromByteString declParser (,) src of
    Right (decl, _) ->
      case decl of
        PD.Value _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> ifDone lines (Decl name src)
        PD.Union _ (A.At _ (Src.Union (A.At _ name) _ _  )) -> ifDone lines (Type name src)
        PD.Alias _ (A.At _ (Src.Alias (A.At _ name) _ _  )) -> ifDone lines (Type name src)
        PD.Port  _ _                                        -> Done Port

    Left declPosition
      | startsWithKeyword "type" lines ->
          ifFail lines (Type "ERR" src)

      | startsWithKeyword "port" lines ->
          Done Port

      | otherwise ->
          case P.fromByteString exprParser (,) src of
            Right _ ->
              ifDone lines (Expr src)

            Left exprPosition ->
              if exprPosition >= declPosition then
                ifFail lines (Expr src)
              else
                case P.fromByteString annotation (\_ _ -> ()) src of
                  Right name -> Continue (DefStart name)
                  Left ()    -> ifFail lines (Decl "ERR" src)


startsWithColon :: Lines -> Bool
startsWithColon lines =
  case dropWhile (==' ') (getFirstLine lines) of
    [] -> False
    c:_ -> c == ':'


toCommand :: Lines -> Input
toCommand lines =
  case drop 1 $ dropWhile (==' ') (getFirstLine lines) of
    "reset" -> Reset
    "exit"  -> Exit
    "quit"  -> Exit
    "help"  -> Help Nothing
    rest    -> Help (Just (takeWhile (/=' ') rest))


startsWithKeyword :: [Char] -> Lines -> Bool
startsWithKeyword keyword lines =
  let
    line = getFirstLine lines
  in
  List.isPrefixOf keyword line &&
    case drop (length keyword) line of
      [] -> True
      c:_ -> not (Char.isAlphaNum c)


toExprPosition :: BS.ByteString -> ES.Expr -> Row -> Col -> (Row, Col)
toExprPosition src expr row col =
  let
    decl = ES.DeclDef N.replValueToPrint (ES.DeclDefBody expr row col) row col
  in
  toDeclPosition src decl row col


toDeclPosition :: BS.ByteString -> ES.Decl -> Row -> Col -> (Row, Col)
toDeclPosition src decl r c =
  let
    err = ES.ParseError (ES.Declarations decl r c)
    report = ES.toReport (Code.toSource src) err

    (Report.Report _ (A.Region (A.Position row col) _) _ _) = report
  in
  (row, col)


annotation :: P.Parser () N.Name
annotation =
  let
    err _ _ = ()
    err_ _ _ _ = ()
  in
  do  name <- PV.lower err
      PS.chompAndCheckIndent err_ err
      P.word1 0x3A {-:-} err
      PS.chompAndCheckIndent err_ err
      (_, _) <- P.specialize err_ PT.expression
      PS.checkFreshLine err
      return name



-- STATE


data State =
  State
    { _imports :: Map.Map N.Name B.Builder
    , _types :: Map.Map N.Name B.Builder
    , _decls :: Map.Map N.Name B.Builder
    }


initialState :: State
initialState =
  State Map.empty Map.empty Map.empty



-- EVAL


eval :: Env -> State -> Input -> IO Outcome
eval env state@(State imports types decls) input =
  Repl.handleInterrupt (putStrLn "" >> return (Loop state)) $
  case input of
    Skip ->
      return (Loop state)

    Exit ->
      return (End Exit.ExitSuccess)

    Reset ->
      do  putStrLn ""
          return (Loop initialState)

    Help maybeUnknownCommand ->
      do  putStrLn (toHelpMessage maybeUnknownCommand)
          return (Loop state)

    Import name src ->
      do  let newState = state { _imports = Map.insert name (B.byteString src) imports }
          Loop <$> attemptEval env state newState OutputNothing

    Type name src ->
      do  let newState = state { _types = Map.insert name (B.byteString src) types }
          Loop <$> attemptEval env state newState OutputNothing

    Port ->
      do  putStrLn "I cannot handle port declarations."
          return (Loop state)

    Decl name src ->
      do  let newState = state { _decls = Map.insert name (B.byteString src) decls }
          Loop <$> attemptEval env state newState (OutputDecl name)

    Expr src ->
      Loop <$> attemptEval env state state (OutputExpr src)



-- ATTEMPT EVAL


data Output
  = OutputNothing
  | OutputDecl N.Name
  | OutputExpr BS.ByteString


attemptEval :: Env -> State -> State -> Output -> IO State
attemptEval (Env root interpreter ansi) oldState newState output =
  do  result <-
        BW.withScope $ \scope ->
        Stuff.withRootLock root $ Task.run $
        do  details <-
              Task.eio Exit.ReplBadDetails $
                Details.load Reporting.silent scope root

            artifacts <-
              Task.eio id $
                Build.fromRepl root details (toByteString newState output)

            traverse (Task.mapError Exit.ReplBadGenerate . Generate.repl root details ansi artifacts) (toPrintName output)

      case result of
        Left exit ->
          do  Exit.toStderr (Exit.replToReport exit)
              return oldState

        Right Nothing ->
          return newState

        Right (Just javascript) ->
          do  exitCode <- interpret interpreter javascript
              case exitCode of
                Exit.ExitSuccess   -> return newState
                Exit.ExitFailure _ -> return oldState


interpret :: FilePath -> B.Builder -> IO Exit.ExitCode
interpret interpreter javascript =
  let
    createProcess = (Proc.proc interpreter []) { Proc.std_in = Proc.CreatePipe }
  in
  Proc.withCreateProcess createProcess $ \(Just stdin) _ _ handle ->
    do  B.hPutBuilder stdin javascript
        IO.hClose stdin
        Proc.waitForProcess handle



-- TO BYTESTRING


toByteString :: State -> Output -> BS.ByteString
toByteString (State imports types decls) output =
  LBS.toStrict $ B.toLazyByteString $
    mconcat
      [ "module ", N.toBuilder N.replModule, " exposing (..)\n"
      , Map.foldr mappend mempty imports
      , Map.foldr mappend mempty types
      , Map.foldr mappend mempty decls
      , outputToBuilder output
      ]


outputToBuilder :: Output -> B.Builder
outputToBuilder output =
  N.toBuilder N.replValueToPrint <> " =" <>
  case output of
    OutputNothing ->
      " ()\n"

    OutputDecl _ ->
      " ()\n"

    OutputExpr expr ->
      foldr (\line rest -> "\n  " <> B.byteString line <> rest) "\n" (BSC.lines expr)



-- TO PRINT NAME


toPrintName :: Output -> Maybe N.Name
toPrintName output =
  case output of
    OutputNothing   -> Nothing
    OutputDecl name -> Just name
    OutputExpr _    -> Just N.replValueToPrint



-- HELP MESSAGES


toHelpMessage :: Maybe String -> String
toHelpMessage maybeBadCommand =
  case maybeBadCommand of
    Nothing ->
      genericHelpMessage

    Just command ->
      "I do not recognize the :" ++ command ++ " command. " ++ genericHelpMessage


genericHelpMessage :: String
genericHelpMessage =
  "Valid commands include:\n\
  \\n\
  \  :exit    Exit the REPL\n\
  \  :help    Show this information\n\
  \  :reset   Clear all previous imports and definitions\n\
  \\n\
  \More info at " ++ D.makeLink "repl" ++ "\n"



-- GET ROOT


getRoot :: IO FilePath
getRoot =
  do  maybeRoot <- Stuff.findRoot
      case maybeRoot of
        Just root ->
          return root

        Nothing ->
          do  cache <- Stuff.getReplCache
              let root = cache  "tmp"
              Dir.createDirectoryIfMissing True (root  "src")
              Outline.write root $ Outline.Pkg $
                Outline.PkgOutline
                  Pkg.dummyName
                  Outline.defaultSummary
                  Licenses.bsd3
                  V.one
                  (Outline.ExposedList [])
                  defaultDeps
                  Map.empty
                  C.defaultElm

              return root


defaultDeps :: Map.Map Pkg.Name C.Constraint
defaultDeps =
  Map.fromList
    [ (Pkg.core, C.anything)
    , (Pkg.json, C.anything)
    , (Pkg.html, C.anything)
    ]



-- GET INTERPRETER


getInterpreter :: Maybe String -> IO FilePath
getInterpreter maybeName =
  case maybeName of
    Just name ->
      getInterpreterHelp name (Dir.findExecutable name)

    Nothing ->
      getInterpreterHelp "node` or `nodejs" $
        do  exe1 <- Dir.findExecutable "node"
            exe2 <- Dir.findExecutable "nodejs"
            return (exe1 <|> exe2)


getInterpreterHelp :: String -> IO (Maybe FilePath) -> IO FilePath
getInterpreterHelp name findExe =
  do  maybePath <- findExe
      case maybePath of
        Just path ->
          return path

        Nothing ->
          do  IO.hPutStrLn IO.stderr (exeNotFound name)
              Exit.exitFailure


exeNotFound :: String -> String
exeNotFound name =
  "The REPL relies on node.js to execute JavaScript code outside the browser.\n"
  ++ "I could not find executable `" ++ name ++ "` on your PATH though!\n\n"
  ++ "You can install node.js from . If it is already installed\n"
  ++ "but has a different name, use the --interpreter flag."



-- SETTINGS


initSettings :: IO (Repl.Settings M)
initSettings =
  do  cache <- Stuff.getReplCache
      return $
        Repl.Settings
          { Repl.historyFile = Just (cache  "history")
          , Repl.autoAddHistory = True
          , Repl.complete = Repl.completeWord Nothing " \n" lookupCompletions
          }


lookupCompletions :: String -> M [Repl.Completion]
lookupCompletions string =
  do  (State imports types decls) <- State.get
      return $
        addMatches string False decls $
        addMatches string False types $
        addMatches string True imports $
        addMatches string False commands []


commands :: Map.Map N.Name ()
commands =
  Map.fromList
    [ (":exit", ())
    , (":quit", ())
    , (":reset", ())
    , (":help", ())
    ]


addMatches :: String -> Bool -> Map.Map N.Name v -> [Repl.Completion] -> [Repl.Completion]
addMatches string isFinished dict completions =
  Map.foldrWithKey (addMatch string isFinished) completions dict


addMatch :: String -> Bool -> N.Name -> v -> [Repl.Completion] -> [Repl.Completion]
addMatch string isFinished name _ completions =
  let
    suggestion = N.toChars name
  in
  if List.isPrefixOf string suggestion then
    Repl.Completion suggestion suggestion isFinished : completions
  else
    completions


================================================
FILE: worker/elm.cabal
================================================

Name: elm
Version: 0.19.1

Synopsis:
    Perform tasks for various Elm websites

Description:
    Compile code for the online editor. Maybe do more someday!

Homepage: https://elm-lang.org

License: BSD3
License-file: ../LICENSE

Author:     Evan Czaplicki
Maintainer: info@elm-lang.org
Copyright:  Copyright (c) 2019-present, Evan Czaplicki

Category: Compiler, Language

Cabal-version: >=1.9
Build-type: Simple

source-repository head
    type:     git
    location: git://github.com/elm/compiler.git


Flag dev {
  Description: Turn off optimization and make warnings errors
  Default: False
}


Executable worker
    if flag(dev)
        ghc-options: -O0 -Wall -Werror
    else
        ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg"

    Hs-Source-Dirs:
        src
        ../compiler/src
        ../builder/src
        ../terminal/src

    Main-Is:
        Main.hs

    other-modules:
        Artifacts
        Cors
        Endpoint.Compile
        Endpoint.Quotes
        Endpoint.Repl
        Endpoint.Slack

        AST.Canonical
        AST.Optimized
        AST.Source
        AST.Utils.Binop
        AST.Utils.Shader
        AST.Utils.Type
        BackgroundWriter
        Build
        Canonicalize.Effects
        Canonicalize.Environment
        Canonicalize.Environment.Dups
        Canonicalize.Environment.Foreign
        Canonicalize.Environment.Local
        Canonicalize.Expression
        Canonicalize.Module
        Canonicalize.Pattern
        Canonicalize.Type
        Compile
        Data.Bag
        Data.Index
        Data.Map.Utils
        Data.Name
        Data.NonEmptyList
        Data.OneOrMore
        Data.Utf8
        Deps.Registry
        Deps.Solver
        Deps.Website
        Elm.Compiler.Imports
        Elm.Compiler.Type
        Elm.Compiler.Type.Extract
        Elm.Constraint
        Elm.Details
        Elm.Docs
        Elm.Float
        Elm.Interface
        Elm.Kernel
        Elm.Licenses
        Elm.Magnitude
        Elm.ModuleName
        Elm.Outline
        Elm.Package
        Elm.String
        Elm.Version
        File
        Generate
        Generate.Html
        Generate.JavaScript
        Generate.JavaScript.Builder
        Generate.JavaScript.Expression
        Generate.JavaScript.Functions
        Generate.JavaScript.Name
        Generate.Mode
        Http
        Json.Decode
        Json.Encode
        Json.String
        Nitpick.Debug
        Nitpick.PatternMatches
        Optimize.Case
        Optimize.DecisionTree
        Optimize.Expression
        Optimize.Module
        Optimize.Names
        Optimize.Port
        Parse.Declaration
        Parse.Expression
        Parse.Keyword
        Parse.Module
        Parse.Number
        Parse.Pattern
        Parse.Primitives
        Parse.Shader
        Parse.Space
        Parse.String
        Parse.Symbol
        Parse.Type
        Parse.Variable
        Paths_elm
        Repl
        Reporting
        Reporting.Annotation
        Reporting.Doc
        Reporting.Error
        Reporting.Error.Canonicalize
        Reporting.Error.Docs
        Reporting.Error.Import
        Reporting.Error.Json
        Reporting.Error.Main
        Reporting.Error.Pattern
        Reporting.Error.Syntax
        Reporting.Error.Type
        Reporting.Exit
        Reporting.Exit.Help
        Reporting.Render.Code
        Reporting.Render.Type
        Reporting.Render.Type.Localizer
        Reporting.Report
        Reporting.Result
        Reporting.Suggest
        Reporting.Task
        Reporting.Warning
        Stuff
        Type.Constrain.Expression
        Type.Constrain.Module
        Type.Constrain.Pattern
        Type.Error
        Type.Instantiate
        Type.Occurs
        Type.Solve
        Type.Type
        Type.Unify
        Type.UnionFind

    Build-depends:
        aeson,
        ansi-terminal >= 0.8,
        ansi-wl-pprint >= 0.6.8 && < 1,
        base >=4.11 && <5,
        base64-bytestring,
        binary >= 0.8,
        bytestring >= 0.9,
        containers >= 0.5.8.2,
        directory >= 1.2.3.0,
        edit-distance >= 0.2,
        filelock,
        filepath >= 1,
        ghc-prim >= 0.5.2,
        haskeline,
        HTTP >= 4000.2.5,
        http-client >= 0.6,
        http-client-tls >= 0.3,
        http-types >= 0.12,
        io-streams,
        language-glsl >= 0.3,
        mtl >= 2.2.1,
        network >= 2.4,
        network-uri,
        parsec,
        process,
        random,
        raw-strings-qq,
        scientific,
        SHA,
        snap-core,
        snap-server,
        template-haskell,
        text,
        time >= 1.9.1,
        unordered-containers,
        utf8-string,
        vector,
        zip-archive


================================================
FILE: worker/elm.json
================================================
{
    "type": "application",
    "source-directories": [
        "src"
    ],
    "elm-version": "0.19.1",
    "dependencies": {
        "direct": {
            "elm/browser": "1.0.1",
            "elm/core": "1.0.2",
            "elm/html": "1.0.0",
            "elm/json": "1.1.3",
            "elm/project-metadata-utils": "1.0.0"
        },
        "indirect": {
            "elm/parser": "1.1.0",
            "elm/time": "1.0.0",
            "elm/url": "1.0.0",
            "elm/virtual-dom": "1.0.2"
        }
    },
    "test-dependencies": {
        "direct": {},
        "indirect": {}
    }
}


================================================
FILE: worker/logrotate.conf
================================================
/usr/local/elm/nginx/logs/*.log {
        daily
        size 64M
        rotate 16
        missingok
        compress
        delaycompress
        notifempty
        sharedscripts
        postrotate
                if [ -f /usr/local/elm/nginx/logs/nginx.pid ]; then
                        kill -USR1 `cat /usr/local/elm/nginx/logs/nginx.pid`
                fi
        endscript
}


================================================
FILE: worker/nginx.conf
================================================
server {
    listen 80;
    server_name worker.elm-lang.org;

    location / {
        proxy_pass http://localhost:8000;
    }
}

server {
    listen 443 ssl;
    server_name worker.elm-lang.org;

    location / {
        proxy_pass http://localhost:8000;
    }

    ssl_certificate /etc/letsencrypt/live/worker.elm-lang.org/fullchain.pem; # managed by Certbot
    ssl_certificate_key /etc/letsencrypt/live/worker.elm-lang.org/privkey.pem; # managed by Certbot
    include /etc/letsencrypt/options-ssl-nginx.conf;
    ssl_dhparam /etc/letsencrypt/ssl-dhparams.pem;
}


================================================
FILE: worker/outlines/compile/elm.json
================================================
{
    "type": "application",
    "source-directories": [
        "../../src"
    ],
    "elm-version": "0.19.1",
    "dependencies": {
        "direct": {
            "elm/browser": "1.0.1",
            "elm/core": "1.0.2",
            "elm/file": "1.0.5",
            "elm/html": "1.0.0",
            "elm/http": "2.0.0",
            "elm/json": "1.1.3",
            "elm/random": "1.0.0",
            "elm/svg": "1.0.1",
            "elm/time": "1.0.0",
            "elm-explorations/linear-algebra": "1.0.3",
            "elm-explorations/webgl": "1.1.0",
            "evancz/elm-playground": "1.0.2"
        },
        "indirect": {
            "elm/bytes": "1.0.8",
            "elm/url": "1.0.0",
            "elm/virtual-dom": "1.0.2"
        }
    },
    "test-dependencies": {
        "direct": {},
        "indirect": {}
    }
}


================================================
FILE: worker/outlines/repl/elm.json
================================================
{
    "type": "application",
    "source-directories": [
        "../../src"
    ],
    "elm-version": "0.19.1",
    "dependencies": {
        "direct": {
            "elm/core": "1.0.2"
        },
        "indirect": {
            "elm/json": "1.1.3"
        }
    },
    "test-dependencies": {
        "direct": {},
        "indirect": {}
    }
}


================================================
FILE: worker/src/Artifacts.hs
================================================
module Artifacts
  ( Artifacts(..)
  , Root(..)
  , loadCompile
  , loadRepl
  , toDepsInfo
  )
  where


import Control.Concurrent (readMVar)
import Control.Monad (liftM2)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map
import qualified Data.Name as N
import qualified Data.OneOrMore as OneOrMore
import System.FilePath (())

import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified BackgroundWriter as BW
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 Json.Encode ((==>))
import qualified Json.Encode as E
import qualified Json.String as Json
import qualified Reporting



-- ARTIFACTS


data Artifacts =
  Artifacts
    { _ifaces :: Map.Map ModuleName.Raw I.Interface
    , _graph :: Opt.GlobalGraph
    }


data Root =
  Root FilePath


loadCompile :: Root -> IO Artifacts
loadCompile root =
  load root ("outlines"  "compile")


loadRepl :: Root -> IO Artifacts
loadRepl root =
  load root ("outlines"  "repl")



-- LOAD


load :: Root -> FilePath -> IO Artifacts
load (Root rootPath) dir =
  BW.withScope $ \scope ->
  do  putStrLn $ "Loading " ++ rootPath  dir  "elm.json"
      style <- Reporting.terminal
      let root = rootPath  dir
      result <- Details.load style scope root
      case result of
        Left _ ->
          error $ "Ran into some problem loading elm.json\nTry running `elm make` in: " ++ dir

        Right details ->
          do  omvar <- Details.loadObjects root details
              imvar <- Details.loadInterfaces root details
              mdeps <- readMVar imvar
              mobjs <- readMVar omvar
              case liftM2 (,) mdeps mobjs of
                Nothing ->
                  error $ "Ran into some weird problem loading elm.json\nTry running `elm make` in: " ++ dir

                Just (deps, objs) ->
                  return $ Artifacts (toInterfaces deps) objs


toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
toInterfaces deps =
  Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
    Map.elems (Map.mapMaybeWithKey getPublic deps)


getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
getPublic (ModuleName.Canonical _ name) dep =
  case dep of
    I.Public  iface -> Just (name, OneOrMore.one iface)
    I.Private _ _ _ -> Nothing


toUnique :: OneOrMore.OneOrMore a -> Maybe a
toUnique oneOrMore =
  case oneOrMore of
    OneOrMore.One value -> Just value
    OneOrMore.More _ _  -> Nothing



-- TO DEPS INFO


toDepsInfo :: Artifacts -> BS.ByteString
toDepsInfo (Artifacts ifaces _) =
  LBS.toStrict $ B.toLazyByteString $ E.encodeUgly $ encode ifaces



-- ENCODE


encode :: Map.Map ModuleName.Raw I.Interface -> E.Value
encode ifaces =
  E.dict Json.fromName encodeInterface ifaces


encodeInterface :: I.Interface -> E.Value
encodeInterface (I.Interface pkg values unions aliases binops) =
  E.object
    [ "pkg" ==> E.chars (Pkg.toChars pkg)
    , "ops" ==> E.list E.name (Map.keys binops)
    , "values" ==> E.list E.name (Map.keys values)
    , "aliases" ==> E.list E.name (Map.keys (Map.filter isPublicAlias aliases))
    , "types" ==> E.dict Json.fromName (E.list E.name) (Map.mapMaybe toPublicUnion unions)
    ]


isPublicAlias :: I.Alias -> Bool
isPublicAlias alias =
  case alias of
    I.PublicAlias  _ -> True
    I.PrivateAlias _ -> False


toPublicUnion :: I.Union -> Maybe [N.Name]
toPublicUnion union =
  case union of
    I.OpenUnion (Can.Union _ variants _ _) ->
      Just (map getVariantName variants)

    I.ClosedUnion _ ->
      Just []

    I.PrivateUnion _ ->
      Nothing


getVariantName :: Can.Ctor -> N.Name
getVariantName (Can.Ctor name _ _ _) =
  name


================================================
FILE: worker/src/Cors.hs
================================================
module Cors
  ( allow
  )
  where


import qualified Data.HashSet as HashSet
import Network.URI (parseURI)
import Snap.Core (Snap, Method, method)
import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet)



-- ALLOW


allow :: Method -> [String] -> Snap () -> Snap ()
allow method_ origins snap =
  applyCORS (toOptions method_ origins) $ method method_ $
    snap



-- TO OPTIONS


toOptions :: (Monad m) => Method -> [String] -> CORSOptions m
toOptions method_ origins =
  let
    allowedOrigins = toOriginList origins
    allowedMethods = HashSet.singleton (HashableMethod method_)
  in
  CORSOptions
    { corsAllowOrigin = return allowedOrigins
    , corsAllowCredentials = return True
    , corsExposeHeaders = return HashSet.empty
    , corsAllowedMethods = return allowedMethods
    , corsAllowedHeaders = return
    }


toOriginList :: [String] -> OriginList
toOriginList origins =
  Origins $ mkOriginSet $
    case traverse parseURI origins of
      Just uris -> uris
      Nothing -> error "invalid entry given to toOriginList list"


================================================
FILE: worker/src/Endpoint/Compile.hs
================================================
{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
module Endpoint.Compile
  ( endpoint_V1
  , endpoint_V2
  , loadErrorJS
  )
  where


import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map
import qualified Data.Map.Utils as Map
import qualified Data.Name as N
import qualified Data.NonEmptyList as NE
import Snap.Core
import Snap.Util.FileUploads
import System.FilePath (())
import qualified System.IO.Streams as Stream
import Text.RawString.QQ (r)

import qualified Artifacts as A
import qualified Cors

import qualified AST.Source as Src
import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified BackgroundWriter as BW
import qualified Build
import qualified Compile
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
import qualified Generate.Html as Html
import qualified Generate.JavaScript as JS
import qualified Generate.Mode as Mode
import qualified Json.Encode as Encode
import qualified Parse.Module as Parse
import qualified Reporting
import qualified Reporting.Annotation as A
import Reporting.Doc ((<>))
import qualified Reporting.Doc as D
import qualified Reporting.Error as Error
import qualified Reporting.Error.Import as Import
import qualified Reporting.Exit as Exit
import qualified Reporting.Exit.Help as Help
import qualified Reporting.Task as Task



-- ALLOWED ORIGINS


allowedOrigins :: [String]
allowedOrigins =
  [ "https://elm-lang.org"
  , "https://package.elm-lang.org"
  ]



-- ENDPOINT (V1)


endpoint_V1 :: A.Artifacts -> Snap ()
endpoint_V1 artifacts =
  endpoint artifacts $ \result ->
    case result of
      Ok name js -> writeBuilder $ Html.sandwich name js
      Err report -> writeBuilder $ renderProblem_V1 report



-- ENDPOINT (V2)


endpoint_V2 :: A.Artifacts -> Snap ()
endpoint_V2 artifacts =
  endpoint artifacts $ \result ->
    case result of
      Ok name js -> writeBuilder $ renderSuccess_V2 name js
      Err report -> writeBuilder $ renderProblem_V2 report



-- ENDPOINT


data Result
  = Ok N.Name B.Builder
  | Err Help.Report


endpoint :: A.Artifacts -> (Result -> Snap ()) -> Snap ()
endpoint artifacts callback =
  Cors.allow POST allowedOrigins $
  do  result <- foldMultipart defaultUploadPolicy ignoreFile 0
      case result of
        ([("code",source)], 0) ->
          do  modifyResponse $ setContentType "text/html; charset=utf-8"
              callback $
                case compile artifacts source of
                  Success name js   -> Ok name js
                  NoMain            -> Err noMain
                  BadInput name err -> Err $ Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) []

        _ ->
          do  modifyResponse $ setResponseStatus 400 "Bad Request"
              modifyResponse $ setContentType "text/html; charset=utf-8"
              writeBS
                "
Unexpected request format. This should not be possible!
\
                \
Please report this\
                \ here\
                \ along with the URL and your browser version.
"


ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int
ignoreFile _ _ count =
  return (count + 1)



-- COMPILE


data Outcome
  = Success N.Name B.Builder
  | NoMain
  | BadInput ModuleName.Raw Error.Error


compile :: A.Artifacts -> B.ByteString -> Outcome
compile (A.Artifacts interfaces objects) source =
  case Parse.fromByteString Parse.Application source of
    Left err ->
      BadInput N._Main (Error.BadSyntax err)

    Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
      case checkImports interfaces imports of
        Left err ->
          BadInput (Src.getName modul) (Error.BadImports err)

        Right ifaces ->
          case Compile.compile Pkg.dummyName ifaces modul of
            Left err ->
              BadInput (Src.getName modul) err

            Right (Compile.Artifacts canModule _ locals) ->
              case locals of
                Opt.LocalGraph Nothing _ _ ->
                  NoMain

                Opt.LocalGraph (Just main_) _ _ ->
                  let
                    mode  = Mode.Dev Nothing
                    home  = Can._name canModule
                    name  = ModuleName._module home
                    mains = Map.singleton home main_
                    graph = Opt.addLocalGraph locals objects
                  in
                  Success name $ JS.generate mode graph mains


checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
checkImports interfaces imports =
  let
    importDict = Map.fromValues Src.getImportName imports
    missing = Map.difference importDict interfaces
  in
  case Map.elems missing of
    [] ->
      Right (Map.intersection interfaces importDict)

    i:is ->
      let
        unimported =
          Map.keysSet (Map.difference interfaces importDict)

        toError (Src.Import (A.At region name) _ _) =
          Import.Error region name unimported Import.NotFound
      in
      Left (fmap toError (NE.List i is))



-- RENDER PROBLEM (V1)


renderProblem_V1 :: Help.Report -> B.Builder
renderProblem_V1 report =
  [r|


  
  
  


  

|]



-- RENDER SUCCESS (V2)


renderSuccess_V2 :: N.Name -> B.Builder -> B.Builder
renderSuccess_V2 moduleName javascript =
  let name = N.toBuilder moduleName in
  [r|


  
  |] <> name <> [r|
  










|]



-- RENDER PROBLEM (V2)


renderProblem_V2 :: Help.Report -> B.Builder
renderProblem_V2 report =
  [r|


  
  


  

|]



-- NO MAIN


noMain :: Help.Report
noMain =
  Help.report "NO MAIN" Nothing
    (
      "Without a `main` value, I do not know what to show on screen!"
    )
    [ D.reflow $
        "Adding a `main` value can be as brief as:"
    , D.vcat
        [ D.fillSep [D.cyan "import","Html"]
        , ""
        , D.fillSep [D.green "main","="]
        , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
        ]
    , D.reflow $
        "Try adding something like that!"
    , D.toSimpleNote $
        "I recommend looking through https://guide.elm-lang.org for more advice on\
        \ how to fill in `main` values."
    ]



-- LOAD ERROR JS


loadErrorJS :: A.Root -> IO B.ByteString
loadErrorJS (A.Root root) =
  let
    run work =
      do  result <- work
          case result of
            Right a -> return a
            Left _ -> error "problem building src/Errors.elm"
  in
  BW.withScope $ \scope ->
    do  details <- run $ Details.load Reporting.silent scope root
        artifacts <- run $ Build.fromPaths Reporting.silent root details (NE.List (root  "src"  "Errors.elm") [])
        javascript <- run $ Task.run $ Generate.prod root details artifacts
        return $ LBS.toStrict $ B.toLazyByteString javascript


================================================
FILE: worker/src/Endpoint/Quotes.hs
================================================
{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
module Endpoint.Quotes
  ( endpoint
  )
  where


import Control.Monad.IO.Class (liftIO)
import Data.Bits ((.&.), (.|.), shiftR)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import qualified Data.Char as Char
import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))
import GHC.IO (IO(IO), unsafePerformIO)
import GHC.Int (Int(I#))
import GHC.Prim
import GHC.ST (ST(ST), runST)
import GHC.Word (Word8(W8#))
import qualified System.Random as Random

import Snap.Core



-- ENDPOINT


endpoint :: Snap ()
endpoint =
  do  modifyResponse
        $ setContentType "application/json"
        . setHeader "Access-Control-Allow-Origin" "*"
      writeBS =<< liftIO getQuote


getQuote :: IO BS.ByteString
getQuote =
  let
    (Quotes sa) = quotes
  in
  do  (I# i) <- Random.randomRIO (0, I# (sizeofSmallArray# sa -# 1#))
      case indexSmallArray# sa i of
        (# json #) ->
          return json



-- QUOTES


data Quotes =
  Quotes (SmallArray# BS.ByteString)


{-# NOINLINE quotes #-}
quotes :: Quotes
quotes =
  let
    !(I# len) = length quoteList
  in
  runST $ ST $ \s ->
    case newSmallArray# len ""       s of { (# s, sma #) ->
    case quotesHelp# sma quoteList   s of {    s         ->
    case unsafeFreezeSmallArray# sma s of { (# s, sa  #) ->
      (# s, Quotes sa #)
    }}}


quotesHelp# :: SmallMutableArray# s a -> [a] -> State# s -> State# s
quotesHelp# sma =
    go 0#
  where
    go i list s =
      case list of
        [] ->
          s

        x:xs ->
          case writeSmallArray# sma i x s of
            s ->
              go (i +# 1#) xs s


quoteList :: [BS.ByteString]
quoteList =
  map toUtf8
    [ "{\"source\":\"Civilization and its Discontents\",\"author\":\"Sigmund Freud\",\"year\":1902,\"quote\":\"The enormous expansion of communications, due to the world-wide telegraph and telephone networks, has entirely transformed the conditions of trade and commerce. Everything is done in haste, at fever pitch. The night is used for travel, the day for business; even \\u201Choliday trips\\u201D put a strain on the nervous system. Great political, industrial and financial crises carry this excitement into far wider areas of the population than ever before. Interest in political life has become universal: tempers are inflamed by political, religious and social struggles, party politics, electioneering and the immense growth of trade-unionism; people are forced to engage in constant mental activity and robbed of the time the need for relaxation, sleep and rest.\"}"
    , "{\"source\":\"A Preface to Politics\",\"author\":\"Walter Lippmann\",\"year\":1913,\"quote\":\"The Economic Man\\u2014that lazy abstraction\\u2014is still paraded in the lecture room.\"}"
    , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"You ask me to say what you should consider it particularly important to avoid. My answer is this: a mass crowd. It is something to which you cannot entrust yourself yet without risk. I at any rate am ready to confess my own frailty in this respect. I never come back home with quite the same moral character as I went out with.\"}"
    , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"December used to be a month but it is now a year\"}"
    , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"But nothing is as ruinous to the character as sitting away one\\u2019s time at a show - for it is then, through the medium of entertainment, that vices creep into one with more than usual ease.\"}"
    , "{\"source\":\"Letters from a Stoic\",\"author\":\"Seneca\",\"year\":54,\"quote\":\"All this hurrying from place to place won\\u2019t bring you any relief, for you\\u2019re travelling in the company of your own emotions, followed by your troubles all the way. If only they were really following you! They\\u2019d be farther away from you: as it is they\\u2019re not at your back, but on it! That\\u2019s why they weigh you down with just the same uncomfortable chafing wherever you are. It\\u2019s medicine, not a particular part of the world, that a person needs if he\\u2019s ill. Suppose someone has broken his leg or dislocated a joint; he doesn\\u2019t get into a carriage or board a ship: he calls in a doctor to have the fracture set or the dislocation reduced. Well then, when a person\\u2019s spirit is wrenched or broken at so many points, do you imagine that it can be put right by a change of scenery, that that sort of trouble isn\\u2019t so serious that it can\\u2019t be cured by an outing?\"}"
    , "{\"source\":\"Progress and Poverty\",\"author\":\"Henry George\",\"year\":1879,\"quote\":\"The present century has been marked by a prodigious increase in wealth-producing power. The utilization of steam and electricity, the introduction of improved processes and laborsaving machinery, the greater subdivision and grander scale of production, the wonderful facilitation of exchanges, have multiplied enormously the effectiveness of labor. At the beginning of this marvelous era it was natural to expect, and it was expected, that laborsaving inventions would lighten the toil and improve the condition of the laborer; that the enormous increase in the power of producing wealth would make real poverty a thing of the past.\"}"
    , "{\"source\":\"Imperialism\",\"author\":\"John Hobson\",\"year\":1902,\"quote\":\"Although the new Imperialism has been bad business for the nation, it has been good business for certain classes and certain trades within the nation. The vast expenditure on armaments, the costly wars, the grave risks and embarrassments of foreign policy, the stoppage of political and social reforms within Great Britain, though fraught with great injury to the nation, have served well the present business interests of certain industries and professions.\"}"
    , "{\"source\":\"Neo-Colonialism\",\"author\":\"Kwame Nkrumah\",\"year\":1965,\"quote\":\"The essence of neo-colonialism is that the State which is subject to it is, in theory, independent and has all the outward trappings of international sovereignty. In reality its economic system and thus its political policy is directed from the outside. The methods and form of this direction can take various shapes. For example, in an extreme case the troops of the imperial power may garrison the territory of the neo-colonial State and control the government of it. More often, however, neo-colonialist control is exercised through economic or monetary means. The neo-colonial State may be obliged to take the manufactured products of the imperialist power to the exclusion of competing products from elsewhere. Control over government policy in the neo-colonial State may be secured by payments towards the cost of running the State, by the provision of civil servants in positions where they can dictate policy, and by monetary control over foreign exchange through the imposition of a banking system controlled by the imperial power.\"}"
    , "{\"source\":\"Neo-Colonialism\",\"author\":\"Kwame Nkrumah\",\"year\":1965,\"quote\":\"In the end the situation arises that the only type of aid which the neo-colonialist masters consider as safe is \\u2018military aid\\u2019. Once a neo-colonialist territory is brought to such a state of economic chaos and misery that revolt actually breaks out then, and only then, is there no limit to the generosity of the neo-colonial overlord, provided, of course, that the funds supplied are utilised exclusively for military purposes. Military aid in fact marks the last stage of neo-colonialism and its effect is self-destructive. Sooner or later the weapons supplied pass into the hands of the opponents of the neo-colonialist regime and the war itself increases the social misery which originally provoked it.\"}"
    , "{\"source\":\"Barnyard in your Backyard\",\"author\":\"Gail Damerow\",\"year\":2002,\"quote\":\"Wild jungle fowl, the ancestors of modern chickens, met their nutritional needs by consuming a variety of plants and insects. Given enough room to roam, some of today\\u2019s breeds remain active foragers.\"}"
    , "{\"source\":\"Barnyard in your Backyard\",\"author\":\"Gail Damerow\",\"year\":2002,\"quote\":\"Another way to reduce the cost of feed is to let your chickens roam on a lawn or in a pasture for part of the day. By eating plants, seeds, and insects, they will balance their diet and eat less of the expensive commercial stuff. Take care not to put your chickens on grass or around buildings that have been sprayed with toxins.\"}"
    , "{\"source\":\"Co-operation in Danish Agriculture\",\"author\":\"Harald Faber\",\"year\":1918,\"quote\":\"A plan for improving the butter made from the milk from peasant farms by collecting the milk to be worked at one place was submitted to the Royal Agricultural Society of Denmark as early as 1852, and it pointed out that this could be done on co-operative lines, the peasants being the owners of the factory and sharing the proceeds.\"}"
    , "{\"source\":\"Co-operation in Danish Agriculture\",\"author\":\"Harald Faber\",\"year\":1918,\"quote\":\"It was the Danish peasants themselves who found a practical way of developing the dairy industry, and they found this by applying the co-operative principles introduced by the Rochdale weavers. They received no support and only lukewarm sympathy from large farmers and estate owners, until later on when the co-operative dairies were doing so well that even owners of estates with two to three hundred cows found it to their advantage to close their private dairies and to join co-operative dairies.\"}"
    , "{\"source\":\"Beekeeping: A Practical Guide\",\"author\":\"Richard Bonney\",\"year\":1993,\"quote\":\"How many of you have been in a classroom or a training program where the instructor says at the outset, \\u201CLook at the person on your right; now look at the person on your left. One of you won\\u2019t be here next year.\\u201D Beekeeping is like that. Furthermore, not all beekeepers are truly beekeepers. Some are beehavers.\"}"
    , "{\"source\":\"The Rodale Book of Composting\",\"author\":\"Deborah Martin and Grace Gershuny\",\"year\":1992,\"quote\":\"Earthworms. If bacteria are the champion microscopic decomposers, then the heavyweight champion is doubtless the earthworm. Pages of praise have been written to the earthworm, ever since it became known that this creature spends most of its time tilling and enriching the soil.\"}"
    , "{\"source\":\"War is a Racket\",\"author\":\"General Smedley Butler\",\"year\":1935,\"quote\":\"There are 40,000,000 men under arms in the world today, and our statesmen and diplomats have the temerity to say that war is not in the making. Hell\\u2019s bells! Are these 40,000,000 men being trained to be dancers?\"}"
    , "{\"source\":\"Root Cellaring\",\"author\":\"Mike and Nancy Bubel\",\"year\":1991,\"quote\":\"What is not so widely acknowledged is that the soil in which your plants grow can influence the keeping quality of the vegetables you harvest. According to studies reported in E. P. Shirakov\\u2019s \\u201CPractical Course in Storage and Processing of Fruits and Vegetables\\u201D, abundant potash in the soil promotes long storage life of fruits and vegetables grown on that soil.\"}"
    , "{\"source\":\"Angora Goats the Northern Way\",\"author\":\"Susan Black Drummond\",\"year\":1985,\"quote\":\"Because of its long wearing qualities and resistance to soil, mohair was once a major upholstery fabric in this country, and was the seat cover material in many cars and in British Railroad seats. The synthetic fiber craze put an end to mohair use as upholstery fabric here.\"}"
    , "{\"source\":\"Making a Newspaper\",\"author\":\"John Given\",\"year\":1912,\"quote\":\"Yellow journalism originated through a desire to gain readers and advertisers, and it produced results. Its original disciples have readers by the hundred thousand and they have about all the advertising that they can well handle.\"}"
    , "{\"source\":\"Making a Newspaper\",\"author\":\"John Given\",\"year\":1912,\"quote\":\"With the adding of every new train and the improvement of every new time-table, the building of every new trolley road, and the establishment of every new mail route, the big city papers are enabled to reach out further, and, wherever they reach, the local papers suffer [...] There is not a paper published in any city between New York and Boston that has not in the last ten years been hurt by the papers of these two cities.\"}"
    , "{\"source\":\"Muscles: Testing and Function (4th Edition)\",\"author\":\"Florence Kendall, Elizabeth McCreary, Patricia Provance\",\"year\":1993,\"quote\":\"The mechanics of the low back is inseparable from that of the overall posture but especially that of the pelvis and the lower extremities. Pain manifested in the leg may be due to an underlying problem in the back. Conversely, the symptoms appearing in the low back may be due to underlying faulty mechanics of the feet, legs, or pelvis.\"}"
    , "{\"source\":\"Farmers of Forty Centuries\",\"author\":\"F. H. King\",\"year\":1911,\"quote\":\"The Sikiang is one of the great rivers of China and indeed of the world. Its width at Wuchow at low water was nearly a mile and our steamer anchored in twenty-four feet of water to a floating dock made fast by huge iron chains reaching three hundred feet up the slop to the city proper, thus providing for a rise of twenty-six feet in the river at its flood stage during the rainy season.\"}"
    , "{\"source\":\"How to Grow More Vegetables\",\"author\":\"John Jeavons\",\"year\":1974,\"quote\":\"If you are having trouble with birds eating the berries in your berry patch, you could erect a wren house in the middle of it. Wrens are insectivores, and they will not bother the berries. But they will attack any bird, however large, that comes near their nest.\"}"
    , "{\"source\":\"Confidence Men and Painted Women\",\"author\":\"Karen Halttunen\",\"year\":1982,\"quote\":\"Even one\\u2019s neighbor next door, as a visitor to Pittsburgh commented in 1818, might be a stranger: \\u201CA next door neighbor is, with them, frequently unknown, and months and years pass, without their exchanging with each other the ordinary compliments of friendship and goodwill.\\u201D\"}"
    , "{\"source\":\"Secondhand Time\",\"author\":\"Svetlana Alexievich\",\"year\":2016,\"quote\":\"I couldn\\u2019t understand what was going on. I remember seeing Gaidar on TV saying, \\u201Clearn how to sell... The market will save us...\\u201D You buy a bottle of mineral water on one corner and sell it on another\\u2014that\\u2019s business. The people listened, bewildered. I would come home, lock the door, and weep.\"}"
    , "{\"source\":\"Hiroshima\",\"author\":\"John Hersey\",\"year\":1985,\"quote\":\"At exactly fifteen minutes past eight in the morning, on August 6, 1945, Japanese time, at the moment when the atomic bomb flashed above Hiroshima, Miss Toshiko Sasaki, a clerk in the personnel department of the East Asia Tin Works, had just sat down at her place in the plant office and was turning her head to speak to the girl at the next desk.\"}"
    , "{\"source\":\"The Orphan\",\"author\":\"Maxim Gorky\",\"year\":1899,\"quote\":\"On a foggy and rainy day, by the cemetery gate, a small group of people standing in a muddy puddle were bargaining with the cabman. \\u201CFifteen kopeks!\\u201D The tall and heavy-set priest exclaimed in a deep bass, in response to the cabman\\u2019s shouts asking for twenty-five kopecks.\"}"
    , "{\"source\":\"Shah of Shahs\",\"author\":\"Ryszard Kapuściński\",\"year\":1982,\"quote\":\"This plane flies out of Teheran every day and lands at Munich at noon. Waiting limousines carry the passengers to elegant restaurants for lunch. After lunch they all fly back to Teheran in the same airplane and eat their suppers at home. Hardly an expensive entertainment, the jaunt costs only two thousand dollars a head. For people in the Shah\\u2019s favor, such a sum is nothing.\"}"
    , "{\"source\":\"Introduction to Fortran IV\",\"author\":\"Paul Chirlian\",\"year\":1973,\"quote\":\"There are many programming languages that can be used. We shall discuss a language that is almost universally used, and which is particularly applicable to mathematical and scientific computations. This language is FORTRAN IV.\"}"
    ]



-- TO UTF8 BYTESTRING


toUtf8 :: [Char] -> BS.ByteString
toUtf8 chars =
  unsafePerformIO $
    do  mba <- newByteArray (sum (map getWidth chars))
        writeChars mba 0 chars


writeChars :: MBA -> Int -> [Char] -> IO BS.ByteString
writeChars mba !offset chars =
  case chars of
    [] ->
      finalize mba

    char : chars
      | n < 0x80 ->
          do  writeWord8 mba (offset    ) (fromIntegral n)
              writeChars mba (offset + 1) chars

      | n < 0x800 ->
          do  writeWord8 mba (offset    ) (fromIntegral ((shiftR n 6         ) + 0xC0))
              writeWord8 mba (offset + 1) (fromIntegral ((       n   .&. 0x3F) + 0x80))
              writeChars mba (offset + 2) chars

      | n < 0x10000 ->
          do  writeWord8 mba (offset    ) (fromIntegral ((shiftR n 12         ) + 0xE0))
              writeWord8 mba (offset + 1) (fromIntegral ((shiftR n  6 .&. 0x3F) + 0x80))
              writeWord8 mba (offset + 2) (fromIntegral ((       n    .&. 0x3F) + 0x80))
              writeChars mba (offset + 3) chars

      | otherwise ->
          do  writeWord8 mba (offset    ) (fromIntegral ((shiftR n 18         ) + 0xF0))
              writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
              writeWord8 mba (offset + 2) (fromIntegral ((shiftR n  6 .&. 0x3F) + 0x80))
              writeWord8 mba (offset + 3) (fromIntegral ((       n    .&. 0x3F) + 0x80))
              writeChars mba (offset + 4) chars

      where
        n = Char.ord char


getWidth :: Char -> Int
getWidth char
  | code < 0x80    = 1
  | code < 0x800   = 2
  | code < 0x10000 = 3
  | otherwise      = 4
  where
    code = Char.ord char



-- MUTABLE BYTE ARRAYS


data MBA =
  MBA (MutableByteArray# RealWorld)


newByteArray :: Int -> IO MBA
newByteArray (I# len) =
  IO $ \s ->
    case newPinnedByteArray# len s of
      (# s, mba #) -> (# s, MBA mba #)


writeWord8 :: MBA -> Int -> Word8 -> IO ()
writeWord8 (MBA mba) (I# offset) (W8# w) =
  IO $ \s ->
    case writeWord8Array# mba offset w s of
      s -> (# s, () #)


finalize :: MBA -> IO BS.ByteString
finalize (MBA mba) =
  IO $ \s ->
    case getSizeofMutableByteArray# mba s of { (# s, len #) ->
    case mutableByteArrayContents# mba    of {       addr   ->
      (# s, BS.BS (ForeignPtr addr (PlainPtr mba)) (I# len) #)
    }}



================================================
FILE: worker/src/Endpoint/Repl.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Endpoint.Repl
  ( endpoint
  )
  where


import Data.Aeson ((.:))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as LBS
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Map.Utils as Map
import qualified Data.Name as N
import qualified Data.NonEmptyList as NE
import Snap.Core

import qualified Artifacts as A
import qualified Cors

import qualified AST.Source as Src
import qualified AST.Canonical as Can
import qualified AST.Optimized as Opt
import qualified Compile
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 Json.Encode as Encode
import qualified Parse.Module as Parse
import qualified Repl
import qualified Reporting.Annotation as A
import qualified Reporting.Error as Error
import qualified Reporting.Error.Import as Import
import qualified Reporting.Exit as Exit
import qualified Reporting.Exit.Help as Help
import qualified Reporting.Render.Type.Localizer as L



-- ALLOWED ORIGINS


allowedOrigins :: [String]
allowedOrigins =
  [ "https://guide.elm-lang.org"
  , "https://guide.elm-lang.jp"
  , "http://localhost:8007"
  ]



-- ENDPOINT


endpoint :: A.Artifacts -> Snap ()
endpoint artifacts =
  Cors.allow POST allowedOrigins $
  do  body <- readRequestBody (64 * 1024)
      case decodeBody body of
        Just (state, entry) ->
          serveOutcome (toOutcome artifacts state entry)

        Nothing ->
          do  modifyResponse $ setResponseStatus 400 "Bad Request"
              modifyResponse $ setContentType "text/html; charset=utf-8"
              writeBS "Received unexpected JSON body."



-- TO OUTCOME


data Outcome
  = NewImport N.Name
  | NewType N.Name
  | NewWork B.Builder
  --
  | Skip
  | Indent
  | DefStart N.Name
  --
  | NoPorts
  | InvalidCommand
  | Failure BS.ByteString Error.Error


toOutcome :: A.Artifacts -> Repl.State -> String -> Outcome
toOutcome artifacts state entry =
  case reverse (lines entry) of
    [] ->
      Skip

    prev : rev ->
      case Repl.categorize (Repl.Lines prev rev) of
        Repl.Done input ->
          case input of
            Repl.Import name src -> compile artifacts state (ImportEntry name src)
            Repl.Type name src   -> compile artifacts state (TypeEntry name src)
            Repl.Decl name src   -> compile artifacts state (DeclEntry name src)
            Repl.Expr src        -> compile artifacts state (ExprEntry src)
            Repl.Port            -> NoPorts
            Repl.Skip            -> Skip
            Repl.Reset           -> InvalidCommand
            Repl.Exit            -> InvalidCommand
            Repl.Help _          -> InvalidCommand

        Repl.Continue prefill ->
          case prefill of
            Repl.Indent        -> Indent
            Repl.DefStart name -> DefStart name



-- SERVE OUTCOME


serveOutcome :: Outcome -> Snap ()
serveOutcome outcome =
  let
    serveString = serveBuilder "text/plain"
  in
  case outcome of
    NewImport name -> serveString $ "add-import:" <> N.toBuilder name
    NewType name   -> serveString $ "add-type:" <> N.toBuilder name
    NewWork js     -> serveBuilder "application/javascript" js
    Skip           -> serveString $ "skip"
    Indent         -> serveString $ "indent"
    DefStart name  -> serveString $ "def-start:" <> N.toBuilder name
    NoPorts        -> serveString $ "no-ports"
    InvalidCommand -> serveString $ "invalid-command"
    Failure source err ->
      serveBuilder "application/json" $ Encode.encodeUgly $ Exit.toJson $
        Help.compilerReport "/" (Error.Module N.replModule "/repl" File.zeroTime source err) []


serveBuilder :: BS.ByteString -> B.Builder -> Snap ()
serveBuilder mime builder =
  do  modifyResponse (setContentType mime)
      writeBuilder builder



-- COMPILE


data EntryType
  = ImportEntry N.Name BS.ByteString
  | TypeEntry N.Name BS.ByteString
  | DeclEntry N.Name BS.ByteString
  | ExprEntry BS.ByteString


compile :: A.Artifacts -> Repl.State -> EntryType -> Outcome
compile (A.Artifacts interfaces objects) state@(Repl.State imports types decls) entryType =
  let
    source =
      case entryType of
        ImportEntry name src -> Repl.toByteString (state { Repl._imports = Map.insert name (B.byteString src) imports }) Repl.OutputNothing
        TypeEntry   name src -> Repl.toByteString (state { Repl._types = Map.insert name (B.byteString src) types }) Repl.OutputNothing
        DeclEntry   name src -> Repl.toByteString (state { Repl._decls = Map.insert name (B.byteString src) decls }) (Repl.OutputDecl name)
        ExprEntry        src -> Repl.toByteString state (Repl.OutputExpr src)
  in
  case
    do  modul <- mapLeft Error.BadSyntax $ Parse.fromByteString Parse.Application source
        ifaces <- mapLeft Error.BadImports $ checkImports interfaces (Src._imports modul)
        artifacts <- Compile.compile Pkg.dummyName ifaces modul
        return ( modul, artifacts, objects )
  of
    Left err ->
      Failure source err

    Right info ->
      case entryType of
        ImportEntry name _ -> NewImport name
        TypeEntry name _   -> NewType name
        DeclEntry name _   -> NewWork (toJavaScript info (Just name))
        ExprEntry _        -> NewWork (toJavaScript info Nothing)


toJavaScript :: (Src.Module, Compile.Artifacts, Opt.GlobalGraph) -> Maybe N.Name -> B.Builder
toJavaScript (modul, Compile.Artifacts canModule types locals, objects) maybeName =
  let
    localizer = L.fromModule modul
    graph = Opt.addLocalGraph locals objects
    home = Can._name canModule
    tipe = types ! maybe N.replValueToPrint id maybeName
  in
  JS.generateForReplEndpoint localizer graph home maybeName tipe


mapLeft :: (x -> y) -> Either x a -> Either y a
mapLeft func result =
  either (Left . func) Right result


checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
checkImports interfaces imports =
  let
    importDict = Map.fromValues Src.getImportName imports
    missing = Map.difference importDict interfaces
  in
  case Map.elems missing of
    [] ->
      Right (Map.intersection interfaces importDict)

    i:is ->
      let
        unimported =
          Map.keysSet (Map.difference interfaces importDict)

        toError (Src.Import (A.At region name) _ _) =
          Import.Error region name unimported Import.NotFound
      in
      Left (fmap toError (NE.List i is))



-- DECODE BODY


decodeBody :: LBS.ByteString -> Maybe ( Repl.State, String )
decodeBody body =
  Aeson.parseMaybe decodeBodyHelp =<< Aeson.decode' body


decodeBodyHelp :: Aeson.Object -> Aeson.Parser ( Repl.State, String )
decodeBodyHelp obj =
  let
    get key =
      do  dict <- obj .: key
          let f (k,v) = (N.fromChars k, B.stringUtf8 v)
          return $ Map.fromList $ map f $ Map.toList dict
  in
  do  imports <- get "imports"
      types   <- get "types"
      decls   <- get "decls"
      entry   <- obj .: "entry"
      return ( Repl.State imports types decls, entry )


================================================
FILE: worker/src/Endpoint/Slack.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Endpoint.Slack
  ( endpoint
  )
  where


import Control.Monad.IO.Class (liftIO)
import Network.HTTP.Client
import Snap.Core

import qualified Cors

import qualified Data.ByteString.Char8 as BSC
import qualified Data.Map as Map



-- Send invitations to the Elm Slack to whoever asks.
--
-- NOTE: The API to invite users is not officially documented, but the people
-- here looked in the Network tab of Developer Tools to figure it out:
--
--   https://levels.io/slack-typeform-auto-invite-sign-ups/
--   https://github.com/outsideris/slack-invite-automation
--



-- ALLOWED ORIGINS


allowedOrigins :: [String]
allowedOrigins =
  [ "https://elm-lang.org"
  ]



-- ENDPOINT


endpoint :: String -> Manager -> Snap ()
endpoint token manager =
  Cors.allow POST allowedOrigins $
    do  req <- getRequest
        case Map.findWithDefault [] "email" (rqQueryParams req) of
          [email] ->
            do  response <- liftIO $ httpLbs (request email) manager
                modifyResponse $ setContentType "application/json"
                writeLBS (responseBody response)

          _ ->
            do  modifyResponse $ setResponseStatus 400 "Bad Request"
                modifyResponse $ setContentType "text/html; charset=utf-8"
                writeBS "expecting query parameter like ?email=you@example.com"
  where
    slack_token =
      BSC.pack token

    request email =
      urlEncodedBody
        [ ("email", email)
        , ("token", slack_token)
        , ("set_active","true")
        ]
        (parseRequest_ "https://elmlang.slack.com/api/users.admin.invite")


================================================
FILE: worker/src/Errors.elm
================================================
port module Errors exposing (main)


import Browser
import Char
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (onClick)
import String
import Json.Decode as D
import Elm.Error as Error



-- PORTS


port jumpTo : Error.Region -> Cmd msg



-- MAIN


main =
  Browser.document
    { init = \flags -> (D.decodeValue Error.decoder flags, Cmd.none)
    , update = \region result -> (result, jumpTo region)
    , view = view
    , subscriptions = \_ -> Sub.none
    }


type alias Msg = Error.Region



-- VIEW


view : Result D.Error Error.Error -> Browser.Document Msg
view result =
  { title = "Problem!"
  , body =
      case result of
        Err err ->
          [ text (D.errorToString err) ]

        Ok error ->
          [ viewError error ]
  }


viewError : Error.Error -> Html Msg
viewError error =
  div
    [ style "width" "calc(100% - 4em)"
    , style "min-height" "calc(100% - 4em)"
    , style "font-family" "monospace"
    , style "white-space" "pre-wrap"
    , style "background-color" "black"
    , style "color" "rgb(233,235,235)"
    , style "padding" "2em"
    ]
    (viewErrorHelp error)


viewErrorHelp : Error.Error -> List (Html Msg)
viewErrorHelp error =
  case error of
    Error.GeneralProblem { title, message } ->
      viewHeader title Nothing :: viewMessage message

    Error.ModuleProblems badModules ->
      viewBadModules badModules



-- VIEW HEADER


viewHeader : String -> Maybe Error.Region -> Html Msg
viewHeader title maybeRegion =
  case maybeRegion of
    Nothing ->
      span [ style "color" "rgb(51,187,200)" ]
        [ text <| "-- " ++ title ++ " "
        , text <| String.repeat (76 - String.length title) "-"
        , text <| "\n\n"
        ]

    Just region ->
      span [ style "color" "rgb(51,187,200)" ]
        [ text <| "-- " ++ title ++ " "
        , text <| String.repeat (60 - String.length title) "-"
        , text " "
        , span
            [ style "cursor" "pointer"
            , style "text-decoration" "underline"
            , onClick region
            ]
            [ text "Jump To Problem"
            ]
        , text <| "\n\n"
        ]



-- VIEW BAD MODULES


viewBadModules : List Error.BadModule -> List (Html Msg)
viewBadModules badModules =
  case badModules of
    [] ->
      []

    [badModule] ->
      [viewBadModule badModule]

    a :: b :: cs ->
      viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs)


viewBadModule : Error.BadModule -> Html Msg
viewBadModule { problems } =
  span [] (List.map viewProblem problems)


viewProblem : Error.Problem -> Html Msg
viewProblem problem =
  span [] (viewHeader problem.title (Just problem.region) :: viewMessage problem.message)


viewSeparator : String -> String -> Html msg
viewSeparator before after =
  span [ style "color" "rgb(211,56,211)" ]
    [ text <|
        String.padLeft 80 ' ' (before ++ "  ↑    ") ++ "\n" ++
        "====o======================================================================o====\n" ++
        "    ↓  " ++ after ++ "\n\n\n"
    ]



-- VIEW MESSAGE


viewMessage : List Error.Chunk -> List (Html msg)
viewMessage chunks =
  case chunks of
    [] ->
      [ text "\n\n\n" ]

    chunk :: others ->
      let
        htmlChunk =
          case chunk of
            Error.Unstyled string ->
              text string

            Error.Styled style string ->
              span (styleToAttrs style) [ text string ]
      in
      htmlChunk :: viewMessage others


styleToAttrs : Error.Style -> List (Attribute msg)
styleToAttrs { bold, underline, color } =
  addBold bold <| addUnderline underline <| addColor color []


addBold : Bool -> List (Attribute msg) -> List (Attribute msg)
addBold bool attrs =
  if bool then
    style "font-weight" "bold" :: attrs
  else
    attrs


addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg)
addUnderline bool attrs =
  if bool then
    style "text-decoration" "underline" :: attrs
  else
    attrs


addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg)
addColor maybeColor attrs =
  case maybeColor of
    Nothing ->
      attrs

    Just color ->
      style "color" (colorToCss color) :: attrs


colorToCss : Error.Color -> String
colorToCss color =
  case color of
    Error.Red -> "rgb(194,54,33)"
    Error.RED -> "rgb(252,57,31)"
    Error.Magenta -> "rgb(211,56,211)"
    Error.MAGENTA -> "rgb(249,53,248)"
    Error.Yellow -> "rgb(173,173,39)"
    Error.YELLOW -> "rgb(234,236,35)"
    Error.Green -> "rgb(37,188,36)"
    Error.GREEN -> "rgb(49,231,34)"
    Error.Cyan -> "rgb(51,187,200)"
    Error.CYAN -> "rgb(20,240,240)"
    Error.Blue -> "rgb(73,46,225)"
    Error.BLUE -> "rgb(88,51,255)"
    Error.White -> "rgb(203,204,205)"
    Error.WHITE -> "rgb(233,235,235)"
    Error.Black -> "rgb(0,0,0)"
    Error.BLACK -> "rgb(129,131,131)"


================================================
FILE: worker/src/Main.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Main
  ( main
  )
  where


import Control.Monad (msum)
import qualified Data.ByteString as BS
import Network.HTTP.Client.TLS (newTlsManager)
import Snap.Core
import Snap.Http.Server
import qualified System.Environment as Env

import qualified Artifacts
import qualified Cors
import qualified Endpoint.Compile as Compile
import qualified Endpoint.Quotes as Quotes
import qualified Endpoint.Repl as Repl
import qualified Endpoint.Slack as Slack



-- RUN THE DEV SERVER


main :: IO ()
main =
  withArgs $ \root ->
  do  manager    <- newTlsManager
      slackToken <- Env.getEnv "SLACK_TOKEN"
      rArtifacts <- Artifacts.loadRepl root
      cArtifacts <- Artifacts.loadCompile root
      errorJS    <- Compile.loadErrorJS root
      let depsInfo = Artifacts.toDepsInfo cArtifacts

      httpServe config $ msum $
        [ ifTop $ status
        , path "repl" $ Repl.endpoint rArtifacts
        , path "compile" $ Compile.endpoint_V1 cArtifacts
        , path "compile/v2" $ Compile.endpoint_V2 cArtifacts
        , path "compile/errors.js" $ serveJavaScript errorJS
        , path "compile/deps-info.json" $ serveDepsInfo depsInfo
        , path "quotes" $ Quotes.endpoint
        , path "slack-invite" $ Slack.endpoint slackToken manager
        , notFound
        ]


config :: Config Snap a
config =
  setPort 8000 $
  setAccessLog ConfigNoLog $
  setErrorLog ConfigNoLog $
    defaultConfig


withArgs :: (Artifacts.Root -> IO r) -> IO r
withArgs cont =
  do  args <- Env.getArgs
      case args of
        [rootPath] -> cont (Artifacts.Root rootPath)
        _          -> error "expecting one argument, the path to the artifacts directory"


status :: Snap ()
status =
  do  modifyResponse $ setContentType "text/plain"
      writeBuilder "Status: OK"


notFound :: Snap ()
notFound =
  do  modifyResponse $ setResponseStatus 404 "Not Found"
      modifyResponse $ setContentType "text/html; charset=utf-8"
      writeBuilder "Not Found"


serveJavaScript :: BS.ByteString -> Snap ()
serveJavaScript javascript =
  do  modifyResponse $ setContentType "application/javascript"
      writeBS javascript


serveDepsInfo :: BS.ByteString -> Snap ()
serveDepsInfo json =
  Cors.allow GET ["https://elm-lang.org"] $
    do  modifyResponse $ setContentType "application/json"
        writeBS json