├── .github ├── CONTRIBUTING.md └── ISSUE_TEMPLATE.md ├── .gitignore ├── ContributorAgreement.pdf ├── LICENSE ├── README.md ├── builder └── src │ ├── Deps │ ├── Cache.hs │ ├── Diff.hs │ ├── Explorer.hs │ ├── Plan.hs │ ├── Solver.hs │ ├── Verify.hs │ └── Website.hs │ ├── Elm │ ├── Bump.hs │ ├── Diff.hs │ ├── Install.hs │ ├── PerUserCache.hs │ ├── Project.hs │ ├── Project │ │ ├── Constraint.hs │ │ ├── Json.hs │ │ ├── Licenses.hs │ │ ├── Root.hs │ │ └── Summary.hs │ └── Publish.hs │ ├── File │ ├── Args.hs │ ├── Artifacts.hs │ ├── Compile.hs │ ├── Crawl.hs │ ├── Find.hs │ ├── Hash.hs │ ├── Header.hs │ ├── IO.hs │ ├── Plan.hs │ └── Watcher.hs │ ├── Generate │ ├── Functions.hs │ ├── Html.hs │ ├── Nitpick.hs │ └── Output.hs │ ├── Reporting │ ├── Exit.hs │ ├── Exit │ │ ├── Assets.hs │ │ ├── Bump.hs │ │ ├── Compile.hs │ │ ├── Crawl.hs │ │ ├── Deps.hs │ │ ├── Diff.hs │ │ ├── Help.hs │ │ ├── Http.hs │ │ ├── Init.hs │ │ ├── Install.hs │ │ ├── Make.hs │ │ └── Publish.hs │ ├── Progress.hs │ ├── Progress │ │ ├── Bar.hs │ │ ├── Json.hs │ │ ├── Repl.hs │ │ └── Terminal.hs │ ├── Task.hs │ └── Task │ │ └── Http.hs │ └── Stuff │ ├── Paths.hs │ └── Verify.hs ├── compiler └── src │ ├── AST │ ├── Canonical.hs │ ├── Module │ │ └── Name.hs │ ├── Optimized.hs │ ├── Source.hs │ ├── Utils │ │ ├── Binop.hs │ │ ├── Shader.hs │ │ └── Type.hs │ └── Valid.hs │ ├── Canonicalize │ ├── Effects.hs │ ├── Environment.hs │ ├── Environment │ │ ├── Dups.hs │ │ ├── Foreign.hs │ │ └── Local.hs │ ├── Expression.hs │ ├── Module.hs │ ├── Pattern.hs │ └── Type.hs │ ├── Compile.hs │ ├── Data │ ├── Bag.hs │ ├── Index.hs │ └── OneOrMore.hs │ ├── Elm │ ├── Compiler.hs │ ├── Compiler │ │ ├── Imports.hs │ │ ├── Module.hs │ │ ├── Objects.hs │ │ ├── Type.hs │ │ ├── Type │ │ │ └── Extract.hs │ │ └── Version.hs │ ├── Docs.hs │ ├── Header.hs │ ├── Interface.hs │ ├── Kernel.hs │ ├── Name.hs │ └── Package.hs │ ├── Generate │ ├── JavaScript.hs │ └── JavaScript │ │ ├── Builder.hs │ │ ├── Expression.hs │ │ ├── Mode.hs │ │ └── Name.hs │ ├── Json │ ├── Decode.hs │ ├── Decode │ │ ├── Error.hs │ │ └── Internals.hs │ └── Encode.hs │ ├── Nitpick │ └── PatternMatches.hs │ ├── Optimize │ ├── Case.hs │ ├── DecisionTree.hs │ ├── Expression.hs │ ├── Module.hs │ ├── Names.hs │ └── Port.hs │ ├── Parse │ ├── Declaration.hs │ ├── Expression.hs │ ├── Module.hs │ ├── Parse.hs │ ├── Pattern.hs │ ├── Primitives.hs │ ├── Primitives │ │ ├── Internals.hs │ │ ├── Kernel.hs │ │ ├── Keyword.hs │ │ ├── Number.hs │ │ ├── Shader.hs │ │ ├── Symbol.hs │ │ ├── Utf8.hs │ │ ├── Variable.hs │ │ └── Whitespace.hs │ ├── Repl.hs │ ├── Shader.hs │ └── Type.hs │ ├── Reporting │ ├── Annotation.hs │ ├── Doc.hs │ ├── Error.hs │ ├── Error │ │ ├── Canonicalize.hs │ │ ├── Docs.hs │ │ ├── Main.hs │ │ ├── Pattern.hs │ │ ├── Syntax.hs │ │ └── Type.hs │ ├── Region.hs │ ├── Render │ │ ├── Code.hs │ │ ├── Type.hs │ │ └── Type │ │ │ └── Localizer.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 │ └── Validate.hs ├── docs └── elm.json │ ├── application.md │ └── package.md ├── elm.cabal ├── installers ├── mac │ ├── Distribution.xml │ ├── Resources │ │ └── en.lproj │ │ │ ├── background.png │ │ │ ├── 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 │ ├── index.js │ └── package.json └── win │ ├── CreateInternetShortcut.nsh │ ├── Nsisfile.nsi │ ├── README.md │ ├── file.ico │ ├── inst.dat │ ├── logo.ico │ ├── make_installer.cmd │ ├── removefrompath.vbs │ ├── uninst.dat │ ├── updatepath.vbs │ └── welcome.bmp ├── reactor ├── assets │ ├── favicon.ico │ ├── source-code-pro.ttf │ ├── source-sans-pro.ttf │ ├── styles.css │ └── waiting.gif ├── check.py ├── elm.json └── src │ ├── Errors.elm │ ├── Index.elm │ ├── Index │ ├── Icon.elm │ ├── Navigator.elm │ └── Skeleton.elm │ └── NotFound.elm ├── terminal └── src │ ├── Bump.hs │ ├── Develop.hs │ ├── Develop │ ├── Generate │ │ ├── Help.hs │ │ └── Index.hs │ ├── Socket.hs │ ├── StaticFiles.hs │ └── StaticFiles │ │ └── Build.hs │ ├── Diff.hs │ ├── Init.hs │ ├── Install.hs │ ├── Main.hs │ ├── Make.hs │ ├── Publish.hs │ ├── Repl.hs │ └── Terminal │ ├── Args.hs │ └── Args │ ├── Chomp.hs │ ├── Error.hs │ ├── Helpers.hs │ └── Internal.hs └── upgrade-docs ├── 0.16.md ├── 0.17.md ├── 0.18.md ├── 0.19.md └── earlier.md /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Elm 2 | 3 | Thanks helping with the development of Elm! This document describes the basic 4 | standards for opening pull requests and making the review process as smooth as 5 | possible. 6 | 7 | ## Licensing 8 | 9 | You need to sign the [contributor agreement](ContributorAgreement.pdf) 10 | and send it to before opening your pull request. 11 | 12 | ## Style Guide 13 | 14 | * Haskell — conform to [these guidelines][haskell] 15 | * JavaScript — use [Google's JS style guide][js] 16 | 17 | [haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be 18 | [js]: https://google.github.io/styleguide/javascriptguide.xml 19 | 20 | ## Branches 21 | 22 | * [The master branch][master] is the home of the next release of the compiler 23 | so new features and improvements get merged there. Most pull requests 24 | should target this branch! 25 | 26 | * [The stable branch][stable] is for tagging releases and critical bug fixes. 27 | This branch is handy for folks who want to build the most recent public 28 | release from source. 29 | 30 | [master]: http://github.com/elm-lang/elm/tree/master 31 | [stable]: http://github.com/elm-lang/elm/tree/stable 32 | 33 | If you are working on a fairly large feature, we will probably want to merge it 34 | in as its own branch and do some testing before bringing it into the master 35 | branch. This way we can keep releases of the master branch independent of new 36 | features. 37 | 38 | Note that the master branch of the compiler should always be in sync with the 39 | master branch of the [website][], and the stable branch of the compiler should 40 | always be in sync with the stable branch of the [website][]. Make sure that 41 | your changes maintain this compatibility. 42 | 43 | [website]: https://github.com/elm-lang/elm-lang.org 44 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | BEFORE DELETING THIS: 2 | 3 | - Runtime error? https://github.com/elm-lang/elm-compiler/issues/1591 4 | - Type annotations? https://github.com/elm-lang/elm-compiler/issues/1214 5 | - Core libraries? https://github.com/elm-lang/core/issues 6 | - Bad error message? https://github.com/elm-lang/error-message-catalog/issues 7 | - Compiler hangs? https://github.com/elm-lang/elm-compiler/issues/1240 8 | - Parser / code gen problem? https://github.com/elm-lang/elm-compiler/labels/meta 9 | 10 | 11 | If none of that applies, write up a report that satisfies this checklist: 12 | 13 | https://github.com/process-bot/contribution-checklist/blob/master/issues.md 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | elm-stuff 2 | dist 3 | cabal-dev 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | .DS_Store 7 | *~ 8 | -------------------------------------------------------------------------------- /ContributorAgreement.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/ContributorAgreement.pdf -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-present, Evan Czaplicki 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Czaplicki nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The Elm Compiler 2 | 3 | Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/). 4 | 5 | This is a fork of the Elm Compiler maintained by CurrySoftware GmbH. 6 | We merged a few bug fixes by the community and also expanded the reactor. 7 | 8 | ## Build 9 | 10 | With Stack: 11 | 12 | 1. Install Stack (https://www.haskellstack.org) 13 | 2. Clone the repo 14 | 3. `cd compiler` 15 | 4. `stack init` 16 | 5. `stack build` 17 | 18 | 19 | ## Install 20 | 21 | 22 | The built Elm executable will reside inside `.stack-work/dist///build/elm/elm`. 23 | To install it link or copy it to the `/usr/bin/` folder. 24 | 25 | For example: 26 | 27 | `copy .stack-work/dist/x86_64-linux-tinfo6/Cabal-2.0.1.0/build/elm/elm /usr/bin/elm-dev` 28 | 29 | or 30 | `ln -s .stack-work/dist/x86_64-linux-tinfo6/Cabal-2.0.1.0/build/elm/elm /usr/bin/elm-dev` 31 | 32 | 33 | ## Using the new Features in Elm Reactor 34 | 35 | This Elm-fork contains two new features in the Elm reactor: 36 | 37 | 1. The reactor can now emit compiled JavaScript instead of Html with the `output=js` parameter: 38 | 39 | ```html 40 | 41 | ``` 42 | 43 | 2. The reactor can now emit code compiled in debug mode with the `debug=true` parameter: 44 | 45 | `http://localhost:8000/src/Main.elm?debug=true` 46 | 47 | or in combination with JavaScript output: 48 | ```html 49 | 50 | ``` 51 | 52 | 53 | For a working example check out [elm-reactor-example](https://github.com/CurrySoftware/elm-reactor-example). 54 | 55 | 56 | ## Future 57 | 58 | We are currently exploring the idea of building a private Elm package repository to facilitate usage of Elm in corporate environments. 59 | 60 | Currently, it is not possible to use either local packages or another package repository than `package.elm-lang.org`. 61 | 62 | We want to change that! 63 | 64 | If you are a corporate Elm-user and want to support us or if you are interested in a closed beta please contact us through [elm@curry-software.com](mailto:elm@curry-software.com). 65 | 66 | ## Support 67 | 68 | Please contact [elm@curry-software.com](mailto:elm@curry-software.com) for support. 69 | 70 | We also offer [Elm Consulting Services](https://www.curry-software.com/en/elm-services/) for general help with Elm. 71 | -------------------------------------------------------------------------------- /builder/src/Deps/Explorer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Deps.Explorer 3 | ( Explorer 4 | , Metadata 5 | , Info(..) 6 | , run 7 | , exists 8 | , getVersions 9 | , getConstraints 10 | ) 11 | where 12 | 13 | {-| It is expensive to load ALL package metadata. You would need to: 14 | 15 | 1. Know all the packages and all their versions. 16 | 2. Download or read the elm.json file for each version. 17 | 18 | The goal of this module is to only pay for (1) and pay for (2) as needed. 19 | -} 20 | 21 | 22 | import Control.Monad.Except (liftIO, lift, throwError) 23 | import Control.Monad.State (StateT, evalStateT, gets, modify) 24 | import Data.Map (Map) 25 | import qualified Data.Map as Map 26 | 27 | import Elm.Package (Name, Version) 28 | 29 | import qualified Deps.Cache as Cache 30 | import qualified Elm.PerUserCache as PerUserCache 31 | import qualified Elm.Project.Json as Project 32 | import Elm.Project.Constraint (Constraint) 33 | import qualified Reporting.Exit as Exit 34 | import qualified Reporting.Exit.Deps as E 35 | import qualified Reporting.Task as Task 36 | 37 | 38 | 39 | -- EXPLORER 40 | 41 | 42 | type Explorer = 43 | StateT Metadata Task.Task 44 | 45 | 46 | data Metadata = 47 | Metadata 48 | { _registry :: Cache.PackageRegistry 49 | , _info :: Map (Name, Version) Info 50 | } 51 | 52 | 53 | data Info = 54 | Info 55 | { _elm :: Constraint 56 | , _pkgs :: Map Name Constraint 57 | } 58 | 59 | 60 | run :: Cache.PackageRegistry -> Explorer a -> Task.Task a 61 | run registry explorer = 62 | evalStateT explorer (Metadata registry Map.empty) 63 | 64 | 65 | 66 | -- EXISTS 67 | 68 | 69 | exists :: Name -> Explorer () 70 | exists name = 71 | do registry <- gets _registry 72 | case Cache.getVersions name registry of 73 | Right _ -> 74 | return () 75 | 76 | Left suggestions -> 77 | throwError (Exit.Deps (E.PackageNotFound name suggestions)) 78 | 79 | 80 | 81 | -- VERSIONS 82 | 83 | 84 | getVersions :: Name -> Explorer [Version] 85 | getVersions name = 86 | do registry <- gets _registry 87 | case Cache.getVersions name registry of 88 | Right versions -> 89 | return versions 90 | 91 | Left _suggestions -> 92 | do elmHome <- liftIO PerUserCache.getElmHome 93 | throwError (Exit.Deps (E.CorruptVersionCache elmHome name)) 94 | 95 | 96 | 97 | -- CONSTRAINTS 98 | 99 | 100 | getConstraints :: Name -> Version -> Explorer Info 101 | getConstraints name version = 102 | do allInfo <- gets _info 103 | case Map.lookup (name, version) allInfo of 104 | Just info -> 105 | return info 106 | 107 | Nothing -> 108 | do pkgInfo <- lift $ Cache.getElmJson name version 109 | 110 | let elm = Project._pkg_elm_version pkgInfo 111 | let pkgs = Project._pkg_deps pkgInfo 112 | let info = Info elm pkgs 113 | 114 | modify $ \(Metadata vsns infos) -> 115 | Metadata vsns $ Map.insert (name, version) info infos 116 | 117 | return info 118 | -------------------------------------------------------------------------------- /builder/src/Deps/Plan.hs: -------------------------------------------------------------------------------- 1 | module Install.Plan where 2 | 3 | import qualified Data.Map as Map 4 | 5 | import qualified Elm.Package.Solution as S 6 | import qualified Elm.Package as Package 7 | 8 | 9 | data Plan = 10 | Plan 11 | { installs :: Map.Map Package.Name Package.Version 12 | , upgrades :: Map.Map Package.Name (Package.Version, Package.Version) 13 | , removals :: Map.Map Package.Name Package.Version 14 | } 15 | 16 | 17 | create :: S.Solution -> S.Solution -> Plan 18 | create old new = 19 | Plan 20 | { installs = Map.difference new old 21 | , upgrades = discardNoOps (Map.intersectionWith (,) old new) 22 | , removals = Map.difference old new 23 | } 24 | where 25 | discardNoOps updates = 26 | Map.mapMaybe isChanged updates 27 | 28 | isChanged upgrade@(oldVersion,newVersion) = 29 | if oldVersion == newVersion 30 | then Nothing 31 | else Just upgrade 32 | 33 | 34 | isEmpty :: Plan -> Bool 35 | isEmpty (Plan installs upgrades removals) = 36 | Map.null installs 37 | && Map.null upgrades 38 | && Map.null removals 39 | 40 | 41 | -- DISPLAY 42 | 43 | display :: Plan -> String 44 | display (Plan installs upgrades removals) = 45 | "\n" 46 | ++ displayCategory "Install" displayInstall installs 47 | ++ displayCategory "Upgrade" displayUpgrade upgrades 48 | ++ displayCategory "Remove" displayRemove removals 49 | where 50 | displayCategory name render category = 51 | if Map.null category then "" else 52 | " " ++ name ++ ":" 53 | ++ concatMap (\entry -> "\n " ++ render entry) (Map.toList category) 54 | ++ "\n" 55 | 56 | displayInstall (name, version) = 57 | Package.toString name ++ " " ++ Package.versionToString version 58 | 59 | displayUpgrade (name, (old, new)) = 60 | Package.toString name ++ " (" 61 | ++ Package.versionToString old ++ " => " ++ Package.versionToString new ++ ")" 62 | 63 | displayRemove (name, _version) = 64 | Package.toString name 65 | -------------------------------------------------------------------------------- /builder/src/Deps/Solver.hs: -------------------------------------------------------------------------------- 1 | module Deps.Solver 2 | ( Solver 3 | , run 4 | , solve 5 | ) 6 | where 7 | 8 | 9 | import Control.Monad (foldM, guard, mzero, msum) 10 | import Control.Monad.Logic (LogicT, runLogicT, lift) 11 | import qualified Data.List as List 12 | import qualified Data.Map as Map 13 | import Data.Map (Map) 14 | 15 | import Elm.Package (Name, Version) 16 | 17 | import Deps.Explorer (Explorer) 18 | import qualified Deps.Explorer as Explorer 19 | import Elm.Project.Constraint (Constraint) 20 | import qualified Elm.Project.Constraint as Con 21 | 22 | 23 | 24 | -- SOLVE 25 | 26 | 27 | solve :: Map Name Constraint -> Solver (Map Name Version) 28 | solve cons = 29 | mkSolver (State Map.empty cons) 30 | 31 | 32 | type Solver a = 33 | LogicT Explorer a 34 | 35 | 36 | run :: Solver a -> Explorer (Maybe a) 37 | run solver = 38 | runLogicT solver (const . return . Just) (return Nothing) 39 | 40 | 41 | 42 | -- SOLVER 43 | 44 | 45 | data State = 46 | State 47 | { _solution :: Map Name Version 48 | , _unsolved :: Map Name Constraint 49 | } 50 | 51 | 52 | mkSolver :: State -> Solver (Map Name Version) 53 | mkSolver (State solution unsolved) = 54 | case Map.minViewWithKey unsolved of 55 | Nothing -> 56 | return solution 57 | 58 | Just ((name, constraint), otherUnsolved) -> 59 | do allVersions <- lift $ Explorer.getVersions name 60 | let versions = 61 | reverse $ List.sort $ 62 | filter (Con.satisfies constraint) allVersions 63 | 64 | let state1 = State solution otherUnsolved 65 | state2 <- msum (map (addVersion state1 name) versions) 66 | mkSolver state2 67 | 68 | 69 | addVersion :: State -> Name -> Version -> Solver State 70 | addVersion (State solution unsolved) name version = 71 | do (Explorer.Info elm cons) <- 72 | lift $ Explorer.getConstraints name version 73 | 74 | guard (Con.goodElm elm) 75 | newUnsolved <- foldM (addConstraint solution) unsolved (Map.toList cons) 76 | return (State (Map.insert name version solution) newUnsolved) 77 | 78 | 79 | addConstraint :: Map Name Version -> Map Name Constraint -> (Name, Constraint) -> Solver (Map Name Constraint) 80 | addConstraint solution unsolved (name, newConstraint) = 81 | case Map.lookup name solution of 82 | Just version -> 83 | if Con.satisfies newConstraint version then 84 | return unsolved 85 | else 86 | mzero 87 | 88 | Nothing -> 89 | case Map.lookup name unsolved of 90 | Nothing -> 91 | return $ Map.insert name newConstraint unsolved 92 | 93 | Just oldConstraint -> 94 | case Con.intersect oldConstraint newConstraint of 95 | Nothing -> 96 | mzero 97 | 98 | Just mergedConstraint -> 99 | if oldConstraint == mergedConstraint then 100 | return unsolved 101 | else 102 | return (Map.insert name mergedConstraint unsolved) 103 | 104 | -------------------------------------------------------------------------------- /builder/src/Elm/PerUserCache.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.PerUserCache 3 | ( getPackageRoot 4 | , getReplRoot 5 | , getElmHome 6 | ) 7 | where 8 | 9 | import qualified System.Directory as Dir 10 | import qualified System.Environment as Env 11 | import System.FilePath (()) 12 | 13 | import qualified Elm.Compiler as Compiler 14 | import qualified Elm.Package as Pkg 15 | 16 | 17 | 18 | -- ROOTS 19 | 20 | 21 | getPackageRoot :: IO FilePath 22 | getPackageRoot = 23 | getRoot "package" 24 | 25 | 26 | getReplRoot :: IO FilePath 27 | getReplRoot = 28 | getRoot "repl" 29 | 30 | 31 | getRoot :: FilePath -> IO FilePath 32 | getRoot projectName = 33 | do home <- getElmHome 34 | let root = home version projectName 35 | Dir.createDirectoryIfMissing True root 36 | return root 37 | 38 | 39 | version :: FilePath 40 | version = 41 | Pkg.versionToString Compiler.version 42 | 43 | 44 | getElmHome :: IO FilePath 45 | getElmHome = 46 | do maybeHome <- Env.lookupEnv "ELM_HOME" 47 | maybe (Dir.getAppUserDataDirectory "elm") return maybeHome 48 | -------------------------------------------------------------------------------- /builder/src/Elm/Project.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Elm.Project 4 | ( getRoot 5 | , getRootWithReplFallback 6 | , compile 7 | , compileForRepl 8 | , generateDocs 9 | ) 10 | where 11 | 12 | 13 | import qualified Data.ByteString as BS 14 | import Data.Map ((!)) 15 | import System.FilePath (()) 16 | 17 | import qualified Elm.Compiler as Compiler 18 | import qualified Elm.Docs as Docs 19 | import qualified Elm.Name as N 20 | import qualified Elm.Project.Json as Project 21 | import qualified Elm.Project.Root as Root 22 | import qualified Elm.Project.Summary as Summary 23 | import Elm.Project.Summary (Summary) 24 | import qualified File.Args as Args 25 | import qualified File.Artifacts as Artifacts 26 | import qualified File.Compile as Compile 27 | import qualified File.Crawl as Crawl 28 | import qualified File.Plan as Plan 29 | import qualified Generate.Output as Output 30 | import qualified Reporting.Render.Type.Localizer as L 31 | import qualified Reporting.Task as Task 32 | import qualified Stuff.Paths as Path 33 | 34 | 35 | 36 | -- GET ROOT 37 | 38 | 39 | getRoot :: Task.Task Summary 40 | getRoot = 41 | Root.get 42 | 43 | 44 | getRootWithReplFallback :: IO FilePath 45 | getRootWithReplFallback = 46 | Root.getWithReplFallback 47 | 48 | 49 | 50 | -- COMPILE 51 | 52 | 53 | compile 54 | :: Output.Mode 55 | -> Output.Target 56 | -> Maybe Output.Output 57 | -> Maybe FilePath 58 | -> Summary 59 | -> [FilePath] 60 | -> Task.Task () 61 | compile mode target maybeOutput docs summary@(Summary.Summary root project _ _ _) paths = 62 | do Project.check project 63 | args <- Args.fromPaths summary paths 64 | graph <- Crawl.crawl summary args 65 | (dirty, ifaces) <- Plan.plan docs summary graph 66 | answers <- Compile.compile project docs ifaces dirty 67 | results <- Artifacts.write root answers 68 | _ <- traverse (Artifacts.writeDocs results) docs 69 | Output.generate mode target maybeOutput summary graph results 70 | 71 | 72 | 73 | -- COMPILE FOR REPL 74 | 75 | 76 | compileForRepl :: Bool -> L.Localizer -> BS.ByteString -> Maybe N.Name -> Task.Task (Maybe FilePath) 77 | compileForRepl noColors localizer source maybeName = 78 | do summary@(Summary.Summary root project _ _ _) <- getRoot 79 | Project.check project 80 | graph <- Crawl.crawlFromSource summary source 81 | (dirty, ifaces) <- Plan.plan Nothing summary graph 82 | answers <- Compile.compile project Nothing ifaces dirty 83 | results <- Artifacts.write root answers 84 | let (Compiler.Artifacts elmi _ _) = results ! N.replModule 85 | traverse (Output.generateReplFile noColors localizer summary graph elmi) maybeName 86 | 87 | 88 | 89 | -- GENERATE DOCS 90 | 91 | 92 | generateDocs :: Summary.Summary -> Task.Task Docs.Documentation 93 | generateDocs summary@(Summary.Summary root project _ _ _) = 94 | do let docsPath = root Path.docs 95 | args <- Args.fromSummary summary 96 | graph <- Crawl.crawl summary args 97 | (dirty, ifaces) <- Plan.plan (Just docsPath) summary graph 98 | answers <- Compile.compile project (Just docsPath) ifaces dirty 99 | results <- Artifacts.write root answers 100 | Output.noDebugUsesInPackage summary graph 101 | Artifacts.writeDocs results docsPath 102 | -------------------------------------------------------------------------------- /builder/src/Elm/Project/Root.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Elm.Project.Root 3 | ( get 4 | , unsafeGet 5 | , getWithReplFallback 6 | ) 7 | where 8 | 9 | 10 | import Control.Monad.Trans (liftIO) 11 | import qualified Data.Map as Map 12 | import qualified System.Directory as Dir 13 | import System.FilePath (()) 14 | 15 | import qualified Elm.Package as Pkg 16 | import qualified Elm.Project.Constraint as Con 17 | import qualified Elm.Project.Json as Project 18 | import qualified Elm.Project.Licenses as Licenses 19 | import qualified Elm.Project.Summary as Summary 20 | import qualified Elm.PerUserCache as PerUserCache 21 | import qualified File.IO as IO 22 | import qualified Reporting.Exit as Exit 23 | import qualified Reporting.Task as Task 24 | import qualified Stuff.Verify as Verify 25 | import qualified Json.Encode as Encode 26 | 27 | 28 | 29 | -- GET 30 | 31 | 32 | get :: Task.Task Summary.Summary 33 | get = 34 | do root <- moveToRoot 35 | project <- Project.read "elm.json" 36 | Verify.verify root project 37 | 38 | 39 | unsafeGet :: Task.Task (FilePath, Project.Project) 40 | unsafeGet = 41 | (,) <$> moveToRoot <*> Project.read "elm.json" 42 | 43 | 44 | 45 | -- MOVE TO ROOT 46 | 47 | 48 | moveToRoot :: Task.Task FilePath 49 | moveToRoot = 50 | do maybeRoot <- liftIO $ IO.find "elm.json" 51 | case maybeRoot of 52 | Just root -> 53 | do liftIO $ Dir.setCurrentDirectory root 54 | return root 55 | 56 | Nothing -> 57 | Task.throw Exit.NoElmJson 58 | 59 | 60 | 61 | -- GET WITH FALLBACK 62 | 63 | 64 | getWithReplFallback :: IO FilePath 65 | getWithReplFallback = 66 | do maybeRoot <- IO.find "elm.json" 67 | 68 | case maybeRoot of 69 | Just root -> 70 | do Dir.setCurrentDirectory root 71 | return root 72 | 73 | Nothing -> 74 | do cache <- PerUserCache.getReplRoot 75 | let root = cache "tmp" 76 | Dir.createDirectoryIfMissing True root 77 | Dir.setCurrentDirectory root 78 | IO.removeDir "elm-stuff" 79 | Encode.write "elm.json" (Project.encode (Project.Pkg replInfo)) 80 | return root 81 | 82 | 83 | replInfo :: Project.PkgInfo 84 | replInfo = 85 | Project.PkgInfo 86 | { Project._pkg_name = Pkg.dummyName 87 | , Project._pkg_summary = "dummy code for the REPL" 88 | , Project._pkg_license = Licenses.bsd3 89 | , Project._pkg_version = Pkg.dummyVersion 90 | , Project._pkg_exposed = Project.ExposedList [] 91 | , Project._pkg_deps = Map.singleton Pkg.core Con.anything 92 | , Project._pkg_test_deps = Map.empty 93 | , Project._pkg_elm_version = Con.defaultElm 94 | } 95 | -------------------------------------------------------------------------------- /builder/src/Elm/Project/Summary.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Project.Summary 3 | ( Summary(..) 4 | , ExposedModules 5 | , DepsGraph 6 | , init 7 | , cheapInit 8 | ) 9 | where 10 | 11 | 12 | import Prelude hiding (init) 13 | import qualified Data.List as List 14 | import qualified Data.Map as Map 15 | import Data.Map (Map) 16 | 17 | import qualified Elm.Compiler.Module as Module 18 | import Elm.Package (Package(..), Name, Version) 19 | import Elm.Project.Json (Project(..), AppInfo(..), PkgInfo(..)) 20 | import qualified Elm.Project.Json as Project 21 | 22 | 23 | 24 | -- SUMMARY 25 | 26 | 27 | data Summary = 28 | Summary 29 | { _root :: FilePath 30 | , _project :: Project 31 | , _exposed :: ExposedModules 32 | , _ifaces :: Module.Interfaces 33 | , _depsGraph :: DepsGraph 34 | } 35 | 36 | 37 | type ExposedModules = 38 | Map.Map Module.Raw [Package] 39 | 40 | 41 | type DepsGraph = 42 | Map.Map Name ( Version, [Name] ) 43 | 44 | 45 | 46 | -- MAKE SUMMARY 47 | 48 | 49 | init :: FilePath -> Project -> Map Name PkgInfo -> Module.Interfaces -> Summary 50 | init root project deps ifaces = 51 | let 52 | exposed = 53 | case project of 54 | Project.App info -> 55 | getExposed deps (_app_deps_direct info) 56 | 57 | Project.Pkg info -> 58 | getExposed deps (_pkg_deps info) 59 | 60 | privatizedInterfaces = 61 | Map.mapMaybeWithKey (privatize exposed) ifaces 62 | 63 | depsGraph = 64 | Map.foldr toNode Map.empty deps 65 | in 66 | Summary root project exposed privatizedInterfaces depsGraph 67 | 68 | 69 | privatize :: ExposedModules -> Module.Canonical -> Module.Interface -> Maybe Module.Interface 70 | privatize exposed (Module.Canonical _ name) iface = 71 | case Map.lookup name exposed of 72 | Just [_] -> 73 | Just iface 74 | 75 | _ -> 76 | Nothing 77 | 78 | 79 | toNode :: PkgInfo -> DepsGraph -> DepsGraph 80 | toNode (PkgInfo name _ _ version _ deps _ _) graph = 81 | Map.insert name (version, Map.keys deps) graph 82 | 83 | 84 | 85 | -- MAKE CHEAP SUMMARY 86 | 87 | 88 | cheapInit :: FilePath -> PkgInfo -> Map Name PkgInfo -> Module.Interfaces -> Summary 89 | cheapInit root info deps ifaces = 90 | Summary root (Pkg info) (getExposed deps (_pkg_deps info)) ifaces Map.empty 91 | 92 | 93 | getExposed :: Map Name PkgInfo -> Map Name a -> ExposedModules 94 | getExposed deps directs = 95 | Map.foldl insertExposed Map.empty (Map.intersection deps directs) 96 | 97 | 98 | insertExposed :: ExposedModules -> PkgInfo -> ExposedModules 99 | insertExposed exposed info = 100 | let 101 | home = 102 | Package (_pkg_name info) (_pkg_version info) 103 | 104 | insertModule dict modul = 105 | Map.insertWith (++) modul [home] dict 106 | in 107 | List.foldl' insertModule exposed (Project.getExposed info) 108 | -------------------------------------------------------------------------------- /builder/src/File/Args.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module File.Args 3 | ( Args(..) 4 | , fromPaths 5 | , fromSummary 6 | ) 7 | where 8 | 9 | 10 | import qualified Elm.Compiler.Module as Module 11 | import qualified Elm.Project.Json as Project 12 | import qualified Elm.Project.Summary as Summary 13 | import qualified Reporting.Exit as Exit 14 | import qualified Reporting.Exit.Make as E 15 | import qualified Reporting.Task as Task 16 | 17 | 18 | data Args root 19 | = Pkg [Module.Raw] 20 | | Roots root [root] 21 | 22 | 23 | fromPaths :: Summary.Summary -> [FilePath] -> Task.Task (Args FilePath) 24 | fromPaths summary paths = 25 | case paths of 26 | [] -> 27 | fromSummary summary 28 | 29 | first : rest -> 30 | return $ Roots first rest 31 | 32 | 33 | fromSummary :: Summary.Summary -> Task.Task (Args a) 34 | fromSummary (Summary.Summary _ project _ _ _) = 35 | case project of 36 | Project.Pkg info -> 37 | return $ Pkg (Project.getExposed info) 38 | 39 | Project.App _ -> 40 | Task.throw (Exit.Make E.CannotMakeNothing) 41 | -------------------------------------------------------------------------------- /builder/src/File/Artifacts.hs: -------------------------------------------------------------------------------- 1 | module File.Artifacts 2 | ( ignore 3 | , write 4 | , writeDocs 5 | ) 6 | where 7 | 8 | 9 | import Control.Concurrent (forkIO) 10 | import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) 11 | import Control.Monad (foldM, void) 12 | import Control.Monad.Except (liftIO) 13 | import qualified Data.Binary as Binary 14 | import Data.Map (Map) 15 | import qualified Data.Map as Map 16 | import qualified Data.Maybe as Maybe 17 | import qualified Data.Text.Encoding as Text 18 | 19 | import qualified Elm.Compiler as Compiler 20 | import qualified Elm.Compiler.Module as Module 21 | import qualified Elm.Docs as Docs 22 | import qualified Json.Encode as Encode 23 | 24 | import File.Compile (Answer(..)) 25 | import qualified Reporting.Exit.Compile as E 26 | import qualified Reporting.Exit as Exit 27 | import qualified Reporting.Task as Task 28 | import qualified Stuff.Paths as Path 29 | 30 | 31 | 32 | -- IGNORE 33 | 34 | 35 | ignore :: Map Module.Raw Answer -> Task.Task (Map Module.Raw Compiler.Artifacts) 36 | ignore answers = 37 | let 38 | ignorer _name result = 39 | return result 40 | in 41 | gather ignorer answers 42 | 43 | 44 | 45 | -- WRITE 46 | 47 | 48 | write :: FilePath -> Map Module.Raw Answer -> Task.Task (Map Module.Raw Compiler.Artifacts) 49 | write root answers = 50 | let 51 | writer name result@(Compiler.Artifacts elmi elmo _) = 52 | do mvar <- newEmptyMVar 53 | void $ forkIO $ 54 | do Binary.encodeFile (Path.elmi root name) elmi 55 | Binary.encodeFile (Path.elmo root name) elmo 56 | putMVar mvar result 57 | return mvar 58 | in 59 | do mvars <- gather writer answers 60 | liftIO $ traverse readMVar mvars 61 | 62 | 63 | writeDocs :: Map Module.Raw Compiler.Artifacts -> FilePath -> Task.Task Docs.Documentation 64 | writeDocs results path = 65 | let 66 | getDocs (Compiler.Artifacts _ _ docs) = 67 | docs 68 | in 69 | case Maybe.mapMaybe getDocs (Map.elems results) of 70 | [] -> 71 | return Map.empty 72 | 73 | docs -> 74 | do liftIO $ Encode.writeUgly path $ Encode.list Docs.encode docs 75 | return $ Docs.toDict docs 76 | 77 | 78 | 79 | -- GATHER 80 | 81 | 82 | gather :: OnGood a -> Map Module.Raw Answer -> Task.Task (Map Module.Raw a) 83 | gather onGood answers = 84 | do summary <- liftIO $ 85 | foldM (gatherHelp onGood) (Right Map.empty) (Map.toList answers) 86 | 87 | case summary of 88 | Left (err, errors) -> 89 | Task.throw (Exit.Compile err errors) 90 | 91 | Right results -> 92 | return results 93 | 94 | 95 | type OnGood a = Module.Raw -> Compiler.Artifacts -> IO a 96 | 97 | 98 | gatherHelp :: OnGood a -> Summary a -> (Module.Raw, Answer) -> IO (Summary a) 99 | gatherHelp onGood summary (name, answer) = 100 | case answer of 101 | Blocked -> 102 | return summary 103 | 104 | Bad path time src errors -> 105 | do let err = E.Exit name path time (Text.decodeUtf8 src) errors 106 | return (addErr err summary) 107 | 108 | Good result -> 109 | do value <- onGood name result 110 | return (addOk name value summary) 111 | 112 | 113 | 114 | -- DICT RESULT 115 | 116 | 117 | type Summary a = 118 | Either (E.Exit, [E.Exit]) (Map Module.Raw a) 119 | 120 | 121 | addOk :: Module.Raw -> a -> Summary a -> Summary a 122 | addOk name result acc = 123 | case acc of 124 | Left _ -> 125 | acc 126 | 127 | Right results -> 128 | Right (Map.insert name result results) 129 | 130 | 131 | addErr :: E.Exit -> Summary a -> Summary a 132 | addErr err acc = 133 | case acc of 134 | Left (e, es) -> 135 | Left (err, e:es) 136 | 137 | Right _ -> 138 | Left (err, []) 139 | -------------------------------------------------------------------------------- /builder/src/File/Find.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module File.Find 4 | ( Asset(..) 5 | , find 6 | ) 7 | where 8 | 9 | import Control.Monad.Except (liftIO) 10 | import qualified Data.Map as Map 11 | import qualified Data.Maybe as Maybe 12 | import qualified System.FilePath as FP 13 | import qualified System.Directory as Dir 14 | import System.FilePath ((), (<.>)) 15 | 16 | import qualified Elm.Compiler.Module as Module 17 | import qualified Elm.Name as N 18 | import qualified Elm.Package as Pkg 19 | 20 | import qualified Elm.Project.Json as Project 21 | import qualified Elm.Project.Summary as Summary 22 | import qualified Reporting.Exit.Crawl as E 23 | import qualified Reporting.Task as Task 24 | 25 | 26 | 27 | -- ASSET 28 | 29 | 30 | data Asset 31 | = Local FilePath 32 | | Kernel FilePath (Maybe FilePath) 33 | | Foreign Pkg.Package 34 | | ForeignKernel 35 | 36 | 37 | 38 | -- FIND 39 | 40 | 41 | find :: Summary.Summary -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset 42 | find (Summary.Summary root project exposed _ _) origin name = 43 | do here <- liftIO Dir.getCurrentDirectory 44 | let toRoot dir = FP.makeRelative here (root dir) 45 | case project of 46 | Project.App info -> 47 | do let srcDirs = map toRoot (Project._app_source_dirs info) 48 | findElm project srcDirs exposed origin name 49 | 50 | Project.Pkg _ -> 51 | if N.startsWith "Elm.Kernel." name then 52 | if Project.isPlatformPackage project then 53 | findKernel (toRoot "src") exposed origin name 54 | else 55 | Task.throw $ E.ModuleNameReservedForKernel origin name 56 | 57 | else 58 | findElm project [ toRoot "src" ] exposed origin name 59 | 60 | 61 | 62 | -- FIND ELM 63 | 64 | 65 | findElm :: Project.Project -> [FilePath] -> Summary.ExposedModules -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset 66 | findElm project srcDirs exposed origin name = 67 | do 68 | paths <- liftIO $ Maybe.catMaybes <$> mapM (elmExists name) srcDirs 69 | 70 | case (paths, Map.lookup name exposed) of 71 | ([path], Nothing) -> 72 | return (Local path) 73 | 74 | ([], Just [pkg]) -> 75 | return (Foreign pkg) 76 | 77 | ([], Nothing) -> 78 | case project of 79 | Project.App _ -> 80 | Task.throw $ E.ModuleNotFound origin name (E.App srcDirs) 81 | 82 | Project.Pkg _ -> 83 | Task.throw $ E.ModuleNotFound origin name E.Pkg 84 | 85 | (_, maybePkgs) -> 86 | Task.throw $ E.ModuleAmbiguous origin name paths (maybe [] id maybePkgs) 87 | 88 | 89 | elmExists :: Module.Raw -> FilePath -> IO (Maybe FilePath) 90 | elmExists name srcDir = 91 | do let path = srcDir Module.nameToSlashPath name <.> "elm" 92 | exists <- Dir.doesFileExist path 93 | return $ if exists then Just path else Nothing 94 | 95 | 96 | 97 | -- FIND KERNEL 98 | 99 | 100 | findKernel :: FilePath -> Summary.ExposedModules -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset 101 | findKernel srcDir exposed origin name = 102 | do let clientPath = srcDir Module.nameToSlashPath name <.> "js" 103 | let serverPath = srcDir Module.nameToSlashPath name <.> "server.js" 104 | client <- liftIO $ Dir.doesFileExist clientPath 105 | server <- liftIO $ Dir.doesFileExist serverPath 106 | if client 107 | then return $ Kernel clientPath (if server then Just serverPath else Nothing) 108 | else 109 | case Map.lookup (N.drop 11 name) exposed of 110 | Just [Pkg.Package pkg _vsn] | pkg == Pkg.core || pkg == Pkg.virtualDom -> 111 | return ForeignKernel 112 | 113 | _ -> 114 | Task.throw $ E.ModuleNotFound origin name E.Pkg 115 | -------------------------------------------------------------------------------- /builder/src/File/Hash.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module File.Hash 3 | ( Hasher 4 | , put 5 | , Digest 6 | , toString 7 | , putByteString 8 | , putBuilder 9 | , putFile 10 | ) 11 | where 12 | 13 | 14 | import Prelude hiding (appendFile) 15 | import Control.Monad (foldM) 16 | import qualified Control.Monad.State as State 17 | import qualified Data.Binary.Get as Binary 18 | import qualified Data.ByteString as BS 19 | import qualified Data.ByteString.Builder as BS 20 | import qualified Data.ByteString.Builder.Extra as BS (defaultChunkSize) 21 | import qualified Data.ByteString.Lazy as LBS 22 | import qualified Data.Digest.Pure.SHA as SHA 23 | import qualified System.IO as IO 24 | 25 | 26 | 27 | -- HASHER 28 | 29 | 30 | type Hasher = State.StateT State IO () 31 | 32 | 33 | type Digest = SHA.Digest SHA.SHA1State 34 | 35 | 36 | put :: FilePath -> Hasher -> IO Digest 37 | put path hasher = 38 | IO.withBinaryFile path IO.WriteMode $ \handle -> 39 | do let state = State handle 0 SHA.sha1Incremental 40 | (State _ len decoder) <- State.execStateT hasher state 41 | return (SHA.completeSha1Incremental decoder len) 42 | 43 | 44 | toString :: Digest -> String 45 | toString = 46 | SHA.showDigest 47 | 48 | 49 | 50 | -- HASH STATE 51 | 52 | 53 | data State = 54 | State 55 | { _handle :: !IO.Handle 56 | , _length :: !Int 57 | , _decoder :: !(Binary.Decoder SHA.SHA1State) 58 | } 59 | 60 | 61 | 62 | -- PUBLIC API 63 | 64 | 65 | putByteString :: BS.ByteString -> Hasher 66 | putByteString chunk = 67 | do state <- State.get 68 | State.put =<< State.liftIO (appendByteString state chunk) 69 | 70 | 71 | putBuilder :: BS.Builder -> Hasher 72 | putBuilder builder = 73 | do state <- State.get 74 | State.put =<< State.liftIO (appendBuilder builder state) 75 | 76 | 77 | putFile :: FilePath -> Hasher 78 | putFile path = 79 | do state <- State.get 80 | State.put =<< State.liftIO (appendFile path state) 81 | 82 | 83 | 84 | -- PRIMITIVES 85 | 86 | 87 | appendByteString :: State -> BS.ByteString -> IO State 88 | appendByteString (State handle len decoder) chunk = 89 | do BS.hPut handle chunk 90 | return $ State handle (len + BS.length chunk) (Binary.pushChunk decoder chunk) 91 | 92 | 93 | appendBuilder :: BS.Builder -> State -> IO State 94 | appendBuilder builder state = 95 | foldM appendByteString state $ 96 | LBS.toChunks (BS.toLazyByteString builder) 97 | 98 | 99 | appendFile :: FilePath -> State -> IO State 100 | appendFile path state = 101 | IO.withBinaryFile path IO.ReadMode $ \handle -> 102 | appendHelp handle state 103 | 104 | 105 | appendHelp :: IO.Handle -> State -> IO State 106 | appendHelp handle state = 107 | do chunk <- BS.hGet handle BS.defaultChunkSize 108 | if BS.null chunk 109 | then return state 110 | else appendHelp handle =<< appendByteString state chunk 111 | -------------------------------------------------------------------------------- /builder/src/File/Watcher.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module File.Watcher where 3 | 4 | import Control.Concurrent (forkIO, threadDelay) 5 | import Control.Concurrent.Chan (newChan, readChan, writeChan) 6 | import qualified System.FSNotify as Notify 7 | 8 | import qualified Elm.Project as Project 9 | import Elm.Project (Project) 10 | 11 | 12 | 13 | -- GRAPH 14 | 15 | 16 | data Graph = 17 | Graph 18 | { _elm :: Map.Map Module.Raw Node 19 | , _js :: Map.Map Module.Raw FilePath 20 | } 21 | 22 | 23 | data Node = 24 | Node 25 | { _path :: FilePath 26 | , _time :: UTCTime 27 | , _needs :: Set.Set Module.Raw 28 | , _blocks :: Set.Set Module.Raw 29 | , _iface :: Maybe (UTCTime, Interface) 30 | } 31 | 32 | 33 | 34 | -- ABC 35 | 36 | 37 | action :: Notify.Event -> IO () 38 | action event = 39 | case event of 40 | Notify.Added path time -> 41 | return () 42 | 43 | Notify.Modified path time -> 44 | return () 45 | 46 | Notify.Removed path time -> 47 | return () 48 | 49 | 50 | watcher :: Project -> IO () 51 | watcher project = 52 | let 53 | srcDir = 54 | Project.toSourceDir project 55 | 56 | action event = 57 | case event of 58 | Notify.Added _ _ -> 59 | return () 60 | 61 | Notify.Modified path time -> 62 | 63 | Notify.Removed path time -> 64 | 65 | in 66 | do killer <- newChan 67 | mapM_ (watcherHelp killer action) [srcDir] 68 | 69 | 70 | 71 | watcherHelp :: Notify.Action -> FilePath -> IO () 72 | watcherHelp killer action dir = 73 | void $ forkIO $ Notify.withManager $ \manager -> 74 | do stop <- Notify.watchTree manager dir (const True) action 75 | _ <- readChan killer 76 | stop 77 | -------------------------------------------------------------------------------- /builder/src/Generate/Functions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | module Generate.Functions (functions) where 4 | 5 | import qualified Data.ByteString.Builder as B 6 | import Text.RawString.QQ (r) 7 | 8 | 9 | 10 | -- FUNCTIONS 11 | 12 | 13 | functions :: B.Builder 14 | functions = [r| 15 | 16 | function F(arity, fun, wrapper) { 17 | wrapper.a = arity; 18 | wrapper.f = fun; 19 | return wrapper; 20 | } 21 | 22 | function F2(fun) { 23 | return F(2, fun, function(a) { return function(b) { return fun(a,b); }; }) 24 | } 25 | function F3(fun) { 26 | return F(3, fun, function(a) { 27 | return function(b) { return function(c) { return fun(a, b, c); }; }; 28 | }); 29 | } 30 | function F4(fun) { 31 | return F(4, fun, function(a) { return function(b) { return function(c) { 32 | return function(d) { return fun(a, b, c, d); }; }; }; 33 | }); 34 | } 35 | function F5(fun) { 36 | return F(5, fun, function(a) { return function(b) { return function(c) { 37 | return function(d) { return function(e) { return fun(a, b, c, d, e); }; }; }; }; 38 | }); 39 | } 40 | function F6(fun) { 41 | return F(6, fun, function(a) { return function(b) { return function(c) { 42 | return function(d) { return function(e) { return function(f) { 43 | return fun(a, b, c, d, e, f); }; }; }; }; }; 44 | }); 45 | } 46 | function F7(fun) { 47 | return F(7, fun, function(a) { return function(b) { return function(c) { 48 | return function(d) { return function(e) { return function(f) { 49 | return function(g) { return fun(a, b, c, d, e, f, g); }; }; }; }; }; }; 50 | }); 51 | } 52 | function F8(fun) { 53 | return F(8, fun, function(a) { return function(b) { return function(c) { 54 | return function(d) { return function(e) { return function(f) { 55 | return function(g) { return function(h) { 56 | return fun(a, b, c, d, e, f, g, h); }; }; }; }; }; }; }; 57 | }); 58 | } 59 | function F9(fun) { 60 | return F(9, fun, function(a) { return function(b) { return function(c) { 61 | return function(d) { return function(e) { return function(f) { 62 | return function(g) { return function(h) { return function(i) { 63 | return fun(a, b, c, d, e, f, g, h, i); }; }; }; }; }; }; }; }; 64 | }); 65 | } 66 | 67 | function A2(fun, a, b) { 68 | return fun.a === 2 ? fun.f(a, b) : fun(a)(b); 69 | } 70 | function A3(fun, a, b, c) { 71 | return fun.a === 3 ? fun.f(a, b, c) : fun(a)(b)(c); 72 | } 73 | function A4(fun, a, b, c, d) { 74 | return fun.a === 4 ? fun.f(a, b, c, d) : fun(a)(b)(c)(d); 75 | } 76 | function A5(fun, a, b, c, d, e) { 77 | return fun.a === 5 ? fun.f(a, b, c, d, e) : fun(a)(b)(c)(d)(e); 78 | } 79 | function A6(fun, a, b, c, d, e, f) { 80 | return fun.a === 6 ? fun.f(a, b, c, d, e, f) : fun(a)(b)(c)(d)(e)(f); 81 | } 82 | function A7(fun, a, b, c, d, e, f, g) { 83 | return fun.a === 7 ? fun.f(a, b, c, d, e, f, g) : fun(a)(b)(c)(d)(e)(f)(g); 84 | } 85 | function A8(fun, a, b, c, d, e, f, g, h) { 86 | return fun.a === 8 ? fun.f(a, b, c, d, e, f, g, h) : fun(a)(b)(c)(d)(e)(f)(g)(h); 87 | } 88 | function A9(fun, a, b, c, d, e, f, g, h, i) { 89 | 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); 90 | } 91 | 92 | |] 93 | -------------------------------------------------------------------------------- /builder/src/Generate/Html.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | module Generate.Html 4 | ( sandwich 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.ByteString.Builder as B 10 | import Data.Monoid ((<>)) 11 | import Text.RawString.QQ (r) 12 | 13 | import qualified Elm.Name as N 14 | 15 | 16 | 17 | -- SANDWICH 18 | 19 | 20 | sandwich :: N.Name -> B.Builder -> B.Builder 21 | sandwich moduleName javascript = 22 | let name = N.toBuilder moduleName in 23 | [r| 24 | 25 | 26 | 27 | |] <> name <> [r| 28 | 29 | 30 | 31 |
32 | 41 | 42 | |] 43 | -------------------------------------------------------------------------------- /builder/src/Generate/Nitpick.hs: -------------------------------------------------------------------------------- 1 | module Generate.Nitpick 2 | ( findDebugUses 3 | ) 4 | where 5 | 6 | 7 | import qualified Data.Map as Map 8 | import qualified Data.Set as Set 9 | 10 | import qualified AST.Optimized as Opt 11 | import qualified AST.Module.Name as ModuleName 12 | import qualified Elm.Package as Pkg 13 | import qualified Elm.Name as N 14 | 15 | 16 | 17 | -- FIND DEBUG USES 18 | 19 | 20 | findDebugUses :: Pkg.Name -> Opt.Graph -> [N.Name] 21 | findDebugUses pkg (Opt.Graph _ graph _) = 22 | Set.toList $ Map.foldrWithKey (addDebugUses pkg) Set.empty graph 23 | 24 | 25 | addDebugUses :: Pkg.Name -> Opt.Global -> Opt.Node -> Set.Set N.Name -> Set.Set N.Name 26 | addDebugUses here (Opt.Global (ModuleName.Canonical pkg home) _) node uses = 27 | if pkg == here && nodeHasDebug node then 28 | Set.insert home uses 29 | else 30 | uses 31 | 32 | 33 | nodeHasDebug :: Opt.Node -> Bool 34 | nodeHasDebug node = 35 | case node of 36 | Opt.Define expr _ -> hasDebug expr 37 | Opt.DefineTailFunc _ expr _ -> hasDebug expr 38 | Opt.Ctor _ _ -> False 39 | Opt.Enum _ -> False 40 | Opt.Box -> False 41 | Opt.Link _ -> False 42 | Opt.Cycle _ vs fs _ -> any (hasDebug . snd) vs || any defHasDebug fs 43 | Opt.Manager _ -> False 44 | Opt.Kernel _ _ -> False 45 | Opt.PortIncoming expr _ -> hasDebug expr 46 | Opt.PortOutgoing expr _ -> hasDebug expr 47 | 48 | 49 | hasDebug :: Opt.Expr -> Bool 50 | hasDebug expression = 51 | case expression of 52 | Opt.Bool _ -> False 53 | Opt.Chr _ -> False 54 | Opt.Str _ -> False 55 | Opt.Int _ -> False 56 | Opt.Float _ -> False 57 | Opt.VarLocal _ -> False 58 | Opt.VarGlobal _ -> False 59 | Opt.VarEnum _ _ -> False 60 | Opt.VarBox _ -> False 61 | Opt.VarCycle _ _ -> False 62 | Opt.VarDebug _ _ _ _ -> True 63 | Opt.VarKernel _ _ -> False 64 | Opt.List exprs -> any hasDebug exprs 65 | Opt.Function _ expr -> hasDebug expr 66 | Opt.Call e es -> hasDebug e || any hasDebug es 67 | Opt.TailCall _ args -> any (hasDebug . snd) args 68 | Opt.If conds finally -> any (\(c,e) -> hasDebug c || hasDebug e) conds || hasDebug finally 69 | Opt.Let def body -> defHasDebug def || hasDebug body 70 | Opt.Destruct _ expr -> hasDebug expr 71 | Opt.Case _ _ d jumps -> deciderHasDebug d || any (hasDebug . snd) jumps 72 | Opt.Accessor _ -> False 73 | Opt.Access r _ -> hasDebug r 74 | Opt.Update r fs -> hasDebug r || any hasDebug fs 75 | Opt.Record fs -> any hasDebug fs 76 | Opt.Unit -> False 77 | Opt.Tuple a b c -> hasDebug a || hasDebug b || maybe False hasDebug c 78 | Opt.Shader _ _ _ -> False 79 | 80 | 81 | defHasDebug :: Opt.Def -> Bool 82 | defHasDebug def = 83 | case def of 84 | Opt.Def _ expr -> hasDebug expr 85 | Opt.TailDef _ _ expr -> hasDebug expr 86 | 87 | 88 | deciderHasDebug :: Opt.Decider Opt.Choice -> Bool 89 | deciderHasDebug decider = 90 | case decider of 91 | Opt.Leaf (Opt.Inline expr) -> hasDebug expr 92 | Opt.Leaf (Opt.Jump _) -> False 93 | Opt.Chain _ success failure -> deciderHasDebug success || deciderHasDebug failure 94 | Opt.FanOut _ tests fallback -> any (deciderHasDebug . snd) tests || deciderHasDebug fallback 95 | 96 | 97 | 98 | -- TODO: FIND GLOBALLY UNUSED DEFINITIONS? 99 | -- TODO: FIND PACKAGE USAGE STATS? (e.g. elm/core = 142, author/project = 2, etc.) 100 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Exit 3 | ( Exit(..) 4 | , toString 5 | , toStderr 6 | , toJson 7 | ) 8 | where 9 | 10 | 11 | import qualified Elm.Compiler.Module as Module 12 | import qualified Json.Encode as Encode 13 | import qualified Reporting.Doc as D 14 | import qualified Reporting.Exit.Assets as Asset 15 | import qualified Reporting.Exit.Bump as Bump 16 | import qualified Reporting.Exit.Compile as Compile 17 | import qualified Reporting.Exit.Crawl as Crawl 18 | import qualified Reporting.Exit.Deps as Deps 19 | import qualified Reporting.Exit.Diff as Diff 20 | import qualified Reporting.Exit.Help as Help 21 | import qualified Reporting.Exit.Http as Http 22 | import qualified Reporting.Exit.Make as Make 23 | import qualified Reporting.Exit.Init as Init 24 | import qualified Reporting.Exit.Install as Install 25 | import qualified Reporting.Exit.Publish as Publish 26 | 27 | 28 | 29 | -- ALL POSSIBLE ERRORS 30 | 31 | 32 | data Exit 33 | = NoElmJson 34 | | Assets Asset.Exit 35 | | Bump Bump.Exit 36 | | Compile Compile.Exit [Compile.Exit] 37 | | Crawl Crawl.Exit 38 | | Cycle [Module.Raw] -- TODO write docs to help with this scenario 39 | | Deps Deps.Exit 40 | | Diff Diff.Exit 41 | | Make Make.Exit 42 | | Init Init.Exit 43 | | Install Install.Exit 44 | | Publish Publish.Exit 45 | | BadHttp String Http.Exit 46 | 47 | 48 | 49 | -- RENDERERS 50 | 51 | 52 | toString :: Exit -> String 53 | toString exit = 54 | Help.toString (Help.reportToDoc (toReport exit)) 55 | 56 | 57 | toStderr :: Exit -> IO () 58 | toStderr exit = 59 | Help.toStderr (Help.reportToDoc (toReport exit)) 60 | 61 | 62 | toJson :: Exit -> Encode.Value 63 | toJson exit = 64 | Help.reportToJson (toReport exit) 65 | 66 | 67 | toReport :: Exit -> Help.Report 68 | toReport exit = 69 | case exit of 70 | NoElmJson -> 71 | Help.report "NO elm.json FILE" Nothing 72 | "It looks like you are starting a new Elm project. Very exciting! Try running:" 73 | [ D.indent 4 $ D.green $ "elm init" 74 | , D.reflow $ 75 | "It will help you get set up. It is really simple!" 76 | ] 77 | 78 | Assets assetExit -> 79 | Asset.toReport assetExit 80 | 81 | Bump bumpExit -> 82 | Bump.toReport bumpExit 83 | 84 | Compile e es -> 85 | Help.compilerReport e es 86 | 87 | Crawl crawlExit -> 88 | Crawl.toReport crawlExit 89 | 90 | Cycle names -> 91 | Help.report "IMPORT CYCLE" Nothing 92 | "Your module imports form a cycle:" 93 | [ D.cycle 4 names 94 | , D.reflow $ 95 | "Learn more about why this is disallowed and how to break cycles here:" 96 | ++ D.makeLink "import-cycles" 97 | ] 98 | 99 | Deps depsExit -> 100 | Deps.toReport depsExit 101 | 102 | Diff commandsExit -> 103 | Diff.toReport commandsExit 104 | 105 | Make makeExit -> 106 | Make.toReport makeExit 107 | 108 | Init initExit -> 109 | Init.toReport initExit 110 | 111 | Install installExit -> 112 | Install.toReport installExit 113 | 114 | Publish publishExit -> 115 | Publish.toReport publishExit 116 | 117 | BadHttp url httpExit -> 118 | Http.toReport url httpExit 119 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit/Bump.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Exit.Bump 3 | ( Exit(..) 4 | , toReport 5 | ) 6 | where 7 | 8 | 9 | import qualified Elm.Package as Pkg 10 | import Reporting.Doc ((<>)) 11 | import qualified Reporting.Doc as D 12 | import qualified Reporting.Exit.Help as Help 13 | 14 | 15 | 16 | -- EXITS 17 | 18 | 19 | data Exit 20 | = Application 21 | | Unbumpable Pkg.Version [Pkg.Version] 22 | 23 | 24 | 25 | -- TO REPORT 26 | 27 | 28 | toReport :: Exit -> Help.Report 29 | toReport exit = 30 | case exit of 31 | Application -> 32 | Help.report "UNBUMPABLE" (Just "elm.json") 33 | "Your elm.json says this is an application. That means it cannot be published\ 34 | \ on and therefore has no version to bump!" 35 | [] 36 | 37 | Unbumpable vsn versions -> 38 | Help.docReport "UNBUMPABLE" (Just "elm.json") 39 | ( D.fillSep 40 | ["Your","elm.json","says","I","should","bump","relative","to","version" 41 | ,D.red (D.fromText (Pkg.versionToText vsn)) <> "," 42 | ,"but","I","cannot","find","that","version","on","." 43 | ,"That","means","there","is","no","API","for","me","to","diff","against","and" 44 | ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes." 45 | ] 46 | ) 47 | [ D.fillSep $ 48 | ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"] 49 | ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"] 50 | , D.vcat $ map (D.green . D.fromText . Pkg.versionToText) versions 51 | ] 52 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Exit.Compile 4 | ( Exit(..) 5 | , toJson 6 | , toDoc 7 | ) 8 | where 9 | 10 | 11 | import qualified Data.List as List 12 | import qualified Data.Text as Text 13 | import qualified Data.Time.Clock as Time 14 | 15 | import qualified Elm.Compiler as Compiler 16 | import qualified Elm.Compiler.Module as Module 17 | import qualified Json.Encode as Encode 18 | import qualified Reporting.Doc as D 19 | 20 | 21 | 22 | -- EXITS 23 | 24 | 25 | data Exit = 26 | Exit 27 | { _name :: Module.Raw 28 | , _path :: FilePath 29 | , _time :: Time.UTCTime 30 | , _source :: Text.Text 31 | , _errors :: [Compiler.Error] 32 | } 33 | 34 | 35 | 36 | -- TO JSON 37 | 38 | 39 | toJson :: Exit -> Encode.Value 40 | toJson (Exit name path _ source errors) = 41 | Compiler.errorsToJson name path source errors 42 | 43 | 44 | 45 | -- TO DOC 46 | 47 | 48 | toDoc :: Exit -> [Exit] -> D.Doc 49 | toDoc e es = 50 | let 51 | (exit, exits) = sortByTime e es 52 | in 53 | D.vcat (toDocHelp exit exits) 54 | 55 | 56 | toDocHelp :: Exit -> [Exit] -> [D.Doc] 57 | toDocHelp e1 exits = 58 | case exits of 59 | [] -> 60 | [exitToDoc e1] 61 | 62 | e2 : otherErrors -> 63 | exitToDoc e1 : separator (_name e1) (_name e2) : toDocHelp e2 otherErrors 64 | 65 | 66 | exitToDoc :: Exit -> D.Doc 67 | exitToDoc (Exit _name path _time source errors) = 68 | Compiler.errorsToDoc path source errors 69 | 70 | 71 | separator :: Module.Raw -> Module.Raw -> D.Doc 72 | separator beforeName afterName = 73 | let 74 | before = Module.nameToString beforeName ++ " ↑ " 75 | after = " ↓ " ++ Module.nameToString afterName 76 | in 77 | D.dullred $ D.vcat $ 78 | [ D.indent (80 - length before) (D.fromString before) 79 | , "====o======================================================================o====" 80 | , D.fromString after 81 | , D.empty 82 | , D.empty 83 | ] 84 | 85 | 86 | 87 | -- SORT BY TIME 88 | 89 | 90 | sortByTime :: Exit -> [Exit] -> (Exit, [Exit]) 91 | sortByTime exit exits = 92 | case List.sortBy timeCompare exits of 93 | [] -> 94 | (exit, []) 95 | 96 | e:es -> 97 | if _time exit < _time e then 98 | (exit, e:es) 99 | else 100 | (e, List.insertBy timeCompare exit es) 101 | 102 | 103 | timeCompare :: Exit -> Exit -> Ordering 104 | timeCompare e1 e2 = 105 | compare (_time e1) (_time e2) 106 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Exit.Diff 3 | ( Exit(..) 4 | , toReport 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.List as List 10 | 11 | import qualified Elm.Package as Pkg 12 | import qualified Reporting.Doc as D 13 | import qualified Reporting.Exit.Help as Help 14 | 15 | 16 | 17 | -- EXITS 18 | 19 | 20 | data Exit 21 | = Application 22 | | Unpublished 23 | | UnknownPackage Pkg.Name [Pkg.Name] 24 | | UnknownVersion Pkg.Name Pkg.Version [Pkg.Version] 25 | 26 | 27 | 28 | -- TO DOC 29 | 30 | 31 | toReport :: Exit -> Help.Report 32 | toReport exit = 33 | case exit of 34 | Application -> 35 | Help.report "CANNOT DIFF APPLICATIONS" Nothing 36 | "I cannot perform diffs on applications, only packages! If you are\ 37 | \ just curious to see a diff, try running this command:" 38 | [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0" 39 | ] 40 | 41 | Unpublished -> 42 | Help.report "UNPUBLISHED" Nothing 43 | "This package is not published yet. There is nothing to diff against!" 44 | [] 45 | 46 | UnknownPackage pkg suggestions -> 47 | Help.report "UNKNOWN PACKAGE" Nothing 48 | ( "I cannot find a package called:" 49 | ) 50 | [ D.indent 4 $ D.red $ D.fromText $ Pkg.toText pkg 51 | , "Maybe you want one of these instead?" 52 | , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromText . Pkg.toText) suggestions 53 | , "But check to see all possibilities!" 54 | ] 55 | 56 | UnknownVersion _pkg vsn realVersions -> 57 | Help.docReport "UNKNOWN VERSION" Nothing 58 | ( D.fillSep $ 59 | [ "Version", D.red (D.fromText (Pkg.versionToText vsn)) 60 | , "has", "never", "been", "published,", "so", "I" 61 | , "cannot", "diff", "against", "it." 62 | ] 63 | ) 64 | [ "Here are all the versions that HAVE been published:" 65 | , D.indent 4 $ D.dullyellow $ D.vcat $ 66 | let 67 | sameMajor v1 v2 = Pkg._major v1 == Pkg._major v2 68 | mkRow vsns = D.hsep $ map (D.fromText . Pkg.versionToText) vsns 69 | in 70 | map mkRow $ List.groupBy sameMajor (List.sort realVersions) 71 | , "Want one of those instead?" 72 | ] 73 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit/Help.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Exit.Help 3 | ( Report 4 | , report 5 | , docReport 6 | , jsonReport 7 | , compilerReport 8 | , reportToDoc 9 | , reportToJson 10 | , toString 11 | , toStdout 12 | , toStderr 13 | ) 14 | where 15 | 16 | 17 | import qualified Data.Text as Text 18 | import GHC.IO.Handle (hIsTerminalDevice) 19 | import System.IO (Handle, hPutStr, stderr, stdout) 20 | 21 | import qualified Json.Encode as Encode 22 | import Reporting.Doc ((<+>)) 23 | import qualified Reporting.Doc as D 24 | import qualified Reporting.Exit.Compile as Compile 25 | 26 | 27 | 28 | -- REPORT 29 | 30 | 31 | data Report 32 | = CompilerReport Compile.Exit [Compile.Exit] 33 | | Report 34 | { _title :: String 35 | , _path :: Maybe FilePath 36 | , _message :: D.Doc 37 | } 38 | 39 | 40 | report :: String -> Maybe FilePath -> String -> [D.Doc] -> Report 41 | report title path startString others = 42 | Report title path $ D.stack (D.reflow startString:others) 43 | 44 | 45 | docReport :: String -> Maybe FilePath -> D.Doc -> [D.Doc] -> Report 46 | docReport title path startDoc others = 47 | Report title path $ D.stack (startDoc:others) 48 | 49 | 50 | jsonReport :: String -> Maybe FilePath -> D.Doc -> Report 51 | jsonReport = 52 | Report 53 | 54 | 55 | compilerReport :: Compile.Exit -> [Compile.Exit] -> Report 56 | compilerReport = 57 | CompilerReport 58 | 59 | 60 | 61 | -- TO DOC 62 | 63 | 64 | reportToDoc :: Report -> D.Doc 65 | reportToDoc report_ = 66 | case report_ of 67 | CompilerReport e es -> 68 | Compile.toDoc e es 69 | 70 | Report title maybePath message -> 71 | let 72 | makeDashes n = 73 | replicate (max 1 (80 - n)) '-' 74 | 75 | errorBarEnd = 76 | case maybePath of 77 | Nothing -> 78 | makeDashes (4 + length title) 79 | 80 | Just path -> 81 | makeDashes (5 + length title + length path) ++ " " ++ path 82 | 83 | errorBar = 84 | D.dullcyan $ 85 | "--" <+> D.fromString title <+> D.fromString errorBarEnd 86 | in 87 | D.stack [errorBar, message, ""] 88 | 89 | 90 | 91 | -- TO JSON 92 | 93 | 94 | reportToJson :: Report -> Encode.Value 95 | reportToJson report_ = 96 | case report_ of 97 | CompilerReport e es -> 98 | Encode.object 99 | [ ("type", Encode.text "compile-errors") 100 | , ("errors", Encode.list Compile.toJson (e:es)) 101 | ] 102 | 103 | Report title maybePath message -> 104 | Encode.object 105 | [ ("type", Encode.text "error") 106 | , ("path", maybe Encode.null (Encode.text . Text.pack) maybePath) 107 | , ("title", Encode.text (Text.pack title)) 108 | , ("message", D.encode message) 109 | ] 110 | 111 | 112 | 113 | -- OUTPUT 114 | 115 | 116 | toString :: D.Doc -> String 117 | toString = 118 | D.toString 119 | 120 | 121 | toStdout :: D.Doc -> IO () 122 | toStdout doc = 123 | toHandle stdout doc 124 | 125 | 126 | toStderr :: D.Doc -> IO () 127 | toStderr doc = 128 | toHandle stderr doc 129 | 130 | 131 | toHandle :: Handle -> D.Doc -> IO () 132 | toHandle handle doc = 133 | do isTerminal <- hIsTerminalDevice handle 134 | if isTerminal 135 | then D.toAnsi handle doc 136 | else hPutStr handle (toString doc) 137 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit/Http.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Exit.Http 3 | ( Exit(..) 4 | , toReport 5 | , BadJson(..) 6 | , badJsonToDocs 7 | ) 8 | where 9 | 10 | 11 | import qualified Data.Text as Text 12 | 13 | import Reporting.Doc ((<>)) 14 | import qualified Reporting.Doc as D 15 | import qualified Reporting.Exit.Help as Help 16 | 17 | 18 | 19 | -- EXITS 20 | 21 | 22 | data Exit 23 | = Unknown String 24 | | BadJson String D.Doc 25 | | BadZipData 26 | | BadZipSha String String 27 | 28 | 29 | 30 | -- TO REPORT 31 | 32 | 33 | toReport :: String -> Exit -> Help.Report 34 | toReport url exit = 35 | let 36 | urlDoc = 37 | D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">" 38 | in 39 | case exit of 40 | Unknown message -> 41 | Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:" 42 | [ urlDoc 43 | , D.stack 44 | [ "Here is the error message I was able to extract:" 45 | , D.indent 4 $ D.reflow message 46 | ] 47 | ] 48 | 49 | BadJson path doc -> 50 | Help.jsonReport "UNEXPECTED JSON" (Just path) doc 51 | 52 | BadZipData -> 53 | Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:" 54 | [ urlDoc 55 | , D.reflow $ 56 | "If it is a transient issue, it should be fixed if you try this\ 57 | \ again. If it seems like an Elm problem, please report it though!" 58 | ] 59 | 60 | BadZipSha expectedHash actualHash -> 61 | Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:" 62 | [ urlDoc 63 | , D.reflow "I check the hash the zip, and it seems off:" 64 | , D.vcat $ map D.fromString $ 65 | [ " Expected: " ++ expectedHash 66 | , " Actual: " ++ actualHash 67 | ] 68 | , D.reflow $ 69 | "This usually means that the package author moved the version\ 70 | \ tag, so report it to them and see if that is the issue. Folks\ 71 | \ on Elm slack can probably help as well." 72 | ] 73 | 74 | 75 | 76 | -- BAD JSON 77 | 78 | 79 | data BadJson 80 | = BadNewPkg Text.Text 81 | | BadAllPkg Text.Text String 82 | | BadAllVsn Text.Text 83 | 84 | 85 | badJsonToDocs :: BadJson -> [D.Doc] 86 | badJsonToDocs badJson = 87 | case badJson of 88 | BadNewPkg txt -> 89 | ["I","ran","into",D.red (D.fromString (show txt)) <> "," 90 | ,"but","I","need","entries","like" 91 | ,D.green "\"elm/core@6.0.0\"" <> "." 92 | ] 93 | 94 | BadAllPkg txt suggestion -> 95 | ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name." 96 | ] 97 | ++ map D.fromString (words suggestion) 98 | 99 | BadAllVsn txt -> 100 | ["You","provided",D.red (D.fromString (show txt)) 101 | ,"which","is","not","a","valid","version.","I","need","something","like" 102 | ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "." 103 | ] 104 | 105 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit/Init.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Exit.Init 3 | ( Exit(..) 4 | , toReport 5 | ) 6 | where 7 | 8 | 9 | import qualified Reporting.Doc as D 10 | import qualified Reporting.Exit.Help as Help 11 | 12 | import qualified Elm.Package as Pkg 13 | 14 | 15 | 16 | -- EXITS 17 | 18 | 19 | data Exit 20 | = NoSolution [Pkg.Name] 21 | | AlreadyStarted 22 | 23 | 24 | 25 | -- TO REPORT 26 | 27 | 28 | toReport :: Exit -> Help.Report 29 | toReport exit = 30 | case exit of 31 | NoSolution pkgs -> 32 | Help.report "NO SOLUTION" Nothing 33 | "I tried to create an elm.json with the following direct dependencies:" 34 | [ D.indent 4 $ D.vcat $ 35 | map (D.dullyellow . D.fromString . Pkg.toString) pkgs 36 | , D.reflow $ 37 | "I could not find compatible versions though! This should not happen, so please\ 38 | \ ask around one of the community forums to learn\ 39 | \ what is going on!" 40 | ] 41 | 42 | AlreadyStarted -> 43 | Help.report "EXISTING PROJECT" Nothing 44 | "You already have an elm.json file, so there is nothing for me to initialize!" 45 | [ D.fillSep 46 | ["Maybe",D.green (D.fromString (D.makeLink "init")),"can","help" 47 | ,"you","figure","out","what","to","do","next?" 48 | ] 49 | ] 50 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit/Install.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Exit.Install 3 | ( Exit(..) 4 | , toReport 5 | ) 6 | where 7 | 8 | 9 | import qualified Elm.Compiler as Compiler 10 | import qualified Elm.Package as Pkg 11 | import qualified Reporting.Doc as D 12 | import qualified Reporting.Exit.Help as Help 13 | 14 | 15 | 16 | -- EXITS 17 | 18 | 19 | data Exit 20 | = NoArgs FilePath 21 | | NoSolution [Pkg.Name] 22 | 23 | 24 | 25 | -- TO REPORT 26 | 27 | 28 | toReport :: Exit -> Help.Report 29 | toReport exit = 30 | case exit of 31 | NoArgs elmHome -> 32 | Help.report "INSTALL WHAT?" Nothing 33 | "I am expecting commands like:" 34 | [ D.green $ D.indent 4 $ D.vcat $ 35 | [ "elm install elm/http" 36 | , "elm install elm/json" 37 | , "elm install elm/random" 38 | ] 39 | , D.toFancyHint 40 | ["In","JavaScript","folks","run","`npm install`","to","start","projects." 41 | ,"\"Gotta","download","everything!\"","But","why","download","packages" 42 | ,"again","and","again?","Instead,","Elm","caches","packages","in" 43 | ,D.dullyellow (D.fromString elmHome) 44 | ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine." 45 | ,"Elm","projects","check","that","cache","before","trying","the","internet." 46 | ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it" 47 | ,"easier","to","work","offline.","As","a","result" 48 | ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json," 49 | ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies" 50 | ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?" 51 | ] 52 | ] 53 | 54 | NoSolution badPackages -> 55 | case badPackages of 56 | [] -> 57 | Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") 58 | "This usually happens if you try to modify dependency constraints by\ 59 | \ hand. I recommend deleting any dependency you added recently (or all\ 60 | \ of them if things are bad) and then adding them again with:" 61 | [ D.indent 4 $ D.green "elm install" 62 | , D.reflow $ 63 | "And do not be afaid to ask for help on Slack if you get stuck!" 64 | ] 65 | 66 | _:_ -> 67 | Help.report "OLD DEPENDENCIES" (Just "elm.json") 68 | ( "The following packages do not work with Elm " ++ Pkg.versionToString Compiler.version ++ " right now:" 69 | ) 70 | [ D.indent 4 $ D.vcat $ map (D.red . D.fromString . Pkg.toString) badPackages 71 | , D.reflow $ 72 | "This may be because it is not upgraded yet. It may be because a\ 73 | \ better solution came along, so there was no need to upgrade it.\ 74 | \ Etc. Try asking around on Slack to learn more about the topic." 75 | , D.toSimpleNote 76 | "Whatever the case, please be kind to the relevant package authors! Having\ 77 | \ friendly interactions with users is great motivation, and conversely, getting\ 78 | \ berated by strangers on the internet sucks your soul dry. Furthermore, package\ 79 | \ authors are humans with families, friends, jobs, vacations, responsibilities,\ 80 | \ goals, etc. They face obstacles outside of their technical work you will never\ 81 | \ know about, so please assume the best and try to be patient and supportive!" 82 | ] 83 | -------------------------------------------------------------------------------- /builder/src/Reporting/Exit/Make.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Exit.Make 3 | ( Exit(..) 4 | , toReport 5 | ) 6 | where 7 | 8 | 9 | import qualified Elm.Compiler.Module as Module 10 | import qualified Reporting.Doc as D 11 | import qualified Reporting.Exit.Help as Help 12 | 13 | 14 | 15 | -- EXITS 16 | 17 | 18 | data Exit 19 | = CannotMakeNothing 20 | | CannotOptimizeDebugValues Module.Raw [Module.Raw] 21 | | CannotOptimizeAndDebug 22 | 23 | 24 | 25 | -- TO REPORT 26 | 27 | 28 | toReport :: Exit -> Help.Report 29 | toReport exit = 30 | case exit of 31 | CannotMakeNothing -> 32 | Help.report "NO INPUT" Nothing 33 | "What should I make though? I need more information, like:" 34 | [ D.vcat 35 | [ D.indent 4 $ D.green "elm make src/Main.elm" 36 | , D.indent 4 $ D.green "elm make src/This.elm src/That.elm" 37 | ] 38 | , D.reflow 39 | "However many files you give, I will create one JS file out of them." 40 | ] 41 | 42 | CannotOptimizeDebugValues m ms -> 43 | Help.report "DEBUG REMNANTS" Nothing 44 | "There are uses of the `Debug` module in the following modules:" 45 | [ D.indent 4 $ D.red $ D.vcat $ map (D.fromString . Module.nameToString) (m:ms) 46 | , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!" 47 | , D.toSimpleNote $ 48 | "The issue is that --optimize strips out info needed by `Debug` functions.\ 49 | \ Here are two examples:" 50 | , D.indent 4 $ D.reflow $ 51 | "(1) It shortens record field names. This makes the generated JavaScript is\ 52 | \ smaller, but `Debug.toString` cannot know the real field names anymore." 53 | , D.indent 4 $ D.reflow $ 54 | "(2) Values like `type Height = Height Float` are unboxed. This reduces\ 55 | \ allocation, but it also means that `Debug.toString` cannot tell if it is\ 56 | \ looking at a `Height` or `Float` value." 57 | , D.reflow $ 58 | "There are a few other cases like that, and it will be much worse once we start\ 59 | \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\ 60 | \ resulting in unpredictable behavior. I hope that clarifies why this restriction\ 61 | \ exists!" 62 | ] 63 | 64 | CannotOptimizeAndDebug -> 65 | Help.docReport "CLASHING FLAGS" Nothing 66 | ( D.fillSep 67 | ["I","cannot","compile","with",D.red "--optimize","and" 68 | ,D.red "--debug","at","the","same","time." 69 | ] 70 | ) 71 | [ D.reflow 72 | "I need to take away information to optimize things, and I need to\ 73 | \ add information to add the debugger. It is impossible to do both\ 74 | \ at once, so pick just one of those flags." 75 | ] -------------------------------------------------------------------------------- /builder/src/Reporting/Progress.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Reporting.Progress 3 | ( Reporter(..) 4 | , makeReporter 5 | , silentReporter 6 | , Msg(..) 7 | , Progress(..) 8 | , Outcome(..) 9 | , PublishPhase(..) 10 | , BumpPhase(..) 11 | ) 12 | where 13 | 14 | 15 | import Control.Concurrent.Chan (Chan, writeChan) 16 | import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar) 17 | import qualified Elm.Compiler.Module as Module 18 | import Deps.Diff (Magnitude) 19 | import Elm.Package (Name, Version) 20 | import qualified Reporting.Doc as D 21 | import Reporting.Exit (Exit) 22 | 23 | 24 | 25 | -- REPORTER 26 | 27 | 28 | data Reporter = 29 | Reporter 30 | { _tell :: Progress -> IO () 31 | , _ask :: D.Doc -> IO Bool 32 | , _end :: Maybe Exit -> IO () 33 | } 34 | 35 | 36 | makeReporter :: Chan Msg -> MVar () -> Reporter 37 | makeReporter chan mvar = 38 | let 39 | tell progress = 40 | writeChan chan (Progress progress) 41 | 42 | ask doc = 43 | do var <- newEmptyMVar 44 | writeChan chan (Ask doc var) 45 | readMVar var 46 | 47 | end maybeError = 48 | do writeChan chan (End maybeError) 49 | readMVar mvar 50 | in 51 | Reporter tell ask end 52 | 53 | 54 | silentReporter :: Reporter 55 | silentReporter = 56 | Reporter 57 | (\_ -> return ()) 58 | (\_ -> return True) 59 | (\_ -> return ()) 60 | 61 | 62 | 63 | -- MESSAGES 64 | 65 | 66 | data Msg 67 | = Progress Progress 68 | | Ask D.Doc (MVar Bool) 69 | | End (Maybe Exit) 70 | 71 | 72 | data Progress 73 | -- download packages 74 | = DownloadSkip 75 | | DownloadStart [(Name, Version)] 76 | | DownloadPkgStart Name Version 77 | | DownloadPkgEnd Name Version Outcome 78 | | DownloadEnd Outcome 79 | 80 | -- build dependencies 81 | | BuildDepsStart Int 82 | | BuildDepsProgress 83 | | BuildDepsEnd 84 | 85 | -- compile files 86 | | CompileStart Int 87 | | CompileFileStart Module.Raw 88 | | CompileFileEnd Module.Raw Outcome 89 | | CompileEnd 90 | 91 | -- publish 92 | | PublishStart Name Version (Maybe [Version]) 93 | | PublishCheckBump Version BumpPhase 94 | | PublishProgress PublishPhase (Maybe Outcome) 95 | | PublishEnd 96 | 97 | -- solver 98 | | UnableToLoadLatestPackages 99 | 100 | 101 | data Outcome = Good | Bad 102 | 103 | 104 | data PublishPhase 105 | = CheckReadme 106 | | CheckLicense 107 | | CheckTag Version 108 | | CheckDownload 109 | | CheckBuild 110 | | CheckChanges 111 | 112 | 113 | data BumpPhase 114 | = StatedVersion 115 | | GoodStart 116 | | GoodBump Version Magnitude 117 | | BadBump 118 | -------------------------------------------------------------------------------- /builder/src/Reporting/Progress/Bar.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Reporting.Progress.Bar 3 | ( render 4 | , clear 5 | ) 6 | where 7 | 8 | 9 | 10 | -- PROGRESS BAR 11 | 12 | 13 | width :: Float 14 | width = 15 | 50.0 16 | 17 | 18 | render :: Int -> Int -> Int -> String 19 | render successes failures total = 20 | let 21 | numDone = 22 | successes + failures 23 | 24 | fraction = 25 | fromIntegral numDone / fromIntegral total 26 | 27 | unitsDone = 28 | truncate (fraction * width) 29 | 30 | unitsLeft = 31 | truncate width - unitsDone 32 | in 33 | "\r[" 34 | ++ replicate unitsDone '=' 35 | ++ replicate unitsLeft ' ' 36 | ++ "] - " 37 | ++ show numDone ++ " / " ++ show total 38 | 39 | 40 | clear :: String 41 | clear = 42 | '\r' : replicate (length (render 49999 50000 99999)) ' ' ++ "\r" 43 | 44 | -------------------------------------------------------------------------------- /builder/src/Reporting/Progress/Json.hs: -------------------------------------------------------------------------------- 1 | module Reporting.Progress.Json 2 | ( reporter 3 | ) 4 | where 5 | 6 | 7 | import qualified Data.ByteString.Builder as B 8 | import System.IO (stderr) 9 | 10 | import qualified Reporting.Exit as Exit 11 | import qualified Reporting.Progress as Progress 12 | import qualified Json.Encode as Encode 13 | 14 | 15 | 16 | -- REPORTER 17 | 18 | 19 | reporter :: Progress.Reporter 20 | reporter = 21 | Progress.Reporter 22 | (\_ -> return ()) 23 | (\_ -> return True) 24 | end 25 | 26 | 27 | end :: Maybe Exit.Exit -> IO () 28 | end maybeExit = 29 | case maybeExit of 30 | Just exit -> 31 | B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson exit)) 32 | 33 | Nothing -> 34 | return () 35 | -------------------------------------------------------------------------------- /builder/src/Reporting/Progress/Repl.hs: -------------------------------------------------------------------------------- 1 | module Reporting.Progress.Repl 2 | ( reporter 3 | ) 4 | where 5 | 6 | 7 | import qualified Reporting.Exit as Exit 8 | import qualified Reporting.Progress as Progress 9 | 10 | 11 | 12 | -- REPORTER 13 | 14 | 15 | reporter :: Progress.Reporter 16 | reporter = 17 | Progress.Reporter 18 | (\_ -> return ()) 19 | (\_ -> return True) 20 | end 21 | 22 | 23 | end :: Maybe Exit.Exit -> IO () 24 | end maybeExit = 25 | case maybeExit of 26 | Just exit -> 27 | Exit.toStderr exit 28 | 29 | Nothing -> 30 | return () 31 | -------------------------------------------------------------------------------- /builder/src/Stuff/Paths.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Stuff.Paths 3 | ( docs 4 | , summary 5 | , prepublishDir 6 | , removeStuff 7 | , elmi 8 | , elmo 9 | , moduleDocs 10 | , temp 11 | ) 12 | where 13 | 14 | 15 | import Control.Monad.Trans (liftIO) 16 | import qualified System.Directory as Dir 17 | import System.FilePath ((), (<.>)) 18 | 19 | import qualified Elm.Compiler as Compiler 20 | import qualified Elm.Compiler.Module as Module 21 | import qualified Elm.Package as Pkg 22 | import qualified Reporting.Task as Task 23 | 24 | 25 | 26 | -- PATHS 27 | 28 | 29 | stuff :: FilePath 30 | stuff = 31 | "elm-stuff" Pkg.versionToString Compiler.version 32 | 33 | 34 | docs :: FilePath 35 | docs = 36 | stuff "docs.json" 37 | 38 | 39 | summary :: FilePath 40 | summary = 41 | stuff "summary.dat" 42 | 43 | 44 | prepublishDir :: FilePath 45 | prepublishDir = 46 | stuff "prepublish" 47 | 48 | 49 | 50 | -- REMOVE STUFF 51 | 52 | 53 | removeStuff :: FilePath -> Task.Task_ e () 54 | removeStuff root = 55 | liftIO $ 56 | do let dir = root "elm-stuff" 57 | exists <- Dir.doesDirectoryExist dir 58 | if exists 59 | then Dir.removeDirectoryRecursive dir 60 | else return () 61 | 62 | 63 | 64 | -- ELMI and ELMO 65 | 66 | 67 | elmi :: FilePath -> Module.Raw -> FilePath 68 | elmi root name = 69 | toArtifactPath root name "elmi" 70 | 71 | 72 | elmo :: FilePath -> Module.Raw -> FilePath 73 | elmo root name = 74 | toArtifactPath root name "elmo" 75 | 76 | 77 | moduleDocs :: FilePath -> Module.Raw -> FilePath 78 | moduleDocs root name = 79 | toArtifactPath root name "json" 80 | 81 | 82 | toArtifactPath :: FilePath -> Module.Raw -> String -> FilePath 83 | toArtifactPath root name ext = 84 | root stuff Module.nameToHyphenPath name <.> ext 85 | 86 | 87 | 88 | -- TEMP 89 | 90 | 91 | temp :: String -> FilePath 92 | temp ext = 93 | stuff "temp" <.> ext 94 | -------------------------------------------------------------------------------- /builder/src/Stuff/Verify.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Stuff.Verify 3 | ( verify 4 | ) 5 | where 6 | 7 | 8 | import Control.Monad (liftM2, liftM4) 9 | import Data.Binary 10 | import Data.Map (Map) 11 | 12 | import qualified Elm.Compiler.Module as Module 13 | import Elm.Package (Name, Version) 14 | 15 | import qualified Deps.Verify as Verify 16 | import qualified Elm.Project.Json as Project 17 | import qualified Elm.Project.Constraint as Con 18 | import qualified Elm.Project.Summary as Summary 19 | import qualified File.IO as IO 20 | import qualified Reporting.Task as Task 21 | import qualified Stuff.Paths as Path 22 | 23 | 24 | 25 | -- VERIFY 26 | 27 | 28 | verify :: FilePath -> Project.Project -> Task.Task Summary.Summary 29 | verify root project = 30 | do exists <- IO.exists Path.summary 31 | if exists 32 | then 33 | do (MiniSummary deps exposed ifaces graph) <- IO.readBinary Path.summary 34 | if isValidMiniSummary deps project 35 | then 36 | return (Summary.Summary root project exposed ifaces graph) 37 | else 38 | do IO.remove Path.summary 39 | cacheSummary root project 40 | else 41 | cacheSummary root project 42 | 43 | 44 | cacheSummary :: FilePath -> Project.Project -> Task.Task Summary.Summary 45 | cacheSummary root project = 46 | do summary@(Summary.Summary _ _ exposed ifaces graph) <- Verify.verify root project 47 | IO.writeBinary Path.summary (MiniSummary (getDeps project) exposed ifaces graph) 48 | return summary 49 | 50 | 51 | 52 | -- MINI SUMMARY 53 | 54 | 55 | data MiniSummary = 56 | MiniSummary 57 | { _deps :: ProjectDeps 58 | , _exposed :: Summary.ExposedModules 59 | , _ifaces :: Module.Interfaces 60 | , _depsGraph :: Summary.DepsGraph 61 | } 62 | 63 | 64 | data ProjectDeps 65 | = App (Map Name Version) (Map Name Version) (Map Name Version) (Map Name Version) 66 | | Pkg (Map Name Con.Constraint) (Map Name Con.Constraint) 67 | 68 | 69 | getDeps :: Project.Project -> ProjectDeps 70 | getDeps project = 71 | case project of 72 | Project.App (Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) -> 73 | App depsDirect depsTrans testDirect testTrans 74 | 75 | Project.Pkg (Project.PkgInfo _ _ _ _ _ direct test _) -> 76 | Pkg direct test 77 | 78 | 79 | isValidMiniSummary :: ProjectDeps -> Project.Project -> Bool 80 | isValidMiniSummary deps project = 81 | case deps of 82 | App a b c d -> 83 | case project of 84 | Project.Pkg _ -> 85 | False 86 | 87 | Project.App (Project.AppInfo _ _ a2 b2 c2 d2) -> 88 | a == a2 && b == b2 && c == c2 && d == d2 89 | 90 | Pkg a b -> 91 | case project of 92 | Project.Pkg (Project.PkgInfo _ _ _ _ _ a2 b2 _) -> 93 | a == a2 && b == b2 94 | 95 | Project.App _ -> 96 | False 97 | 98 | 99 | 100 | -- BINARY 101 | 102 | 103 | instance Binary MiniSummary where 104 | get = liftM4 MiniSummary get get get get 105 | put (MiniSummary a b c d) = put a >> put b >> put c >> put d 106 | 107 | 108 | 109 | instance Binary ProjectDeps where 110 | put deps = 111 | case deps of 112 | App a b c d -> putWord8 0 >> put a >> put b >> put c >> put d 113 | Pkg a b -> putWord8 1 >> put a >> put b 114 | 115 | get = 116 | do n <- getWord8 117 | case n of 118 | 0 -> liftM4 App get get get get 119 | 1 -> liftM2 Pkg get get 120 | _ -> error "binary encoding of ProjectDeps was corrupted" -------------------------------------------------------------------------------- /compiler/src/AST/Module/Name.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module AST.Module.Name 4 | ( Canonical(..) 5 | , basics, char, string 6 | , maybe, result, list, array, dict, tuple 7 | , platform, cmd, sub 8 | , virtualDom, debug, bitwise 9 | , jsonDecode, jsonEncode 10 | , webgl, texture, vector2, vector3, vector4, matrix4 11 | , isKernel, getKernel, canonicalIsKernel 12 | ) 13 | where 14 | 15 | 16 | import Prelude hiding (maybe) 17 | import Control.Monad (liftM2) 18 | import Data.Binary 19 | 20 | import qualified Elm.Name as N 21 | import qualified Elm.Package as Pkg 22 | 23 | 24 | 25 | -- NAMES 26 | 27 | 28 | data Canonical = 29 | Canonical 30 | { _package :: !Pkg.Name 31 | , _module :: !N.Name 32 | } 33 | deriving (Ord) 34 | 35 | 36 | instance Eq Canonical where 37 | (==) (Canonical pkg home) (Canonical pkg' home') = 38 | home == home' && pkg == pkg' 39 | 40 | 41 | 42 | -- PRIMITIVES 43 | 44 | 45 | {-# NOINLINE basics #-} 46 | basics :: Canonical 47 | basics = Canonical Pkg.core "Basics" 48 | 49 | 50 | {-# NOINLINE char #-} 51 | char :: Canonical 52 | char = Canonical Pkg.core N.char 53 | 54 | 55 | {-# NOINLINE string #-} 56 | string :: Canonical 57 | string = Canonical Pkg.core N.string 58 | 59 | 60 | 61 | -- CONTAINERS 62 | 63 | 64 | {-# NOINLINE maybe #-} 65 | maybe :: Canonical 66 | maybe = Canonical Pkg.core N.maybe 67 | 68 | 69 | {-# NOINLINE result #-} 70 | result :: Canonical 71 | result = Canonical Pkg.core N.result 72 | 73 | 74 | {-# NOINLINE list #-} 75 | list :: Canonical 76 | list = Canonical Pkg.core N.list 77 | 78 | 79 | {-# NOINLINE array #-} 80 | array :: Canonical 81 | array = Canonical Pkg.core N.array 82 | 83 | 84 | {-# NOINLINE dict #-} 85 | dict :: Canonical 86 | dict = Canonical Pkg.core N.dict 87 | 88 | 89 | {-# NOINLINE tuple #-} 90 | tuple :: Canonical 91 | tuple = Canonical Pkg.core N.tuple 92 | 93 | 94 | 95 | -- EFFECTS 96 | 97 | 98 | {-# NOINLINE platform #-} 99 | platform :: Canonical 100 | platform = Canonical Pkg.core N.platform 101 | 102 | 103 | {-# NOINLINE cmd #-} 104 | cmd :: Canonical 105 | cmd = Canonical Pkg.core "Platform.Cmd" 106 | 107 | 108 | {-# NOINLINE sub #-} 109 | sub :: Canonical 110 | sub = Canonical Pkg.core "Platform.Sub" 111 | 112 | 113 | 114 | -- MISC 115 | 116 | 117 | {-# NOINLINE virtualDom #-} 118 | virtualDom :: Canonical 119 | virtualDom = Canonical Pkg.virtualDom N.virtualDom 120 | 121 | 122 | {-# NOINLINE debug #-} 123 | debug :: Canonical 124 | debug = Canonical Pkg.core N.debug 125 | 126 | 127 | {-# NOINLINE bitwise #-} 128 | bitwise :: Canonical 129 | bitwise = Canonical Pkg.core N.bitwise 130 | 131 | 132 | 133 | -- JSON 134 | 135 | 136 | {-# NOINLINE jsonDecode #-} 137 | jsonDecode :: Canonical 138 | jsonDecode = Canonical Pkg.json "Json.Decode" 139 | 140 | 141 | {-# NOINLINE jsonEncode #-} 142 | jsonEncode :: Canonical 143 | jsonEncode = Canonical Pkg.json "Json.Encode" 144 | 145 | 146 | 147 | -- WEBGL 148 | 149 | 150 | {-# NOINLINE webgl #-} 151 | webgl :: Canonical 152 | webgl = Canonical Pkg.webgl "WebGL" 153 | 154 | 155 | {-# NOINLINE texture #-} 156 | texture :: Canonical 157 | texture = Canonical Pkg.webgl "WebGL.Texture" 158 | 159 | 160 | {-# NOINLINE vector2 #-} 161 | vector2 :: Canonical 162 | vector2 = Canonical Pkg.linearAlgebra "Math.Vector2" 163 | 164 | 165 | {-# NOINLINE vector3 #-} 166 | vector3 :: Canonical 167 | vector3 = Canonical Pkg.linearAlgebra "Math.Vector3" 168 | 169 | 170 | {-# NOINLINE vector4 #-} 171 | vector4 :: Canonical 172 | vector4 = Canonical Pkg.linearAlgebra "Math.Vector4" 173 | 174 | 175 | {-# NOINLINE matrix4 #-} 176 | matrix4 :: Canonical 177 | matrix4 = Canonical Pkg.linearAlgebra "Math.Matrix4" 178 | 179 | 180 | 181 | -- IS KERNEL 182 | 183 | 184 | isKernel :: N.Name -> Bool 185 | isKernel name = 186 | N.startsWith "Elm.Kernel." name 187 | 188 | 189 | getKernel :: N.Name -> N.Name 190 | getKernel name = 191 | N.drop 11 name 192 | 193 | 194 | canonicalIsKernel :: Canonical -> Bool 195 | canonicalIsKernel (Canonical _ name) = 196 | isKernel name 197 | 198 | 199 | 200 | -- BINARY 201 | 202 | 203 | instance Binary Canonical where 204 | put (Canonical a b) = 205 | put a >> put b 206 | 207 | get = 208 | liftM2 Canonical get get 209 | -------------------------------------------------------------------------------- /compiler/src/AST/Source.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module AST.Source 3 | ( Expr, Expr_(..), VarType(..) 4 | , Decl, Decl_(..) 5 | , Def(..) 6 | , Pattern, Pattern_(..) 7 | , Type, Type_(..) 8 | , Module(..) 9 | , Header(..) 10 | , Docs(..) 11 | , Import(..) 12 | , Effects(..) 13 | , Manager(..) 14 | , Exposing(..) 15 | , Exposed(..) 16 | , Privacy(..) 17 | ) 18 | where 19 | 20 | 21 | import qualified Data.ByteString as B 22 | import Data.Text (Text) 23 | 24 | import qualified AST.Utils.Binop as Binop 25 | import qualified AST.Utils.Shader as Shader 26 | import qualified Elm.Name as N 27 | import qualified Reporting.Annotation as A 28 | import qualified Reporting.Region as R 29 | 30 | 31 | 32 | -- EXPRESSIONS 33 | 34 | 35 | type Expr = A.Located Expr_ 36 | 37 | 38 | data Expr_ 39 | = Chr Text 40 | | Str Text 41 | | Int Int 42 | | Float Double 43 | | Var VarType N.Name 44 | | VarQual VarType N.Name N.Name 45 | | List [Expr] 46 | | Op N.Name 47 | | Negate Expr 48 | | Binops [(Expr, A.Located N.Name)] Expr 49 | | Lambda [Pattern] Expr 50 | | Call Expr [Expr] 51 | | If [(Expr, Expr)] Expr 52 | | Let [A.Located Def] Expr 53 | | Case Expr [(Pattern, Expr)] 54 | | Accessor N.Name 55 | | Access Expr (A.Located N.Name) 56 | | Update (A.Located N.Name) [(A.Located N.Name, Expr)] 57 | | Record [(A.Located N.Name, Expr)] 58 | | Unit 59 | | Tuple Expr Expr [Expr] 60 | | Shader Text Text Shader.Shader 61 | 62 | 63 | data VarType = Value | Ctor 64 | 65 | 66 | 67 | -- DEFINITIONS 68 | 69 | 70 | data Def 71 | = Annotate N.Name Type 72 | | Define (A.Located N.Name) [Pattern] Expr 73 | | Destruct Pattern Expr 74 | 75 | 76 | 77 | -- PATTERN 78 | 79 | 80 | type Pattern = A.Located Pattern_ 81 | 82 | 83 | data Pattern_ 84 | = PAnything 85 | | PVar N.Name 86 | | PRecord [A.Located N.Name] 87 | | PAlias Pattern (A.Located N.Name) 88 | | PUnit 89 | | PTuple Pattern Pattern [Pattern] 90 | | PCtor R.Region N.Name [Pattern] 91 | | PCtorQual R.Region N.Name N.Name [Pattern] 92 | | PList [Pattern] 93 | | PCons Pattern Pattern 94 | | PChr Text 95 | | PStr Text 96 | | PInt Int 97 | 98 | 99 | 100 | -- TYPE 101 | 102 | 103 | type Type = 104 | A.Located Type_ 105 | 106 | 107 | data Type_ 108 | = TLambda Type Type 109 | | TVar N.Name 110 | | TType R.Region N.Name [Type] 111 | | TTypeQual R.Region N.Name N.Name [Type] 112 | | TRecord [(A.Located N.Name, Type)] (Maybe (A.Located N.Name)) 113 | | TUnit 114 | | TTuple Type Type [Type] 115 | 116 | 117 | 118 | -- DECLARATIONS 119 | 120 | 121 | type Decl = A.Located Decl_ 122 | 123 | 124 | data Decl_ 125 | = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Type])] 126 | | Alias (A.Located N.Name) [A.Located N.Name] Type 127 | | Binop N.Name Binop.Associativity Binop.Precedence N.Name 128 | | Port (A.Located N.Name) Type 129 | | Docs Text 130 | | Annotation (A.Located N.Name) Type 131 | | Definition (A.Located N.Name) [Pattern] Expr 132 | 133 | 134 | 135 | -- MODULE 136 | 137 | 138 | data Module decls = 139 | Module (Maybe Header) [Import] decls 140 | 141 | 142 | data Header 143 | = Header 144 | { _name :: N.Name 145 | , _effects :: Effects 146 | , _exports :: A.Located Exposing 147 | , _docs :: Docs 148 | } 149 | 150 | 151 | data Import = 152 | Import 153 | { _import :: A.Located N.Name 154 | , _alias :: Maybe N.Name 155 | , _exposing :: Exposing 156 | } 157 | 158 | 159 | data Docs 160 | = NoDocs R.Region 161 | | YesDocs R.Region B.ByteString 162 | 163 | 164 | data Effects 165 | = NoEffects 166 | | Ports R.Region 167 | | Manager R.Region Manager 168 | 169 | 170 | data Manager 171 | = Cmd (A.Located N.Name) 172 | | Sub (A.Located N.Name) 173 | | Fx (A.Located N.Name) (A.Located N.Name) 174 | 175 | 176 | 177 | -- EXPOSING 178 | 179 | 180 | data Exposing 181 | = Open 182 | | Explicit ![A.Located Exposed] 183 | 184 | 185 | data Exposed 186 | = Lower !N.Name 187 | | Upper !N.Name !Privacy 188 | | Operator !N.Name 189 | 190 | 191 | data Privacy 192 | = Public 193 | | Private 194 | -------------------------------------------------------------------------------- /compiler/src/AST/Utils/Binop.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module AST.Utils.Binop 3 | ( Precedence(..) 4 | , Associativity(..) 5 | ) 6 | where 7 | 8 | 9 | import Prelude hiding (Either(..)) 10 | import Control.Monad (liftM) 11 | import Data.Binary 12 | 13 | 14 | 15 | -- BINOP STUFF 16 | 17 | 18 | newtype Precedence = Precedence Int 19 | deriving (Eq, Ord) 20 | 21 | 22 | data Associativity 23 | = Left 24 | | Non 25 | | Right 26 | deriving (Eq) 27 | 28 | 29 | 30 | -- BINARY 31 | 32 | 33 | instance Binary Precedence where 34 | get = 35 | liftM Precedence get 36 | 37 | put (Precedence n) = 38 | put n 39 | 40 | 41 | instance Binary Associativity where 42 | get = 43 | do n <- getWord8 44 | return $ 45 | case n of 46 | 0 -> Left 47 | 1 -> Non 48 | 2 -> Right 49 | _ -> error "Error reading valid associativity from serialized string" 50 | 51 | put assoc = 52 | putWord8 $ 53 | case assoc of 54 | Left -> 0 55 | Non -> 1 56 | Right -> 2 57 | -------------------------------------------------------------------------------- /compiler/src/AST/Utils/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module AST.Utils.Shader 3 | ( Shader(..) 4 | , Type(..) 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.Map as Map 10 | import qualified Elm.Name as N 11 | 12 | 13 | 14 | -- SHADERS 15 | 16 | 17 | data Shader = 18 | Shader 19 | { _attribute :: Map.Map N.Name Type 20 | , _uniform :: Map.Map N.Name Type 21 | , _varying :: Map.Map N.Name Type 22 | } 23 | 24 | 25 | 26 | -- GL TYPES 27 | 28 | 29 | data Type 30 | = Int 31 | | Float 32 | | V2 33 | | V3 34 | | V4 35 | | M4 36 | | Texture 37 | -------------------------------------------------------------------------------- /compiler/src/AST/Utils/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module AST.Utils.Type 4 | ( delambda 5 | , dealias 6 | , deepDealias 7 | , iteratedDealias 8 | ) 9 | where 10 | 11 | 12 | import qualified Data.Map as Map 13 | 14 | import AST.Canonical (Type(..), AliasType(..), FieldType(..)) 15 | import qualified Elm.Name as N 16 | 17 | 18 | 19 | -- DELAMBDA 20 | 21 | 22 | delambda :: Type -> [Type] 23 | delambda tipe = 24 | case tipe of 25 | TLambda arg result -> 26 | arg : delambda result 27 | 28 | _ -> 29 | [tipe] 30 | 31 | 32 | 33 | -- DEALIAS 34 | 35 | 36 | dealias :: [(N.Name, Type)] -> AliasType -> Type 37 | dealias args aliasType = 38 | case aliasType of 39 | Holey tipe -> 40 | dealiasHelp (Map.fromList args) tipe 41 | 42 | Filled tipe -> 43 | tipe 44 | 45 | 46 | dealiasHelp :: Map.Map N.Name Type -> Type -> Type 47 | dealiasHelp typeTable tipe = 48 | case tipe of 49 | TLambda a b -> 50 | TLambda 51 | (dealiasHelp typeTable a) 52 | (dealiasHelp typeTable b) 53 | 54 | TVar x -> 55 | Map.findWithDefault tipe x typeTable 56 | 57 | TRecord fields ext -> 58 | TRecord (Map.map (dealiasField typeTable) fields) ext 59 | 60 | TAlias home name args t' -> 61 | TAlias home name (map (fmap (dealiasHelp typeTable)) args) t' 62 | 63 | TType home name args -> 64 | TType home name (map (dealiasHelp typeTable) args) 65 | 66 | TUnit -> 67 | TUnit 68 | 69 | TTuple a b maybeC -> 70 | TTuple 71 | (dealiasHelp typeTable a) 72 | (dealiasHelp typeTable b) 73 | (fmap (dealiasHelp typeTable) maybeC) 74 | 75 | 76 | dealiasField :: Map.Map N.Name Type -> FieldType -> FieldType 77 | dealiasField typeTable (FieldType index tipe) = 78 | FieldType index (dealiasHelp typeTable tipe) 79 | 80 | 81 | 82 | -- DEEP DEALIAS 83 | 84 | 85 | deepDealias :: Type -> Type 86 | deepDealias tipe = 87 | case tipe of 88 | TLambda a b -> 89 | TLambda (deepDealias a) (deepDealias b) 90 | 91 | TVar _ -> 92 | tipe 93 | 94 | TRecord fields ext -> 95 | TRecord (Map.map deepDealiasField fields) ext 96 | 97 | TAlias _ _ args tipe' -> 98 | deepDealias (dealias args tipe') 99 | 100 | TType home name args -> 101 | TType home name (map deepDealias args) 102 | 103 | TUnit -> 104 | TUnit 105 | 106 | TTuple a b c -> 107 | TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c) 108 | 109 | 110 | deepDealiasField :: FieldType -> FieldType 111 | deepDealiasField (FieldType index tipe) = 112 | FieldType index (deepDealias tipe) 113 | 114 | 115 | 116 | -- ITERATED DEALIAS 117 | 118 | 119 | iteratedDealias :: Type -> Type 120 | iteratedDealias tipe = 121 | case tipe of 122 | TAlias _ _ args realType -> 123 | iteratedDealias (dealias args realType) 124 | 125 | _ -> 126 | tipe 127 | -------------------------------------------------------------------------------- /compiler/src/AST/Valid.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module AST.Valid 4 | ( Expr, Expr_(..) 5 | , Def(..) 6 | , Module(..) 7 | , Decl(..) 8 | , Union(..) 9 | , Alias(..) 10 | , Binop(..) 11 | , Effects(..) 12 | , Port(..) 13 | , Manager(..) 14 | , defaultModule 15 | ) 16 | where 17 | 18 | 19 | import qualified Data.Map as Map 20 | import Data.Text (Text) 21 | 22 | import qualified AST.Utils.Binop as Binop 23 | import qualified AST.Source as Src 24 | import qualified AST.Utils.Shader as Shader 25 | import qualified Elm.Name as N 26 | import qualified Reporting.Annotation as A 27 | import qualified Reporting.Region as R 28 | 29 | 30 | 31 | -- EXPRESSIONS 32 | 33 | 34 | type Expr = A.Located Expr_ 35 | 36 | 37 | data Expr_ 38 | = Chr Text 39 | | Str Text 40 | | Int Int 41 | | Float Double 42 | | Var Src.VarType N.Name 43 | | VarQual Src.VarType N.Name N.Name 44 | | List [Expr] 45 | | Op N.Name 46 | | Negate Expr 47 | | Binops [(Expr, A.Located N.Name)] Expr 48 | | Lambda [Src.Pattern] Expr 49 | | Call Expr [Expr] 50 | | If [(Expr, Expr)] Expr 51 | | Let [Def] Expr 52 | | Case Expr [(Src.Pattern, Expr)] 53 | | Accessor N.Name 54 | | Access Expr (A.Located N.Name) 55 | | Update (A.Located N.Name) [(A.Located N.Name, Expr)] 56 | | Record [(A.Located N.Name, Expr)] 57 | | Unit 58 | | Tuple Expr Expr [Expr] 59 | | Shader Text Text Shader.Shader 60 | 61 | 62 | 63 | -- DEFINITIONS 64 | 65 | 66 | data Def 67 | = Define R.Region (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type) 68 | | Destruct R.Region Src.Pattern Expr 69 | 70 | 71 | 72 | -- MODULE 73 | 74 | 75 | data Module = 76 | Module 77 | { _name :: N.Name 78 | , _overview :: Src.Docs 79 | , _docs :: Map.Map N.Name Text 80 | , _exports :: A.Located Src.Exposing 81 | , _imports :: [Src.Import] 82 | , _decls :: [A.Located Decl] 83 | , _unions :: [Union] 84 | , _aliases :: [Alias] 85 | , _binop :: [Binop] 86 | , _effects :: Effects 87 | } 88 | 89 | 90 | data Decl = Decl (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type) 91 | data Union = Union R.Region (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Src.Type])] 92 | data Alias = Alias R.Region (A.Located N.Name) [A.Located N.Name] Src.Type 93 | data Binop = Binop N.Name Binop.Associativity Binop.Precedence N.Name 94 | 95 | 96 | data Effects 97 | = NoEffects 98 | | Ports [Port] 99 | | Manager R.Region Manager 100 | 101 | 102 | data Manager 103 | = Cmd (A.Located N.Name) 104 | | Sub (A.Located N.Name) 105 | | Fx (A.Located N.Name) (A.Located N.Name) 106 | 107 | 108 | data Port = Port (A.Located N.Name) Src.Type 109 | 110 | 111 | defaultModule :: Map.Map N.Name Text -> [Src.Import] -> [A.Located Decl] -> [Union] -> [Alias] -> [Binop] -> Module 112 | defaultModule docs imports decls unions aliases binop = 113 | Module 114 | { _name = "Main" 115 | , _overview = Src.NoDocs R.one 116 | , _docs = docs 117 | , _exports = A.At R.one Src.Open 118 | , _imports = imports 119 | , _decls = decls 120 | , _unions = unions 121 | , _aliases = aliases 122 | , _binop = binop 123 | , _effects = NoEffects 124 | } 125 | -------------------------------------------------------------------------------- /compiler/src/Canonicalize/Environment/Dups.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Canonicalize.Environment.Dups 4 | ( detect 5 | , checkFields 6 | , checkFields' 7 | , Dict 8 | , none 9 | , one 10 | , insert 11 | , union 12 | , unions 13 | ) 14 | where 15 | 16 | 17 | import qualified Data.Map as Map 18 | 19 | import qualified Data.OneOrMore as OneOrMore 20 | import qualified Elm.Name as N 21 | import qualified Reporting.Annotation as A 22 | import qualified Reporting.Error.Canonicalize as Error 23 | import qualified Reporting.Region as R 24 | import qualified Reporting.Result as Result 25 | 26 | 27 | 28 | -- DUPLICATE TRACKER 29 | 30 | 31 | type Dict value = 32 | Map.Map N.Name (OneOrMore.OneOrMore (Info value)) 33 | 34 | 35 | data Info value = 36 | Info 37 | { _region :: R.Region 38 | , _value :: value 39 | } 40 | 41 | 42 | 43 | -- DETECT 44 | 45 | 46 | type ToError = 47 | N.Name -> R.Region -> R.Region -> Error.Error 48 | 49 | 50 | detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map N.Name a) 51 | detect toError dict = 52 | Map.traverseWithKey (detectHelp toError) dict 53 | 54 | 55 | detectHelp :: ToError -> N.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a 56 | detectHelp toError name values = 57 | case values of 58 | OneOrMore.One (Info _ value) -> 59 | return value 60 | 61 | OneOrMore.More _ _ -> 62 | let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in 63 | Result.throw (toError name r1 r2) 64 | 65 | 66 | 67 | -- CHECK FIELDS 68 | 69 | 70 | checkFields :: [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name a) 71 | checkFields fields = 72 | detect Error.DuplicateField (foldr addField none fields) 73 | 74 | 75 | addField :: (A.Located N.Name, a) -> Dict a -> Dict a 76 | addField (A.At region name, value) dups = 77 | Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups 78 | 79 | 80 | checkFields' :: (R.Region -> a -> b) -> [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name b) 81 | checkFields' toValue fields = 82 | detect Error.DuplicateField (foldr (addField' toValue) none fields) 83 | 84 | 85 | addField' :: (R.Region -> a -> b) -> (A.Located N.Name, a) -> Dict b -> Dict b 86 | addField' toValue (A.At region name, value) dups = 87 | Map.insertWith OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups 88 | 89 | 90 | 91 | -- BUILDING DICTIONARIES 92 | 93 | 94 | none :: Dict a 95 | none = 96 | Map.empty 97 | 98 | 99 | one :: N.Name -> R.Region -> value -> Dict value 100 | one name region value = 101 | Map.singleton name (OneOrMore.one (Info region value)) 102 | 103 | 104 | insert :: N.Name -> R.Region -> a -> Dict a -> Dict a 105 | insert name region value dict = 106 | Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict 107 | 108 | 109 | union :: Dict a -> Dict a -> Dict a 110 | union a b = 111 | Map.unionWith OneOrMore.more a b 112 | 113 | 114 | unions :: [Dict a] -> Dict a 115 | unions dicts = 116 | Map.unionsWith OneOrMore.more dicts 117 | -------------------------------------------------------------------------------- /compiler/src/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} 2 | module Compile 3 | ( DocsFlag(..) 4 | , compile 5 | , Artifacts(..) 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.ByteString as BS 11 | import qualified Data.Map as Map 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified AST.Optimized as Opt 15 | import qualified AST.Module.Name as ModuleName 16 | import qualified Canonicalize.Module as Canonicalize 17 | import qualified Elm.Docs as Docs 18 | import qualified Elm.Interface as I 19 | import qualified Elm.Name as N 20 | import qualified Elm.Package as Pkg 21 | import qualified Nitpick.PatternMatches as PatternMatches 22 | import qualified Optimize.Module as Optimize 23 | import qualified Parse.Parse as Parse 24 | import qualified Reporting.Error as Error 25 | import qualified Reporting.Render.Type.Localizer as L 26 | import qualified Reporting.Result as Result 27 | import qualified Reporting.Warning as Warning 28 | import qualified Type.Constrain.Module as Type 29 | import qualified Type.Solve as Type 30 | 31 | import System.IO.Unsafe (unsafePerformIO) 32 | 33 | 34 | 35 | -- COMPILE 36 | 37 | 38 | type Result i a = 39 | Result.Result i [Warning.Warning] Error.Error a 40 | 41 | 42 | type ImportDict = 43 | Map.Map N.Name ModuleName.Canonical 44 | 45 | 46 | data Artifacts = 47 | Artifacts 48 | { _elmi :: I.Interface 49 | , _elmo :: Opt.Graph 50 | , _docs :: Maybe Docs.Module 51 | } 52 | 53 | 54 | compile :: DocsFlag -> Pkg.Name -> ImportDict -> I.Interfaces -> BS.ByteString -> Result i Artifacts 55 | compile flag pkg importDict interfaces source = 56 | do 57 | valid <- Result.mapError Error.Syntax $ 58 | Parse.program pkg source 59 | 60 | canonical <- Result.mapError Error.Canonicalize $ 61 | Canonicalize.canonicalize pkg importDict interfaces valid 62 | 63 | let localizer = L.fromModule valid -- TODO should this be strict for GC? 64 | 65 | annotations <- 66 | runTypeInference localizer canonical 67 | 68 | () <- 69 | exhaustivenessCheck canonical 70 | 71 | graph <- Result.mapError (Error.Main localizer) $ 72 | Optimize.optimize annotations canonical 73 | 74 | documentation <- 75 | genarateDocs flag canonical 76 | 77 | Result.ok $ 78 | Artifacts 79 | { _elmi = I.fromModule annotations canonical 80 | , _elmo = graph 81 | , _docs = documentation 82 | } 83 | 84 | 85 | 86 | -- TYPE INFERENCE 87 | 88 | 89 | runTypeInference :: L.Localizer -> Can.Module -> Result i (Map.Map N.Name Can.Annotation) 90 | runTypeInference localizer canonical = 91 | case unsafePerformIO (Type.run =<< Type.constrain canonical) of 92 | Right annotations -> 93 | Result.ok annotations 94 | 95 | Left errors -> 96 | Result.throw (Error.Type localizer errors) 97 | 98 | 99 | 100 | -- EXHAUSTIVENESS CHECK 101 | 102 | 103 | exhaustivenessCheck :: Can.Module -> Result i () 104 | exhaustivenessCheck canonical = 105 | case PatternMatches.check canonical of 106 | Left errors -> 107 | Result.throw (Error.Pattern errors) 108 | 109 | Right () -> 110 | Result.ok () 111 | 112 | 113 | 114 | -- DOCUMENTATION 115 | 116 | 117 | data DocsFlag = YesDocs | NoDocs 118 | 119 | 120 | genarateDocs :: DocsFlag -> Can.Module -> Result.Result i w Error.Error (Maybe Docs.Module) 121 | genarateDocs flag modul = 122 | case flag of 123 | NoDocs -> 124 | Result.ok Nothing 125 | 126 | YesDocs -> 127 | Just <$> Docs.fromModule modul 128 | -------------------------------------------------------------------------------- /compiler/src/Data/Bag.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Data.Bag 3 | ( Bag(..) 4 | , empty 5 | , one 6 | , append 7 | , map 8 | , toList 9 | , fromList 10 | ) 11 | where 12 | 13 | 14 | import Prelude hiding (map) 15 | import qualified Data.List as List 16 | 17 | 18 | 19 | -- BAGS 20 | 21 | 22 | data Bag a 23 | = Empty 24 | | One a 25 | | Two (Bag a) (Bag a) 26 | 27 | 28 | 29 | -- HELPERS 30 | 31 | 32 | empty :: Bag a 33 | empty = 34 | Empty 35 | 36 | 37 | one :: a -> Bag a 38 | one = 39 | One 40 | 41 | 42 | append :: Bag a -> Bag a -> Bag a 43 | append left right = 44 | case (left, right) of 45 | (other, Empty) -> 46 | other 47 | 48 | (Empty, other) -> 49 | other 50 | 51 | (_, _) -> 52 | Two left right 53 | 54 | 55 | 56 | -- MAP 57 | 58 | 59 | map :: (a -> b) -> Bag a -> Bag b 60 | map func bag = 61 | case bag of 62 | Empty -> 63 | Empty 64 | 65 | One a -> 66 | One (func a) 67 | 68 | Two left right -> 69 | Two (map func left) (map func right) 70 | 71 | 72 | 73 | -- TO LIST 74 | 75 | 76 | toList :: Bag a -> [a] 77 | toList bag = 78 | toListHelp bag [] 79 | 80 | 81 | toListHelp :: Bag a -> [a] -> [a] 82 | toListHelp bag list = 83 | case bag of 84 | Empty -> 85 | list 86 | 87 | One x -> 88 | x : list 89 | 90 | Two a b -> 91 | toListHelp a (toListHelp b list) 92 | 93 | 94 | 95 | -- FROM LIST 96 | 97 | 98 | fromList :: (a -> b) -> [a] -> Bag b 99 | fromList func list = 100 | case list of 101 | [] -> 102 | Empty 103 | 104 | first : rest -> 105 | List.foldl' (add func) (One (func first)) rest 106 | 107 | 108 | add :: (a -> b) -> Bag b -> a -> Bag b 109 | add func bag value = 110 | Two (One (func value)) bag 111 | -------------------------------------------------------------------------------- /compiler/src/Data/Index.hs: -------------------------------------------------------------------------------- 1 | module Data.Index 2 | ( ZeroBased 3 | , first 4 | , second 5 | , third 6 | , next 7 | , toMachine 8 | , toHuman 9 | , indexedMap 10 | , indexedTraverse 11 | , indexedForA 12 | , VerifiedList(..) 13 | , indexedZipWith 14 | , indexedZipWithA 15 | ) 16 | where 17 | 18 | 19 | import Control.Monad (liftM) 20 | import Data.Binary 21 | 22 | 23 | 24 | -- ZERO BASED 25 | 26 | 27 | newtype ZeroBased = ZeroBased Int 28 | deriving (Eq, Ord) 29 | 30 | 31 | first :: ZeroBased 32 | first = 33 | ZeroBased 0 34 | 35 | 36 | second :: ZeroBased 37 | second = 38 | ZeroBased 1 39 | 40 | 41 | third :: ZeroBased 42 | third = 43 | ZeroBased 2 44 | 45 | 46 | {-# INLINE next #-} 47 | next :: ZeroBased -> ZeroBased 48 | next (ZeroBased i) = 49 | ZeroBased (i + 1) 50 | 51 | 52 | 53 | -- DESTRUCT 54 | 55 | 56 | toMachine :: ZeroBased -> Int 57 | toMachine (ZeroBased index) = 58 | index 59 | 60 | 61 | toHuman :: ZeroBased -> Int 62 | toHuman (ZeroBased index) = 63 | index + 1 64 | 65 | 66 | 67 | -- INDEXED MAP 68 | 69 | 70 | {-# INLINE indexedMap #-} 71 | indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b] 72 | indexedMap func xs = 73 | zipWith func (map ZeroBased [0 .. length xs]) xs 74 | 75 | 76 | {-# INLINE indexedTraverse #-} 77 | indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b] 78 | indexedTraverse func xs = 79 | sequenceA (indexedMap func xs) 80 | 81 | 82 | {-# INLINE indexedForA #-} 83 | indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b] 84 | indexedForA xs func = 85 | sequenceA (indexedMap func xs) 86 | 87 | 88 | 89 | -- VERIFIED/INDEXED ZIP 90 | 91 | 92 | data VerifiedList a 93 | = LengthMatch [a] 94 | | LengthMismatch Int Int 95 | 96 | 97 | indexedZipWith :: (ZeroBased -> a -> b -> c) -> [a] -> [b] -> VerifiedList c 98 | indexedZipWith func listX listY = 99 | indexedZipWithHelp func 0 listX listY [] 100 | 101 | 102 | indexedZipWithHelp :: (ZeroBased -> a -> b -> c) -> Int -> [a] -> [b] -> [c] -> VerifiedList c 103 | indexedZipWithHelp func index listX listY revListZ = 104 | case (listX, listY) of 105 | ([], []) -> 106 | LengthMatch (reverse revListZ) 107 | 108 | (x:xs, y:ys) -> 109 | indexedZipWithHelp func (index + 1) xs ys $ 110 | func (ZeroBased index) x y : revListZ 111 | 112 | (_, _) -> 113 | LengthMismatch (index + length listX) (index + length listY) 114 | 115 | 116 | indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c) 117 | indexedZipWithA func listX listY = 118 | case indexedZipWith func listX listY of 119 | LengthMatch xs -> 120 | LengthMatch <$> sequenceA xs 121 | 122 | LengthMismatch x y -> 123 | pure (LengthMismatch x y) 124 | 125 | 126 | 127 | -- BINARY 128 | 129 | 130 | instance Binary ZeroBased where 131 | get = liftM ZeroBased get 132 | put (ZeroBased n) = put n 133 | -------------------------------------------------------------------------------- /compiler/src/Data/OneOrMore.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Data.OneOrMore 3 | ( OneOrMore(..) 4 | , one 5 | , more 6 | , toList 7 | , map 8 | ) 9 | where 10 | 11 | 12 | import Prelude hiding (map) 13 | 14 | 15 | 16 | -- ONE OR MORE 17 | 18 | 19 | data OneOrMore a 20 | = One a 21 | | More (OneOrMore a) (OneOrMore a) 22 | 23 | 24 | one :: a -> OneOrMore a 25 | one = 26 | One 27 | 28 | 29 | more :: OneOrMore a -> OneOrMore a -> OneOrMore a 30 | more = 31 | More 32 | 33 | 34 | 35 | -- TO LIST 36 | 37 | 38 | toList :: OneOrMore a -> [a] 39 | toList oneOrMore = 40 | toListHelp oneOrMore [] 41 | 42 | 43 | toListHelp :: OneOrMore a -> [a] -> [a] 44 | toListHelp oneOrMore list = 45 | case oneOrMore of 46 | One x -> 47 | x : list 48 | 49 | More a b -> 50 | toListHelp a (toListHelp b list) 51 | 52 | 53 | 54 | -- MAP 55 | 56 | 57 | map :: (a -> b) -> OneOrMore a -> OneOrMore b 58 | map func oneOrMore = 59 | case oneOrMore of 60 | One value -> 61 | One (func value) 62 | 63 | More left right -> 64 | More (map func left) (map func right) 65 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Elm.Compiler 3 | ( version 4 | , Compile.DocsFlag(..) 5 | , Compile.Artifacts(..) 6 | , compile 7 | , Error.Error 8 | , errorsToDoc 9 | , errorsToJson 10 | , Warning.Warning 11 | ) 12 | where 13 | 14 | 15 | import qualified Data.ByteString as BS 16 | import qualified Data.Map as Map 17 | import qualified Data.Text as Text 18 | 19 | import qualified Compile 20 | import qualified Elm.Compiler.Module as M 21 | import qualified Elm.Compiler.Version 22 | import qualified Elm.Package as Pkg 23 | import qualified Json.Encode as Encode 24 | import qualified Reporting.Doc as D 25 | import qualified Reporting.Error as Error 26 | import qualified Reporting.Render.Code as Code 27 | import qualified Reporting.Region as Region 28 | import qualified Reporting.Report as Report 29 | import qualified Reporting.Result as Result 30 | import qualified Reporting.Warning as Warning 31 | 32 | 33 | 34 | -- VERSION 35 | 36 | 37 | version :: Pkg.Version 38 | version = 39 | Elm.Compiler.Version.version 40 | 41 | 42 | 43 | -- COMPILE 44 | 45 | 46 | compile 47 | :: Compile.DocsFlag 48 | -> Pkg.Name 49 | -> Map.Map M.Raw M.Canonical 50 | -> M.Interfaces 51 | -> BS.ByteString 52 | -> ( [Warning.Warning], Either [Error.Error] Compile.Artifacts ) 53 | compile docsFlag pkg importDict interfaces source = 54 | Result.run $ Compile.compile docsFlag pkg importDict interfaces source 55 | 56 | 57 | 58 | -- ERRORS TO DOC 59 | 60 | 61 | errorsToDoc :: FilePath -> Text.Text -> [Error.Error] -> D.Doc 62 | errorsToDoc filePath source errors = 63 | let 64 | reports = 65 | concatMap (Error.toReports (Code.toSource source)) errors 66 | in 67 | D.vcat $ map (Report.toDoc filePath) reports 68 | 69 | 70 | 71 | -- ERRORS TO JSON 72 | 73 | 74 | errorsToJson :: M.Raw -> FilePath -> Text.Text -> [Error.Error] -> Encode.Value 75 | errorsToJson moduleName filePath source errors = 76 | let 77 | reports = 78 | concatMap (Error.toReports (Code.toSource source)) errors 79 | in 80 | Encode.object 81 | [ ("path", Encode.text (Text.pack filePath)) 82 | , ("name", Encode.name moduleName) 83 | , ("problems", Encode.array (map reportToJson reports)) 84 | ] 85 | 86 | 87 | reportToJson :: Report.Report -> Encode.Value 88 | reportToJson (Report.Report title region _sgstns message) = 89 | Encode.object 90 | [ ("title", Encode.text (Text.pack title)) 91 | , ("region", Region.encode region) 92 | , ("message", D.encode message) 93 | ] -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Elm.Compiler.Imports 4 | ( addDefaults 5 | ) 6 | where 7 | 8 | 9 | import qualified AST.Source as Src 10 | import qualified AST.Module.Name as Module 11 | import qualified Elm.Name as N 12 | import qualified Elm.Package as Pkg 13 | import qualified Reporting.Annotation as A 14 | import qualified Reporting.Region as R 15 | 16 | 17 | 18 | -- ADD DEFAULTS 19 | 20 | 21 | addDefaults :: Pkg.Name -> [Src.Import] -> [Src.Import] 22 | addDefaults pkgName imports = 23 | if pkgName == Pkg.core 24 | then imports 25 | else defaults ++ imports 26 | 27 | 28 | 29 | -- DEFAULTS 30 | 31 | 32 | defaults :: [Src.Import] 33 | defaults = 34 | [ import_ Module.basics Nothing Src.Open 35 | , import_ Module.debug Nothing closed 36 | , import_ Module.list Nothing (operator "::") 37 | , import_ Module.maybe Nothing (typeOpen N.maybe) 38 | , import_ Module.result Nothing (typeOpen N.result) 39 | , import_ Module.string Nothing (typeClosed N.string) 40 | , import_ Module.char Nothing (typeClosed N.char) 41 | , import_ Module.tuple Nothing closed 42 | , import_ Module.platform Nothing (typeClosed N.program) 43 | , import_ Module.cmd (Just N.cmd) (typeClosed N.cmd) 44 | , import_ Module.sub (Just N.sub) (typeClosed N.sub) 45 | ] 46 | 47 | 48 | import_ :: Module.Canonical -> Maybe N.Name -> Src.Exposing -> Src.Import 49 | import_ (Module.Canonical _ name) maybeAlias exposing = 50 | Src.Import (A.At R.zero name) maybeAlias exposing 51 | 52 | 53 | 54 | -- EXPOSING 55 | 56 | 57 | closed :: Src.Exposing 58 | closed = 59 | Src.Explicit [] 60 | 61 | 62 | typeOpen :: N.Name -> Src.Exposing 63 | typeOpen name = 64 | Src.Explicit [ A.At R.zero (Src.Upper name Src.Public) ] 65 | 66 | 67 | typeClosed :: N.Name -> Src.Exposing 68 | typeClosed name = 69 | Src.Explicit [ A.At R.zero (Src.Upper name Src.Private) ] 70 | 71 | 72 | operator :: N.Name -> Src.Exposing 73 | operator op = 74 | Src.Explicit [ A.At R.zero (Src.Operator op) ] 75 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Module.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Elm.Compiler.Module 4 | -- interfaces 5 | ( I.Interface 6 | , I.Interfaces 7 | 8 | -- module names 9 | , Raw 10 | , nameToString 11 | , nameToSlashPath 12 | , nameToHyphenPath 13 | , fromHyphenPath 14 | , encode 15 | , decoder 16 | 17 | -- canonical names 18 | , ModuleName.Canonical(..) 19 | ) 20 | where 21 | 22 | 23 | import qualified Data.Char as Char 24 | import qualified Data.List as List 25 | import qualified Data.Text as Text 26 | import System.FilePath (()) 27 | 28 | import qualified AST.Module.Name as ModuleName 29 | import qualified Elm.Interface as I 30 | import qualified Elm.Name as N 31 | import qualified Json.Decode as Decode 32 | import qualified Json.Encode as Encode 33 | 34 | 35 | 36 | -- NAMES 37 | 38 | 39 | type Raw = N.Name 40 | 41 | 42 | nameToString :: Raw -> String 43 | nameToString = 44 | N.toString 45 | 46 | 47 | nameToSlashPath :: Raw -> FilePath 48 | nameToSlashPath name = 49 | List.foldl1 () (map Text.unpack (Text.splitOn "." (N.toText name))) 50 | 51 | 52 | nameToHyphenPath :: Raw -> FilePath 53 | nameToHyphenPath name = 54 | Text.unpack (Text.replace "." "-" (N.toText name)) 55 | 56 | 57 | fromHyphenPath :: Text.Text -> Maybe Raw 58 | fromHyphenPath txt = 59 | if all isGoodChunk (Text.splitOn "-" txt) 60 | then Just (N.fromText (Text.replace "-" "." txt)) 61 | else Nothing 62 | 63 | 64 | 65 | -- JSON 66 | 67 | 68 | encode :: Raw -> Encode.Value 69 | encode = 70 | Encode.name 71 | 72 | 73 | decoder :: Decode.Decoder Text.Text Raw 74 | decoder = 75 | do txt <- Decode.text 76 | let chunks = Text.splitOn "." txt 77 | if all isGoodChunk chunks 78 | then Decode.succeed (N.fromText txt) 79 | else Decode.fail txt 80 | 81 | 82 | isGoodChunk :: Text.Text -> Bool 83 | isGoodChunk chunk = 84 | case Text.uncons chunk of 85 | Nothing -> 86 | False 87 | 88 | Just (first, rest) -> 89 | Char.isUpper first && Text.all isGoodChar rest 90 | 91 | 92 | isGoodChar :: Char -> Bool 93 | isGoodChar char = 94 | Char.isAlphaNum char || char == '_' 95 | 96 | 97 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Objects.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Compiler.Objects 3 | ( JS.Output(..) 4 | , JS.generate 5 | , JS.generateForRepl 6 | , Opt.Graph 7 | , empty 8 | , union 9 | , unions 10 | , Kernel(..) 11 | , fromKernels 12 | ) 13 | where 14 | 15 | 16 | import qualified Data.List as List 17 | import qualified Data.Map as Map 18 | 19 | import qualified AST.Optimized as Opt 20 | import qualified AST.Module.Name as ModuleName 21 | import qualified Elm.Name as N 22 | import qualified Elm.Package as Pkg 23 | import qualified Generate.JavaScript as JS 24 | 25 | 26 | 27 | -- COMBINE GRAPHS 28 | 29 | 30 | {-# NOINLINE empty #-} 31 | empty :: Opt.Graph 32 | empty = 33 | Opt.Graph Map.empty Map.empty Map.empty 34 | 35 | 36 | union :: Opt.Graph -> Opt.Graph -> Opt.Graph 37 | union (Opt.Graph mains1 graph1 fields1) (Opt.Graph mains2 graph2 fields2) = 38 | Opt.Graph 39 | (Map.union mains1 mains2) 40 | (Map.union graph1 graph2) 41 | (Map.union fields1 fields2) 42 | 43 | 44 | unions :: [Opt.Graph] -> Opt.Graph 45 | unions graphs = 46 | case graphs of 47 | [] -> 48 | empty 49 | 50 | g:gs -> 51 | List.foldl' union g gs 52 | 53 | 54 | 55 | -- KERNEL GRAPHS 56 | 57 | 58 | data Kernel = 59 | Kernel 60 | { _client :: Opt.KContent 61 | , _server :: Maybe Opt.KContent 62 | } 63 | 64 | 65 | fromKernels :: Map.Map N.Name Kernel -> Opt.Graph 66 | fromKernels kernels = 67 | Opt.Graph 68 | Map.empty 69 | (Map.mapKeys toGlobal (Map.map toNode kernels)) 70 | (Map.foldl' addKernel Map.empty kernels) 71 | 72 | 73 | 74 | -- KERNEL TO NODES 75 | 76 | 77 | toGlobal :: N.Name -> Opt.Global 78 | toGlobal home = 79 | Opt.Global (ModuleName.Canonical Pkg.kernel (ModuleName.getKernel home)) N.dollar 80 | 81 | 82 | toNode :: Kernel -> Opt.Node 83 | toNode (Kernel client server) = 84 | Opt.Kernel client server 85 | 86 | 87 | 88 | -- KERNEL TO ELM FIELDS 89 | 90 | 91 | addKernel :: Map.Map N.Name Int -> Kernel -> Map.Map N.Name Int 92 | addKernel fields (Kernel client maybeServer) = 93 | addContent (maybe fields (addContent fields) maybeServer) client 94 | 95 | 96 | addContent :: Map.Map N.Name Int -> Opt.KContent -> Map.Map N.Name Int 97 | addContent fields (Opt.KContent chunks _) = 98 | List.foldl' addChunk fields chunks 99 | 100 | 101 | addChunk :: Map.Map N.Name Int -> Opt.KChunk -> Map.Map N.Name Int 102 | addChunk fields chunk = 103 | case chunk of 104 | Opt.ElmField name -> 105 | Map.insertWith (+) name 1 fields 106 | 107 | _ -> 108 | fields 109 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Version.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Compiler.Version (version) where 3 | 4 | import qualified Data.Version as Version 5 | import qualified Paths_elm 6 | import Elm.Package (Version(Version)) 7 | 8 | 9 | 10 | -- VERSION 11 | 12 | 13 | version :: Version 14 | version = 15 | case map fromIntegral (Version.versionBranch Paths_elm.version) of 16 | major : minor : patch : _ -> 17 | Version major minor patch 18 | 19 | [major, minor] -> 20 | Version major minor 0 21 | 22 | [major] -> 23 | Version major 0 0 24 | 25 | [] -> 26 | error "could not detect version of elm-compiler you are using" 27 | 28 | -------------------------------------------------------------------------------- /compiler/src/Elm/Header.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Header 3 | ( Tag(..) 4 | , parse 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.ByteString as B 10 | 11 | import qualified AST.Source as Src 12 | import qualified Elm.Compiler.Module as M 13 | import qualified Elm.Name as N 14 | import qualified Elm.Package as Pkg 15 | import qualified Parse.Primitives as Parser 16 | import qualified Parse.Module as Module 17 | import qualified Reporting.Annotation as A 18 | import qualified Reporting.Error as Error 19 | 20 | 21 | 22 | -- HEADER TAGS 23 | 24 | 25 | data Tag = Normal | Effect | Port 26 | 27 | 28 | 29 | -- PARSE 30 | 31 | 32 | parse :: Pkg.Name -> B.ByteString -> Either Error.Error (Maybe (Tag, M.Raw), [M.Raw]) 33 | parse pkgName sourceCode = 34 | let 35 | headerParser = 36 | Module.module_ pkgName (return ()) 37 | in 38 | case Parser.run headerParser sourceCode of 39 | Right (Src.Module header imports _) -> 40 | Right 41 | ( fmap simplifyHeader header 42 | , map getName imports 43 | ) 44 | 45 | Left err -> 46 | Left (Error.Syntax err) 47 | 48 | 49 | getName :: Src.Import -> N.Name 50 | getName (Src.Import (A.At _ name) _ _) = 51 | name 52 | 53 | 54 | 55 | -- TO HEADER 56 | 57 | 58 | simplifyHeader :: Src.Header -> (Tag, N.Name) 59 | simplifyHeader (Src.Header name effects _ _) = 60 | ( toTag effects, name ) 61 | 62 | 63 | toTag :: Src.Effects -> Tag 64 | toTag effects = 65 | case effects of 66 | Src.NoEffects -> 67 | Normal 68 | 69 | Src.Ports _ -> 70 | Port 71 | 72 | Src.Manager _ _ -> 73 | Effect 74 | -------------------------------------------------------------------------------- /compiler/src/Generate/JavaScript/Mode.hs: -------------------------------------------------------------------------------- 1 | module Generate.JavaScript.Mode 2 | ( Mode(..) 3 | , Target(..) 4 | , debug 5 | , dev 6 | , prod 7 | , isDebug 8 | , isServer 9 | ) 10 | where 11 | 12 | 13 | import qualified Data.List as List 14 | import qualified Data.Map as Map 15 | import qualified Data.Maybe as Maybe 16 | 17 | import qualified AST.Optimized as Opt 18 | import qualified Elm.Interface as I 19 | import qualified Elm.Name as N 20 | import qualified Generate.JavaScript.Name as Name 21 | 22 | 23 | 24 | -- MODE 25 | 26 | 27 | data Mode 28 | = Dev Target (Maybe I.Interfaces) 29 | | Prod Target ShortFieldNames 30 | 31 | 32 | data Target = Client | Server 33 | 34 | 35 | debug :: Target -> I.Interfaces -> Mode 36 | debug target interfaces = 37 | Dev target (Just interfaces) 38 | 39 | 40 | dev :: Target -> Mode 41 | dev target = 42 | Dev target Nothing 43 | 44 | 45 | prod :: Target -> Opt.Graph -> Mode 46 | prod target (Opt.Graph _ _ fieldCounts) = 47 | Prod target (shortenFieldNames fieldCounts) 48 | 49 | 50 | 51 | -- IS DEBUG? 52 | 53 | 54 | isDebug :: Mode -> Bool 55 | isDebug mode = 56 | case mode of 57 | Dev _ mi -> Maybe.isJust mi 58 | Prod _ _ -> False 59 | 60 | 61 | -- IS SERVER? 62 | 63 | 64 | isServer :: Mode -> Bool 65 | isServer mode = 66 | case mode of 67 | Dev target _ -> isServerHelp target 68 | Prod target _ -> isServerHelp target 69 | 70 | 71 | isServerHelp :: Target -> Bool 72 | isServerHelp target = 73 | case target of 74 | Client -> False 75 | Server -> True 76 | 77 | 78 | 79 | -- SHORTEN FIELD NAMES 80 | 81 | 82 | type ShortFieldNames = 83 | Map.Map N.Name Name.Name 84 | 85 | 86 | shortenFieldNames :: Map.Map N.Name Int -> ShortFieldNames 87 | shortenFieldNames frequencies = 88 | Map.foldr addToShortNames Map.empty $ 89 | Map.foldrWithKey addToBuckets Map.empty frequencies 90 | 91 | 92 | addToBuckets :: N.Name -> Int -> Map.Map Int [N.Name] -> Map.Map Int [N.Name] 93 | addToBuckets field frequency buckets = 94 | -- TODO try using an IntMap for buckets 95 | Map.insertWith (++) frequency [field] buckets 96 | 97 | 98 | addToShortNames :: [N.Name] -> ShortFieldNames -> ShortFieldNames 99 | addToShortNames fields shortNames = 100 | List.foldl' addField shortNames fields 101 | 102 | 103 | addField :: ShortFieldNames -> N.Name -> ShortFieldNames 104 | addField shortNames field = 105 | let rename = Name.fromInt (Map.size shortNames) in 106 | Map.insert field rename shortNames 107 | -------------------------------------------------------------------------------- /compiler/src/Parse/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Parse.Parse 3 | ( program 4 | ) 5 | where 6 | 7 | 8 | import qualified Data.ByteString as B 9 | 10 | import qualified AST.Source as Src 11 | import qualified AST.Valid as Valid 12 | import qualified Elm.Package as Pkg 13 | import qualified Parse.Declaration as Decl 14 | import qualified Parse.Module as Module 15 | import qualified Parse.Primitives as P 16 | import qualified Reporting.Error.Syntax as Error 17 | import qualified Reporting.Result as Result 18 | import qualified Validate 19 | 20 | 21 | 22 | -- PROGRAM 23 | 24 | 25 | program :: Pkg.Name -> B.ByteString -> Result.Result i w Error.Error Valid.Module 26 | program pkg src = 27 | let 28 | bodyParser = 29 | if Pkg.isKernel pkg then 30 | chompDeclarations =<< chompInfixes [] 31 | else 32 | chompDeclarations [] 33 | 34 | parser = 35 | Module.module_ pkg bodyParser <* P.endOfFile 36 | in 37 | case P.run parser src of 38 | Right modul -> 39 | Validate.validate modul 40 | 41 | Left syntaxError -> 42 | Result.throw syntaxError 43 | 44 | 45 | 46 | -- CHOMP DECLARATIONS 47 | 48 | 49 | chompDeclarations :: [Src.Decl] -> P.Parser [Src.Decl] 50 | chompDeclarations decls = 51 | do (decl, _, pos) <- Decl.declaration 52 | P.oneOf 53 | [ do P.checkFreshLine pos 54 | chompDeclarations (decl:decls) 55 | , return (reverse (decl:decls)) 56 | ] 57 | 58 | 59 | chompInfixes :: [Src.Decl] -> P.Parser [Src.Decl] 60 | chompInfixes decls = 61 | P.oneOf 62 | [ do decl <- Decl.infix_ 63 | chompInfixes (decl:decls) 64 | , return decls 65 | ] 66 | -------------------------------------------------------------------------------- /compiler/src/Parse/Primitives/Kernel.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} 3 | module Parse.Primitives.Kernel 4 | ( Special(..) 5 | , chunk 6 | ) 7 | where 8 | 9 | 10 | import Prelude hiding (length) 11 | import qualified Data.ByteString.Internal as B 12 | import Data.Word (Word8) 13 | import Foreign.ForeignPtr (ForeignPtr) 14 | 15 | import qualified Elm.Name as N 16 | import Parse.Primitives.Internals (Parser(..), State(..), noError) 17 | import qualified Parse.Primitives.Internals as I 18 | import qualified Parse.Primitives.Variable as Var 19 | 20 | 21 | 22 | -- SPECIAL 23 | 24 | 25 | data Special 26 | = Enum Word8 N.Name 27 | | Prod 28 | | Debug 29 | | Import N.Name 30 | | JsField N.Name 31 | | ElmField N.Name 32 | 33 | 34 | 35 | -- CHUNK 36 | 37 | 38 | chunk :: Parser (B.ByteString, Maybe Special) 39 | chunk = 40 | Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ -> 41 | let 42 | (# maybeSpecial, jsOffset, newOffset, newRow, newCol #) = 43 | chompChunk fp offset terminal row col 44 | 45 | !javascript = B.PS fp offset (jsOffset - offset) 46 | !newState = State fp newOffset terminal indent newRow newCol ctx 47 | in 48 | cok (javascript, maybeSpecial) newState noError 49 | 50 | 51 | 52 | -- CHOMP CHUNK 53 | 54 | 55 | chompChunk :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #) 56 | chompChunk fp offset terminal row col = 57 | if offset >= terminal then 58 | (# Nothing, offset, offset, row, col #) 59 | 60 | else 61 | let !word = I.unsafeIndex fp offset in 62 | if word == 0x5F {- _ -} then 63 | 64 | let 65 | !offset1 = offset + 1 66 | !offset3 = offset + 3 67 | in 68 | if offset3 <= terminal && I.unsafeIndex fp offset1 == 0x5F {- _ -} then 69 | chompSpecial fp offset3 terminal row (col + 3) offset 70 | else 71 | chompChunk fp offset1 terminal row (col + 1) 72 | 73 | else if word == 0x0A {- \n -} then 74 | chompChunk fp (offset + 1) terminal (row + 1) 1 75 | 76 | else 77 | let !newOffset = offset + I.getCharWidth fp offset terminal word in 78 | chompChunk fp newOffset terminal row (col + 1) 79 | 80 | 81 | 82 | -- CHOMP TAG 83 | 84 | 85 | -- relies on external checks in chompChunk 86 | chompSpecial :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #) 87 | chompSpecial fp offset terminal row col jsOffset = 88 | let 89 | (# newOffset, newCol #) = 90 | Var.chompInnerChars fp offset terminal col 91 | 92 | !tagOffset = offset - 1 93 | !word = I.unsafeIndex fp tagOffset 94 | 95 | !special = 96 | if word == 0x24 {- $ -} then 97 | ElmField (N.fromForeignPtr fp offset (newOffset - offset)) 98 | 99 | else 100 | let !name = N.fromForeignPtr fp tagOffset (newOffset - tagOffset) in 101 | if 0x30 <= word && word <= 0x39 then 102 | Enum (fromIntegral (word - 0x30)) name 103 | 104 | else if 0x61 {- a -} <= word && word <= 0x7A {- z -} then 105 | JsField name 106 | 107 | else if name == "DEBUG" then 108 | Debug 109 | 110 | else if name == "PROD" then 111 | Prod 112 | 113 | else 114 | Import name 115 | in 116 | (# Just special, jsOffset, newOffset, row, newCol #) 117 | -------------------------------------------------------------------------------- /compiler/src/Parse/Primitives/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | module Parse.Primitives.Shader 4 | ( block 5 | , failure 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.ByteString.Internal as B 11 | import qualified Data.Text as Text 12 | import qualified Data.Text.Encoding as Text 13 | import Foreign.ForeignPtr (ForeignPtr) 14 | import GHC.Word (Word8) 15 | 16 | import Parse.Primitives.Internals (Parser(..), State(..), noError) 17 | import qualified Parse.Primitives.Internals as I 18 | import qualified Parse.Primitives.Symbol as Symbol 19 | import qualified Reporting.Error.Syntax as E 20 | 21 | 22 | 23 | -- SHADER 24 | 25 | 26 | failure :: Int -> Int -> Text.Text -> Parser a 27 | failure row col msg = 28 | Parser $ \_ _ cerr _ _ -> 29 | cerr (E.ParseError row col (E.BadShader msg)) 30 | 31 | 32 | block :: Parser Text.Text 33 | block = 34 | do Symbol.shaderBlockOpen 35 | Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ -> 36 | case eatShader fp offset terminal row col of 37 | Err -> 38 | cerr (E.ParseError row col E.EndOfFile_Shader) 39 | 40 | Ok newOffset newRow newCol -> 41 | let 42 | !size = newOffset - offset 43 | !shader = Text.decodeUtf8 (B.PS fp offset size) 44 | !newState = State fp (newOffset + 2) terminal indent newRow newCol ctx 45 | in 46 | cok shader newState noError 47 | 48 | 49 | data Result 50 | = Err 51 | | Ok Int Int Int 52 | 53 | 54 | eatShader :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result 55 | eatShader fp offset terminal row col = 56 | if offset >= terminal then 57 | Err 58 | 59 | else 60 | let !word = I.unsafeIndex fp offset in 61 | if word == 0x007C {- | -} && I.isWord fp (offset + 1) terminal 0x5D {- ] -} then 62 | Ok offset row (col + 2) 63 | 64 | else if word == 0x0A {- \n -} then 65 | eatShader fp (offset + 1) terminal (row + 1) 1 66 | 67 | else 68 | let !newOffset = offset + I.getCharWidth fp offset terminal word in 69 | eatShader fp newOffset terminal row (col + 1) 70 | -------------------------------------------------------------------------------- /compiler/src/Parse/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Parse.Repl 4 | ( Entry(..) 5 | , parseEntry 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.ByteString.UTF8 as Utf8 11 | import qualified Data.Text as Text 12 | import Data.Text (Text) 13 | 14 | import qualified AST.Source as Src 15 | import qualified Elm.Name as N 16 | import qualified Parse.Module as Module 17 | import Parse.Primitives 18 | import qualified Parse.Primitives.Keyword as Keyword 19 | import qualified Parse.Primitives.Symbol as Symbol 20 | import qualified Parse.Primitives.Variable as Var 21 | import qualified Parse.Pattern as Pattern 22 | import qualified Reporting.Annotation as A 23 | 24 | 25 | 26 | -- ENTRY 27 | 28 | 29 | data Entry 30 | = Import N.Name (Maybe N.Name) Src.Exposing Text 31 | | Type N.Name Text 32 | | Def (Maybe N.Name) Text 33 | | Other Text 34 | | Annotation 35 | | Port 36 | 37 | 38 | 39 | -- PARSE 40 | 41 | 42 | parseEntry :: String -> Entry 43 | parseEntry rawEntry = 44 | let 45 | source = 46 | Text.pack rawEntry 47 | in 48 | case run (entryParser source) (Utf8.fromString rawEntry) of 49 | Right entry -> 50 | entry 51 | 52 | Left _ -> 53 | Other source 54 | 55 | 56 | entryParser :: Text -> Parser Entry 57 | entryParser source = 58 | oneOf 59 | [ do Keyword.import_ 60 | spaces 61 | name <- Var.moduleName 62 | alias <- tryAlias 63 | exposing <- tryExposing 64 | return (Import name alias exposing source) 65 | 66 | , do Keyword.port_ 67 | return Port 68 | 69 | , do Keyword.type_ 70 | spaces 71 | oneOf 72 | [ do Keyword.alias_ 73 | spaces 74 | , return () 75 | ] 76 | name <- Var.upper 77 | return (Type name source) 78 | 79 | , do root <- Pattern.term 80 | spaces 81 | case A.toValue root of 82 | Src.PVar name -> 83 | oneOf 84 | [ do Symbol.hasType 85 | return Annotation 86 | , do chompArgs 87 | return (Def (Just name) source) 88 | ] 89 | 90 | _ -> 91 | do Symbol.equals 92 | return (Def Nothing source) 93 | ] 94 | 95 | 96 | chompArgs :: Parser () 97 | chompArgs = 98 | oneOf 99 | [ do Pattern.term 100 | spaces 101 | chompArgs 102 | , do Symbol.equals 103 | return () 104 | ] 105 | 106 | 107 | tryAlias :: Parser (Maybe N.Name) 108 | tryAlias = 109 | oneOf 110 | [ try $ 111 | do spaces 112 | Keyword.as_ 113 | spaces 114 | Just <$> Var.upper 115 | , return Nothing 116 | ] 117 | 118 | 119 | tryExposing :: Parser Src.Exposing 120 | tryExposing = 121 | oneOf 122 | [ try $ 123 | do spaces 124 | Keyword.exposing_ 125 | spaces 126 | Module.exposing 127 | , return (Src.Explicit []) 128 | ] 129 | -------------------------------------------------------------------------------- /compiler/src/Parse/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Parse.Shader 4 | ( shader 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.List as List 10 | import qualified Data.Map as Map 11 | import qualified Data.Text as Text 12 | import qualified Language.GLSL.Parser as GLP 13 | import qualified Language.GLSL.Syntax as GLS 14 | import qualified Text.Parsec as Parsec 15 | import qualified Text.Parsec.Error as Parsec 16 | 17 | import qualified AST.Source as Src 18 | import qualified AST.Utils.Shader as Shader 19 | import qualified Elm.Name as N 20 | import qualified Reporting.Annotation as A 21 | import qualified Reporting.Region as R 22 | import Parse.Primitives (Parser, getPosition) 23 | import qualified Parse.Primitives.Shader as Shader 24 | 25 | 26 | 27 | -- SHADERS 28 | 29 | 30 | shader :: R.Position -> Parser Src.Expr 31 | shader start@(R.Position row col) = 32 | do block <- Shader.block 33 | shdr <- parseSource row col (Text.unpack block) 34 | end@(R.Position row2 col2) <- getPosition 35 | let uid = List.intercalate ":" (map show [row, col, row2, col2]) 36 | let src = Text.replace "\n" "\\n" (Text.replace "\r\n" "\\n" block) 37 | return (A.at start end (Src.Shader (Text.pack uid) src shdr)) 38 | 39 | 40 | parseSource :: Int -> Int -> String -> Parser Shader.Shader 41 | parseSource startRow startCol src = 42 | case GLP.parse src of 43 | Right (GLS.TranslationUnit decls) -> 44 | return (foldr addInput emptyShader (concatMap extractInputs decls)) 45 | 46 | Left err -> 47 | let 48 | pos = Parsec.errorPos err 49 | row = Parsec.sourceLine pos 50 | col = Parsec.sourceColumn pos 51 | msg = 52 | Parsec.showErrorMessages 53 | "or" 54 | "unknown parse error" 55 | "expecting" 56 | "unexpected" 57 | "end of input" 58 | (Parsec.errorMessages err) 59 | in 60 | if row == 1 then 61 | Shader.failure startRow (startCol + 6 + col) (Text.pack msg) 62 | else 63 | Shader.failure (startRow + row - 1) col (Text.pack msg) 64 | 65 | 66 | emptyShader :: Shader.Shader 67 | emptyShader = 68 | Shader.Shader Map.empty Map.empty Map.empty 69 | 70 | 71 | addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Shader -> Shader.Shader 72 | addInput (qual, tipe, name) glDecls = 73 | case qual of 74 | GLS.Attribute -> glDecls { Shader._attribute = Map.insert (N.fromString name) tipe (Shader._attribute glDecls) } 75 | GLS.Uniform -> glDecls { Shader._uniform = Map.insert (N.fromString name) tipe (Shader._uniform glDecls) } 76 | GLS.Varying -> glDecls { Shader._varying = Map.insert (N.fromString name) tipe (Shader._varying glDecls) } 77 | _ -> error "Should never happen due to `extractInputs` function" 78 | 79 | 80 | extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, String)] 81 | extractInputs decl = 82 | case decl of 83 | GLS.Declaration 84 | (GLS.InitDeclaration 85 | (GLS.TypeDeclarator 86 | (GLS.FullType 87 | (Just (GLS.TypeQualSto qual)) 88 | (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1)))) 89 | [GLS.InitDecl name _mexpr2 _mexpr3] 90 | ) -> 91 | case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of 92 | False -> [] 93 | True -> 94 | case tipe of 95 | GLS.Vec2 -> [(qual, Shader.V2, name)] 96 | GLS.Vec3 -> [(qual, Shader.V3, name)] 97 | GLS.Vec4 -> [(qual, Shader.V4, name)] 98 | GLS.Mat4 -> [(qual, Shader.M4, name)] 99 | GLS.Int -> [(qual, Shader.Int, name)] 100 | GLS.Float -> [(qual, Shader.Float, name)] 101 | GLS.Sampler2D -> [(qual, Shader.Texture, name)] 102 | _ -> [] 103 | _ -> [] 104 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Annotation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Reporting.Annotation 3 | ( Located(..) 4 | , at, merge 5 | , map 6 | , toValue 7 | , toRegion 8 | , traverse 9 | ) 10 | where 11 | 12 | 13 | import Prelude hiding (map, traverse) 14 | import qualified Reporting.Region as R 15 | 16 | 17 | 18 | -- ANNOTATION 19 | 20 | 21 | data Located a = 22 | At R.Region a 23 | 24 | 25 | 26 | -- CREATE 27 | 28 | 29 | at :: R.Position -> R.Position -> a -> Located a 30 | at start end value = 31 | At (R.Region start end) value 32 | 33 | 34 | merge :: Located a -> Located b -> value -> Located value 35 | merge (At region1 _) (At region2 _) value = 36 | At (R.merge region1 region2) value 37 | 38 | 39 | 40 | -- MANIPULATE 41 | 42 | 43 | map :: (a -> b) -> Located a -> Located b 44 | map f (At info value) = 45 | At info (f value) 46 | 47 | 48 | toValue :: Located a -> a 49 | toValue (At _ value) = 50 | value 51 | 52 | 53 | toRegion :: Located a -> R.Region 54 | toRegion (At region _) = 55 | region 56 | 57 | 58 | traverse :: (Functor f) => (a -> f b) -> Located a -> f (Located b) 59 | traverse func (At region value) = 60 | At region <$> func value 61 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Error.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Error 4 | ( Error(..) 5 | , toReports 6 | ) 7 | where 8 | 9 | 10 | import qualified Reporting.Error.Canonicalize as Canonicalize 11 | import qualified Reporting.Error.Docs as Docs 12 | import qualified Reporting.Error.Main as Main 13 | import qualified Reporting.Error.Pattern as Pattern 14 | import qualified Reporting.Error.Syntax as Syntax 15 | import qualified Reporting.Error.Type as Type 16 | import qualified Reporting.Render.Code as Code 17 | import qualified Reporting.Render.Type.Localizer as L 18 | import qualified Reporting.Report as Report 19 | 20 | 21 | 22 | -- ALL POSSIBLE ERRORS 23 | 24 | 25 | data Error 26 | = Syntax Syntax.Error 27 | | Canonicalize Canonicalize.Error 28 | | Type L.Localizer [Type.Error] 29 | | Main L.Localizer Main.Error 30 | | Pattern [Pattern.Error] 31 | | Docs Docs.Error 32 | 33 | 34 | 35 | -- TO REPORT 36 | 37 | 38 | toReports :: Code.Source -> Error -> [Report.Report] 39 | toReports source err = 40 | case err of 41 | Syntax syntaxError -> 42 | [Syntax.toReport source syntaxError] 43 | 44 | Canonicalize canonicalizeError -> 45 | [Canonicalize.toReport source canonicalizeError] 46 | 47 | Type localizer typeErrors -> 48 | map (Type.toReport source localizer) typeErrors 49 | 50 | Main localizer mainError -> 51 | [Main.toReport localizer source mainError] 52 | 53 | Pattern patternErrors -> 54 | map (Pattern.toReport source) patternErrors 55 | 56 | Docs docsError -> 57 | [Docs.toReport source docsError] 58 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Region.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Region 3 | ( Region(..) 4 | , Position(..) 5 | , zero 6 | , one 7 | , merge 8 | , encode 9 | ) 10 | where 11 | 12 | 13 | import qualified Json.Encode as Json 14 | import Data.Binary (Binary, get, put) 15 | 16 | 17 | 18 | -- REGION 19 | 20 | 21 | data Region = 22 | Region 23 | { _start :: !Position 24 | , _end :: !Position 25 | } 26 | deriving (Eq, Ord) 27 | 28 | 29 | data Position = 30 | Position 31 | { _line :: !Int 32 | , _column :: !Int 33 | } 34 | deriving (Eq, Ord) 35 | 36 | 37 | merge :: Region -> Region -> Region 38 | merge (Region start _) (Region _ end) = 39 | Region start end 40 | 41 | 42 | {-# NOINLINE zero #-} 43 | zero :: Region 44 | zero = 45 | Region (Position 0 0) (Position 0 0) 46 | 47 | 48 | {-# NOINLINE one #-} 49 | one :: Region 50 | one = 51 | Region (Position 1 1) (Position 1 1) 52 | 53 | 54 | 55 | -- JSON 56 | 57 | 58 | encode :: Region -> Json.Value 59 | encode (Region start end) = 60 | Json.object 61 | [ ("start", encodePosition start) 62 | , ("end", encodePosition end) 63 | ] 64 | 65 | 66 | encodePosition :: Position -> Json.Value 67 | encodePosition (Position line column) = 68 | Json.object 69 | [ ("line", Json.int line) 70 | , ("column", Json.int column) 71 | ] 72 | 73 | 74 | 75 | -- BINARY 76 | 77 | 78 | instance Binary Region where 79 | get = 80 | Region <$> get <*> get 81 | 82 | put (Region start end) = 83 | do put start 84 | put end 85 | 86 | 87 | instance Binary Position where 88 | get = 89 | Position <$> get <*> get 90 | 91 | put (Position line column) = 92 | do put line 93 | put column 94 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Render/Type/Localizer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Render.Type.Localizer 4 | ( Localizer 5 | , toDoc 6 | , toString 7 | , empty 8 | , fromNames 9 | , fromModule 10 | , replEmpty 11 | , replAdd 12 | ) 13 | where 14 | 15 | 16 | import qualified Data.Map as Map 17 | import qualified Data.Set as Set 18 | 19 | import qualified AST.Source as Src 20 | import qualified AST.Module.Name as ModuleName 21 | import qualified AST.Valid as Valid 22 | import qualified Elm.Compiler.Imports as Imports 23 | import qualified Elm.Name as N 24 | import qualified Elm.Package as Pkg 25 | import Reporting.Doc ((<>)) 26 | import qualified Reporting.Doc as D 27 | import qualified Reporting.Annotation as A 28 | 29 | 30 | 31 | -- LOCALIZER 32 | 33 | 34 | newtype Localizer = 35 | Localizer (Map.Map N.Name Import) 36 | 37 | 38 | data Import = 39 | Import 40 | { _alias :: Maybe N.Name 41 | , _exposing :: Exposing 42 | } 43 | 44 | 45 | data Exposing 46 | = All 47 | | Only (Set.Set N.Name) 48 | 49 | 50 | empty :: Localizer 51 | empty = 52 | Localizer Map.empty 53 | 54 | 55 | 56 | -- LOCALIZE 57 | 58 | 59 | toDoc :: Localizer -> ModuleName.Canonical -> N.Name -> D.Doc 60 | toDoc localizer home name = 61 | D.fromString (toString localizer home name) 62 | 63 | 64 | toString :: Localizer -> ModuleName.Canonical -> N.Name -> String 65 | toString (Localizer localizer) moduleName@(ModuleName.Canonical _ home) name = 66 | case Map.lookup home localizer of 67 | Nothing -> 68 | N.toString home <> "." <> N.toString name 69 | 70 | Just (Import alias exposing) -> 71 | case exposing of 72 | All -> 73 | N.toString name 74 | 75 | Only set -> 76 | if Set.member name set then 77 | N.toString name 78 | else if name == N.list && moduleName == ModuleName.list then 79 | "List" 80 | else 81 | N.toString (maybe home id alias) <> "." <> N.toString name 82 | 83 | 84 | 85 | -- FROM NAMES 86 | 87 | 88 | fromNames :: Map.Map N.Name a -> Localizer 89 | fromNames names = 90 | Localizer $ Map.map (\_ -> Import Nothing All) names 91 | 92 | 93 | 94 | -- FROM MODULE 95 | 96 | 97 | fromModule :: Valid.Module -> Localizer 98 | fromModule (Valid.Module name _ _ _ imports _ _ _ _ _) = 99 | Localizer $ Map.fromList $ 100 | (name, Import Nothing All) : map toPair imports 101 | 102 | 103 | toPair :: Src.Import -> (N.Name, Import) 104 | toPair (Src.Import (A.At _ name) alias exposing) = 105 | ( name 106 | , Import alias (toExposing exposing) 107 | ) 108 | 109 | 110 | toExposing :: Src.Exposing -> Exposing 111 | toExposing exposing = 112 | case exposing of 113 | Src.Open -> 114 | All 115 | 116 | Src.Explicit exposedList -> 117 | Only (foldr addType Set.empty exposedList) 118 | 119 | 120 | addType :: A.Located Src.Exposed -> Set.Set N.Name -> Set.Set N.Name 121 | addType (A.At _ exposed) types = 122 | case exposed of 123 | Src.Lower _ -> types 124 | Src.Upper name _ -> Set.insert name types 125 | Src.Operator _ -> types 126 | 127 | 128 | 129 | -- REPL STUFF 130 | 131 | 132 | replEmpty :: Localizer 133 | replEmpty = 134 | Localizer $ 135 | Map.insert N.replModule (Import Nothing All) $ 136 | Map.fromList $ map toPair $ Imports.addDefaults Pkg.dummyName [] 137 | 138 | 139 | replAdd :: N.Name -> Maybe N.Name -> Src.Exposing -> Localizer -> Localizer 140 | replAdd name alias exposing (Localizer localizer) = 141 | Localizer $ Map.insert name (Import alias (toExposing exposing)) localizer 142 | 143 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Report.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Report 3 | ( Report(..) 4 | , toDoc 5 | , toCodeSnippet 6 | , toCodePair 7 | ) 8 | where 9 | 10 | 11 | import qualified Reporting.Doc as D 12 | import qualified Reporting.Region as R 13 | import qualified Reporting.Render.Code as Code 14 | 15 | 16 | 17 | -- BUILD REPORTS 18 | 19 | 20 | data Report = 21 | Report 22 | { _title :: String 23 | , _region :: R.Region 24 | , _sgstns :: [String] 25 | , _message :: D.Doc 26 | } 27 | 28 | 29 | toDoc :: FilePath -> Report -> D.Doc 30 | toDoc filePath (Report title _ _ message) = 31 | D.vcat 32 | [ messageBar title filePath 33 | , "" 34 | , message 35 | , "" 36 | ] 37 | 38 | 39 | messageBar :: String -> FilePath -> D.Doc 40 | messageBar title filePath = 41 | let 42 | usedSpace = 43 | 4 + length title + 1 + length filePath 44 | in 45 | D.dullcyan $ D.fromString $ 46 | "-- " ++ title 47 | ++ " " ++ replicate (max 1 (80 - usedSpace)) '-' 48 | ++ " " ++ filePath 49 | 50 | 51 | 52 | -- CODE FORMATTING 53 | 54 | 55 | toCodeSnippet :: Code.Source -> R.Region -> Maybe R.Region -> (D.Doc, D.Doc) -> D.Doc 56 | toCodeSnippet source region highlight (preHint, postHint) = 57 | D.vcat 58 | [ preHint 59 | , "" 60 | , Code.render source region highlight 61 | , postHint 62 | ] 63 | 64 | 65 | toCodePair :: Code.Source -> R.Region -> R.Region -> (D.Doc, D.Doc) -> (D.Doc, D.Doc, D.Doc) -> D.Doc 66 | toCodePair source r1 r2 (oneStart, oneEnd) (twoStart, twoMiddle, twoEnd) = 67 | case Code.renderPair source r1 r2 of 68 | Code.OneLine codeDocs -> 69 | D.vcat 70 | [ oneStart 71 | , "" 72 | , codeDocs 73 | , oneEnd 74 | ] 75 | 76 | Code.TwoChunks code1 code2 -> 77 | D.vcat 78 | [ twoStart 79 | , "" 80 | , code1 81 | , twoMiddle 82 | , "" 83 | , code2 84 | , twoEnd 85 | ] 86 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Result.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | module Reporting.Result 4 | ( Result(..) 5 | , run 6 | , ok 7 | , warn 8 | , throw 9 | , mapError 10 | ) 11 | where 12 | 13 | 14 | import qualified Data.OneOrMore as OneOrMore 15 | import qualified Reporting.Warning as Warning 16 | 17 | 18 | 19 | -- RESULT 20 | 21 | 22 | newtype Result info warnings error a = 23 | Result ( 24 | forall result. 25 | info 26 | -> warnings 27 | -> (info -> warnings -> OneOrMore.OneOrMore error -> result) 28 | -> (info -> warnings -> a -> result) 29 | -> result 30 | ) 31 | 32 | 33 | run :: Result () [w] e a -> ([w], Either [e] a) 34 | run (Result k) = 35 | k () [] 36 | (\() w e -> (reverse w, Left (OneOrMore.toList e))) 37 | (\() w a -> (reverse w, Right a)) 38 | 39 | 40 | 41 | -- HELPERS 42 | 43 | 44 | ok :: a -> Result i w e a 45 | ok a = 46 | Result $ \i w _ good -> 47 | good i w a 48 | 49 | 50 | warn :: Warning.Warning -> Result i [Warning.Warning] e () 51 | warn warning = 52 | Result $ \i warnings _ good -> 53 | good i (warning:warnings) () 54 | 55 | 56 | throw :: e -> Result i w e a 57 | throw e = 58 | Result $ \i w bad _ -> 59 | bad i w (OneOrMore.one e) 60 | 61 | 62 | mapError :: (e -> e') -> Result i w e a -> Result i w e' a 63 | mapError func (Result k) = 64 | Result $ \i w bad good -> 65 | let 66 | bad1 i1 w1 e1 = 67 | bad i1 w1 (OneOrMore.map func e1) 68 | in 69 | k i w bad1 good 70 | 71 | 72 | 73 | -- FANCY INSTANCE STUFF 74 | 75 | 76 | instance Functor (Result i w e) where 77 | fmap func (Result k) = 78 | Result $ \i w bad good -> 79 | let 80 | good1 i1 w1 value = 81 | good i1 w1 (func value) 82 | in 83 | k i w bad good1 84 | 85 | 86 | instance Applicative (Result i w e) where 87 | pure = ok 88 | 89 | (<*>) (Result kf) (Result kv) = 90 | Result $ \i w bad good -> 91 | let 92 | bad1 i1 w1 e1 = 93 | let 94 | bad2 i2 w2 e2 = bad i2 w2 (OneOrMore.more e1 e2) 95 | good2 i2 w2 _value = bad i2 w2 e1 96 | in 97 | kv i1 w1 bad2 good2 98 | 99 | good1 i1 w1 func = 100 | let 101 | bad2 i2 w2 e2 = bad i2 w2 e2 102 | good2 i2 w2 value = good i2 w2 (func value) 103 | in 104 | kv i1 w1 bad2 good2 105 | in 106 | kf i w bad1 good1 107 | 108 | 109 | instance Monad (Result i w e) where 110 | return = ok 111 | 112 | (>>=) (Result ka) callback = 113 | Result $ \i w bad good -> 114 | let 115 | good1 i1 w1 a = 116 | case callback a of 117 | Result kb -> kb i1 w1 bad good 118 | in 119 | ka i w bad good1 120 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Suggest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Suggest 4 | ( distance 5 | , sort 6 | , rank 7 | ) 8 | where 9 | 10 | 11 | import qualified Data.Char as Char 12 | import qualified Data.List as List 13 | import qualified Text.EditDistance as Dist 14 | 15 | 16 | 17 | -- DISTANCE 18 | 19 | 20 | distance :: String -> String -> Int 21 | distance x y = 22 | Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y 23 | 24 | 25 | 26 | -- SORT 27 | 28 | 29 | sort :: String -> (a -> String) -> [a] -> [a] 30 | sort target toString values = 31 | List.sortOn (distance (toLower target) . toLower . toString) values 32 | 33 | 34 | toLower :: String -> String 35 | toLower string = 36 | map Char.toLower string 37 | 38 | 39 | 40 | -- RANK 41 | 42 | 43 | rank :: String -> (a -> String) -> [a] -> [(Int,a)] 44 | rank target toString values = 45 | let 46 | toRank v = 47 | distance (toLower target) (toLower (toString v)) 48 | 49 | addRank v = 50 | (toRank v, v) 51 | in 52 | List.sortOn fst (map addRank values) 53 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Warning.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Warning 4 | ( Warning(..) 5 | , Context(..) 6 | , toReport 7 | ) 8 | where 9 | 10 | 11 | import Data.Monoid ((<>)) 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified AST.Utils.Type as Type 15 | import qualified Elm.Name as N 16 | import qualified Reporting.Doc as D 17 | import qualified Reporting.Region as R 18 | import qualified Reporting.Report as Report 19 | import qualified Reporting.Render.Code as Code 20 | import qualified Reporting.Render.Type as RT 21 | import qualified Reporting.Render.Type.Localizer as L 22 | 23 | 24 | 25 | -- ALL POSSIBLE WARNINGS 26 | 27 | 28 | data Warning 29 | = UnusedImport R.Region N.Name 30 | | UnusedVariable R.Region Context N.Name 31 | | MissingTypeAnnotation R.Region N.Name Can.Type 32 | 33 | 34 | data Context = Def | Pattern 35 | 36 | 37 | 38 | -- TO REPORT 39 | 40 | 41 | toReport :: L.Localizer -> Code.Source -> Warning -> Report.Report 42 | toReport localizer source warning = 43 | case warning of 44 | UnusedImport region moduleName -> 45 | Report.Report "unused import" region [] $ 46 | Report.toCodeSnippet source region Nothing 47 | ( 48 | D.reflow $ 49 | "Nothing from the `" <> N.toString moduleName <> "` module is used in this file." 50 | , 51 | "I recommend removing unused imports." 52 | ) 53 | 54 | UnusedVariable region context name -> 55 | let title = defOrPat context "unused definition" "unused variable" in 56 | Report.Report title region [] $ 57 | Report.toCodeSnippet source region Nothing 58 | ( 59 | D.reflow $ 60 | "You are not using `" <> N.toString name <> "` anywhere." 61 | , 62 | D.stack 63 | [ D.reflow $ 64 | "Is there a typo? Maybe you intended to use `" <> N.toString name 65 | <> "` somewhere but typed another name instead?" 66 | , D.reflow $ 67 | defOrPat context 68 | ( "If you are sure there is no typo, remove the definition.\ 69 | \ This way future readers will not have to wonder why it is there!" 70 | ) 71 | ( "If you are sure there is no typo, replace `" <> N.toString name 72 | <> "` with _ so future readers will not have to wonder why it is there!" 73 | ) 74 | ] 75 | ) 76 | 77 | MissingTypeAnnotation region name inferredType -> 78 | Report.Report "missing type annotation" region [] $ 79 | Report.toCodeSnippet source region Nothing 80 | ( 81 | D.reflow $ 82 | case Type.deepDealias inferredType of 83 | Can.TLambda _ _ -> 84 | "The `" <> N.toString name <> "` function has no type annotation." 85 | 86 | _ -> 87 | "The `" <> N.toString name <> "` definition has no type annotation." 88 | , 89 | D.stack 90 | [ "I inferred the type annotation myself though! You can copy it into your code:" 91 | , D.green $ D.hang 4 $ D.sep $ 92 | [ D.fromName name <> " :" 93 | , RT.canToDoc localizer RT.None inferredType 94 | ] 95 | ] 96 | ) 97 | 98 | 99 | defOrPat :: Context -> a -> a -> a 100 | defOrPat context def pat = 101 | case context of 102 | Def -> def 103 | Pattern -> pat 104 | 105 | -------------------------------------------------------------------------------- /compiler/src/Type/Instantiate.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Type.Instantiate 4 | ( FreeVars 5 | , fromSrcType 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.Map.Strict as Map 11 | import Data.Map.Strict ((!)) 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified Elm.Name as N 15 | import Type.Type 16 | 17 | 18 | 19 | -- FREE VARS 20 | 21 | 22 | type FreeVars = 23 | Map.Map N.Name Type 24 | 25 | 26 | 27 | -- FROM SOURCE TYPE 28 | 29 | 30 | fromSrcType :: Map.Map N.Name Type -> Can.Type -> IO Type 31 | fromSrcType freeVars sourceType = 32 | case sourceType of 33 | Can.TLambda arg result -> 34 | FunN 35 | <$> fromSrcType freeVars arg 36 | <*> fromSrcType freeVars result 37 | 38 | Can.TVar name -> 39 | return (freeVars ! name) 40 | 41 | Can.TType home name args -> 42 | AppN home name <$> traverse (fromSrcType freeVars) args 43 | 44 | Can.TAlias home name args aliasedType -> 45 | do targs <- traverse (traverse (fromSrcType freeVars)) args 46 | AliasN home name targs <$> 47 | case aliasedType of 48 | Can.Filled realType -> 49 | fromSrcType freeVars realType 50 | 51 | Can.Holey realType -> 52 | fromSrcType (Map.fromList targs) realType 53 | 54 | Can.TTuple a b maybeC -> 55 | TupleN 56 | <$> fromSrcType freeVars a 57 | <*> fromSrcType freeVars b 58 | <*> traverse (fromSrcType freeVars) maybeC 59 | 60 | Can.TUnit -> 61 | return UnitN 62 | 63 | Can.TRecord fields maybeExt -> 64 | RecordN 65 | <$> traverse (fromSrcFieldType freeVars) fields 66 | <*> 67 | case maybeExt of 68 | Nothing -> 69 | return EmptyRecordN 70 | 71 | Just ext -> 72 | return (freeVars ! ext) 73 | 74 | 75 | fromSrcFieldType :: Map.Map N.Name Type -> Can.FieldType -> IO Type 76 | fromSrcFieldType freeVars (Can.FieldType _ tipe) = 77 | fromSrcType freeVars tipe 78 | -------------------------------------------------------------------------------- /compiler/src/Type/Occurs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Type.Occurs 4 | ( occurs 5 | ) 6 | where 7 | 8 | 9 | import Data.Foldable (foldrM) 10 | import qualified Data.Map.Strict as Map 11 | 12 | import Type.Type as Type 13 | import qualified Type.UnionFind as UF 14 | 15 | 16 | 17 | -- OCCURS 18 | 19 | 20 | occurs :: Type.Variable -> IO Bool 21 | occurs var = 22 | occursHelp [] var False 23 | 24 | 25 | occursHelp :: [Type.Variable] -> Type.Variable -> Bool -> IO Bool 26 | occursHelp seen var foundCycle = 27 | if elem var seen then 28 | return True 29 | 30 | else 31 | do (Descriptor content _ _ _) <- UF.get var 32 | case content of 33 | FlexVar _ -> 34 | return foundCycle 35 | 36 | FlexSuper _ _ -> 37 | return foundCycle 38 | 39 | RigidVar _ -> 40 | return foundCycle 41 | 42 | RigidSuper _ _ -> 43 | return foundCycle 44 | 45 | Structure term -> 46 | let newSeen = var : seen in 47 | case term of 48 | App1 _ _ args -> 49 | foldrM (occursHelp newSeen) foundCycle args 50 | 51 | Fun1 a b -> 52 | occursHelp newSeen a =<< 53 | occursHelp newSeen b foundCycle 54 | 55 | EmptyRecord1 -> 56 | return foundCycle 57 | 58 | Record1 fields ext -> 59 | occursHelp newSeen ext =<< 60 | foldrM (occursHelp newSeen) foundCycle (Map.elems fields) 61 | 62 | Unit1 -> 63 | return foundCycle 64 | 65 | Tuple1 a b maybeC -> 66 | case maybeC of 67 | Nothing -> 68 | occursHelp newSeen a =<< 69 | occursHelp newSeen b foundCycle 70 | 71 | Just c -> 72 | occursHelp newSeen a =<< 73 | occursHelp newSeen b =<< 74 | occursHelp newSeen c foundCycle 75 | 76 | Alias _ _ args _ -> 77 | foldrM (occursHelp (var:seen)) foundCycle (map snd args) 78 | 79 | Error -> 80 | return foundCycle 81 | -------------------------------------------------------------------------------- /docs/elm.json/application.md: -------------------------------------------------------------------------------- 1 | # `elm.json` for applications 2 | 3 | This is a decent baseline for pretty much any applications made with Elm. You will need these dependencies or more. 4 | 5 | ```json 6 | { 7 | "type": "application", 8 | "source-directories": [ 9 | "src" 10 | ], 11 | "elm-version": "0.19.0", 12 | "dependencies": { 13 | "direct": { 14 | "elm/browser": "1.0.0", 15 | "elm/core": "1.0.0", 16 | "elm/html": "1.0.0", 17 | "elm/json": "1.0.0" 18 | }, 19 | "indirect": { 20 | "elm/time": "1.0.0", 21 | "elm/url": "1.0.0", 22 | "elm/virtual-dom": "1.0.0" 23 | } 24 | }, 25 | "test-dependencies": { 26 | "direct": {}, 27 | "indirect": {} 28 | } 29 | } 30 | ``` 31 | 32 |
33 | 34 | 35 | ## `"type"` 36 | 37 | Either `"application"` or `"package"`. All the other fields are based on this choice! 38 | 39 |
40 | 41 | 42 | ## `"source-directories"` 43 | 44 | A list of directories where Elm code lives. Most projects just use `"src"` for everything. 45 | 46 |
47 | 48 | 49 | ## `"elm-version"` 50 | 51 | The exact version of Elm this builds with. Should be `"0.19.0"` for most people! 52 | 53 |
54 | 55 | 56 | ## `"dependencies"` 57 | 58 | All the packages you depend upon. We use exact versions, so your `elm.json` file doubles as a "lock file" that ensures reliable builds. 59 | 60 | 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. 61 | 62 | **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! 63 | 64 |
65 | 66 | 67 | ## `"test-dependencies"` 68 | 69 | 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. 70 | -------------------------------------------------------------------------------- /docs/elm.json/package.md: -------------------------------------------------------------------------------- 1 | # `elm.json` for packages 2 | 3 | This is roughly `elm.json` for the `elm/json` package: 4 | 5 | ```json 6 | { 7 | "type": "package", 8 | "name": "elm/json", 9 | "summary": "Encode and decode JSON values", 10 | "license": "BSD-3-Clause", 11 | "version": "1.0.0", 12 | "exposed-modules": [ 13 | "Json.Decode", 14 | "Json.Encode" 15 | ], 16 | "elm-version": "0.19.0 <= v < 0.20.0", 17 | "dependencies": { 18 | "elm/core": "1.0.0 <= v < 2.0.0" 19 | }, 20 | "test-dependencies": {} 21 | } 22 | ``` 23 | 24 |
25 | 26 | 27 | ## `"type"` 28 | 29 | Either `"application"` or `"package"`. All the other fields are based on this choice. 30 | 31 |
32 | 33 | 34 | ## `"name"` 35 | 36 | The name of a GitHub repo like `"elm-lang/core"` or `"rtfeldman/elm-css"`. 37 | 38 | > **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. 39 | 40 |
41 | 42 | 43 | ## `"summary"` 44 | 45 | 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. 46 | 47 |
48 | 49 | 50 | ## `"license"` 51 | 52 | An OSI approved SPDX code like `"BSD-3-Clause"` or `"MIT"`. These are the two most common licenses in the Elm ecosystem, but you can see the full list of options [here](https://spdx.org/licenses/). 53 | 54 |
55 | 56 | 57 | ## `"version"` 58 | 59 | All packages start at `"1.0.0"` and from there, Elm automatically enforces semantic versioning by comparing API changes. 60 | 61 | 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. 62 | 63 |
64 | 65 | 66 | ## `"exposed-modules"` 67 | 68 | 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/). 69 | 70 | **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. 71 | 72 |
73 | 74 | 75 | ## `"elm-version"` 76 | 77 | 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. 78 | 79 |
80 | 81 | 82 | ## `"dependencies"` 83 | 84 | 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! 85 | 86 | > **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. 87 | 88 |
89 | 90 | 91 | ## `"test-dependencies"` 92 | 93 | Dependencies that are only used in the `tests/` directory by `elm test`. Values from these packages will not appear in any final build artifacts. 94 | -------------------------------------------------------------------------------- /installers/mac/Distribution.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | Elm Platform 4 | 5 | 6 | 7 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | binaries.pkg 31 | 32 | -------------------------------------------------------------------------------- /installers/mac/Resources/en.lproj/background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/installers/mac/Resources/en.lproj/background.png -------------------------------------------------------------------------------- /installers/mac/Resources/en.lproj/conclusion.rtf: -------------------------------------------------------------------------------- 1 | {\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf400 2 | {\fonttbl\f0\fswiss\fcharset0 Helvetica;} 3 | {\colortbl;\red255\green255\blue255;} 4 | \paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0 5 | \pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural 6 | 7 | \f0\fs26 \cf0 A bunch of useful programs were just placed in /usr/local/bin/\ 8 | \ 9 | Check out {\field{\*\fldinst HYPERLINK "http://elm-lang.org/Get-Started.elm"}{\fldrslt this tutorial}} to learn how to use them!} -------------------------------------------------------------------------------- /installers/mac/Resources/en.lproj/welcome.rtf: -------------------------------------------------------------------------------- 1 | {\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf400 2 | {\fonttbl\f0\fswiss\fcharset0 Helvetica;} 3 | {\colortbl;\red255\green255\blue255;} 4 | \paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0 5 | \pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural 6 | 7 | \f0\fs28 \cf0 This package will install Elm on your machine.} -------------------------------------------------------------------------------- /installers/mac/helper-scripts/elm-startup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | open 'http://elm-lang.org' 4 | -------------------------------------------------------------------------------- /installers/mac/helper-scripts/uninstall.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | echo "Warning: You are about to remove all Elm executables!" 6 | 7 | installdir=/usr/local/bin 8 | 9 | for bin in elm elm-compiler elm-get elm-reactor elm-repl elm-doc elm-server elm-package elm-make 10 | do 11 | if [ -f $installdir/$bin ]; then 12 | sudo rm -f $installdir/$bin 13 | fi 14 | if [ -f $installdir/$bin-unwrapped ]; then 15 | sudo rm -f $installdir/$bin-unwrapped 16 | fi 17 | 18 | done 19 | 20 | sharedir=/usr/local/share/elm 21 | sudo rm -rf $sharedir 22 | -------------------------------------------------------------------------------- /installers/mac/make-installer.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Run the following command to create an installer: 3 | # 4 | # bash make-installer.sh 5 | # 6 | 7 | 8 | 9 | #### SETUP #### 10 | 11 | set -e 12 | 13 | # Create directory structure for new pkgs 14 | pkg_root=$(mktemp -d -t package-artifacts) 15 | pkg_binaries=$pkg_root 16 | pkg_scripts=$pkg_root/Scripts 17 | 18 | mkdir -p $pkg_binaries 19 | mkdir -p $pkg_scripts 20 | 21 | usr_binaries=/usr/local/bin 22 | 23 | 24 | #### BUILD ASSETS #### 25 | 26 | cp ../../dist/build/elm/elm $pkg_binaries/elm 27 | 28 | cp $(pwd)/preinstall $pkg_scripts 29 | cp $(pwd)/postinstall $pkg_scripts 30 | 31 | pkgbuild \ 32 | --identifier org.elm-lang.binaries.pkg \ 33 | --install-location $usr_binaries \ 34 | --scripts $pkg_scripts \ 35 | --filter 'Scripts.*' \ 36 | --root $pkg_root \ 37 | binaries.pkg 38 | 39 | 40 | #### BUNDLE ASSETS #### 41 | 42 | rm -f Elm.pkg 43 | 44 | productbuild \ 45 | --distribution Distribution.xml \ 46 | --package-path . \ 47 | --resources Resources \ 48 | Elm.pkg 49 | 50 | 51 | #### CLEAN UP #### 52 | 53 | rm binaries.pkg 54 | rm -rf $pkg_root 55 | -------------------------------------------------------------------------------- /installers/mac/postinstall: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -ex 4 | 5 | echo "$(date)" > /tmp/elm-installer.log 6 | -------------------------------------------------------------------------------- /installers/mac/preinstall: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | installdir=/usr/local/bin 6 | 7 | for bin in elm elm-compiler elm-package elm-reactor elm-repl 8 | do 9 | if [ -f $installdir/$bin ]; then 10 | sudo rm -f $installdir/$bin 11 | fi 12 | if [ -f $installdir/$bin-unwrapped ]; then 13 | sudo rm -f $installdir/$bin-unwrapped 14 | fi 15 | done 16 | 17 | sharedir=/usr/local/share/elm 18 | sudo rm -rf $sharedir 19 | -------------------------------------------------------------------------------- /installers/npm/.gitignore: -------------------------------------------------------------------------------- 1 | node_modules/ 2 | -------------------------------------------------------------------------------- /installers/npm/.npmignore: -------------------------------------------------------------------------------- 1 | README.md 2 | .gitignore 3 | .git 4 | -------------------------------------------------------------------------------- /installers/npm/README.md: -------------------------------------------------------------------------------- 1 | npm install elm [![Travis build Status](https://travis-ci.org/elm-lang/elm-platform.svg?branch=master)](http://travis-ci.org/elm-lang/elm-platform) [![AppVeyor build status](https://ci.appveyor.com/api/projects/status/6mcub79i04ianpm9/branch/master?svg=true)](https://ci.appveyor.com/project/rtfeldman/elm-platform/branch/master) 2 | =============== 3 | 4 | Install the [Elm Platform](https://github.com/elm-lang/elm-platform) via [`npm`](https://www.npmjs.com). 5 | 6 | ## Installing 7 | 8 | Run this to get the binaries: 9 | 10 | ``` 11 | $ npm install -g elm 12 | ``` 13 | 14 | ## Installing behind a proxy server 15 | 16 | If you are behind a proxy server, set the environment variable "HTTPS_PROXY". 17 | 18 | ``` 19 | $ export HTTPS_PROXY=$YourProxyServer$ 20 | $ npm install -g elm 21 | ``` 22 | 23 | Or on Windows: 24 | 25 | ``` 26 | $ set HTTPS_PROXY=$YourProxyServer$ 27 | $ npm install -g elm 28 | ``` 29 | 30 | ## Troubleshooting 31 | 32 | 1. [Troubleshooting npm](https://github.com/npm/npm/wiki/Troubleshooting) 33 | 2. On Debian/Ubuntu systems, you may have to install the nodejs-legacy package: `apt-get install nodejs-legacy`. 34 | 3. If the installer says that it cannot find any usable binaries for your operating system and architecture, check the [Build from Source](https://github.com/elm-lang/elm-platform/blob/master/README.md#build-from-source) documentation. 35 | 36 | ## Getting Started 37 | 38 | Once everything has installed successfully, head over to the [Get Started](http://elm-lang.org/Get-Started.elm) page! 39 | -------------------------------------------------------------------------------- /installers/npm/bin/elm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | 3 | // This file exists for the benefit of npm users who have --ignore-scripts 4 | // enabled. (Enabling this flag globally is a good security measure.) 5 | // Since they won't run the post-install hook, the binaries won't be downloaded 6 | // and installed. 7 | // 8 | // Since this file is included in "bin" in package.json, npm will install 9 | // it automatically in a place that should be on the PATH. All the file does 10 | // is to download the appropriate binary (just like the post-install hook would 11 | // have), replace this file with that binary, and run the binary. 12 | // 13 | // In this way, the first time a user with --ignore-scripts enabled runs this 14 | // binary, it will download and install itself, and then run as normal. From 15 | // then on, it will run as normal without re-downloading. 16 | 17 | var install = require("..").install; 18 | var child_process = require("child_process"); 19 | var path = require("path"); 20 | var fs = require("fs"); 21 | 22 | // Make sure we get the right path even if we're executing from the symlinked 23 | // node_modules/.bin/ executable 24 | var interpreter = fs.realpathSync(process.argv[0]); 25 | var targetPath = fs.realpathSync(process.argv[1]); 26 | 27 | // Figure out the binary name as we'll eventually want to execute 28 | // this. Re-executing this script doesn't always work because of varying 29 | // permissions and modes of operation across platforms (for example, Windows has 30 | // some interesting edge cases here.) 31 | var binaryName = path.join( 32 | __dirname, 33 | "..", 34 | "unpacked_bin", 35 | path.basename(targetPath) 36 | ); 37 | if (process.platform === "win") { 38 | binaryName += ".exe"; 39 | } 40 | 41 | // cd into the directory above bin/ so install() puts bin/ in the right place. 42 | process.chdir(path.join(path.dirname(targetPath), "..")); 43 | 44 | install(process.platform, process.arch).then(function() { 45 | child_process 46 | .spawn(binaryName, process.argv.slice(2), { stdio: "inherit" }) 47 | .on("exit", process.exit); 48 | }); 49 | -------------------------------------------------------------------------------- /installers/npm/index.js: -------------------------------------------------------------------------------- 1 | var binwrap = require("binwrap"); 2 | var path = require("path"); 3 | 4 | var packageInfo = require(path.join(__dirname, "package.json")); 5 | // Use major.minor.patch from version string - e.g. "1.2.3" from "1.2.3-alpha" 6 | var binVersion = packageInfo.version.replace(/^(\d+\.\d+\.\d+).*$/, "$1"); 7 | 8 | var root = 9 | "https://github.com/elm/compiler/releases/download/" + 10 | binVersion + 11 | "/binaries-for-"; 12 | 13 | module.exports = binwrap({ 14 | binaries: ["elm"], 15 | urls: { 16 | "darwin-x64": root + "mac.tar.gz", 17 | "win32-x64": root + "windows.tar.gz", 18 | "win32-ia32": root + "windows.tar.gz", 19 | "linux-x64": root + "linux.tar.gz" 20 | } 21 | }); 22 | -------------------------------------------------------------------------------- /installers/npm/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "elm", 3 | "version": "0.19.0-bugfix2", 4 | "description": "The Elm Platform: Binaries for the Elm programming language.", 5 | "main": "index.js", 6 | "preferGlobal": true, 7 | "license": "BSD-3-Clause", 8 | "repository": { 9 | "type": "git", 10 | "url": "https://github.com/elm/compiler.git" 11 | }, 12 | "homepage": "https://github.com/elm/compiler/tree/master/installers/npm", 13 | "bugs": "https://github.com/elm/compiler/issues", 14 | "author": { 15 | "name": "Richard Feldman", 16 | "email": "richard.t.feldman@gmail.com", 17 | "url": "https://github.com/rtfeldman" 18 | }, 19 | "engines": { 20 | "node": ">=4.0.0" 21 | }, 22 | "scripts": { 23 | "install": "binwrap-install", 24 | "prepublishOnly": "binwrap-test" 25 | }, 26 | "files": [ 27 | "index.js", 28 | "bin", 29 | "bin/elm" 30 | ], 31 | "keywords": [ 32 | "bin", 33 | "binary", 34 | "binaries", 35 | "elm", 36 | "platform" 37 | ], 38 | "bin": { 39 | "elm": "bin/elm" 40 | }, 41 | "dependencies": { 42 | "binwrap": "0.1.4" 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /installers/win/CreateInternetShortcut.nsh: -------------------------------------------------------------------------------- 1 | !macro CreateInternetShortcut FILENAME URL ICONFILE ICONINDEX 2 | WriteINIStr "${FILENAME}.url" "InternetShortcut" "URL" "${URL}" 3 | WriteINIStr "${FILENAME}.url" "InternetShortcut" "IconFile" "${ICONFILE}" 4 | WriteINIStr "${FILENAME}.url" "InternetShortcut" "IconIndex" "${ICONINDEX}" 5 | !macroend -------------------------------------------------------------------------------- /installers/win/README.md: -------------------------------------------------------------------------------- 1 | # Building Windows installer 2 | 3 | You will need the [NSIS installer](http://nsis.sourceforge.net/Download) to be installed. 4 | 5 | Once everything is installed, run something like this command: 6 | 7 | make_installer.cmd 0.19 8 | 9 | It will build an installer called `Elm-0.19-setup.exe`. -------------------------------------------------------------------------------- /installers/win/file.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/installers/win/file.ico -------------------------------------------------------------------------------- /installers/win/inst.dat: -------------------------------------------------------------------------------- 1 | SetOutPath "$INSTDIR\bin" 2 | File "${FILES_SOURCE_PATH}\bin\elm.exe" 3 | 4 | SetOutPath "$INSTDIR" 5 | File "file.ico" 6 | File "updatepath.vbs" 7 | File "removefrompath.vbs" -------------------------------------------------------------------------------- /installers/win/logo.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/installers/win/logo.ico -------------------------------------------------------------------------------- /installers/win/make_installer.cmd: -------------------------------------------------------------------------------- 1 | 2 | set version=%1 3 | 4 | mkdir files 5 | mkdir files\bin 6 | 7 | xcopy ..\..\dist\build\elm\elm.exe files\bin /s /e 8 | xcopy updatepath.vbs files 9 | 10 | if EXIST "%ProgramFiles%\NSIS" ( 11 | set nsis="%ProgramFiles%\NSIS\makensis.exe" 12 | ) else ( 13 | set nsis="%ProgramFiles(x86)%\NSIS\makensis.exe" 14 | ) 15 | 16 | %nsis% /DPLATFORM_VERSION=%version% Nsisfile.nsi 17 | 18 | rd /s /q files 19 | -------------------------------------------------------------------------------- /installers/win/removefrompath.vbs: -------------------------------------------------------------------------------- 1 | Set WshShell = CreateObject("WScript.Shell") 2 | ' Make sure there is no trailing slash at the end of elmBasePath 3 | elmBasePath = WScript.Arguments(0) 4 | 'const PathRegKey = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path" 5 | const PathRegKey = "HKCU\Environment\Path" 6 | 7 | on error resume next 8 | path = WshShell.RegRead(PathRegKey) 9 | if err.number = 0 then 10 | Set regEx = New RegExp 11 | elmBasePath = Replace(Replace(Replace(elmBasePath, "\", "\\"), "(", "\("), ")", "\)") 12 | regEx.Pattern = elmBasePath & "\\\d+\.\d+(\.\d+|)\\bin(;|)" 13 | regEx.Global = True 14 | newPath = regEx.Replace(path, "") 15 | Call WshShell.RegWrite(PathRegKey, newPath, "REG_EXPAND_SZ") 16 | end if 17 | on error goto 0 18 | -------------------------------------------------------------------------------- /installers/win/uninst.dat: -------------------------------------------------------------------------------- 1 | Delete "$INSTDIR\bin\elm.exe" 2 | RmDir "$INSTDIR\bin" 3 | 4 | Delete "$INSTDIR\file.ico" 5 | Delete "$INSTDIR\updatepath.vbs" 6 | Delete "$INSTDIR\removefrompath.vbs" 7 | RmDir "$INSTDIR" -------------------------------------------------------------------------------- /installers/win/updatepath.vbs: -------------------------------------------------------------------------------- 1 | Set WshShell = CreateObject("WScript.Shell") 2 | elmPath = WScript.Arguments(0) 3 | 'const PathRegKey = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path" 4 | const PathRegKey = "HKCU\Environment\Path" 5 | 6 | on error resume next 7 | path = WshShell.RegRead(PathRegKey) 8 | if err.number <> 0 then 9 | path = "" 10 | end if 11 | on error goto 0 12 | 13 | newPath = elmPath & ";" & path 14 | Call WshShell.RegWrite(PathRegKey, newPath, "REG_EXPAND_SZ") 15 | -------------------------------------------------------------------------------- /installers/win/welcome.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/installers/win/welcome.bmp -------------------------------------------------------------------------------- /reactor/assets/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/reactor/assets/favicon.ico -------------------------------------------------------------------------------- /reactor/assets/source-code-pro.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/reactor/assets/source-code-pro.ttf -------------------------------------------------------------------------------- /reactor/assets/source-sans-pro.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/reactor/assets/source-sans-pro.ttf -------------------------------------------------------------------------------- /reactor/assets/styles.css: -------------------------------------------------------------------------------- 1 | @charset "UTF-8"; 2 | 3 | 4 | /* FONTS */ 5 | 6 | @font-face { 7 | font-family: 'Source Code Pro'; 8 | font-style: normal; 9 | font-weight: 400; 10 | src: local('Source Code Pro'), local('SourceCodePro-Regular'), url(/_elm/source-code-pro.ttf) format('truetype'); 11 | } 12 | 13 | @font-face { 14 | font-family: 'Source Sans Pro'; 15 | font-style: normal; 16 | font-weight: 400; 17 | src: local('Source Sans Pro'), local('SourceSansPro-Regular'), url(/_elm/source-sans-pro.ttf) format('truetype'); 18 | } 19 | 20 | 21 | /* GENERIC STUFF */ 22 | 23 | html, head, body { 24 | margin: 0; 25 | height: 100%; 26 | } 27 | 28 | body { 29 | font-family: 'Source Sans Pro', 'Trebuchet MS', 'Lucida Grande', 'Bitstream Vera Sans', 'Helvetica Neue', sans-serif; 30 | color: #293c4b; 31 | } 32 | 33 | a { 34 | color: #60B5CC; 35 | text-decoration: none; 36 | } 37 | 38 | a:hover { 39 | text-decoration: underline; 40 | } 41 | 42 | 43 | /* INDEX */ 44 | 45 | .header { 46 | width: 100%; 47 | background-color: #60B5CC; 48 | height: 8px; 49 | } 50 | 51 | .content { 52 | width: 960px; 53 | margin-left: auto; 54 | margin-right: auto; 55 | } 56 | 57 | 58 | /* COLUMNS */ 59 | 60 | .left-column { 61 | float: left; 62 | width: 600px; 63 | padding-bottom: 80px; 64 | } 65 | 66 | .right-column { 67 | float: right; 68 | width: 300px; 69 | padding-bottom: 80px; 70 | } 71 | 72 | 73 | /* BOXES */ 74 | 75 | .box { 76 | border: 1px solid #c7c7c7; 77 | border-radius: 5px; 78 | margin-bottom: 40px; 79 | } 80 | 81 | .box-header { 82 | display: block; 83 | overflow: hidden; 84 | padding: 7px 12px; 85 | background-color: #fafafa; 86 | text-align: center; 87 | border-radius: 5px; 88 | } 89 | 90 | .box-item { 91 | display: block; 92 | overflow: hidden; 93 | padding: 7px 12px; 94 | border-top: 1px solid #e1e1e1; 95 | } 96 | 97 | .box-footer { 98 | display: block; 99 | overflow: hidden; 100 | padding: 2px 12px; 101 | border-top: 1px solid #e1e1e1; 102 | text-align: center; 103 | background-color: #fafafa; 104 | height: 16px; 105 | } 106 | 107 | 108 | /* ICONS */ 109 | 110 | .icon { 111 | display: inline-block; 112 | vertical-align: middle; 113 | padding-right: 0.5em; 114 | } 115 | 116 | 117 | /* PAGES */ 118 | 119 | .page-name { 120 | float: left; 121 | } 122 | 123 | .page-size { 124 | float: right; 125 | color: #293c4b; 126 | } 127 | 128 | .page-size:hover { 129 | color: #60B5CC; 130 | } 131 | 132 | 133 | /* WAITING */ 134 | 135 | .waiting { 136 | width: 100%; 137 | height: 100%; 138 | display: flex; 139 | flex-direction: column; 140 | justify-content: center; 141 | align-items: center; 142 | color: #9A9A9A; 143 | } 144 | 145 | 146 | /* NOT FOUND */ 147 | 148 | .not-found { 149 | width: 100%; 150 | height: 100%; 151 | display: flex; 152 | flex-direction: column; 153 | justify-content: center; 154 | align-items: center; 155 | background-color: #F5F5F5; 156 | color: #9A9A9A; 157 | } 158 | -------------------------------------------------------------------------------- /reactor/assets/waiting.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/83e7c042ab3d636f6674abddac0f18b280d4b84a/reactor/assets/waiting.gif -------------------------------------------------------------------------------- /reactor/check.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | import os 4 | import sys 5 | 6 | 7 | ## FIGURE OUT NEW MODIFICATION TIME 8 | 9 | def mostRecentModification(directory): 10 | mostRecent = 0 11 | 12 | for dirpath, dirs, files in os.walk(directory): 13 | for f in files: 14 | lastModified = os.path.getmtime(dirpath + '/' + f) 15 | mostRecent = max(int(lastModified), mostRecent) 16 | 17 | return mostRecent 18 | 19 | 20 | srcTime = mostRecentModification('ui/src') 21 | assetTime = mostRecentModification('ui/assets') 22 | mostRecent = max(srcTime, assetTime) 23 | 24 | 25 | ## FIGURE OUT OLD MODIFICATION TIME 26 | 27 | with open('ui/last-modified', 'a') as handle: 28 | pass 29 | 30 | 31 | prevMostRecent = 0 32 | 33 | 34 | with open('ui/last-modified', 'r+') as handle: 35 | line = handle.read() 36 | prevMostRecent = int(line) if line else 0 37 | 38 | 39 | ## TOUCH FILES IF NECESSARY 40 | 41 | if mostRecent > prevMostRecent: 42 | print "+------------------------------------------------------------+" 43 | print "| Some ui/ code changed. Touching src/Reactor/StaticFiles.hs |" 44 | print "| to trigger a recompilation of the Template Haskell stuff. |" 45 | print "+------------------------------------------------------------+" 46 | os.utime('src/Reactor/StaticFiles.hs', None) 47 | with open('ui/last-modified', 'w') as handle: 48 | handle.write(str(mostRecent)) 49 | -------------------------------------------------------------------------------- /reactor/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.0", 7 | "dependencies": { 8 | "direct": { 9 | "elm/browser": "1.0.0", 10 | "elm/core": "1.0.0", 11 | "elm/html": "1.0.0", 12 | "elm/http": "1.0.0", 13 | "elm/json": "1.0.0", 14 | "elm/project-metadata-utils": "1.0.0", 15 | "elm/svg": "1.0.0", 16 | "elm-explorations/markdown": "1.0.0" 17 | }, 18 | "indirect": { 19 | "elm/parser": "1.0.0", 20 | "elm/time": "1.0.0", 21 | "elm/url": "1.0.0", 22 | "elm/virtual-dom": "1.0.0" 23 | } 24 | }, 25 | "test-dependencies": { 26 | "direct": {}, 27 | "indirect": {} 28 | } 29 | } -------------------------------------------------------------------------------- /reactor/src/Index/Navigator.elm: -------------------------------------------------------------------------------- 1 | module Index.Navigator exposing (view) 2 | 3 | 4 | import Html exposing (..) 5 | import Html.Attributes exposing (..) 6 | import Index.Icon as Icon 7 | 8 | 9 | 10 | -- VIEW 11 | 12 | 13 | view : String -> List String -> Html msg 14 | view root dirs = 15 | div 16 | [ style "font-size" "2em" 17 | , style "padding" "20px 0" 18 | , style "display" "flex" 19 | , style "align-items" "center" 20 | , style "height" "40px" 21 | ] 22 | (makeLinks root dirs "/" []) 23 | 24 | 25 | makeLinks : String -> List String -> String -> List (Html msg) -> List (Html msg) 26 | makeLinks root dirs oldPath revAnchors = 27 | case dirs of 28 | dir :: otherDirs -> 29 | let 30 | newPath = 31 | oldPath ++ "/" ++ dir 32 | 33 | anchor = 34 | a [ href newPath ] [ text dir ] 35 | in 36 | makeLinks root otherDirs newPath (anchor :: revAnchors) 37 | 38 | [] -> 39 | let 40 | home = 41 | a [ href "/" 42 | , title root 43 | , style "display" "inherit" 44 | ] 45 | [ Icon.home 46 | ] 47 | in 48 | case revAnchors of 49 | [] -> 50 | [home] 51 | 52 | lastAnchor :: otherRevAnchors -> 53 | home :: slash :: List.foldl addSlash [lastAnchor] otherRevAnchors 54 | 55 | 56 | addSlash : Html msg -> List (Html msg) -> List (Html msg) 57 | addSlash front back = 58 | front :: slash :: back 59 | 60 | 61 | slash : Html msg 62 | slash = 63 | span [ style "padding" "0 8px" ] [ text "/" ] 64 | -------------------------------------------------------------------------------- /reactor/src/Index/Skeleton.elm: -------------------------------------------------------------------------------- 1 | module Index.Skeleton exposing 2 | ( box 3 | , readmeBox 4 | ) 5 | 6 | import Html exposing (..) 7 | import Html.Attributes exposing (..) 8 | import Markdown 9 | 10 | import Index.Icon as Icon 11 | 12 | 13 | 14 | -- VIEW BOXES 15 | 16 | 17 | type alias BoxArgs msg = 18 | { title : String 19 | , items : List (List (Html msg)) 20 | , footer : Maybe (String, String) 21 | } 22 | 23 | 24 | box : BoxArgs msg -> Html msg 25 | box { title, items, footer } = 26 | let 27 | realItems = 28 | List.map (div [ class "box-item" ]) items 29 | in 30 | boxHelp title realItems footer 31 | 32 | 33 | readmeBox : String -> Html msg 34 | readmeBox markdown = 35 | let 36 | readme = 37 | Markdown.toHtml [ class "box-item" ] markdown 38 | in 39 | boxHelp "README" [readme] Nothing 40 | 41 | 42 | boxHelp : String -> List (Html msg) -> Maybe (String, String) -> Html msg 43 | boxHelp boxTitle items footer = 44 | div [ class "box" ] <| 45 | div [ class "box-header" ] [ text boxTitle ] 46 | :: items 47 | ++ [ boxFooter footer ] 48 | 49 | 50 | boxFooter : Maybe (String, String) -> Html msg 51 | boxFooter maybeFooter = 52 | case maybeFooter of 53 | Nothing -> 54 | text "" 55 | 56 | Just (path, description) -> 57 | a [ href path 58 | , title description 59 | ] 60 | [ div [ class "box-footer" ] [ Icon.plus ] 61 | ] 62 | -------------------------------------------------------------------------------- /reactor/src/NotFound.elm: -------------------------------------------------------------------------------- 1 | module NotFound exposing (main) 2 | 3 | 4 | import Browser 5 | import Html exposing (..) 6 | import Html.Attributes exposing (..) 7 | 8 | 9 | 10 | main : Program () () () 11 | main = 12 | Browser.document 13 | { init = \_ -> ((), Cmd.none) 14 | , update = \_ _ -> ((), Cmd.none) 15 | , subscriptions = \_ -> Sub.none 16 | , view = \_ -> page 17 | } 18 | 19 | 20 | page : Browser.Document () 21 | page = 22 | { title = "Page not found" 23 | , body = 24 | [ div [ class "not-found" ] 25 | [ div [ style "font-size" "12em" ] [ text "404" ] 26 | , div [ style "font-size" "3em" ] [ text "Page not found" ] 27 | ] 28 | ] 29 | } -------------------------------------------------------------------------------- /terminal/src/Bump.hs: -------------------------------------------------------------------------------- 1 | module Bump (run) where 2 | 3 | 4 | import qualified Elm.Bump as Bump 5 | import qualified Elm.Project as Project 6 | import qualified Reporting.Task as Task 7 | import qualified Reporting.Progress.Terminal as Terminal 8 | 9 | 10 | 11 | -- RUN 12 | 13 | 14 | run :: () -> () -> IO () 15 | run () () = 16 | do reporter <- Terminal.create 17 | Task.run reporter $ 18 | do summary <- Project.getRoot 19 | Bump.bump summary 20 | -------------------------------------------------------------------------------- /terminal/src/Develop/Generate/Help.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | module Develop.Generate.Help 5 | ( makePageHtml 6 | , makeCodeHtml 7 | ) 8 | where 9 | 10 | 11 | import qualified Data.ByteString.Builder as B 12 | import Data.Monoid ((<>)) 13 | import Text.RawString.QQ (r) 14 | 15 | import qualified Elm.Name as N 16 | import qualified Json.Encode as Encode 17 | 18 | 19 | 20 | -- PAGES 21 | 22 | 23 | makePageHtml :: N.Name -> Maybe Encode.Value -> B.Builder 24 | makePageHtml moduleName maybeFlags = 25 | [r| 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 36 | 37 | 38 | |] 39 | 40 | 41 | 42 | -- CODE 43 | 44 | 45 | makeCodeHtml :: FilePath -> B.Builder -> B.Builder 46 | makeCodeHtml title code = 47 | [r| 48 | 49 | 50 | 51 | |] <> B.stringUtf8 title <> [r| 52 | 57 | 58 | 59 | 60 | 61 | 62 | 
|] <> code <> [r|
63 | 64 | 65 | |] 66 | -------------------------------------------------------------------------------- /terminal/src/Develop/Generate/Index.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Develop.Generate.Index 4 | ( get 5 | ) 6 | where 7 | 8 | 9 | import Control.Monad (filterM) 10 | import qualified Data.ByteString.Builder as B 11 | import qualified Data.Map as Map 12 | import qualified Data.Text as Text 13 | import qualified Data.Text.IO as Text 14 | import qualified System.Directory as Dir 15 | import System.FilePath ((), splitDirectories, takeExtension) 16 | 17 | import qualified Develop.Generate.Help as Help 18 | import qualified Elm.Package as Pkg 19 | import qualified Elm.Project.Json as Project 20 | import qualified Elm.Project.Summary as Summary 21 | import qualified Json.Encode as E 22 | import qualified Reporting.Progress as Progress 23 | import qualified Reporting.Task as Task 24 | import qualified Stuff.Verify as Verify 25 | 26 | 27 | 28 | -- GET 29 | 30 | 31 | get :: FilePath -> FilePath -> IO B.Builder 32 | get root pwd = 33 | do flags <- getFlags root pwd 34 | return $ Help.makePageHtml "Index" (Just (encode flags)) 35 | 36 | 37 | 38 | -- FLAGS 39 | 40 | 41 | data Flags = 42 | Flags 43 | { _root :: FilePath 44 | , _pwd :: [String] 45 | , _dirs :: [FilePath] 46 | , _files :: [(FilePath, Bool)] 47 | , _readme :: Maybe Text.Text 48 | , _project :: Maybe Project.Project 49 | , _exactDeps :: Map.Map Pkg.Name Pkg.Version 50 | } 51 | 52 | 53 | 54 | -- JSON 55 | 56 | 57 | encode :: Flags -> E.Value 58 | encode (Flags root pwd dirs files readme project exactDeps) = 59 | E.object 60 | [ ( "root", encodeFilePath root ) 61 | , ( "pwd", E.list encodeFilePath pwd ) 62 | , ( "dirs", E.list encodeFilePath dirs ) 63 | , ( "files", E.list encodeFile files ) 64 | , ( "readme", maybe E.null E.text readme ) 65 | , ( "project", maybe E.null Project.encode project ) 66 | , ( "exactDeps", E.dict Pkg.toText Pkg.encodeVersion exactDeps) 67 | ] 68 | 69 | 70 | encodeFilePath :: FilePath -> E.Value 71 | encodeFilePath filePath = 72 | E.text (Text.pack filePath) 73 | 74 | 75 | encodeFile :: (FilePath, Bool) -> E.Value 76 | encodeFile (file, hasMain) = 77 | E.object 78 | [ ("name", encodeFilePath file) 79 | , ("runnable", E.bool hasMain) 80 | ] 81 | 82 | 83 | 84 | -- GET FLAGS 85 | 86 | 87 | getFlags :: FilePath -> FilePath -> IO Flags 88 | getFlags root pwd = 89 | do (dirs, files) <- getDirsAndFiles pwd 90 | readme <- getReadme pwd 91 | exists <- Dir.doesFileExist (root "elm.json") 92 | 93 | maybeSummary <- 94 | if exists then 95 | Task.try Progress.silentReporter $ 96 | Verify.verify root =<< Project.read (root "elm.json") 97 | else 98 | return Nothing 99 | 100 | return $ 101 | Flags 102 | { _root = root 103 | , _pwd = dropWhile ("." ==) (splitDirectories pwd) 104 | , _dirs = dirs 105 | , _files = files 106 | , _readme = readme 107 | , _project = fmap Summary._project maybeSummary 108 | , _exactDeps = maybe Map.empty (Map.map fst . Summary._depsGraph) maybeSummary 109 | } 110 | 111 | 112 | getReadme :: FilePath -> IO (Maybe Text.Text) 113 | getReadme dir = 114 | do let readmePath = dir "README.md" 115 | exists <- Dir.doesFileExist readmePath 116 | if exists 117 | then Just <$> Text.readFile readmePath 118 | else return Nothing 119 | 120 | 121 | getDirsAndFiles :: FilePath -> IO ([FilePath], [(FilePath, Bool)]) 122 | getDirsAndFiles pwd = 123 | do contents <- Dir.getDirectoryContents pwd 124 | dirs <- filterM (Dir.doesDirectoryExist . (pwd )) contents 125 | filePaths <- filterM (Dir.doesFileExist . (pwd )) contents 126 | files <- mapM (inspectFile pwd) filePaths 127 | return (dirs, files) 128 | 129 | 130 | inspectFile :: FilePath -> FilePath -> IO (FilePath, Bool) 131 | inspectFile pwd path = 132 | if takeExtension path == ".elm" then 133 | do source <- Text.readFile (pwd path) 134 | let hasMain = Text.isInfixOf "\nmain " source 135 | return (path, hasMain) 136 | 137 | else 138 | return (path, False) 139 | -------------------------------------------------------------------------------- /terminal/src/Develop/Socket.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Develop.Socket (watchFile) where 4 | 5 | import Control.Concurrent (forkIO, threadDelay) 6 | import Control.Exception (SomeException, catch) 7 | import qualified Data.ByteString.Char8 as BS 8 | import qualified Network.WebSockets as WS 9 | import qualified System.FSNotify.Devel as Notify 10 | import qualified System.FSNotify as Notify 11 | 12 | 13 | 14 | watchFile :: FilePath -> WS.PendingConnection -> IO () 15 | watchFile watchedFile pendingConnection = 16 | do connection <- WS.acceptRequest pendingConnection 17 | 18 | Notify.withManager $ \mgmt -> 19 | do stop <- Notify.treeExtAny mgmt "." ".elm" print 20 | tend connection 21 | stop 22 | 23 | 24 | tend :: WS.Connection -> IO () 25 | tend connection = 26 | let 27 | pinger :: Integer -> IO a 28 | pinger n = 29 | do threadDelay (5 * 1000 * 1000) 30 | WS.sendPing connection (BS.pack (show n)) 31 | pinger (n + 1) 32 | 33 | receiver :: IO () 34 | receiver = 35 | do _ <- WS.receiveDataMessage connection 36 | receiver 37 | 38 | shutdown :: SomeException -> IO () 39 | shutdown _ = 40 | return () 41 | in 42 | do _pid <- forkIO (receiver `catch` shutdown) 43 | pinger 1 `catch` shutdown 44 | -------------------------------------------------------------------------------- /terminal/src/Develop/StaticFiles.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | module Develop.StaticFiles 5 | ( lookup 6 | , cssPath 7 | , elmPath 8 | , waitingPath 9 | ) 10 | where 11 | 12 | import Prelude hiding (lookup) 13 | import qualified Data.ByteString as BS 14 | import Data.FileEmbed (bsToExp) 15 | import qualified Data.HashMap.Strict as HM 16 | import Language.Haskell.TH (runIO) 17 | import System.FilePath (()) 18 | 19 | import qualified Develop.StaticFiles.Build as Build 20 | 21 | 22 | 23 | -- FILE LOOKUP 24 | 25 | 26 | type MimeType = 27 | BS.ByteString 28 | 29 | 30 | lookup :: FilePath -> Maybe (BS.ByteString, MimeType) 31 | lookup path = 32 | HM.lookup path dict 33 | 34 | 35 | dict :: HM.HashMap FilePath (BS.ByteString, MimeType) 36 | dict = 37 | HM.fromList 38 | [ faviconPath ==> (favicon , "image/x-icon") 39 | , waitingPath ==> (waiting , "image/gif") 40 | , elmPath ==> (elm , "application/javascript") 41 | , cssPath ==> (css , "text/css") 42 | , codeFontPath ==> (codeFont, "font/ttf") 43 | , sansFontPath ==> (sansFont, "font/ttf") 44 | ] 45 | 46 | 47 | (==>) :: a -> b -> (a,b) 48 | (==>) a b = 49 | (a, b) 50 | 51 | 52 | 53 | -- PATHS 54 | 55 | 56 | faviconPath :: FilePath 57 | faviconPath = 58 | "favicon.ico" 59 | 60 | 61 | waitingPath :: FilePath 62 | waitingPath = 63 | "_elm" "waiting.gif" 64 | 65 | 66 | elmPath :: FilePath 67 | elmPath = 68 | "_elm" "elm.js" 69 | 70 | 71 | cssPath :: FilePath 72 | cssPath = 73 | "_elm" "styles.css" 74 | 75 | 76 | codeFontPath :: FilePath 77 | codeFontPath = 78 | "_elm" "source-code-pro.ttf" 79 | 80 | 81 | sansFontPath :: FilePath 82 | sansFontPath = 83 | "_elm" "source-sans-pro.ttf" 84 | 85 | 86 | 87 | -- ELM 88 | 89 | 90 | elm :: BS.ByteString 91 | elm = 92 | $(bsToExp =<< runIO Build.compile) 93 | 94 | 95 | 96 | -- CSS 97 | 98 | 99 | css :: BS.ByteString 100 | css = 101 | $(bsToExp =<< runIO (Build.readAsset "styles.css")) 102 | 103 | 104 | 105 | -- FONTS 106 | 107 | 108 | codeFont :: BS.ByteString 109 | codeFont = 110 | $(bsToExp =<< runIO (Build.readAsset "source-code-pro.ttf")) 111 | 112 | 113 | sansFont :: BS.ByteString 114 | sansFont = 115 | $(bsToExp =<< runIO (Build.readAsset "source-sans-pro.ttf")) 116 | 117 | 118 | 119 | -- IMAGES 120 | 121 | 122 | favicon :: BS.ByteString 123 | favicon = 124 | $(bsToExp =<< runIO (Build.readAsset "favicon.ico")) 125 | 126 | 127 | waiting :: BS.ByteString 128 | waiting = 129 | $(bsToExp =<< runIO (Build.readAsset "waiting.gif")) 130 | -------------------------------------------------------------------------------- /terminal/src/Develop/StaticFiles/Build.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Develop.StaticFiles.Build 3 | ( readAsset 4 | , compile 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.ByteString as BS 10 | import qualified System.Directory as Dir 11 | import System.FilePath (()) 12 | 13 | import qualified Elm.Project as Project 14 | import qualified Generate.Output as Output 15 | import qualified Reporting.Task as Task 16 | import qualified Reporting.Progress.Terminal as Terminal 17 | 18 | 19 | 20 | -- ASSETS 21 | 22 | 23 | readAsset :: FilePath -> IO BS.ByteString 24 | readAsset path = 25 | BS.readFile ("reactor" "assets" path) 26 | 27 | 28 | 29 | -- COMPILE 30 | 31 | 32 | compile :: IO BS.ByteString 33 | compile = 34 | Dir.withCurrentDirectory "reactor" $ 35 | do reporter <- Terminal.create 36 | Task.run reporter $ 37 | do summary <- Project.getRoot 38 | let jsOutput = Just (Output.JavaScript Nothing tempFileName) 39 | Project.compile Output.Prod Output.Client jsOutput Nothing summary rootPaths 40 | 41 | result <- BS.readFile tempFileName 42 | seq (BS.length result) (Dir.removeFile tempFileName) 43 | return result 44 | 45 | 46 | tempFileName :: FilePath 47 | tempFileName = 48 | "elm.js" 49 | 50 | 51 | rootPaths :: [FilePath] 52 | rootPaths = 53 | [ "src" "Errors.elm" 54 | , "src" "Index.elm" 55 | , "src" "NotFound.elm" 56 | ] 57 | -------------------------------------------------------------------------------- /terminal/src/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Diff (run) where 3 | 4 | 5 | import qualified Elm.Diff as Diff 6 | import qualified Reporting.Task as Task 7 | import qualified Reporting.Progress.Terminal as Terminal 8 | 9 | 10 | 11 | -- RUN 12 | 13 | 14 | run :: Diff.Args -> () -> IO () 15 | run args () = 16 | do reporter <- Terminal.create 17 | Task.run reporter $ Diff.diff args 18 | -------------------------------------------------------------------------------- /terminal/src/Init.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Init 3 | ( run 4 | ) 5 | where 6 | 7 | 8 | import Prelude hiding (init) 9 | import Control.Monad.Trans (liftIO) 10 | import qualified Data.Map as Map 11 | import qualified System.Directory as Dir 12 | 13 | import qualified Deps.Cache as Cache 14 | import qualified Deps.Explorer as Explorer 15 | import qualified Deps.Solver as Solver 16 | import qualified Elm.Compiler.Version as Compiler 17 | import qualified Elm.Package as Pkg 18 | import qualified Elm.Project.Constraint as Con 19 | import qualified Elm.Project.Json as Project 20 | import qualified Reporting.Doc as D 21 | import qualified Reporting.Exit as Exit 22 | import qualified Reporting.Exit.Init as E 23 | import qualified Reporting.Task as Task 24 | import qualified Reporting.Progress.Terminal as Terminal 25 | 26 | 27 | 28 | -- RUN 29 | 30 | 31 | run :: () -> () -> IO () 32 | run () () = 33 | do reporter <- Terminal.create 34 | exists <- Dir.doesFileExist "elm.json" 35 | Task.run reporter $ 36 | if exists then 37 | Task.throw (Exit.Init E.AlreadyStarted) 38 | else 39 | do approved <- Task.getApproval question 40 | if approved 41 | then 42 | do init 43 | liftIO $ putStrLn "Okay, I created it. Now read that link!" 44 | else 45 | liftIO $ putStrLn "Okay, I did not make any changes!" 46 | 47 | 48 | question :: D.Doc 49 | question = 50 | D.stack 51 | [ D.fillSep 52 | ["Hello!" 53 | ,"Elm","projects","always","start","with","an",D.green "elm.json","file." 54 | ,"I","can","create","them!" 55 | ] 56 | , D.reflow 57 | "Now you may be wondering, what will be in this file? How do I add Elm files to\ 58 | \ my project? How do I see it in the browser? How will my code grow? Do I need\ 59 | \ more directories? What about tests? Etc." 60 | , D.fillSep 61 | ["Check","out",D.cyan (D.fromString (D.makeLink "init")) 62 | ,"for","all","the","answers!" 63 | ] 64 | , "Knowing all that, would you like me to create an elm.json file now? [Y/n]: " 65 | ] 66 | 67 | 68 | 69 | -- INIT 70 | 71 | 72 | init :: Task.Task () 73 | init = 74 | do registry <- Cache.optionalUpdate 75 | 76 | maybeSolution <- 77 | Explorer.run registry $ Solver.run $ Solver.solve defaults 78 | 79 | case maybeSolution of 80 | Just solution -> 81 | let 82 | directs = Map.intersection solution defaults 83 | indirects = Map.difference solution defaults 84 | in 85 | liftIO $ 86 | do Dir.createDirectoryIfMissing True "src" 87 | Project.write "." $ Project.App $ 88 | Project.AppInfo Compiler.version ["src"] directs indirects Map.empty Map.empty 89 | 90 | Nothing -> 91 | Task.throw (Exit.Init (E.NoSolution (Map.keys defaults))) 92 | 93 | 94 | defaults :: Map.Map Pkg.Name Con.Constraint 95 | defaults = 96 | Map.fromList 97 | [ (Pkg.core, Con.anything) 98 | , (Pkg.browser, Con.anything) 99 | , (Pkg.html, Con.anything) 100 | ] 101 | -------------------------------------------------------------------------------- /terminal/src/Install.hs: -------------------------------------------------------------------------------- 1 | module Install 2 | ( Args(..) 3 | , run 4 | ) 5 | where 6 | 7 | 8 | import Control.Monad.Trans (liftIO) 9 | 10 | import qualified Elm.Install as Install 11 | import qualified Elm.PerUserCache as PerUserCache 12 | import qualified Elm.Package as Pkg 13 | import qualified Reporting.Exit as Exit 14 | import qualified Reporting.Exit.Install as E 15 | import qualified Reporting.Task as Task 16 | import qualified Reporting.Progress.Terminal as Terminal 17 | 18 | 19 | 20 | -- RUN 21 | 22 | 23 | data Args 24 | = NoArgs 25 | | Install Pkg.Name 26 | 27 | 28 | run :: Args -> () -> IO () 29 | run args () = 30 | do reporter <- Terminal.create 31 | Task.run reporter $ 32 | case args of 33 | NoArgs -> 34 | do elmHome <- liftIO PerUserCache.getElmHome 35 | Task.throw (Exit.Install (E.NoArgs elmHome)) 36 | 37 | Install pkg -> 38 | Install.install pkg 39 | -------------------------------------------------------------------------------- /terminal/src/Make.hs: -------------------------------------------------------------------------------- 1 | module Make 2 | ( Flags(..) 3 | , run 4 | , ReportType(..) 5 | , reportType 6 | , docsFile 7 | ) 8 | where 9 | 10 | 11 | import qualified System.FilePath as FP 12 | 13 | import qualified Elm.Project as Project 14 | import qualified Generate.Output as Output 15 | import qualified Reporting.Exit as Exit 16 | import qualified Reporting.Exit.Make as E 17 | import qualified Reporting.Task as Task 18 | import qualified Reporting.Progress as Progress 19 | import qualified Reporting.Progress.Json as Json 20 | import qualified Reporting.Progress.Terminal as Terminal 21 | import Terminal.Args (Parser(..)) 22 | 23 | 24 | 25 | -- RUN 26 | 27 | 28 | data Flags = 29 | Flags 30 | { _debug :: Bool 31 | , _optimize :: Bool 32 | , _output :: Maybe Output.Output 33 | , _report :: Maybe ReportType 34 | , _docs :: Maybe FilePath 35 | } 36 | 37 | 38 | run :: [FilePath] -> Flags -> IO () 39 | run paths (Flags debug optimize output report docs) = 40 | do reporter <- toReporter report 41 | Task.run reporter $ 42 | do mode <- toMode debug optimize 43 | summary <- Project.getRoot 44 | Project.compile mode Output.Client output docs summary paths 45 | 46 | 47 | toMode :: Bool -> Bool -> Task.Task Output.Mode 48 | toMode debug optimize = 49 | case (debug, optimize) of 50 | (True , True ) -> Task.throw $ Exit.Make E.CannotOptimizeAndDebug 51 | (False, True ) -> return Output.Prod 52 | (False, False) -> return Output.Dev 53 | (True , False) -> return Output.Debug 54 | 55 | 56 | toReporter :: Maybe ReportType -> IO Progress.Reporter 57 | toReporter report = 58 | case report of 59 | Nothing -> Terminal.create 60 | Just Json -> return Json.reporter 61 | 62 | 63 | 64 | -- REPORT 65 | 66 | 67 | data ReportType 68 | = Json 69 | 70 | 71 | reportType :: Parser ReportType 72 | reportType = 73 | Parser 74 | { _singular = "report type" 75 | , _plural = "report types" 76 | , _parser = \string -> if string == "json" then Just Json else Nothing 77 | , _suggest = \_ -> return ["json"] 78 | , _examples = \_ -> return ["json"] 79 | } 80 | 81 | 82 | 83 | -- DOCS 84 | 85 | 86 | docsFile :: Parser FilePath 87 | docsFile = 88 | Parser 89 | { _singular = "json file" 90 | , _plural = "json files" 91 | , _parser = \string -> if FP.takeExtension string == ".json" then Just string else Nothing 92 | , _suggest = \_ -> return [] 93 | , _examples = \_ -> return ["docs.json","documentation.json"] 94 | } 95 | -------------------------------------------------------------------------------- /terminal/src/Publish.hs: -------------------------------------------------------------------------------- 1 | module Publish (run) where 2 | 3 | 4 | import qualified Elm.Project as Project 5 | import qualified Elm.Publish as Publish 6 | import qualified Reporting.Task as Task 7 | import qualified Reporting.Progress.Terminal as Terminal 8 | 9 | 10 | 11 | -- RUN 12 | 13 | 14 | run :: () -> () -> IO () 15 | run () () = 16 | do reporter <- Terminal.create 17 | Task.run reporter $ 18 | do summary <- Project.getRoot 19 | Publish.publish summary 20 | -------------------------------------------------------------------------------- /terminal/src/Terminal/Args/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Terminal.Args.Helpers 3 | ( version 4 | , elmFile 5 | , package 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.Char as Char 11 | import qualified Data.Text as Text 12 | import qualified System.FilePath as FP 13 | 14 | import Terminal.Args (Parser(..)) 15 | import qualified Elm.Package as Pkg 16 | 17 | 18 | 19 | -- VERSION 20 | 21 | 22 | version :: Parser Pkg.Version 23 | version = 24 | Parser 25 | { _singular = "version" 26 | , _plural = "versions" 27 | , _parser = parseVersion 28 | , _suggest = suggestVersion 29 | , _examples = return . exampleVersions 30 | } 31 | 32 | 33 | parseVersion :: String -> Maybe Pkg.Version 34 | parseVersion str = 35 | Pkg.versionFromText (Text.pack str) 36 | 37 | 38 | suggestVersion :: String -> IO [String] 39 | suggestVersion _ = 40 | return [] 41 | 42 | 43 | exampleVersions :: String -> [String] 44 | exampleVersions string = 45 | let 46 | chunks = map Text.unpack (Text.splitOn "." (Text.pack string)) 47 | isNumber str = not (null str) && all Char.isDigit str 48 | in 49 | if all isNumber chunks then 50 | case chunks of 51 | [x] -> [ x ++ ".0.0" ] 52 | [x,y] -> [ x ++ "." ++ y ++ ".0" ] 53 | x:y:z:_ -> [ x ++ "." ++ y ++ "." ++ z ] 54 | _ -> ["1.0.0", "2.0.3"] 55 | 56 | else 57 | ["1.0.0", "2.0.3"] 58 | 59 | 60 | 61 | -- ELM FILE 62 | 63 | 64 | elmFile :: Parser FilePath 65 | elmFile = 66 | Parser 67 | { _singular = "elm file" 68 | , _plural = "elm files" 69 | , _parser = parseElmFile 70 | , _suggest = \_ -> return [] 71 | , _examples = exampleElmFiles 72 | } 73 | 74 | 75 | parseElmFile :: String -> Maybe FilePath 76 | parseElmFile string = 77 | if FP.takeExtension string == ".elm" then 78 | Just string 79 | else 80 | Nothing 81 | 82 | 83 | exampleElmFiles :: String -> IO [String] 84 | exampleElmFiles _ = 85 | return ["Main.elm","src/Main.elm"] 86 | 87 | 88 | 89 | -- PACKAGE 90 | 91 | 92 | package :: Parser Pkg.Name 93 | package = 94 | Parser 95 | { _singular = "package" 96 | , _plural = "packages" 97 | , _parser = parsePackage 98 | , _suggest = suggestPackages 99 | , _examples = examplePackages 100 | } 101 | 102 | 103 | parsePackage :: String -> Maybe Pkg.Name 104 | parsePackage string = 105 | either (const Nothing) Just $ 106 | Pkg.fromText (Text.pack string) 107 | 108 | 109 | suggestPackages :: String -> IO [String] 110 | suggestPackages _ = 111 | return [] 112 | 113 | 114 | examplePackages :: String -> IO [String] 115 | examplePackages string = 116 | case Pkg.fromText (Text.pack string) of 117 | Left (_, suggestions@(_:_)) -> 118 | return suggestions 119 | 120 | _ -> 121 | return 122 | [ "elm/http" 123 | , "elm/json" 124 | , "elm-community/random-extra" 125 | ] 126 | -------------------------------------------------------------------------------- /terminal/src/Terminal/Args/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module Terminal.Args.Internal 3 | ( Interface(..) 4 | , toName 5 | , Summary(..) 6 | , Flags(..) 7 | , Flag(..) 8 | , Parser(..) 9 | , Args(..) 10 | , CompleteArgs(..) 11 | , RequiredArgs(..) 12 | ) 13 | where 14 | 15 | 16 | import Text.PrettyPrint.ANSI.Leijen (Doc) 17 | 18 | 19 | 20 | -- INTERFACE 21 | 22 | 23 | data Interface where 24 | Interface 25 | :: String 26 | -> Summary 27 | -> String 28 | -> Doc 29 | -> Args args 30 | -> Flags flags 31 | -> (args -> flags -> IO ()) 32 | -> Interface 33 | 34 | 35 | toName :: Interface -> String 36 | toName (Interface name _ _ _ _ _ _) = 37 | name 38 | 39 | 40 | 41 | {-| The information that shows when you run the executable with no arguments. 42 | If you say it is `Common`, you need to tell people what it does. Try to keep 43 | it to two or three lines. If you say it is `Uncommon` you can rely on `Details` 44 | for a more complete explanation. 45 | -} 46 | data Summary = Common String | Uncommon 47 | 48 | 49 | 50 | -- FLAGS 51 | 52 | 53 | data Flags a where 54 | FDone :: a -> Flags a 55 | FMore :: Flags (a -> b) -> Flag a -> Flags b 56 | 57 | 58 | data Flag a where 59 | Flag :: String -> Parser a -> String -> Flag (Maybe a) 60 | OnOff :: String -> String -> Flag Bool 61 | 62 | 63 | 64 | -- PARSERS 65 | 66 | 67 | data Parser a = 68 | Parser 69 | { _singular :: String 70 | , _plural :: String 71 | , _parser :: String -> Maybe a 72 | , _suggest :: String -> IO [String] 73 | , _examples :: String -> IO [String] 74 | } 75 | 76 | 77 | 78 | -- ARGS 79 | 80 | 81 | newtype Args a = 82 | Args [CompleteArgs a] 83 | 84 | 85 | data CompleteArgs args where 86 | Exactly :: RequiredArgs args -> CompleteArgs args 87 | Multiple :: RequiredArgs ([a] -> args) -> Parser a -> CompleteArgs args 88 | Optional :: RequiredArgs (Maybe a -> args) -> Parser a -> CompleteArgs args 89 | 90 | 91 | data RequiredArgs a where 92 | Done :: a -> RequiredArgs a 93 | Required :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b 94 | --------------------------------------------------------------------------------