├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── elm.json ├── scripts └── static-dir.js └── src ├── Builder ├── Build.elm ├── Deps │ ├── Registry.elm │ ├── Solver.elm │ └── Website.elm ├── Elm │ ├── Details.elm │ └── Outline.elm ├── File.elm ├── Generate.elm ├── Http.elm ├── Reporting │ ├── Exit.elm │ ├── Exit │ │ └── Help.elm │ └── Task.elm └── Stuff.elm ├── Compiler ├── AST │ ├── Canonical.elm │ ├── Optimized.elm │ ├── Source.elm │ └── Utils │ │ ├── Binop.elm │ │ ├── Shader.elm │ │ └── Type.elm ├── Canonicalize │ ├── Effects.elm │ ├── Environment.elm │ ├── Environment │ │ ├── Dups.elm │ │ ├── Foreign.elm │ │ └── Local.elm │ ├── Expression.elm │ ├── Module.elm │ ├── Pattern.elm │ └── Type.elm ├── Compile.elm ├── Data │ ├── Bag.elm │ ├── Index.elm │ ├── Name.elm │ ├── NonEmptyList.elm │ ├── OneOrMore.elm │ └── Utf8.elm ├── Elm │ ├── Compiler │ │ ├── Imports.elm │ │ ├── Type.elm │ │ └── Type │ │ │ └── Extract.elm │ ├── Constraint.elm │ ├── Float.elm │ ├── Interface.elm │ ├── Kernel.elm │ ├── Licenses.elm │ ├── ModuleName.elm │ ├── Package.elm │ ├── String.elm │ └── Version.elm ├── Generate │ ├── JavaScript.elm │ ├── JavaScript │ │ ├── Builder.elm │ │ ├── Expression.elm │ │ ├── Functions.elm │ │ └── Name.elm │ └── Mode.elm ├── Json │ ├── Decode.elm │ ├── Encode.elm │ └── String.elm ├── Nitpick │ ├── Debug.elm │ └── PatternMatches.elm ├── Optimize │ ├── Case.elm │ ├── DecisionTree.elm │ ├── Expression.elm │ ├── Module.elm │ ├── Names.elm │ └── Port.elm ├── Parse │ ├── Declaration.elm │ ├── Expression.elm │ ├── Keyword.elm │ ├── Module.elm │ ├── Number.elm │ ├── Pattern.elm │ ├── Primitives.elm │ ├── Shader.elm │ ├── Space.elm │ ├── String.elm │ ├── Symbol.elm │ ├── Type.elm │ └── Variable.elm ├── Reporting │ ├── Annotation.elm │ ├── Doc.elm │ ├── Error.elm │ ├── Error │ │ ├── Canonicalize.elm │ │ ├── Import.elm │ │ ├── Json.elm │ │ ├── Main.elm │ │ ├── Pattern.elm │ │ ├── Syntax.elm │ │ └── Type.elm │ ├── Render │ │ ├── Code.elm │ │ ├── Type.elm │ │ └── Type │ │ │ └── Localizer.elm │ ├── Report.elm │ ├── Result.elm │ ├── Suggest.elm │ └── Warning.elm └── Type │ ├── Constrain │ ├── Expression.elm │ ├── Module.elm │ └── Pattern.elm │ ├── Error.elm │ ├── Instantiate.elm │ ├── Occurs.elm │ ├── Solve.elm │ ├── Type.elm │ ├── Unify.elm │ └── UnionFind.elm ├── Extra ├── Class │ ├── Applicative.elm │ ├── Foldable.elm │ ├── Functor.elm │ ├── Monad.elm │ ├── Monoid.elm │ ├── StateT.elm │ └── Traversable.elm ├── Data │ ├── Binary.elm │ ├── Binary │ │ ├── Get.elm │ │ └── Put.elm │ ├── Graph.elm │ └── Pretty.elm ├── System │ ├── Exception.elm │ ├── File.elm │ ├── File │ │ ├── Remote.elm │ │ ├── Static.elm │ │ └── Util.elm │ ├── Http.elm │ ├── IO.elm │ ├── IO │ │ └── Pure.elm │ ├── IORef.elm │ ├── MVar.elm │ └── MVector.elm └── Type │ ├── Either.elm │ ├── Lens.elm │ ├── List.elm │ ├── Map.elm │ ├── Maybe.elm │ ├── Set.elm │ ├── String.elm │ └── Tuple.elm ├── Global.elm ├── Terminal ├── Command.elm ├── Helpers.elm ├── Init.elm ├── Install.elm ├── Main.elm ├── Make.elm ├── Reactor.elm ├── Repl.elm ├── Terminal.elm └── Terminal │ ├── Error.elm │ └── Internal.elm └── Test └── Main.elm /.gitignore: -------------------------------------------------------------------------------- 1 | elm-stuff/ 2 | work-in-progress/ -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2024-present Peter Capitain 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | 13 | --- 14 | 15 | License of the original Haskell code: 16 | 17 | Copyright 2012-present Evan Czaplicki 18 | 19 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 20 | 21 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 22 | 23 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 24 | 25 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 26 | 27 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: test 3 | 4 | test: 5 | elm make src/Test/Main.elm --output /dev/null 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Port of the Elm Compiler to Elm 2 | 3 |
4 | 5 | 6 | ## What Is It? 7 | 8 | A port of the Elm compiler from Haskell to Elm. 9 | 10 | For more information see the recording of the August 2024 Elm Online Meetup: 11 | https://www.youtube.com/watch?v=OK9S_HUdReA. 12 | 13 | This repository contains only the compiler backend, but no UI. 14 | As such, it is intended to be embedded into other apps. 15 | 16 |
17 | 18 | 19 | ## How to Use It? 20 | 21 | 22 | #### Embed the Code 23 | 24 | One possibility to embed the compiler backend is to add it as a Git subtree or a Git submodule into your project. 25 | 26 | The following two repositories embed the compiler backend as a Git subtree: 27 | 28 | * [elm-compiler-in-elm-ui](https://github.com/pithub/elm-compiler-in-elm-ui) provides a simple `elm reactor`-like user interface 29 | 30 | * [elm-repl-worker](https://github.com/pithub/elm-repl-worker) implements an Elm `Platform.Worker` internally running `elm repl` that communicates with your app via ports 31 | 32 |
33 | 34 | 35 | #### Compile the Code 36 | 37 | To test whether the code compiles you can run one of the following commands: 38 | 39 | ```sh 40 | make 41 | ``` 42 | 43 | or 44 | 45 | ```sh 46 | elm make src/Test/Main.elm --output /dev/null 47 | ``` 48 | 49 |
50 | -------------------------------------------------------------------------------- /elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.1", 7 | "dependencies": { 8 | "direct": { 9 | "agu-z/elm-zip": "3.0.1", 10 | "cmditch/elm-bigint": "2.0.1", 11 | "dasch/levenshtein": "1.0.3", 12 | "elm/bytes": "1.0.8", 13 | "elm/core": "1.0.5", 14 | "elm/http": "2.0.0", 15 | "elm/json": "1.1.3", 16 | "elm/project-metadata-utils": "1.0.2", 17 | "elm/time": "1.0.0", 18 | "miniBill/elm-unicode": "1.1.1", 19 | "rtfeldman/elm-hex": "1.0.0", 20 | "the-sett/elm-pretty-printer": "3.1.0" 21 | }, 22 | "indirect": { 23 | "elm/file": "1.0.5", 24 | "elm/parser": "1.1.0", 25 | "elm/regex": "1.0.0", 26 | "elm-community/basics-extra": "4.1.0", 27 | "elm-community/list-extra": "8.7.0", 28 | "elm-community/maybe-extra": "5.3.0", 29 | "folkertdev/elm-flate": "2.0.5", 30 | "justinmimbs/date": "4.1.0", 31 | "justinmimbs/time-extra": "1.2.0" 32 | } 33 | }, 34 | "test-dependencies": { 35 | "direct": {}, 36 | "indirect": {} 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /scripts/static-dir.js: -------------------------------------------------------------------------------- 1 | const fs = require('fs') 2 | const os = require('os') 3 | const path = require('path') 4 | 5 | // Read a directory recursively and return its contents as a nested object 6 | // If a file handle is provided, append the content of each file to the given file handle 7 | function readDirRec(dirPath, fileHandle = null) { 8 | const result = {} 9 | fs.readdirSync(dirPath).forEach(file => { 10 | const filePath = path.join(dirPath, file) 11 | const stats = fs.statSync(filePath) 12 | const mtime = Math.trunc(stats.mtimeMs) 13 | if (stats.isDirectory()) { 14 | result[file] = [readDirRec(filePath, fileHandle), mtime] 15 | } else { 16 | result[file] = [stats.size, mtime] 17 | if (fileHandle) { 18 | const content = fs.readFileSync(filePath) 19 | fs.appendFileSync(fileHandle, content) 20 | } 21 | } 22 | }) 23 | return result 24 | } 25 | 26 | // Read a directory recursively and return its contents as a nested array/object 27 | // If a file handle is provided, append the content of each file to the given file handle 28 | function readDir(dirPath, fileHandle = null) { 29 | const stats = fs.statSync(dirPath) 30 | const mtime = Math.trunc(stats.mtimeMs) 31 | return [readDirRec(dirPath, fileHandle), mtime] 32 | } 33 | 34 | // Export the readDir function for use in other modules 35 | module.exports = { readDir: readDir } 36 | 37 | // If this script is run directly, read the directory path provided as an argument 38 | // and write the directory tree and content to stdout 39 | if (require.main === module) { 40 | const dirPath = process.argv[2] 41 | if (!dirPath) { 42 | console.error('Please provide a directory path as the first argument.') 43 | process.exit(1) 44 | } 45 | const tmpDir = fs.mkdtempSync(os.tmpdir() + path.sep) 46 | try { 47 | const filePath = path.join(tmpDir, 'content') 48 | 49 | const fileHandle = fs.openSync(filePath, 'w') 50 | const result = JSON.stringify(readDir(dirPath, fileHandle)) 51 | fs.closeSync(fileHandle) 52 | 53 | const lengthBuffer = Buffer.alloc(4) 54 | lengthBuffer.writeUInt32BE(result.length, 0) 55 | process.stdout.write(lengthBuffer) 56 | process.stdout.write(result) 57 | process.stdout.write(fs.readFileSync(filePath)) 58 | } catch (error) { 59 | console.error('Error reading directory:', error.message) 60 | process.exit(1) 61 | } finally { 62 | fs.rmSync(tmpDir, { recursive: true }) 63 | } 64 | } -------------------------------------------------------------------------------- /src/Builder/Deps/Registry.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Builder.Deps.Registry exposing 3 | ( Registry(..) 4 | , KnownVersions(..) 5 | , read 6 | , fetch 7 | , update 8 | --, latest 9 | , getVersions 10 | , getVersionsE 11 | ) 12 | 13 | 14 | import Builder.Deps.Website as Website 15 | import Builder.File as File 16 | import Builder.Http as Http 17 | import Builder.Reporting.Exit as Exit 18 | import Builder.Stuff as Stuff 19 | import Compiler.Elm.Package as Pkg 20 | import Compiler.Elm.Version as V 21 | import Compiler.Json.Decode as D 22 | import Compiler.Parse.Primitives as P 23 | import Extra.Data.Binary as B 24 | import Extra.System.IO as IO 25 | import Extra.Type.Either exposing (Either(..)) 26 | import Extra.Type.List as MList exposing (TList) 27 | import Extra.Type.Map as Map 28 | 29 | 30 | 31 | -- PRIVATE IO 32 | 33 | 34 | type alias IO c d e f g h v = 35 | IO.IO (Http.State c d e f g h) v 36 | 37 | 38 | 39 | -- REGISTRY 40 | 41 | 42 | type Registry = 43 | Registry 44 | {- count -} Int 45 | {- versions -} (Map.Map Pkg.Comparable KnownVersions) 46 | 47 | 48 | type KnownVersions = 49 | KnownVersions 50 | {- newest -} V.Version 51 | {- previous -} (TList V.Version) 52 | 53 | 54 | 55 | -- READ 56 | 57 | 58 | read : Stuff.PackageCache -> IO c d e f g h (Maybe Registry) 59 | read cache = 60 | File.readBinary bRegistry (Stuff.registry cache) 61 | 62 | 63 | 64 | -- FETCH 65 | 66 | 67 | fetch : Http.Manager -> Stuff.PackageCache -> IO c d e f g h (Either Exit.RegistryProblem Registry) 68 | fetch manager cache = 69 | post manager "/all-packages" allPkgsDecoder <| 70 | \versions -> 71 | let size = Map.foldr addEntry 0 versions in 72 | let registry = Registry size versions in 73 | let path = Stuff.registry cache in 74 | IO.bind (File.writeBinary bRegistry path registry) <| \_ -> 75 | IO.return registry 76 | 77 | 78 | addEntry : KnownVersions -> Int -> Int 79 | addEntry (KnownVersions _ vs) count = 80 | count + 1 + MList.length vs 81 | 82 | 83 | allPkgsDecoder : D.Decoder () (Map.Map Pkg.Comparable KnownVersions) 84 | allPkgsDecoder = 85 | let 86 | keyDecoder = 87 | Pkg.keyDecoder bail 88 | 89 | versionsDecoder = 90 | D.list (D.mapError (\_ -> ()) V.decoder) 91 | 92 | toKnownVersions versions = 93 | case MList.sortBy (\a b -> compare (V.toComparable b) (V.toComparable a)) versions of 94 | v::vs -> D.return (KnownVersions v vs) 95 | [] -> D.failure () 96 | in 97 | D.dict keyDecoder (D.andThen toKnownVersions versionsDecoder) 98 | 99 | 100 | 101 | -- UPDATE 102 | 103 | 104 | update : Http.Manager -> Stuff.PackageCache -> Registry -> IO c d e f g h (Either Exit.RegistryProblem Registry) 105 | update manager cache ((Registry size packages) as oldRegistry) = 106 | post manager ("/all-packages/since/" ++ String.fromInt size) (D.list newPkgDecoder) <| 107 | \news -> 108 | case news of 109 | [] -> 110 | IO.return oldRegistry 111 | 112 | _::_ -> 113 | let 114 | newSize = size + MList.length news 115 | newPkgs = MList.foldr addNew packages news 116 | newRegistry = Registry newSize newPkgs 117 | in 118 | IO.bind (File.writeBinary bRegistry (Stuff.registry cache) newRegistry) <| \_ -> 119 | IO.return newRegistry 120 | 121 | 122 | addNew : (Pkg.Name, V.Version) -> Map.Map Pkg.Comparable KnownVersions -> Map.Map Pkg.Comparable KnownVersions 123 | addNew (name, version) versions = 124 | let 125 | add maybeKnowns = 126 | case maybeKnowns of 127 | Just (KnownVersions v vs) -> 128 | KnownVersions version (v::vs) 129 | 130 | Nothing -> 131 | KnownVersions version [] 132 | in 133 | Map.alter (Just << add) (Pkg.toComparable name) versions 134 | 135 | 136 | 137 | -- NEW PACKAGE DECODER 138 | 139 | 140 | newPkgDecoder : D.Decoder () (Pkg.Name, V.Version) 141 | newPkgDecoder = 142 | D.customString newPkgParser bail 143 | 144 | 145 | newPkgParser : P.Parser () (Pkg.Name, V.Version) 146 | newPkgParser = 147 | P.bind (P.specialize (\_ _ _ -> ()) Pkg.parser) <| \pkg -> 148 | P.bind (P.word1 0x40 {-@-} bail) <| \_ -> 149 | P.bind (P.specialize (\_ _ _ -> ()) V.parser) <| \vsn -> 150 | P.return (pkg, vsn) 151 | 152 | 153 | bail : row -> col -> () 154 | bail _ _ = 155 | () 156 | 157 | 158 | 159 | -- GET VERSIONS 160 | 161 | 162 | getVersions : Pkg.Comparable -> Registry -> Maybe KnownVersions 163 | getVersions name (Registry _ versions) = 164 | Map.lookup name versions 165 | 166 | 167 | getVersionsE : Pkg.Comparable -> Registry -> Either (TList Pkg.Name) KnownVersions 168 | getVersionsE name (Registry _ versions) = 169 | case Map.lookup name versions of 170 | Just kvs -> Right kvs 171 | Nothing -> Left <| Pkg.nearbyNames (Pkg.fromComparable name) (MList.map Pkg.fromComparable <| Map.keys versions) 172 | 173 | 174 | 175 | -- POST 176 | 177 | 178 | post : Http.Manager -> String -> D.Decoder x v -> (v -> IO c d e f g h z) -> IO c d e f g h (Either Exit.RegistryProblem z) 179 | post manager path decoder callback = 180 | let 181 | url = Website.route path [] 182 | in 183 | Http.post manager url [] Exit.RP_Http <| 184 | \body -> 185 | case D.fromByteString decoder body of 186 | Right a -> IO.fmap Right <| callback a 187 | Left _ -> IO.return <| Left <| Exit.RP_Data url body 188 | 189 | 190 | 191 | -- BINARY 192 | 193 | 194 | bRegistry = B.bin2 Registry (\(Registry a b) -> B.T2 a b) 195 | B.bWord64 (B.bMap Pkg.bComparable bKnownVersions) 196 | 197 | 198 | bKnownVersions = B.bin2 KnownVersions (\(KnownVersions a b) -> B.T2 a b) 199 | V.bVersion (B.bTList V.bVersion) 200 | -------------------------------------------------------------------------------- /src/Builder/Deps/Website.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Builder.Deps.Website exposing 3 | ( {-domain 4 | ,-} route 5 | , metadata 6 | ) 7 | 8 | 9 | import Builder.Http as Http 10 | import Compiler.Elm.Package as Pkg 11 | import Compiler.Elm.Version as V 12 | import Extra.Type.List exposing (TList) 13 | 14 | 15 | 16 | domain : String 17 | domain = 18 | "https://package.elm-lang.org" 19 | 20 | 21 | route : String -> TList (String,String) -> String 22 | route path params = 23 | Http.toUrl (domain ++ path) params 24 | 25 | 26 | metadata : Pkg.Name -> V.Version -> String -> String 27 | metadata name version file = 28 | domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file 29 | -------------------------------------------------------------------------------- /src/Builder/File.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Builder.File exposing 3 | ( Time(..), bTime 4 | , getTime 5 | , zeroTime 6 | , writeBinary 7 | , readBinary 8 | , writeUtf8 9 | , readUtf8 10 | , writeBuilder 11 | , writePackage 12 | , exists 13 | , remove 14 | --, removeDir 15 | , toMillis 16 | ) 17 | 18 | 19 | import BigInt exposing (BigInt) 20 | import Bytes exposing (Bytes) 21 | import Bytes.Decode 22 | import Bytes.Encode 23 | import Extra.Data.Binary as B 24 | import Extra.System.File as SysFile exposing (FilePath) 25 | import Extra.System.IO as IO 26 | import Extra.Type.Either exposing (Either(..)) 27 | import Extra.Type.List as MList 28 | import Time as T 29 | import Zip 30 | import Zip.Entry 31 | 32 | 33 | 34 | -- PRIVATE IO 35 | 36 | 37 | type alias IO b c d e f g h v = 38 | IO.IO (SysFile.State b c d e f g h) v 39 | 40 | 41 | 42 | -- TIME 43 | 44 | 45 | type Time = Time T.Posix 46 | 47 | 48 | getTime : FilePath -> IO b c d e f g h Time 49 | getTime path = 50 | IO.fmap Time (SysFile.getModificationTime path) 51 | 52 | 53 | toMillis : Time -> Int 54 | toMillis (Time time) = 55 | T.posixToMillis time 56 | 57 | 58 | zeroTime : Time 59 | zeroTime = 60 | Time (T.millisToPosix 0) 61 | 62 | 63 | bTime : B.Binary Time 64 | bTime = 65 | B.bin1 bigToTime timeToBig B.bBigInt 66 | 67 | 68 | bigToTime : BigInt -> Time 69 | bigToTime big = 70 | case BigInt.divmod big bigTimeFactor of 71 | Just (div, rem) -> 72 | Time (T.millisToPosix (B.bigToInt div + if B.bigToInt rem < halfTimeFactor then 0 else 1)) 73 | Nothing -> 74 | zeroTime 75 | 76 | 77 | timeToBig : Time -> BigInt 78 | timeToBig (Time time) = 79 | BigInt.mul (BigInt.fromInt (T.posixToMillis time)) bigTimeFactor 80 | 81 | 82 | bigTimeFactor : BigInt 83 | bigTimeFactor = 84 | BigInt.fromInt (2 * halfTimeFactor) 85 | 86 | 87 | halfTimeFactor : Int 88 | halfTimeFactor = 89 | 500000000 90 | 91 | 92 | 93 | -- BINARY 94 | 95 | 96 | writeBinary : B.Binary v -> FilePath -> v -> IO b c d e f g h () 97 | writeBinary binA path value = 98 | let dir = SysFile.dropLastName path in 99 | IO.bind (SysFile.createDirectoryIfMissing True dir) <| \_ -> 100 | B.encodeFile binA path value 101 | 102 | 103 | readBinary : B.Binary v -> FilePath -> IO b c d e f g h (Maybe v) 104 | readBinary binA path = 105 | IO.bind (SysFile.doesFileExist path) <| \pathExists -> 106 | if pathExists 107 | then 108 | IO.bind (B.decodeFileOrFail binA path) <| \result -> 109 | case result of 110 | Right a -> 111 | IO.return (Just a) 112 | 113 | Left (offset, message) -> 114 | IO.bind (IO.log "readBinary" <| 115 | [ "+-------------------------------------------------------------------------------" 116 | , "| Corrupt File: " ++ SysFile.toString path 117 | , "| Byte Offset: " ++ String.fromInt offset 118 | , "| Message: " ++ message 119 | , "|" 120 | , "| Please report this to https://github.com/elm/compiler/issues" 121 | , "| Trying to continue anyway." 122 | , "+-------------------------------------------------------------------------------" 123 | ]) <| \_ -> 124 | IO.return Nothing 125 | else 126 | IO.return Nothing 127 | 128 | 129 | 130 | -- WRITE UTF-8 131 | 132 | 133 | writeUtf8 : FilePath -> String -> IO b c d e f g h () 134 | writeUtf8 filePath contents = 135 | SysFile.writeFile filePath <| Bytes.Encode.encode <| Bytes.Encode.string contents 136 | 137 | 138 | 139 | -- READ UTF-8 140 | 141 | 142 | readUtf8 : FilePath -> IO b c d e f g h String 143 | readUtf8 path = 144 | SysFile.readFile path |> IO.fmap (Maybe.andThen bytesToString >> Maybe.withDefault "") 145 | 146 | 147 | bytesToString : Bytes -> Maybe String 148 | bytesToString bytes = 149 | Bytes.Decode.decode (Bytes.Decode.string (Bytes.width bytes)) bytes 150 | 151 | 152 | 153 | -- WRITE BUILDER 154 | 155 | 156 | writeBuilder : FilePath -> String -> IO b c d e f g h () 157 | writeBuilder = 158 | writeUtf8 159 | 160 | 161 | 162 | -- WRITE PACKAGE 163 | 164 | 165 | writePackage : FilePath -> Zip.Zip -> IO b c d e f g h () 166 | writePackage destination archive = 167 | case Zip.entries archive of 168 | [] -> 169 | IO.return () 170 | 171 | entry::entries -> 172 | let root = String.length (Zip.Entry.path entry) in 173 | MList.sortOn Zip.Entry.path entries 174 | |> MList.mapM_ IO.return IO.bind (writeEntry destination root) 175 | 176 | 177 | writeEntry : FilePath -> Int -> Zip.Entry.Entry -> IO b c d e f g h () 178 | writeEntry destination root entry = 179 | let 180 | path = String.dropLeft root (Zip.Entry.path entry) 181 | in 182 | if String.startsWith "src/" path 183 | || path == "LICENSE" 184 | || path == "README.md" 185 | || path == "elm.json" 186 | then 187 | if not (String.isEmpty path) && String.endsWith "/" path 188 | then SysFile.createDirectoryIfMissing True (SysFile.combine destination (SysFile.fromString path)) 189 | else 190 | case Zip.Entry.toBytes entry of 191 | Err _ -> 192 | IO.return () 193 | 194 | Ok bytes -> 195 | SysFile.writeFile (SysFile.combine destination (SysFile.fromString path)) bytes 196 | else 197 | IO.return () 198 | 199 | 200 | 201 | -- EXISTS 202 | 203 | 204 | exists : FilePath -> IO b c d e f g h Bool 205 | exists path = 206 | SysFile.doesFileExist path 207 | 208 | 209 | 210 | -- REMOVE FILES 211 | 212 | 213 | remove : FilePath -> IO b c d e f g h () 214 | remove path = 215 | IO.bind (SysFile.doesFileExist path) <| \exists_ -> 216 | if exists_ 217 | then SysFile.removeFile path 218 | else IO.return () 219 | -------------------------------------------------------------------------------- /src/Builder/Http.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Builder.Http exposing 3 | ( Manager 4 | , getManager 5 | , toUrl 6 | ---- fetch 7 | , get 8 | , post 9 | --, Header 10 | --, accept 11 | , Error(..) 12 | ---- archives 13 | --, Sha 14 | --, shaToChars 15 | , getArchive 16 | ---- upload 17 | --, upload 18 | --, filePart 19 | --, jsonPart 20 | --, stringPart 21 | -- 22 | , State 23 | , LocalState 24 | , initialState 25 | , setPrefix 26 | ) 27 | 28 | 29 | import Compiler.Elm.Version as V 30 | import Extra.System.Exception exposing (handle) 31 | import Extra.System.File as SysFile 32 | import Extra.System.Http as Sys 33 | import Extra.System.IO as IO exposing (IO) 34 | import Extra.Type.Either exposing (Either(..)) 35 | import Extra.Type.Lens exposing (Lens) 36 | import Extra.Type.List exposing (TList) 37 | import Global 38 | import Zip 39 | 40 | 41 | 42 | -- PUBLIC STATE 43 | 44 | type alias State c d e f g h = 45 | SysFile.State LocalState c d e f g h 46 | 47 | 48 | type alias LocalState = 49 | Maybe String 50 | 51 | 52 | initialState : LocalState 53 | initialState = Nothing 54 | 55 | 56 | lensPrefix : Lens (State c d e f g h) (Maybe String) 57 | lensPrefix = 58 | { getter = \(Global.State _ x _ _ _ _ _ _) -> x 59 | , setter = \x (Global.State a _ c d e f g h) -> Global.State a x c d e f g h 60 | } 61 | 62 | 63 | 64 | -- PRIVATE IO 65 | 66 | 67 | type alias IO c d e f g h v = 68 | IO.IO (State c d e f g h) v 69 | 70 | 71 | 72 | -- MANAGER 73 | 74 | 75 | type alias Manager = 76 | Sys.Manager 77 | 78 | 79 | getManager : IO c d e f g h Manager 80 | getManager = 81 | IO.bind (IO.getLens lensPrefix) Sys.newManager 82 | 83 | 84 | setPrefix : Maybe String -> IO c d e f g h () 85 | setPrefix prefix = 86 | IO.putLens lensPrefix prefix 87 | 88 | 89 | 90 | -- URL 91 | 92 | 93 | toUrl : String -> TList (String,String) -> String 94 | toUrl url params = 95 | case params of 96 | [] -> url 97 | _::_ -> url ++ "?" ++ Sys.urlEncodeVars params 98 | 99 | 100 | 101 | -- FETCH 102 | 103 | 104 | get : Sys.Manager -> String -> TList Sys.Header -> (Error -> x) -> (String -> IO c d e f g h (Either x v)) -> IO c d e f g h (Either x v) 105 | get = 106 | fetch Sys.methodGet 107 | 108 | 109 | post : Sys.Manager -> String -> TList Sys.Header -> (Error -> x) -> (String -> IO c d e f g h (Either x v)) -> IO c d e f g h (Either x v) 110 | post = 111 | fetch Sys.methodPost 112 | 113 | 114 | fetch : Sys.Method -> Sys.Manager -> String -> TList Sys.Header -> (Error -> x) -> (String -> IO c d e f g h (Either x v)) -> IO c d e f g h (Either x v) 115 | fetch methodVerb manager url headers onError onSuccess = 116 | handle (handleHttpException url onError) <| 117 | IO.bind (Sys.parseUrlThrow url) <| \req0 -> 118 | let req1 = 119 | { req0 120 | | method = methodVerb 121 | , headers = addDefaultHeaders headers 122 | } in 123 | Sys.withStringResponse req1 manager <| \response -> 124 | case response of 125 | Left err -> 126 | IO.return <| Left err 127 | Right string -> 128 | IO.fmap Right (onSuccess string) 129 | 130 | 131 | addDefaultHeaders : TList Sys.Header -> TList Sys.Header 132 | addDefaultHeaders headers = 133 | Sys.userAgent userAgent :: headers 134 | 135 | 136 | userAgent : String 137 | userAgent = 138 | "elm/" ++ V.toChars V.compiler 139 | 140 | 141 | 142 | -- EXCEPTIONS 143 | 144 | 145 | type Error 146 | = BadHttp String Sys.Exception 147 | 148 | 149 | handleHttpException : String -> (Error -> x) -> Sys.Exception -> IO c d e f g h (Either x v) 150 | handleHttpException url onError httpException = 151 | IO.return (Left (onError (BadHttp url httpException))) 152 | 153 | 154 | 155 | -- FETCH ARCHIVE 156 | 157 | 158 | getArchive : 159 | Manager 160 | -> String 161 | -> (Error -> x) 162 | -> x 163 | -> (Zip.Zip -> IO c d e f g h (Either x v)) 164 | -> IO c d e f g h (Either x v) 165 | getArchive manager url onError err onSuccess = 166 | handle (handleHttpException url onError) <| 167 | IO.bind (Sys.parseUrlThrow url) <| \req0 -> 168 | let req1 = 169 | { req0 170 | | method = Sys.methodGet 171 | , headers = addDefaultHeaders [] 172 | } in 173 | Sys.withBytesResponse req1 manager <| \response -> 174 | case response of 175 | Left error -> 176 | IO.return <| Left error 177 | 178 | Right bytes -> 179 | case Zip.fromBytes bytes of 180 | Nothing -> 181 | IO.return (Right (Left err)) 182 | 183 | Just zip -> 184 | IO.fmap Right (onSuccess zip) 185 | -------------------------------------------------------------------------------- /src/Builder/Reporting/Exit/Help.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Builder.Reporting.Exit.Help exposing 3 | ( Report 4 | , report 5 | , docReport 6 | , jsonReport 7 | , compilerReport 8 | , reportToDoc 9 | , reportToClient -- reportToJson 10 | --, toString 11 | --, toStdout 12 | --, toStderr 13 | ) 14 | 15 | 16 | import Compiler.Reporting.Doc as D exposing (d) 17 | import Compiler.Reporting.Error as Error 18 | import Elm.Error as Client 19 | import Extra.System.File as SysFile exposing (FilePath) 20 | import Extra.Type.List as MList exposing (TList) 21 | 22 | 23 | 24 | -- REPORT 25 | 26 | 27 | type Report 28 | = CompilerReport FilePath Error.Module (TList Error.Module) 29 | | Report 30 | {- title -} String 31 | {- path -} (Maybe FilePath) 32 | {- message -} D.Doc 33 | 34 | 35 | report : String -> Maybe FilePath -> String -> TList D.Doc -> Report 36 | report title path startString others = 37 | Report title path <| D.stack (D.reflow startString::others) 38 | 39 | 40 | docReport : String -> Maybe FilePath -> D.Doc -> TList D.Doc -> Report 41 | docReport title path startDoc others = 42 | Report title path <| D.stack (startDoc::others) 43 | 44 | 45 | jsonReport : String -> Maybe FilePath -> D.Doc -> Report 46 | jsonReport = 47 | Report 48 | 49 | 50 | compilerReport : FilePath -> Error.Module -> TList Error.Module -> Report 51 | compilerReport = 52 | CompilerReport 53 | 54 | 55 | 56 | -- TO DOC 57 | 58 | 59 | reportToDoc : Report -> D.Doc 60 | reportToDoc report_ = 61 | case report_ of 62 | CompilerReport root e es -> 63 | Error.toDoc root e es 64 | 65 | Report title maybePath message -> 66 | let 67 | makeDashes n = 68 | String.repeat (max 1 (80 - n)) "-" 69 | 70 | errorBarEnd = 71 | case maybePath of 72 | Nothing -> 73 | makeDashes (4 + String.length title) 74 | 75 | Just path -> 76 | makeDashes (5 + String.length title + String.length (SysFile.toString path)) ++ " " ++ (SysFile.toString path) 77 | 78 | errorBar = 79 | D.dullcyan <| 80 | D.hsep [d"--", D.fromChars title, D.fromChars errorBarEnd ] 81 | in 82 | D.stack [errorBar, message, d""] 83 | 84 | 85 | 86 | -- TO CLIENT (original: TO JSON) 87 | 88 | 89 | reportToClient : Report -> Client.Error 90 | reportToClient report_ = 91 | case report_ of 92 | CompilerReport _ e es -> 93 | Client.ModuleProblems <| MList.map Error.toClient (e::es) 94 | 95 | Report title maybePath message -> 96 | Client.GeneralProblem 97 | { path = Maybe.map SysFile.toString maybePath 98 | , title = title 99 | , message = D.toClient message 100 | } 101 | -------------------------------------------------------------------------------- /src/Builder/Reporting/Task.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Builder.Reporting.Task exposing 3 | ( Task, fmap, pure, liftA2, return, bind, andThen 4 | , run 5 | , throw 6 | , mapError 7 | -- 8 | , io 9 | --, mio 10 | , eio 11 | ) 12 | 13 | 14 | import Extra.Class.Functor as Functor 15 | import Extra.Class.Applicative as Applicative 16 | import Extra.Class.Monad as Monad 17 | import Extra.System.IO as IO exposing (IO) 18 | import Extra.Type.Either exposing (Either(..)) 19 | 20 | 21 | 22 | -- TASKS 23 | 24 | 25 | type Task z s x a = 26 | Task ((a -> IO s z) -> (x -> IO s z) -> IO s z) 27 | 28 | 29 | run : Task (Either x a) s x a -> IO s (Either x a) 30 | run (Task task) = 31 | task (IO.return << Right) (IO.return << Left) 32 | 33 | 34 | throw : x -> Task z s x a 35 | throw x = 36 | Task <| \_ err -> err x 37 | 38 | 39 | mapError : (x -> y) -> Task z s x a -> Task z s y a 40 | mapError func (Task task) = 41 | Task <| \ok err -> 42 | task ok (err << func) 43 | 44 | 45 | 46 | -- IO 47 | 48 | 49 | io : IO s a -> Task z s x a 50 | io work = 51 | Task <| \ok _ -> IO.bind work ok 52 | 53 | 54 | eio : (x -> y) -> IO s (Either x a) -> Task z s y a 55 | eio func work = 56 | Task <| \ok err -> 57 | IO.bind work <| \result -> 58 | case result of 59 | Right a -> ok a 60 | Left x -> err (func x) 61 | 62 | 63 | 64 | -- INSTANCES 65 | 66 | 67 | fmap : Functor.Fmap a (Task z s x a) b (Task z s x b) 68 | fmap func (Task taskA) = 69 | Task <| \ok err -> 70 | let 71 | okA arg = ok (func arg) 72 | in 73 | taskA okA err 74 | 75 | 76 | pure : Applicative.Pure a (Task z s x a) 77 | pure a = 78 | Task <| \ok _ -> ok a 79 | 80 | andMap : Applicative.AndMap (Task z s x a) (Task z s x (a -> b)) (Task z s x b) 81 | andMap (Task taskArg) (Task taskFunc) = 82 | Task <| \ok err -> 83 | let 84 | okFunc func = 85 | let 86 | okArg arg = ok (func arg) 87 | in 88 | taskArg okArg err 89 | in 90 | taskFunc okFunc err 91 | 92 | liftA2 : Applicative.LiftA2 a (Task z s x a) b (Task z s x b) c (Task z s x c) 93 | liftA2 = Applicative.liftA2 fmap andMap 94 | 95 | 96 | return : Monad.Return a (Task z s x a) 97 | return = pure 98 | 99 | bind : Monad.Bind a (Task z s x a) (Task z s x b) 100 | bind (Task taskA) callback = 101 | Task <| \ok err -> 102 | let 103 | okA a = 104 | case callback a of 105 | Task taskB -> taskB ok err 106 | in 107 | taskA okA err 108 | 109 | andThen : Monad.AndThen a (Task z s x a) (Task z s x b) 110 | andThen = Monad.andThen bind 111 | -------------------------------------------------------------------------------- /src/Builder/Stuff.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Builder.Stuff exposing 3 | ( details 4 | , interfaces 5 | , objects 6 | --, prepublishDir 7 | , elmi 8 | , elmo 9 | --, temp 10 | , findRoot 11 | --, withRootLock 12 | --, withRegistryLock 13 | , PackageCache 14 | , getPackageCache 15 | , registry 16 | , package 17 | , getReplCache 18 | , getElmHome 19 | ) 20 | 21 | 22 | import Compiler.Elm.ModuleName as ModuleName 23 | import Compiler.Elm.Package as Pkg 24 | import Compiler.Elm.Version as V 25 | import Extra.System.File as SysFile exposing (FileName, FilePath) 26 | import Extra.System.IO as IO 27 | 28 | 29 | -- PRIVATE IO 30 | 31 | 32 | type alias IO b c d e f g h v = 33 | IO.IO (SysFile.State b c d e f g h) v 34 | 35 | 36 | 37 | -- PATHS 38 | 39 | 40 | stuff : FilePath -> FilePath 41 | stuff root = 42 | SysFile.addNames root [ "elm-stuff", compilerVersion ] 43 | 44 | 45 | details : FilePath -> FilePath 46 | details root = 47 | SysFile.addName (stuff root) "d.dat" 48 | 49 | 50 | interfaces : FilePath -> FilePath 51 | interfaces root = 52 | SysFile.addName (stuff root) "i.dat" 53 | 54 | 55 | objects : FilePath -> FilePath 56 | objects root = 57 | SysFile.addName (stuff root) "o.dat" 58 | 59 | 60 | compilerVersion : FileName 61 | compilerVersion = 62 | V.toChars V.compiler 63 | 64 | 65 | 66 | -- ELMI and ELMO 67 | 68 | 69 | elmi : FilePath -> ModuleName.Raw -> FilePath 70 | elmi root name = 71 | toArtifactPath root name "elmi" 72 | 73 | 74 | elmo : FilePath -> ModuleName.Raw -> FilePath 75 | elmo root name = 76 | toArtifactPath root name "elmo" 77 | 78 | 79 | toArtifactPath : FilePath -> ModuleName.Raw -> String -> FilePath 80 | toArtifactPath root name ext = 81 | SysFile.addName (stuff root) (ModuleName.toHyphenName name ++ "." ++ ext) 82 | 83 | 84 | 85 | -- ROOT 86 | 87 | 88 | findRoot : IO b c d e f g h (Maybe FilePath) 89 | findRoot = 90 | IO.bind SysFile.getCurrentDirectory <| \dir -> 91 | findRootHelp dir 92 | 93 | 94 | findRootHelp : FilePath -> IO b c d e f g h (Maybe FilePath) 95 | findRootHelp dirs = 96 | IO.bind (SysFile.doesFileExist (SysFile.addName dirs "elm.json")) <| \exists -> 97 | if exists 98 | then IO.return (Just dirs) 99 | else 100 | case SysFile.splitLastName dirs of 101 | ( _, "" ) -> 102 | IO.return Nothing 103 | 104 | ( parent, _ ) -> 105 | findRootHelp parent 106 | 107 | 108 | 109 | -- PACKAGE CACHES 110 | 111 | 112 | type PackageCache = PackageCache FilePath 113 | 114 | 115 | getPackageCache : IO b c d e f g h PackageCache 116 | getPackageCache = 117 | IO.fmap PackageCache <| getCacheDir "packages" 118 | 119 | 120 | registry : PackageCache -> FilePath 121 | registry (PackageCache dir) = 122 | SysFile.addName dir "registry.dat" 123 | 124 | 125 | package : PackageCache -> Pkg.Name -> V.Version -> FilePath 126 | package (PackageCache dir) name version = 127 | SysFile.addName (SysFile.combine dir (Pkg.toFilePath name)) (V.toChars version) 128 | 129 | 130 | 131 | -- CACHE 132 | 133 | 134 | getReplCache : IO b c d e f g h FilePath 135 | getReplCache = 136 | getCacheDir "repl" 137 | 138 | 139 | getCacheDir : FileName -> IO b c d e f g h FilePath 140 | getCacheDir projectName = 141 | IO.bind getElmHome <| \home -> 142 | let root = SysFile.addNames home [ compilerVersion, projectName ] in 143 | IO.bind (SysFile.createDirectoryIfMissing True root) <| \_ -> 144 | IO.return root 145 | 146 | 147 | getElmHome : IO b c d e f g h FilePath 148 | getElmHome = 149 | SysFile.getAppUserDataDirectory "elm" 150 | -------------------------------------------------------------------------------- /src/Compiler/AST/Source.elm: -------------------------------------------------------------------------------- 1 | module Compiler.AST.Source exposing 2 | ( Alias(..) 3 | , Comment(..) 4 | , Def(..) 5 | --, Docs(..) 6 | , Effects(..) 7 | , Exposed(..) 8 | , Exposing(..) 9 | , Expr 10 | , Expr_(..) 11 | , Import(..) 12 | , Infix(..) 13 | , Manager(..) 14 | , Module(..) 15 | , Pattern 16 | , Pattern_(..) 17 | , Port(..) 18 | , Privacy(..) 19 | , Type 20 | , Type_(..) 21 | , Union(..) 22 | , Value(..) 23 | , VarType(..) 24 | , getImportName 25 | , getName 26 | ) 27 | 28 | import Compiler.AST.Utils.Binop as Binop 29 | import Compiler.AST.Utils.Shader as Shader 30 | import Compiler.Data.Name as Name 31 | import Compiler.Elm.Float as EF 32 | import Compiler.Elm.String as ES 33 | import Compiler.Reporting.Annotation as A 34 | import Extra.Type.List exposing (TList) 35 | 36 | 37 | 38 | -- EXPRESSIONS 39 | 40 | 41 | type alias Expr = 42 | A.Located Expr_ 43 | 44 | 45 | type Expr_ 46 | = Chr ES.TString 47 | | Str ES.TString 48 | | CInt Int 49 | | CFloat EF.TFloat 50 | | Var VarType Name.Name 51 | | VarQual VarType Name.Name Name.Name 52 | | CList (TList Expr) 53 | | Op Name.Name 54 | | Negate Expr 55 | | Binops (TList ( Expr, A.Located Name.Name )) Expr 56 | | Lambda (TList Pattern) Expr 57 | | Call Expr (TList Expr) 58 | | If (TList ( Expr, Expr )) Expr 59 | | Let (TList (A.Located Def)) Expr 60 | | Case Expr (TList ( Pattern, Expr )) 61 | | Accessor Name.Name 62 | | Access Expr (A.Located Name.Name) 63 | | Update (A.Located Name.Name) (TList ( A.Located Name.Name, Expr )) 64 | | Record (TList ( A.Located Name.Name, Expr )) 65 | | Unit 66 | | Tuple Expr Expr (TList Expr) 67 | | Shader Shader.Source Shader.Types 68 | 69 | 70 | type VarType 71 | = LowVar 72 | | CapVar 73 | 74 | 75 | 76 | -- DEFINITIONS 77 | 78 | 79 | type Def 80 | = Define (A.Located Name.Name) (TList Pattern) Expr (Maybe Type) 81 | | Destruct Pattern Expr 82 | 83 | 84 | 85 | -- PATTERN 86 | 87 | 88 | type alias Pattern = 89 | A.Located Pattern_ 90 | 91 | 92 | type Pattern_ 93 | = PAnything 94 | | PVar Name.Name 95 | | PRecord (TList (A.Located Name.Name)) 96 | | PAlias Pattern (A.Located Name.Name) 97 | | PUnit 98 | | PTuple Pattern Pattern (TList Pattern) 99 | | PCtor A.Region Name.Name (TList Pattern) 100 | | PCtorQual A.Region Name.Name Name.Name (TList Pattern) 101 | | PList (TList Pattern) 102 | | PCons Pattern Pattern 103 | | PChr ES.TString 104 | | PStr ES.TString 105 | | PInt Int 106 | 107 | 108 | 109 | -- TYPE 110 | 111 | 112 | type alias Type = 113 | A.Located Type_ 114 | 115 | 116 | type Type_ 117 | = TLambda Type Type 118 | | TVar Name.Name 119 | | TType A.Region Name.Name (TList Type) 120 | | TTypeQual A.Region Name.Name Name.Name (TList Type) 121 | | TRecord (TList ( A.Located Name.Name, Type )) (Maybe (A.Located Name.Name)) 122 | | TUnit 123 | | TTuple Type Type (TList Type) 124 | 125 | 126 | 127 | -- MODULE 128 | 129 | 130 | type Module 131 | = Module 132 | --{ name : Maybe (A.Located Name) 133 | --, exports : A.Located Exposing 134 | --, imports : List_ Import 135 | --, values : List_ (A.Located Value) 136 | --, unions : List_ (A.Located Union) 137 | --, aliases : List_ (A.Located Alias) 138 | --, binops : List_ (A.Located Infix) 139 | --, effects : Effects 140 | --} 141 | (Maybe (A.Located Name.Name)) 142 | (A.Located Exposing) 143 | (TList Import) 144 | (TList (A.Located Value)) 145 | (TList (A.Located Union)) 146 | (TList (A.Located Alias)) 147 | (TList (A.Located Infix)) 148 | Effects 149 | 150 | 151 | getName : Module -> Name.Name 152 | getName (Module maybeName _ _ _ _ _ _ _) = 153 | case maybeName of 154 | Just (A.At _ name) -> 155 | name 156 | 157 | Nothing -> 158 | Name.u_Main 159 | 160 | 161 | getImportName : Import -> Name.Name 162 | getImportName (Import (A.At _ name) _ _) = 163 | name 164 | 165 | 166 | type Import 167 | = Import 168 | --{ import : A.Located Name 169 | --, alias : Maybe Name 170 | --, exposing : Exposing 171 | --} 172 | (A.Located Name.Name) 173 | (Maybe Name.Name) 174 | Exposing 175 | 176 | 177 | type Value 178 | = Value (A.Located Name.Name) (TList Pattern) Expr (Maybe Type) 179 | 180 | 181 | type Union 182 | = Union (A.Located Name.Name) (TList (A.Located Name.Name)) (TList ( A.Located Name.Name, TList Type )) 183 | 184 | 185 | type Alias 186 | = Alias (A.Located Name.Name) (TList (A.Located Name.Name)) Type 187 | 188 | 189 | type Infix 190 | = Infix Name.Name Binop.Associativity Binop.Precedence Name.Name 191 | 192 | 193 | type Port 194 | = Port (A.Located Name.Name) Type 195 | 196 | 197 | type Effects 198 | = NoEffects 199 | | Ports (TList Port) 200 | | Manager A.Region Manager 201 | 202 | 203 | type Manager 204 | = CCmd (A.Located Name.Name) 205 | | CSub (A.Located Name.Name) 206 | | Fx (A.Located Name.Name) (A.Located Name.Name) 207 | 208 | 209 | type Comment 210 | = Comment 211 | 212 | 213 | 214 | -- EXPOSING 215 | 216 | 217 | type Exposing 218 | = Open 219 | | Explicit (TList Exposed) 220 | 221 | 222 | type Exposed 223 | = Lower (A.Located Name.Name) 224 | | Upper (A.Located Name.Name) Privacy 225 | | Operator A.Region Name.Name 226 | 227 | 228 | type Privacy 229 | = Public A.Region 230 | | Private 231 | -------------------------------------------------------------------------------- /src/Compiler/AST/Utils/Binop.elm: -------------------------------------------------------------------------------- 1 | module Compiler.AST.Utils.Binop exposing 2 | ( Associativity(..) 3 | , Precedence(..) 4 | , bAssociativity 5 | , bPrecedence 6 | , toInt 7 | ) 8 | 9 | import Extra.Data.Binary as B 10 | 11 | 12 | 13 | -- BINOP STUFF 14 | 15 | 16 | type Precedence 17 | = Precedence Int 18 | 19 | 20 | type Associativity 21 | = Left 22 | | Non 23 | | Right 24 | 25 | 26 | 27 | -- HELPER 28 | 29 | 30 | toInt : Precedence -> Int 31 | toInt (Precedence n) = 32 | n 33 | 34 | 35 | 36 | -- BINARY 37 | 38 | 39 | bPrecedence : B.Binary Precedence 40 | bPrecedence = 41 | B.bin1 Precedence (\(Precedence n) -> n) B.bWord64 42 | 43 | 44 | bAssociativity : B.Binary Associativity 45 | bAssociativity = 46 | B.enum "Error reading valid associativity from serialized string" 47 | [ Left, Non, Right ] 48 | -------------------------------------------------------------------------------- /src/Compiler/AST/Utils/Shader.elm: -------------------------------------------------------------------------------- 1 | module Compiler.AST.Utils.Shader exposing 2 | ( Source 3 | , Types(..) 4 | , bSource 5 | , fromChars 6 | , toJsStringBuilder 7 | ) 8 | 9 | import Compiler.Data.Name as Name 10 | import Extra.Data.Binary as B 11 | import Extra.Type.Set as Set 12 | 13 | 14 | 15 | -- SOURCE 16 | 17 | 18 | type Source 19 | = Source String 20 | 21 | 22 | 23 | -- TYPES 24 | 25 | 26 | type Types 27 | = Types {- attribute -} (Set.Set Name.Name) {- uniform -} (Set.Set Name.Name) {- varying -} (Set.Set Name.Name) 28 | 29 | 30 | 31 | -- TO BUILDER 32 | 33 | 34 | toJsStringBuilder : Source -> String 35 | toJsStringBuilder (Source src) = 36 | src 37 | 38 | 39 | 40 | -- FROM CHARS 41 | 42 | 43 | fromChars : String -> Source 44 | fromChars chars = 45 | Source (escape chars) 46 | 47 | 48 | escape : String -> String 49 | escape chars = 50 | case String.uncons chars of 51 | Nothing -> 52 | "" 53 | 54 | Just ( c, cs ) -> 55 | if c == '\u{000D}' then 56 | escape cs 57 | 58 | else if c == '\n' then 59 | String.cons '\\' (String.cons 'n' (escape cs)) 60 | 61 | else if c == '"' then 62 | String.cons '\\' (String.cons '"' (escape cs)) 63 | 64 | else if c == '\'' then 65 | String.cons '\\' (String.cons '\'' (escape cs)) 66 | 67 | else if c == '\\' then 68 | String.cons '\\' (String.cons '\\' (escape cs)) 69 | 70 | else 71 | String.cons c (escape cs) 72 | 73 | 74 | 75 | -- BINARY 76 | 77 | 78 | bSource : B.Binary Source 79 | bSource = 80 | B.bin1 Source (\(Source a) -> a) B.bString 81 | -------------------------------------------------------------------------------- /src/Compiler/AST/Utils/Type.elm: -------------------------------------------------------------------------------- 1 | module Compiler.AST.Utils.Type exposing 2 | ( dealias 3 | , deepDealias 4 | , delambda 5 | , iteratedDealias 6 | ) 7 | 8 | import Compiler.AST.Canonical as Can 9 | import Compiler.Data.Name as Name 10 | import Extra.Type.List as MList exposing (TList) 11 | import Extra.Type.Map as Map 12 | 13 | 14 | 15 | -- DELAMBDA 16 | 17 | 18 | delambda : Can.Type -> TList Can.Type 19 | delambda tipe = 20 | case tipe of 21 | Can.TLambda arg result -> 22 | arg :: delambda result 23 | 24 | _ -> 25 | [ tipe ] 26 | 27 | 28 | 29 | -- DEALIAS 30 | 31 | 32 | dealias : TList ( Name.Name, Can.Type ) -> Can.AliasType -> Can.Type 33 | dealias args aliasType = 34 | case aliasType of 35 | Can.Holey tipe -> 36 | dealiasHelp (Map.fromList args) tipe 37 | 38 | Can.Filled tipe -> 39 | tipe 40 | 41 | 42 | dealiasHelp : Map.Map Name.Name Can.Type -> Can.Type -> Can.Type 43 | dealiasHelp typeTable tipe = 44 | case tipe of 45 | Can.TLambda a b -> 46 | Can.TLambda 47 | (dealiasHelp typeTable a) 48 | (dealiasHelp typeTable b) 49 | 50 | Can.TVar x -> 51 | Map.findWithDefault tipe x typeTable 52 | 53 | Can.TRecord fields ext -> 54 | Can.TRecord (Map.map (dealiasField typeTable) fields) ext 55 | 56 | Can.TAlias home name args t -> 57 | Can.TAlias home name (MList.map (Tuple.mapSecond (dealiasHelp typeTable)) args) t 58 | 59 | Can.TType home name args -> 60 | Can.TType home name (MList.map (dealiasHelp typeTable) args) 61 | 62 | Can.TUnit -> 63 | Can.TUnit 64 | 65 | Can.TTuple a b maybeC -> 66 | Can.TTuple 67 | (dealiasHelp typeTable a) 68 | (dealiasHelp typeTable b) 69 | (Maybe.map (dealiasHelp typeTable) maybeC) 70 | 71 | 72 | dealiasField : Map.Map Name.Name Can.Type -> Can.FieldType -> Can.FieldType 73 | dealiasField typeTable (Can.FieldType index tipe) = 74 | Can.FieldType index (dealiasHelp typeTable tipe) 75 | 76 | 77 | 78 | -- DEEP DEALIAS 79 | 80 | 81 | deepDealias : Can.Type -> Can.Type 82 | deepDealias tipe = 83 | case tipe of 84 | Can.TLambda a b -> 85 | Can.TLambda (deepDealias a) (deepDealias b) 86 | 87 | Can.TVar _ -> 88 | tipe 89 | 90 | Can.TRecord fields ext -> 91 | Can.TRecord (Map.map deepDealiasField fields) ext 92 | 93 | Can.TAlias _ _ args tipe_ -> 94 | deepDealias (dealias args tipe_) 95 | 96 | Can.TType home name args -> 97 | Can.TType home name (MList.map deepDealias args) 98 | 99 | Can.TUnit -> 100 | Can.TUnit 101 | 102 | Can.TTuple a b c -> 103 | Can.TTuple (deepDealias a) (deepDealias b) (Maybe.map deepDealias c) 104 | 105 | 106 | deepDealiasField : Can.FieldType -> Can.FieldType 107 | deepDealiasField (Can.FieldType index tipe) = 108 | Can.FieldType index (deepDealias tipe) 109 | 110 | 111 | 112 | -- ITERATED DEALIAS 113 | 114 | 115 | iteratedDealias : Can.Type -> Can.Type 116 | iteratedDealias tipe = 117 | case tipe of 118 | Can.TAlias _ _ args realType -> 119 | iteratedDealias (dealias args realType) 120 | 121 | _ -> 122 | tipe 123 | -------------------------------------------------------------------------------- /src/Compiler/Canonicalize/Environment/Dups.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Canonicalize.Environment.Dups exposing 3 | ( detect 4 | , checkFields 5 | , checkFields_ 6 | , TDict 7 | , none 8 | , one 9 | , insert 10 | , union 11 | , unions 12 | ) 13 | 14 | 15 | import Compiler.Data.Name as Name 16 | import Compiler.Data.OneOrMore as OneOrMore 17 | import Compiler.Reporting.Annotation as A 18 | import Compiler.Reporting.Error.Canonicalize as Error 19 | import Compiler.Reporting.Result as MResult 20 | import Extra.Type.List as MList exposing (TList) 21 | import Extra.Type.Map as Map 22 | 23 | 24 | 25 | -- DUPLICATE TRACKER 26 | 27 | 28 | type alias TDict value = 29 | Map.Map Name.Name (OneOrMore.OneOrMore (Info value)) 30 | 31 | 32 | type Info value = 33 | Info 34 | {- region -} A.Region 35 | {- value -} value 36 | 37 | 38 | 39 | -- DETECT 40 | 41 | 42 | type alias ToError = 43 | Name.Name -> A.Region -> A.Region -> Error.Error 44 | 45 | 46 | detect : ToError -> TDict a -> MResult.TResult i w Error.Error (Map.Map Name.Name a) 47 | detect toError dict = 48 | MResult.traverseWithKey (detectHelp toError) dict 49 | 50 | 51 | detectHelp : ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> MResult.TResult i w Error.Error a 52 | detectHelp toError name values = 53 | case values of 54 | OneOrMore.One (Info _ value) -> 55 | MResult.return value 56 | 57 | OneOrMore.More left right -> 58 | let 59 | (Info r1 _, Info r2 _) = 60 | OneOrMore.getFirstTwo left right 61 | in 62 | MResult.throw (toError name r1 r2) 63 | 64 | 65 | 66 | -- CHECK FIELDS 67 | 68 | 69 | checkFields : TList (A.Located Name.Name, a) -> MResult.TResult i w Error.Error (Map.Map Name.Name a) 70 | checkFields fields = 71 | detect Error.DuplicateField (MList.foldr addField none fields) 72 | 73 | 74 | addField : (A.Located Name.Name, a) -> TDict a -> TDict a 75 | addField (A.At region name, value) dups = 76 | Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups 77 | 78 | 79 | checkFields_ : (A.Region -> a -> b) -> TList (A.Located Name.Name, a) -> MResult.TResult i w Error.Error (Map.Map Name.Name b) 80 | checkFields_ toValue fields = 81 | detect Error.DuplicateField (MList.foldr (addField_ toValue) none fields) 82 | 83 | 84 | addField_ : (A.Region -> a -> b) -> (A.Located Name.Name, a) -> TDict b -> TDict b 85 | addField_ toValue (A.At region name, value) dups = 86 | Map.insertWith OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups 87 | 88 | 89 | 90 | -- BUILDING DICTIONARIES 91 | 92 | 93 | none : TDict a 94 | none = 95 | Map.empty 96 | 97 | 98 | one : Name.Name -> A.Region -> value -> TDict value 99 | one name region value = 100 | Map.singleton name (OneOrMore.one (Info region value)) 101 | 102 | 103 | insert : Name.Name -> A.Region -> a -> TDict a -> TDict a 104 | insert name region value dict = 105 | Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict 106 | 107 | 108 | union : TDict a -> TDict a -> TDict a 109 | union a b = 110 | Map.unionWith OneOrMore.more a b 111 | 112 | 113 | unions : TList (TDict a) -> TDict a 114 | unions dicts = 115 | Map.unionsWith MList.foldl OneOrMore.more dicts 116 | -------------------------------------------------------------------------------- /src/Compiler/Canonicalize/Pattern.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Canonicalize.Pattern exposing 3 | ( verify 4 | , Bindings 5 | , DupsDict 6 | , canonicalize 7 | ) 8 | 9 | 10 | import Compiler.AST.Canonical as Can 11 | import Compiler.AST.Source as Src 12 | import Compiler.Canonicalize.Environment as Env 13 | import Compiler.Canonicalize.Environment.Dups as Dups 14 | import Compiler.Data.Index as Index 15 | import Compiler.Data.Name as Name 16 | import Compiler.Elm.ModuleName as ModuleName 17 | import Compiler.Reporting.Annotation as A 18 | import Compiler.Reporting.Error.Canonicalize as Error 19 | import Compiler.Reporting.Result as MResult 20 | import Extra.Type.List as MList exposing (TList) 21 | import Extra.Type.Map as Map 22 | 23 | 24 | 25 | -- RESULTS 26 | 27 | 28 | type alias TResult i w a = 29 | MResult.TResult i w Error.Error a 30 | 31 | 32 | type alias Bindings = 33 | Map.Map Name.Name A.Region 34 | 35 | 36 | 37 | -- VERIFY 38 | 39 | 40 | verify : Error.DuplicatePatternContext -> TResult DupsDict w a -> TResult i w (a, Bindings) 41 | verify context (MResult.CResult k) = 42 | MResult.CResult <| \info warnings -> 43 | case k Dups.none warnings of 44 | MResult.Rbad _ warnings1 errors -> 45 | MResult.Rbad info warnings1 errors 46 | MResult.Rgood bindings warnings1 value -> 47 | case Dups.detect (Error.DuplicatePattern context) bindings of 48 | MResult.CResult k1 -> 49 | case k1 () () of 50 | MResult.Rbad () () errs -> MResult.Rbad info warnings1 errs 51 | MResult.Rgood () () dict -> MResult.Rgood info warnings1 (value, dict) 52 | 53 | 54 | 55 | -- CANONICALIZE 56 | 57 | 58 | type alias DupsDict = 59 | Dups.TDict A.Region 60 | 61 | 62 | canonicalize : Env.Env -> Src.Pattern -> TResult DupsDict w Can.Pattern 63 | canonicalize env (A.At region pattern) = 64 | MResult.fmap (A.At region) <| 65 | case pattern of 66 | Src.PAnything -> 67 | MResult.ok Can.PAnything 68 | 69 | Src.PVar name -> 70 | logVar name region (Can.PVar name) 71 | 72 | Src.PRecord fields -> 73 | logFields fields (Can.PRecord (MList.map A.toValue fields)) 74 | 75 | Src.PUnit -> 76 | MResult.ok Can.PUnit 77 | 78 | Src.PTuple a b cs -> 79 | MResult.pure Can.PTuple 80 | |> MResult.andMap (canonicalize env a) 81 | |> MResult.andMap (canonicalize env b) 82 | |> MResult.andMap (canonicalizeTuple region env cs) 83 | 84 | Src.PCtor nameRegion name patterns -> 85 | MResult.andThen (canonicalizeCtor env region name patterns) (Env.findCtor nameRegion env name) 86 | 87 | Src.PCtorQual nameRegion home name patterns -> 88 | MResult.andThen (canonicalizeCtor env region name patterns) (Env.findCtorQual nameRegion env home name) 89 | 90 | Src.PList patterns -> 91 | MResult.fmap Can.PList (canonicalizeList env patterns) 92 | 93 | Src.PCons first rest -> 94 | MResult.pure Can.PCons 95 | |> MResult.andMap (canonicalize env first) 96 | |> MResult.andMap (canonicalize env rest) 97 | 98 | Src.PAlias ptrn (A.At reg name) -> 99 | MResult.bind (canonicalize env ptrn) <| \cpattern -> 100 | logVar name reg (Can.PAlias cpattern name) 101 | 102 | Src.PChr chr -> 103 | MResult.ok (Can.PChr chr) 104 | 105 | Src.PStr str -> 106 | MResult.ok (Can.PStr str) 107 | 108 | Src.PInt int -> 109 | MResult.ok (Can.PInt int) 110 | 111 | 112 | canonicalizeCtor : Env.Env -> A.Region -> Name.Name -> TList Src.Pattern -> Env.Ctor -> TResult DupsDict w Can.Pattern_ 113 | canonicalizeCtor env region name patterns ctor = 114 | case ctor of 115 | Env.Ctor home tipe union index args -> 116 | let 117 | toCanonicalArg argIndex argPattern argTipe = 118 | MResult.fmap (Can.PatternCtorArg argIndex argTipe) (canonicalize env argPattern) 119 | in 120 | MResult.bind (Index.indexedZipWithA MResult.pure MResult.pure MResult.fmap MResult.liftA2 toCanonicalArg patterns args) <| \verifiedList -> 121 | case verifiedList of 122 | Index.LengthMatch cargs -> 123 | if tipe == Name.bool && home == ModuleName.basics then 124 | MResult.ok (Can.PBool union (name == Name.true)) 125 | else 126 | MResult.ok (Can.PCtor home tipe union name index cargs) 127 | 128 | Index.LengthMismatch actualLength expectedLength -> 129 | MResult.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength) 130 | 131 | Env.RecordCtor _ _ _ -> 132 | MResult.throw (Error.PatternHasRecordCtor region name) 133 | 134 | 135 | canonicalizeTuple : A.Region -> Env.Env -> TList Src.Pattern -> TResult DupsDict w (Maybe Can.Pattern) 136 | canonicalizeTuple tupleRegion env extras = 137 | case extras of 138 | [] -> 139 | MResult.ok Nothing 140 | 141 | [three] -> 142 | MResult.fmap Just (canonicalize env three) 143 | 144 | _ -> 145 | MResult.throw <| Error.TupleLargerThanThree tupleRegion 146 | 147 | 148 | canonicalizeList : Env.Env -> TList Src.Pattern -> TResult DupsDict w (TList Can.Pattern) 149 | canonicalizeList env list = 150 | case list of 151 | [] -> 152 | MResult.ok [] 153 | 154 | pattern :: otherPatterns -> 155 | MResult.pure (::) 156 | |> MResult.andMap (canonicalize env pattern) 157 | |> MResult.andMap (canonicalizeList env otherPatterns) 158 | 159 | 160 | 161 | -- LOG BINDINGS 162 | 163 | 164 | logVar : Name.Name -> A.Region -> a -> TResult DupsDict w a 165 | logVar name region value = 166 | MResult.CResult <| \bindings warnings -> 167 | MResult.Rgood (Dups.insert name region region bindings) warnings value 168 | 169 | 170 | logFields : TList (A.Located Name.Name) -> a -> TResult DupsDict w a 171 | logFields fields value = 172 | let 173 | addField dict (A.At region name) = 174 | Dups.insert name region region dict 175 | in 176 | MResult.CResult <| \bindings warnings -> 177 | MResult.Rgood (MList.foldl addField bindings fields) warnings value 178 | -------------------------------------------------------------------------------- /src/Compiler/Canonicalize/Type.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Canonicalize.Type exposing 3 | ( toAnnotation 4 | , canonicalize 5 | ) 6 | 7 | 8 | import Compiler.AST.Canonical as Can 9 | import Compiler.AST.Source as Src 10 | import Compiler.Canonicalize.Environment as Env 11 | import Compiler.Canonicalize.Environment.Dups as Dups 12 | import Compiler.Data.Name as Name 13 | import Compiler.Reporting.Annotation as A 14 | import Compiler.Reporting.Error.Canonicalize as Error 15 | import Compiler.Reporting.Result as MResult 16 | import Extra.Type.List as MList exposing (TList) 17 | import Extra.Type.Map as Map 18 | 19 | 20 | 21 | -- RESULT 22 | 23 | 24 | type alias TResult i w a = 25 | MResult.TResult i w Error.Error a 26 | 27 | 28 | 29 | -- TO ANNOTATION 30 | 31 | 32 | toAnnotation : Env.Env -> Src.Type -> TResult i w Can.Annotation 33 | toAnnotation env srcType = 34 | MResult.bind (canonicalize env srcType) <| \tipe -> 35 | MResult.ok <| Can.Forall (addFreeVars Map.empty tipe) tipe 36 | 37 | 38 | 39 | -- CANONICALIZE TYPES 40 | 41 | 42 | canonicalize : Env.Env -> Src.Type -> TResult i w Can.Type 43 | canonicalize env (A.At typeRegion tipe) = 44 | case tipe of 45 | Src.TVar x -> 46 | MResult.ok (Can.TVar x) 47 | 48 | Src.TType region name args -> 49 | MResult.andThen (canonicalizeType env typeRegion name args) 50 | (Env.findType region env name) 51 | 52 | Src.TTypeQual region home name args -> 53 | MResult.andThen (canonicalizeType env typeRegion name args) 54 | (Env.findTypeQual region env home name) 55 | 56 | Src.TLambda a b -> 57 | MResult.pure Can.TLambda 58 | |> MResult.andMap (canonicalize env a) 59 | |> MResult.andMap (canonicalize env b) 60 | 61 | Src.TRecord fields ext -> 62 | MResult.bind (MResult.andThen MResult.sequenceAMap (Dups.checkFields (canonicalizeFields env fields))) <| \cfields -> 63 | MResult.return <| Can.TRecord cfields (Maybe.map A.toValue ext) 64 | 65 | Src.TUnit -> 66 | MResult.ok Can.TUnit 67 | 68 | Src.TTuple a b cs -> 69 | MResult.pure Can.TTuple 70 | |> MResult.andMap (canonicalize env a) 71 | |> MResult.andMap (canonicalize env b) 72 | |> MResult.andMap 73 | (case cs of 74 | [] -> 75 | MResult.ok Nothing 76 | 77 | [c] -> 78 | MResult.fmap Just (canonicalize env c) 79 | 80 | _ -> 81 | MResult.throw <| Error.TupleLargerThanThree typeRegion) 82 | 83 | 84 | canonicalizeFields : Env.Env -> TList (A.Located Name.Name, Src.Type) -> TList (A.Located Name.Name, TResult i w Can.FieldType) 85 | canonicalizeFields env fields = 86 | let 87 | len = MList.length fields 88 | canonicalizeField index (name, srcType) = 89 | (name, MResult.fmap (Can.FieldType index) (canonicalize env srcType)) 90 | in 91 | MList.zipWith canonicalizeField (MList.range 0 len) fields 92 | 93 | 94 | 95 | -- CANONICALIZE TYPE 96 | 97 | 98 | canonicalizeType : Env.Env -> A.Region -> Name.Name -> TList Src.Type -> Env.Type -> TResult i w Can.Type 99 | canonicalizeType env region name args info = 100 | MResult.bind (MResult.traverseList (canonicalize env) args) <| \cargs -> 101 | case info of 102 | Env.Alias arity home argNames aliasedType -> 103 | checkArity arity region name args <| 104 | Can.TAlias home name (MList.zip argNames cargs) (Can.Holey aliasedType) 105 | 106 | Env.Union arity home -> 107 | checkArity arity region name args <| 108 | Can.TType home name cargs 109 | 110 | 111 | checkArity : Int -> A.Region -> Name.Name -> TList (A.Located arg) -> answer -> TResult i w answer 112 | checkArity expected region name args answer = 113 | let actual = MList.length args in 114 | if expected == actual then 115 | MResult.ok answer 116 | else 117 | MResult.throw (Error.BadArity region Error.TypeArity name expected actual) 118 | 119 | 120 | 121 | -- ADD FREE VARS 122 | 123 | 124 | addFreeVars : Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name () 125 | addFreeVars freeVars tipe = 126 | case tipe of 127 | Can.TLambda arg result -> 128 | addFreeVars (addFreeVars freeVars result) arg 129 | 130 | Can.TVar var -> 131 | Map.insert var () freeVars 132 | 133 | Can.TType _ _ args -> 134 | MList.foldl addFreeVars freeVars args 135 | 136 | Can.TRecord fields Nothing -> 137 | Map.foldl addFieldFreeVars freeVars fields 138 | 139 | Can.TRecord fields (Just ext) -> 140 | Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields 141 | 142 | Can.TUnit -> 143 | freeVars 144 | 145 | Can.TTuple a b maybeC -> 146 | case maybeC of 147 | Nothing -> 148 | addFreeVars (addFreeVars freeVars a) b 149 | 150 | Just c -> 151 | addFreeVars (addFreeVars (addFreeVars freeVars a) b) c 152 | 153 | Can.TAlias _ _ args _ -> 154 | MList.foldl (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args 155 | 156 | 157 | addFieldFreeVars : Map.Map Name.Name () -> Can.FieldType -> Map.Map Name.Name () 158 | addFieldFreeVars freeVars (Can.FieldType _ tipe) = 159 | addFreeVars freeVars tipe 160 | -------------------------------------------------------------------------------- /src/Compiler/Compile.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Compile exposing (Artifacts(..), compile) 2 | 3 | import Compiler.AST.Canonical as Can 4 | import Compiler.AST.Optimized as Opt 5 | import Compiler.AST.Source as Src 6 | import Compiler.Canonicalize.Module as Canonicalize 7 | import Compiler.Data.Name as Name 8 | import Compiler.Elm.Interface as I 9 | import Compiler.Elm.ModuleName as ModuleName 10 | import Compiler.Elm.Package as Pkg 11 | import Compiler.Nitpick.PatternMatches as PatternMatches 12 | import Compiler.Optimize.Module as Optimize 13 | import Compiler.Reporting.Error as E 14 | import Compiler.Reporting.Render.Type.Localizer as Localizer 15 | import Compiler.Reporting.Result as R 16 | import Compiler.Type.Constrain.Module as Type 17 | import Compiler.Type.Solve as Solve 18 | import Extra.System.IO.Pure as IO 19 | import Extra.Type.Either as Either exposing (Either(..)) 20 | import Extra.Type.Map as Map 21 | 22 | 23 | type Artifacts 24 | = Artifacts 25 | --{ modul : Can.Module 26 | --, types : Map.Map Name.Name Can.Annotation 27 | --, graph : Opt.LocalGraph 28 | --} 29 | Can.Module 30 | (Map.Map Name.Name Can.Annotation) 31 | Opt.LocalGraph 32 | 33 | 34 | compile : Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts 35 | compile pkg ifaces modul = 36 | Either.bind (canonicalize pkg ifaces modul) <| 37 | \canonical -> 38 | Either.bind (typeCheck modul canonical) <| 39 | \annotations -> 40 | Either.bind (nitpick canonical) <| 41 | \() -> 42 | Either.bind (optimize modul annotations canonical) <| 43 | \objects -> 44 | Right (Artifacts canonical annotations objects) 45 | 46 | 47 | 48 | -- PHASES 49 | 50 | 51 | canonicalize : Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module 52 | canonicalize pkg ifaces modul = 53 | case Tuple.second <| R.run <| Canonicalize.canonicalize pkg ifaces modul of 54 | Right canonical -> 55 | Right canonical 56 | 57 | Left errors -> 58 | Left <| E.BadNames errors 59 | 60 | 61 | typeCheck : Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation) 62 | typeCheck modul canonical = 63 | case IO.performIO (IO.andThen Solve.run <| Type.constrain canonical) Solve.init of 64 | Right annotations -> 65 | Right annotations 66 | 67 | Left errors -> 68 | Left (E.BadTypes (Localizer.fromModule modul) errors) 69 | 70 | 71 | nitpick : Can.Module -> Either E.Error () 72 | nitpick canonical = 73 | case PatternMatches.check canonical of 74 | Right () -> 75 | Right () 76 | 77 | Left errors -> 78 | Left (E.BadPatterns errors) 79 | 80 | 81 | optimize : Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph 82 | optimize modul annotations canonical = 83 | case Tuple.second <| R.run <| Optimize.optimize annotations canonical of 84 | Right localGraph -> 85 | Right localGraph 86 | 87 | Left errors -> 88 | Left (E.BadMains (Localizer.fromModule modul) errors) 89 | -------------------------------------------------------------------------------- /src/Compiler/Data/Bag.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Data.Bag exposing 3 | ( Bag(..) 4 | , empty 5 | , one 6 | , append 7 | --, map 8 | , toList 9 | --, fromList 10 | ) 11 | 12 | 13 | import Extra.Type.List exposing (TList) 14 | 15 | 16 | 17 | -- BAGS 18 | 19 | 20 | type Bag a 21 | = Empty 22 | | One a 23 | | Two (Bag a) (Bag a) 24 | 25 | 26 | 27 | -- HELPERS 28 | 29 | 30 | empty : Bag a 31 | empty = 32 | Empty 33 | 34 | 35 | one : a -> Bag a 36 | one = 37 | One 38 | 39 | 40 | append : Bag a -> Bag a -> Bag a 41 | append left right = 42 | case (left, right) of 43 | (other, Empty) -> 44 | other 45 | 46 | (Empty, other) -> 47 | other 48 | 49 | _ -> 50 | Two left right 51 | 52 | 53 | 54 | -- TO LIST 55 | 56 | 57 | toList : Bag a -> TList a 58 | toList bag = 59 | toListHelp bag [] 60 | 61 | 62 | toListHelp : Bag a -> TList a -> TList a 63 | toListHelp bag list = 64 | case bag of 65 | Empty -> 66 | list 67 | 68 | One x -> 69 | x :: list 70 | 71 | Two a b -> 72 | toListHelp a (toListHelp b list) 73 | -------------------------------------------------------------------------------- /src/Compiler/Data/Index.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Data.Index exposing 2 | ( VerifiedList(..) 3 | , ZeroBased(..) 4 | , bZeroBased 5 | , first 6 | , indexedMap 7 | , indexedTraverse 8 | , indexedZipWith 9 | , indexedZipWithA 10 | , next 11 | , second 12 | , third 13 | , toHuman 14 | , toMachine 15 | ) 16 | 17 | import Extra.Class.Applicative as Applicative 18 | import Extra.Class.Functor as Functor 19 | import Extra.Data.Binary as B 20 | import Extra.Type.List as MList exposing (TList) 21 | 22 | 23 | 24 | -- ZERO BASED 25 | 26 | 27 | type ZeroBased 28 | = ZeroBased Int 29 | 30 | 31 | bZeroBased : B.Binary ZeroBased 32 | bZeroBased = 33 | B.bin1 ZeroBased (\(ZeroBased n) -> n) B.bWord64 34 | 35 | 36 | first : ZeroBased 37 | first = 38 | ZeroBased 0 39 | 40 | 41 | second : ZeroBased 42 | second = 43 | ZeroBased 1 44 | 45 | 46 | third : ZeroBased 47 | third = 48 | ZeroBased 2 49 | 50 | 51 | next : ZeroBased -> ZeroBased 52 | next (ZeroBased i) = 53 | ZeroBased (i + 1) 54 | 55 | 56 | 57 | -- DESTRUCT 58 | 59 | 60 | toMachine : ZeroBased -> Int 61 | toMachine (ZeroBased index) = 62 | index 63 | 64 | 65 | toHuman : ZeroBased -> Int 66 | toHuman (ZeroBased index) = 67 | index + 1 68 | 69 | 70 | 71 | -- INDEXED MAP 72 | 73 | 74 | indexedMap : (ZeroBased -> a -> b) -> TList a -> TList b 75 | indexedMap func xs = 76 | MList.zipWith func (MList.map ZeroBased (MList.range 0 (MList.length xs))) xs 77 | 78 | 79 | indexedTraverse : 80 | Applicative.Pure (TList b) flb 81 | -> Applicative.LiftA2 b fb (TList b) flb (TList b) flb 82 | -> ((ZeroBased -> a -> fb) -> TList a -> flb) 83 | indexedTraverse pPure pLiftA2 func xs = 84 | MList.sequenceA pPure pLiftA2 (indexedMap func xs) 85 | 86 | 87 | 88 | -- VERIFIED/INDEXED ZIP 89 | 90 | 91 | type VerifiedList a 92 | = LengthMatch (TList a) 93 | | LengthMismatch Int Int 94 | 95 | 96 | indexedZipWith : (ZeroBased -> a -> b -> c) -> TList a -> TList b -> VerifiedList c 97 | indexedZipWith func listX listY = 98 | indexedZipWithHelp func 0 listX listY [] 99 | 100 | 101 | indexedZipWithHelp : (ZeroBased -> a -> b -> c) -> Int -> TList a -> TList b -> TList c -> VerifiedList c 102 | indexedZipWithHelp func index listX listY revListZ = 103 | case ( listX, listY ) of 104 | ( [], [] ) -> 105 | LengthMatch (MList.reverse revListZ) 106 | 107 | ( x :: xs, y :: ys ) -> 108 | indexedZipWithHelp func (index + 1) xs ys <| 109 | func (ZeroBased index) x y 110 | :: revListZ 111 | 112 | _ -> 113 | LengthMismatch (index + MList.length listX) (index + MList.length listY) 114 | 115 | 116 | indexedZipWithA : 117 | Applicative.Pure (TList c) flc 118 | -> Applicative.Pure (VerifiedList c) fvlc 119 | -> Functor.Fmap (TList c) flc (VerifiedList c) fvlc 120 | -> Applicative.LiftA2 c fc (TList c) flc (TList c) flc 121 | -> ((ZeroBased -> a -> b -> fc) -> TList a -> TList b -> fvlc) 122 | indexedZipWithA pPure pPure2 pMap pLiftA2 func listX listY = 123 | case indexedZipWith func listX listY of 124 | LengthMatch xs -> 125 | pMap LengthMatch <| MList.sequenceA pPure pLiftA2 xs 126 | 127 | LengthMismatch x y -> 128 | pPure2 (LengthMismatch x y) 129 | -------------------------------------------------------------------------------- /src/Compiler/Data/NonEmptyList.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Data.NonEmptyList exposing 3 | ( TList(..), fmap, bTList 4 | , singleton 5 | , toList 6 | , sortBy 7 | -- 8 | , foldr 9 | , sequenceA 10 | , traverse 11 | ) 12 | 13 | 14 | import Extra.Class.Applicative as Applicative 15 | import Extra.Class.Foldable as Foldable 16 | import Extra.Class.Functor as Functor 17 | import Extra.Class.Traversable as Traversable 18 | import Extra.Data.Binary as B 19 | import Extra.Type.List as MList 20 | 21 | 22 | 23 | -- LIST 24 | 25 | 26 | type TList a = 27 | CList a (MList.TList a) 28 | 29 | 30 | singleton : a -> TList a 31 | singleton a = 32 | CList a [] 33 | 34 | 35 | toList : TList a -> MList.TList a 36 | toList (CList x xs) = 37 | x::xs 38 | 39 | 40 | 41 | -- INSTANCES 42 | 43 | 44 | fmap : Functor.Fmap a (TList a) b (TList b) 45 | fmap func (CList x xs) = CList (func x) (MList.map func xs) 46 | 47 | 48 | foldr : Foldable.Foldr a (TList a) b 49 | foldr f b (CList x xs) = f x (MList.foldr f b xs) 50 | 51 | 52 | sequenceA : 53 | Applicative.Pure (MList.TList a) fla 54 | -> Applicative.LiftA2 a fa (MList.TList a) fla (MList.TList a) fla 55 | -> Applicative.LiftA2 a fa (MList.TList a) fla (TList a) fta 56 | -> Traversable.SequenceA (TList fa) fta 57 | sequenceA pPure pLiftA2L pLiftA2C = 58 | traverse pPure pLiftA2L pLiftA2C identity 59 | 60 | 61 | traverse : 62 | Applicative.Pure (MList.TList b) flb 63 | -> Applicative.LiftA2 b fb (MList.TList b) flb (MList.TList b) flb 64 | -> Applicative.LiftA2 b fb (MList.TList b) flb (TList b) ftb 65 | -> Traversable.Traverse a (TList a) fb ftb 66 | traverse pPure pLiftA2L pLiftA2C func (CList x xs) = 67 | pLiftA2C CList (func x) (MList.traverse pPure pLiftA2L func xs) 68 | 69 | 70 | 71 | -- SORT BY 72 | 73 | 74 | sortBy : (a -> comparable) -> TList a -> TList a 75 | sortBy toRank (CList x xs) = 76 | let 77 | comparison a b = 78 | compare (toRank a) (toRank b) 79 | in 80 | case MList.sortBy comparison xs of 81 | [] -> 82 | CList x [] 83 | 84 | y::ys -> 85 | case comparison x y of 86 | LT -> CList x (y::ys) 87 | EQ -> CList x (y::ys) 88 | GT -> CList y (MList.insertBy comparison x ys) 89 | 90 | 91 | 92 | -- BINARY 93 | 94 | 95 | bTList : B.Binary a -> B.Binary (TList a) 96 | bTList binA = 97 | B.bin2 CList (\(CList x xs) -> B.T2 x xs) binA (B.bTList binA) 98 | -------------------------------------------------------------------------------- /src/Compiler/Data/OneOrMore.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Data.OneOrMore exposing 2 | ( OneOrMore(..) 3 | , destruct 4 | , getFirstTwo 5 | , more 6 | , one 7 | ) 8 | 9 | 10 | import Extra.Type.List exposing (TList) 11 | 12 | 13 | 14 | -- ONE OR MORE 15 | 16 | 17 | type OneOrMore a 18 | = One a 19 | | More (OneOrMore a) (OneOrMore a) 20 | 21 | 22 | one : a -> OneOrMore a 23 | one = 24 | One 25 | 26 | 27 | more : OneOrMore a -> OneOrMore a -> OneOrMore a 28 | more = 29 | More 30 | 31 | 32 | 33 | -- DESTRUCT 34 | 35 | 36 | destruct : (a -> TList a -> b) -> OneOrMore a -> b 37 | destruct func oneOrMore = 38 | destructLeft func oneOrMore [] 39 | 40 | 41 | destructLeft : (a -> TList a -> b) -> OneOrMore a -> TList a -> b 42 | destructLeft func oneOrMore xs = 43 | case oneOrMore of 44 | One x -> 45 | func x xs 46 | 47 | More a b -> 48 | destructLeft func a (destructRight b xs) 49 | 50 | 51 | destructRight : OneOrMore a -> TList a -> TList a 52 | destructRight oneOrMore xs = 53 | case oneOrMore of 54 | One x -> 55 | x :: xs 56 | 57 | More a b -> 58 | destructRight a (destructRight b xs) 59 | 60 | 61 | 62 | -- GET FIRST TWO 63 | 64 | 65 | getFirstTwo : OneOrMore a -> OneOrMore a -> ( a, a ) 66 | getFirstTwo left right = 67 | case left of 68 | One x -> 69 | ( x, getFirstOne right ) 70 | 71 | More lleft lright -> 72 | getFirstTwo lleft lright 73 | 74 | 75 | getFirstOne : OneOrMore a -> a 76 | getFirstOne oneOrMore = 77 | case oneOrMore of 78 | One x -> 79 | x 80 | 81 | More left _ -> 82 | getFirstOne left 83 | -------------------------------------------------------------------------------- /src/Compiler/Data/Utf8.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Data.Utf8 exposing 2 | ( Utf8 3 | , bUnder256 4 | , bVeryLong 5 | , contains 6 | , empty 7 | , fromPtr 8 | , fromSnippet 9 | , size 10 | , split 11 | , startsWith 12 | , toBuilder 13 | ) 14 | 15 | import Compiler.Parse.Primitives as P 16 | import Extra.Data.Binary as B 17 | import Extra.Type.List exposing (TList) 18 | 19 | 20 | 21 | -- UTF-8 22 | 23 | 24 | type alias Utf8 = 25 | String 26 | 27 | 28 | 29 | -- EMPTY 30 | 31 | 32 | empty : Utf8 33 | empty = 34 | "" 35 | 36 | 37 | 38 | -- SIZE 39 | 40 | 41 | size : Utf8 -> Int 42 | size = 43 | String.length 44 | 45 | 46 | 47 | -- CONTAINS 48 | 49 | 50 | contains : Int -> Utf8 -> Bool 51 | contains word str = 52 | String.contains (String.fromChar (Char.fromCode word)) str 53 | 54 | 55 | 56 | -- STARTS WITH 57 | 58 | 59 | startsWith : Utf8 -> Utf8 -> Bool 60 | startsWith = 61 | String.startsWith 62 | 63 | 64 | 65 | -- SPLIT 66 | 67 | 68 | split : Int -> Utf8 -> TList Utf8 69 | split divider str = 70 | String.split (String.fromChar (Char.fromCode divider)) str 71 | 72 | 73 | 74 | -- TO BUILDER 75 | 76 | 77 | toBuilder : Utf8 -> String 78 | toBuilder = 79 | identity 80 | 81 | 82 | 83 | -- FROM PTR 84 | 85 | 86 | fromPtr : String -> Int -> Int -> Utf8 87 | fromPtr src pos end = 88 | String.slice pos end src 89 | 90 | 91 | 92 | -- FROM SNIPPET 93 | 94 | 95 | fromSnippet : P.Snippet -> Utf8 96 | fromSnippet (P.Snippet fptr off len _ _) = 97 | String.slice off (off + len) fptr 98 | 99 | 100 | 101 | -- BINARY 102 | 103 | 104 | bUnder256 : B.Binary Utf8 105 | bUnder256 = 106 | B.bStringWith B.bWord8 107 | 108 | 109 | bVeryLong : B.Binary Utf8 110 | bVeryLong = 111 | B.bString 112 | -------------------------------------------------------------------------------- /src/Compiler/Elm/Compiler/Imports.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Elm.Compiler.Imports exposing (defaults) 2 | 3 | import Compiler.AST.Source as Src 4 | import Compiler.Data.Name as Name 5 | import Compiler.Elm.ModuleName as ModuleName 6 | import Compiler.Reporting.Annotation as A 7 | import Extra.Type.List exposing (TList) 8 | 9 | 10 | 11 | -- DEFAULTS 12 | 13 | 14 | defaults : TList Src.Import 15 | defaults = 16 | [ import_ ModuleName.basics Nothing Src.Open 17 | , import_ ModuleName.debug Nothing closed 18 | , import_ ModuleName.list Nothing (operator "::") 19 | , import_ ModuleName.maybe Nothing (typeOpen Name.maybe) 20 | , import_ ModuleName.result Nothing (typeOpen Name.result) 21 | , import_ ModuleName.string Nothing (typeClosed Name.string) 22 | , import_ ModuleName.char Nothing (typeClosed Name.char) 23 | , import_ ModuleName.tuple Nothing closed 24 | , import_ ModuleName.platform Nothing (typeClosed Name.program) 25 | , import_ ModuleName.cmd (Just Name.cmd) (typeClosed Name.cmd) 26 | , import_ ModuleName.sub (Just Name.sub) (typeClosed Name.sub) 27 | ] 28 | 29 | 30 | import_ : ModuleName.Canonical -> Maybe Name.Name -> Src.Exposing -> Src.Import 31 | import_ (ModuleName.Canonical _ name) maybeAlias exposing_ = 32 | Src.Import (A.At A.zero name) maybeAlias exposing_ 33 | 34 | 35 | 36 | -- EXPOSING 37 | 38 | 39 | closed : Src.Exposing 40 | closed = 41 | Src.Explicit [] 42 | 43 | 44 | typeOpen : Name.Name -> Src.Exposing 45 | typeOpen name = 46 | Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ] 47 | 48 | 49 | typeClosed : Name.Name -> Src.Exposing 50 | typeClosed name = 51 | Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ] 52 | 53 | 54 | operator : Name.Name -> Src.Exposing 55 | operator op = 56 | Src.Explicit [ Src.Operator A.zero op ] 57 | -------------------------------------------------------------------------------- /src/Compiler/Elm/Compiler/Type.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Elm.Compiler.Type exposing 3 | ( Type(..) 4 | --, RT.Context(..) 5 | --, toDoc 6 | , DebugMetadata(..) 7 | , Alias(..) 8 | , Union(..) 9 | --, encode 10 | --, decoder 11 | , encodeMetadata 12 | ) 13 | 14 | 15 | import Compiler.Data.Name as Name 16 | import Compiler.Json.Encode as E 17 | import Compiler.Json.String as Json 18 | import Compiler.Reporting.Doc as D exposing (d) 19 | import Compiler.Reporting.Render.Type as RT 20 | import Compiler.Reporting.Render.Type.Localizer as L 21 | import Extra.Type.List as MList exposing (TList) 22 | 23 | 24 | 25 | -- TYPES 26 | 27 | 28 | type Type 29 | = Lambda Type Type 30 | | Var Name.Name 31 | | Type Name.Name (TList Type) 32 | | Record (TList (Name.Name, Type)) (Maybe Name.Name) 33 | | Unit 34 | | Tuple Type Type (TList Type) 35 | 36 | 37 | type DebugMetadata = 38 | DebugMetadata 39 | {- message -} Type 40 | {- aliases -} (TList Alias) 41 | {- unions -} (TList Union) 42 | 43 | 44 | type Alias = Alias Name.Name (TList Name.Name) Type 45 | type Union = Union Name.Name (TList Name.Name) (TList (Name.Name, TList Type)) 46 | 47 | 48 | 49 | -- TO DOC 50 | 51 | 52 | toDoc : L.Localizer -> RT.Context -> Type -> D.Doc 53 | toDoc localizer context tipe = 54 | case tipe of 55 | Lambda _ _ -> 56 | case MList.map (toDoc localizer RT.Func) (collectLambdas tipe) of 57 | a :: b :: cs -> RT.lambda context a b cs 58 | x -> Debug.todo <| "toDoc Lambda " ++ Debug.toString x 59 | 60 | Var name -> 61 | D.fromName name 62 | 63 | Unit -> 64 | d"()" 65 | 66 | Tuple a b cs -> 67 | RT.tuple 68 | (toDoc localizer RT.None a) 69 | (toDoc localizer RT.None b) 70 | (MList.map (toDoc localizer RT.None) cs) 71 | 72 | Type name args -> 73 | RT.apply 74 | context 75 | (D.fromName name) 76 | (MList.map (toDoc localizer RT.App) args) 77 | 78 | Record fields ext -> 79 | RT.record 80 | (MList.map (entryToDoc localizer) fields) 81 | (Maybe.map D.fromName ext) 82 | 83 | 84 | entryToDoc : L.Localizer -> (Name.Name, Type) -> (D.Doc, D.Doc) 85 | entryToDoc localizer (field, fieldType) = 86 | ( D.fromName field, toDoc localizer RT.None fieldType ) 87 | 88 | 89 | collectLambdas : Type -> TList Type 90 | collectLambdas tipe = 91 | case tipe of 92 | Lambda arg body -> 93 | arg :: collectLambdas body 94 | 95 | _ -> 96 | [tipe] 97 | 98 | 99 | 100 | -- JSON for TYPE 101 | 102 | 103 | encode : Type -> E.Value 104 | encode tipe = 105 | E.chars <| D.toLine (toDoc L.empty RT.None tipe) 106 | 107 | 108 | 109 | -- JSON for PROGRAM 110 | 111 | 112 | encodeMetadata : DebugMetadata -> E.Value 113 | encodeMetadata (DebugMetadata msg aliases unions) = 114 | E.object 115 | [ ( "message", encode msg ) 116 | , ( "aliases", E.object (MList.map toTypeAliasField aliases) ) 117 | , ( "unions", E.object (MList.map toCustomTypeField unions) ) 118 | ] 119 | 120 | 121 | toTypeAliasField : Alias -> ( Json.TString, E.Value ) 122 | toTypeAliasField (Alias name args tipe) = 123 | ( Json.fromName name 124 | , E.object 125 | [ ( "args", E.list E.name args ) 126 | , ( "type", encode tipe ) 127 | ] 128 | ) 129 | 130 | 131 | toCustomTypeField : Union -> ( Json.TString, E.Value ) 132 | toCustomTypeField (Union name args constructors) = 133 | ( Json.fromName name 134 | , E.object 135 | [ ( "args", E.list E.name args ) 136 | , ( "tags", E.object (MList.map toVariantObject constructors) ) 137 | ] 138 | ) 139 | 140 | 141 | toVariantObject : (Name.Name, TList Type) -> ( Json.TString, E.Value ) 142 | toVariantObject (name, args) = 143 | ( Json.fromName name, E.list encode args ) 144 | -------------------------------------------------------------------------------- /src/Compiler/Elm/Constraint.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Elm.Constraint exposing 3 | ( Constraint 4 | , exactly 5 | , anything 6 | , toChars 7 | , satisfies 8 | --, check 9 | , intersect 10 | , goodElm 11 | , defaultElm 12 | , untilNextMajor 13 | , untilNextMinor 14 | --, expand 15 | -- 16 | , Error(..) 17 | , decoder 18 | , encode 19 | ) 20 | 21 | 22 | import Compiler.Elm.Version as V 23 | import Compiler.Json.Decode as D 24 | import Compiler.Json.Encode as E 25 | import Compiler.Parse.Primitives as P exposing (Row, Col) 26 | import Extra.Type.List as MList 27 | 28 | 29 | 30 | -- CONSTRAINTS 31 | 32 | 33 | type Constraint 34 | = Range V.Version Op Op V.Version 35 | 36 | 37 | type Op 38 | = Less 39 | | LessOrEqual 40 | 41 | 42 | 43 | -- COMMON CONSTRAINTS 44 | 45 | 46 | exactly : V.Version -> Constraint 47 | exactly version = 48 | Range version LessOrEqual LessOrEqual version 49 | 50 | 51 | anything : Constraint 52 | anything = 53 | Range V.one LessOrEqual LessOrEqual V.max 54 | 55 | 56 | 57 | -- TO CHARS 58 | 59 | 60 | toChars : Constraint -> String 61 | toChars constraint = 62 | case constraint of 63 | Range lower lowerOp upperOp upper -> 64 | V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper 65 | 66 | 67 | opToChars : Op -> String 68 | opToChars op = 69 | case op of 70 | Less -> " < " 71 | LessOrEqual -> " <= " 72 | 73 | 74 | 75 | -- IS SATISFIED 76 | 77 | 78 | satisfies : Constraint -> V.Version -> Bool 79 | satisfies constraint version = 80 | case constraint of 81 | Range lower lowerOp upperOp upper -> 82 | isLess lowerOp (V.toComparable lower) (V.toComparable version) 83 | && 84 | isLess upperOp (V.toComparable version) (V.toComparable upper) 85 | 86 | 87 | isLess : Op -> (comparable -> comparable -> Bool) 88 | isLess op = 89 | case op of 90 | Less -> 91 | (<) 92 | 93 | LessOrEqual -> 94 | (<=) 95 | 96 | 97 | 98 | -- INTERSECT 99 | 100 | 101 | intersect : Constraint -> Constraint -> Maybe Constraint 102 | intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) = 103 | let 104 | (newLo, newLop) = 105 | case compare (V.toComparable lo) (V.toComparable lo_) of 106 | LT -> (lo_, lop_) 107 | EQ -> (lo, if MList.elem Less [lop,lop_] then Less else LessOrEqual) 108 | GT -> (lo, lop) 109 | 110 | (newHi, newHop) = 111 | case compare (V.toComparable hi) (V.toComparable hi_) of 112 | LT -> (hi, hop) 113 | EQ -> (hi, if MList.elem Less [hop, hop_] then Less else LessOrEqual) 114 | GT -> (hi_, hop_) 115 | in 116 | if (V.toComparable newLo) <= (V.toComparable newHi) then 117 | Just (Range newLo newLop newHop newHi) 118 | else 119 | Nothing 120 | 121 | 122 | 123 | -- ELM CONSTRAINT 124 | 125 | 126 | goodElm : Constraint -> Bool 127 | goodElm constraint = 128 | satisfies constraint V.compiler 129 | 130 | 131 | defaultElm : Constraint 132 | defaultElm = 133 | if V.getMajor V.compiler > 0 134 | then untilNextMajor V.compiler 135 | else untilNextMinor V.compiler 136 | 137 | 138 | 139 | -- CREATE CONSTRAINTS 140 | 141 | 142 | untilNextMajor : V.Version -> Constraint 143 | untilNextMajor version = 144 | Range version LessOrEqual Less (V.bumpMajor version) 145 | 146 | 147 | untilNextMinor : V.Version -> Constraint 148 | untilNextMinor version = 149 | Range version LessOrEqual Less (V.bumpMinor version) 150 | 151 | 152 | 153 | -- JSON 154 | 155 | 156 | encode : Constraint -> E.Value 157 | encode constraint = 158 | E.chars (toChars constraint) 159 | 160 | 161 | decoder : D.Decoder Error Constraint 162 | decoder = 163 | D.customString parser BadFormat 164 | 165 | 166 | 167 | -- PARSER 168 | 169 | 170 | type Error 171 | = BadFormat Row Col 172 | | InvalidRange V.Version V.Version 173 | 174 | 175 | parser : P.Parser Error Constraint 176 | parser = 177 | P.bind parseVersion <| \lower -> 178 | P.bind (P.word1 0x20 {- -} BadFormat) <| \_ -> 179 | P.bind parseOp <| \loOp -> 180 | P.bind (P.word1 0x20 {- -} BadFormat) <| \_ -> 181 | P.bind (P.word1 0x76 {-v-} BadFormat) <| \_ -> 182 | P.bind (P.word1 0x20 {- -} BadFormat) <| \_ -> 183 | P.bind parseOp <| \hiOp -> 184 | P.bind (P.word1 0x20 {- -} BadFormat) <| \_ -> 185 | P.bind parseVersion <| \higher -> 186 | P.Parser <| \((P.State _ _ _ _ row col) as state) -> 187 | if V.toComparable lower < V.toComparable higher 188 | then P.Eok (Range lower loOp hiOp higher) state 189 | else P.Eerr row col (\_ _ -> InvalidRange lower higher) 190 | 191 | 192 | parseVersion : P.Parser Error V.Version 193 | parseVersion = 194 | P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser 195 | 196 | 197 | parseOp : P.Parser Error Op 198 | parseOp = 199 | P.bind (P.word1 0x3C {-<-} BadFormat) <| \_ -> 200 | P.oneOfWithFallback 201 | [ P.bind (P.word1 0x3D {-=-} BadFormat) <| \_ -> 202 | P.return LessOrEqual 203 | ] 204 | Less 205 | -------------------------------------------------------------------------------- /src/Compiler/Elm/Float.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Elm.Float exposing 2 | ( TFloat 3 | , bTFloat 4 | , fromPtr 5 | ) 6 | 7 | import Compiler.Data.Utf8 as Utf8 8 | import Extra.Data.Binary as B 9 | 10 | 11 | 12 | -- FLOATS 13 | 14 | 15 | type alias TFloat = 16 | Utf8.Utf8 17 | 18 | 19 | 20 | -- HELPERS 21 | 22 | 23 | fromPtr : String -> Int -> Int -> TFloat 24 | fromPtr = 25 | Utf8.fromPtr 26 | 27 | 28 | 29 | -- BINARY 30 | 31 | 32 | bTFloat : B.Binary TFloat 33 | bTFloat = 34 | Utf8.bUnder256 35 | -------------------------------------------------------------------------------- /src/Compiler/Elm/ModuleName.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Elm.ModuleName exposing 3 | ( Raw, bRaw 4 | , toChars 5 | , toFileNames 6 | , toHyphenName 7 | -- 8 | --, encode 9 | , decoder 10 | -- 11 | , Canonical(..), toString, bCanonical 12 | , basics, char, string 13 | , maybe, result, list, array, dict, tuple 14 | , platform, cmd, sub 15 | , debug 16 | , virtualDom 17 | , jsonDecode, jsonEncode 18 | , webgl, texture 19 | -- 20 | , getPackage, getModule 21 | , Comparable, bComparable 22 | , fromComparable, toComparable 23 | , comparison 24 | ) 25 | 26 | 27 | import Compiler.Data.Name as Name 28 | import Compiler.Data.Utf8 as Utf8 29 | import Compiler.Elm.Package as Pkg 30 | import Compiler.Json.Decode as D 31 | import Compiler.Parse.Primitives as P 32 | import Compiler.Parse.Variable as Var 33 | import Extra.Data.Binary as B 34 | import Extra.System.File exposing (FileName) 35 | import Extra.Type.List exposing (TList) 36 | 37 | 38 | 39 | -- RAW 40 | 41 | 42 | type alias Raw = Name.Name 43 | 44 | 45 | toChars : Raw -> String 46 | toChars = 47 | identity 48 | 49 | 50 | toFileNames : Raw -> TList FileName 51 | toFileNames name = 52 | String.split "." name 53 | 54 | 55 | toHyphenName : Raw -> FileName 56 | toHyphenName name = 57 | String.map (\c -> if c == '.' then '-' else c) name 58 | 59 | 60 | 61 | -- JSON 62 | 63 | 64 | decoder : D.Decoder (P.Row, P.Col) Raw 65 | decoder = 66 | D.customString parser Tuple.pair 67 | 68 | 69 | 70 | -- PARSER 71 | 72 | 73 | parser : P.Parser (P.Row, P.Col) Raw 74 | parser = 75 | P.Parser <| \(P.State src pos end indent row col) -> 76 | let 77 | (isGood, newPos, newCol) = chompStart src pos end col 78 | in 79 | if isGood && newPos - pos < 256 then 80 | let newState = P.State src newPos end indent row newCol in 81 | P.Cok (Utf8.fromPtr src pos newPos) newState 82 | 83 | else if col == newCol then 84 | P.Eerr row newCol Tuple.pair 85 | 86 | else 87 | P.Cerr row newCol Tuple.pair 88 | 89 | 90 | chompStart : String -> Int -> Int -> P.Col -> (Bool, Int, P.Col) 91 | chompStart src pos end col = 92 | let 93 | width = Var.getUpperWidth src pos end 94 | in 95 | if width == 0 then 96 | (False, pos, col) 97 | else 98 | chompInner src (pos + width) end (col + 1) 99 | 100 | 101 | chompInner : String -> Int -> Int -> P.Col -> (Bool, Int, P.Col) 102 | chompInner src pos end col = 103 | if pos >= end then 104 | (True, pos, col) 105 | else 106 | let 107 | word = P.unsafeIndex src pos 108 | width = Var.getInnerWidthHelp word 109 | in 110 | if width == 0 then 111 | if word == 0x2E {-.-} then 112 | chompStart src (pos + 1) end (col + 1) 113 | else 114 | (True, pos, col) 115 | else 116 | chompInner src (pos + width) end (col + 1) 117 | 118 | 119 | 120 | -- CANONICAL 121 | 122 | 123 | type Canonical = 124 | Canonical 125 | {- package -} Pkg.Name 126 | {- module -} Name.Name 127 | 128 | getPackage (Canonical pkg _) = pkg 129 | getModule (Canonical _ name) = name 130 | 131 | 132 | type alias Comparable = 133 | ( String, Pkg.Comparable ) 134 | 135 | 136 | toComparable : Canonical -> Comparable 137 | toComparable (Canonical pkg name) = 138 | ( name, Pkg.toComparable pkg ) 139 | 140 | 141 | fromComparable : Comparable -> Canonical 142 | fromComparable ( name, pkg ) = 143 | Canonical (Pkg.fromComparable pkg) name 144 | 145 | 146 | comparison : Canonical -> Canonical -> Order 147 | comparison can1 can2 = 148 | compare (toComparable can1) (toComparable can2) 149 | 150 | 151 | toString : Canonical -> String 152 | toString (Canonical pkg name) = 153 | Pkg.toString pkg ++ "/" ++ name 154 | 155 | 156 | 157 | -- INSTANCES 158 | 159 | 160 | bRaw : B.Binary Raw 161 | bRaw = 162 | Name.bName 163 | 164 | 165 | bCanonical : B.Binary Canonical 166 | bCanonical = 167 | B.bin2 Canonical (\(Canonical a b) -> B.T2 a b) 168 | Pkg.bName 169 | Name.bName 170 | 171 | 172 | bComparable : B.Binary Comparable 173 | bComparable = 174 | B.iso toComparable fromComparable bCanonical 175 | 176 | 177 | 178 | -- CORE 179 | 180 | 181 | basics : Canonical 182 | basics = Canonical Pkg.core Name.basics 183 | 184 | 185 | char : Canonical 186 | char = Canonical Pkg.core Name.char 187 | 188 | 189 | string : Canonical 190 | string = Canonical Pkg.core Name.string 191 | 192 | 193 | maybe : Canonical 194 | maybe = Canonical Pkg.core Name.maybe 195 | 196 | 197 | result : Canonical 198 | result = Canonical Pkg.core Name.result 199 | 200 | 201 | list : Canonical 202 | list = Canonical Pkg.core Name.list 203 | 204 | 205 | array : Canonical 206 | array = Canonical Pkg.core Name.array 207 | 208 | 209 | dict : Canonical 210 | dict = Canonical Pkg.core Name.dict 211 | 212 | 213 | tuple : Canonical 214 | tuple = Canonical Pkg.core Name.tuple 215 | 216 | 217 | platform : Canonical 218 | platform = Canonical Pkg.core Name.platform 219 | 220 | 221 | cmd : Canonical 222 | cmd = Canonical Pkg.core "Platform.Cmd" 223 | 224 | 225 | sub : Canonical 226 | sub = Canonical Pkg.core "Platform.Sub" 227 | 228 | 229 | debug : Canonical 230 | debug = Canonical Pkg.core Name.debug 231 | 232 | 233 | 234 | -- HTML 235 | 236 | 237 | virtualDom : Canonical 238 | virtualDom = Canonical Pkg.virtualDom Name.virtualDom 239 | 240 | 241 | 242 | -- JSON 243 | 244 | 245 | jsonDecode : Canonical 246 | jsonDecode = Canonical Pkg.json "Json.Decode" 247 | 248 | 249 | jsonEncode : Canonical 250 | jsonEncode = Canonical Pkg.json "Json.Encode" 251 | 252 | 253 | 254 | -- WEBGL 255 | 256 | 257 | webgl : Canonical 258 | webgl = Canonical Pkg.webgl "WebGL" 259 | 260 | 261 | texture : Canonical 262 | texture = Canonical Pkg.webgl "WebGL.Texture" 263 | -------------------------------------------------------------------------------- /src/Compiler/Elm/String.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Elm.String exposing 2 | ( Chunk(..) 3 | , TString 4 | , bTString 5 | , fromChunks 6 | , toChars 7 | ) 8 | 9 | import Compiler.Data.Utf8 as Utf8 10 | import Extra.Data.Binary as B 11 | import Extra.Type.List as MList exposing (TList) 12 | import Hex 13 | 14 | 15 | 16 | -- STRINGS 17 | 18 | 19 | type alias TString = 20 | Utf8.Utf8 21 | 22 | 23 | 24 | -- HELPERS 25 | 26 | 27 | toChars : TString -> String 28 | toChars = 29 | identity 30 | 31 | 32 | 33 | -- FROM CHUNKS 34 | 35 | 36 | type Chunk 37 | = Slice Int Int 38 | | Escape Int 39 | | CodePoint Int 40 | 41 | 42 | fromChunks : String -> TList Chunk -> TString 43 | fromChunks src chunks = 44 | String.concat (MList.map (chunkToString src) chunks) 45 | 46 | 47 | chunkToString : String -> Chunk -> String 48 | chunkToString src chunk = 49 | case chunk of 50 | Slice start len -> 51 | String.slice start (start + len) src 52 | 53 | Escape code -> 54 | String.cons '\\' (String.fromChar (Char.fromCode code)) 55 | 56 | CodePoint code -> 57 | if code < 0xFFFF then 58 | codeToString code 59 | 60 | else 61 | let 62 | rest = 63 | code - 0x00010000 64 | 65 | hi = 66 | rest // 0x0400 67 | 68 | lo = 69 | modBy 0x0400 rest 70 | in 71 | codeToString (hi + 0xD800) 72 | ++ codeToString (lo + 0xDC00) 73 | 74 | 75 | codeToString : Int -> String 76 | codeToString code = 77 | code |> Hex.toString |> String.toUpper |> String.padLeft 4 '0' |> String.append "\\u" 78 | 79 | 80 | 81 | -- BINARY 82 | 83 | 84 | bTString : B.Binary TString 85 | bTString = 86 | Utf8.bVeryLong 87 | -------------------------------------------------------------------------------- /src/Compiler/Elm/Version.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Elm.Version exposing 2 | ( Comparable 3 | , Version(..) 4 | , bComparable 5 | , bVersion 6 | , bumpMajor 7 | , bumpMinor 8 | , compiler 9 | , decoder 10 | , encode 11 | , getMajor 12 | , max 13 | , one 14 | , parser 15 | , toChars 16 | , toComparable 17 | ) 18 | 19 | import Compiler.Json.Decode as D 20 | import Compiler.Json.Encode as E 21 | import Compiler.Parse.Primitives as P exposing (Col, Row) 22 | import Extra.Data.Binary as B 23 | import Extra.Data.Binary.Get as BG 24 | import Extra.Data.Binary.Put as BP 25 | 26 | 27 | 28 | -- VERSION 29 | 30 | 31 | type Version 32 | = Version 33 | --{ major : Int 34 | --, minor : Int 35 | --, patch : Int 36 | --} 37 | Int 38 | Int 39 | Int 40 | 41 | 42 | getMajor : Version -> Int 43 | getMajor (Version major _ _) = 44 | major 45 | 46 | 47 | type alias Comparable = 48 | ( Int, Int, Int ) 49 | 50 | 51 | fromComparable : Comparable -> Version 52 | fromComparable ( major, minor, patch ) = 53 | Version major minor patch 54 | 55 | 56 | toComparable : Version -> Comparable 57 | toComparable (Version major minor patch) = 58 | ( major, minor, patch ) 59 | 60 | 61 | one : Version 62 | one = 63 | Version 1 0 0 64 | 65 | 66 | max : Version 67 | max = 68 | Version (2 ^ 16 - 1) 0 0 69 | 70 | 71 | compiler : Version 72 | compiler = 73 | Version 0 19 1 74 | 75 | 76 | 77 | -- BUMP 78 | 79 | 80 | bumpMinor : Version -> Version 81 | bumpMinor (Version major minor _) = 82 | Version major (minor + 1) 0 83 | 84 | 85 | bumpMajor : Version -> Version 86 | bumpMajor (Version major _ _) = 87 | Version (major + 1) 0 0 88 | 89 | 90 | 91 | -- TO CHARS 92 | 93 | 94 | toChars : Version -> String 95 | toChars (Version major minor patch) = 96 | String.fromInt major ++ "." ++ String.fromInt minor ++ "." ++ String.fromInt patch 97 | 98 | 99 | 100 | -- JSON 101 | 102 | 103 | decoder : D.Decoder ( Row, Col ) Version 104 | decoder = 105 | D.customString parser Tuple.pair 106 | 107 | 108 | encode : Version -> E.Value 109 | encode version = 110 | E.chars (toChars version) 111 | 112 | 113 | 114 | -- BINARY 115 | 116 | 117 | bVersion : B.Binary Version 118 | bVersion = 119 | { put = 120 | \(Version major minor patch) -> 121 | if major < 255 && minor < 256 && patch < 256 then 122 | BP.put3 B.bWord8.put B.bWord8.put B.bWord8.put major minor patch 123 | 124 | else 125 | BP.put4 B.bWord8.put B.bWord16.put B.bWord16.put B.bWord16.put 255 major minor patch 126 | , get = 127 | BG.bind B.bWord8.get <| 128 | \word -> 129 | if word == 255 then 130 | BG.liftM3 Version B.bWord16.get B.bWord16.get B.bWord16.get 131 | 132 | else 133 | BG.liftM2 (Version word) B.bWord8.get B.bWord8.get 134 | } 135 | 136 | 137 | bComparable : B.Binary Comparable 138 | bComparable = 139 | B.iso toComparable fromComparable bVersion 140 | 141 | 142 | 143 | -- PARSER 144 | 145 | 146 | parser : P.Parser ( Row, Col ) Version 147 | parser = 148 | P.bind numberParser <| 149 | \major -> 150 | P.bind (P.word1 0x2E {- . -} Tuple.pair) <| 151 | \_ -> 152 | P.bind numberParser <| 153 | \minor -> 154 | P.bind (P.word1 0x2E {- . -} Tuple.pair) <| 155 | \_ -> 156 | P.bind numberParser <| 157 | \patch -> 158 | P.return (Version major minor patch) 159 | 160 | 161 | numberParser : P.Parser ( Row, Col ) Int 162 | numberParser = 163 | P.Parser <| 164 | \(P.State src pos end indent row col) -> 165 | if pos >= end then 166 | P.Eerr row col Tuple.pair 167 | 168 | else 169 | let 170 | word = 171 | P.unsafeIndex src pos 172 | in 173 | if word == 0x30 {- 0 -} then 174 | let 175 | newState = 176 | P.State src (pos + 1) end indent row (col + 1) 177 | in 178 | P.Cok 0 newState 179 | 180 | else if isDigit word then 181 | let 182 | ( total, newPos ) = 183 | chompWord16 src (pos + 1) end (word - 0x30) 184 | 185 | newState = 186 | P.State src newPos end indent row (col + (newPos - pos)) 187 | in 188 | P.Cok total newState 189 | 190 | else 191 | P.Eerr row col Tuple.pair 192 | 193 | 194 | chompWord16 : String -> Int -> Int -> Int -> ( Int, Int ) 195 | chompWord16 src pos end total = 196 | if pos >= end then 197 | ( total, pos ) 198 | 199 | else 200 | let 201 | word = 202 | P.unsafeIndex src pos 203 | in 204 | if isDigit word then 205 | chompWord16 src (pos + 1) end (10 * total + word - 0x30) 206 | 207 | else 208 | ( total, pos ) 209 | 210 | 211 | isDigit : Int -> Bool 212 | isDigit word = 213 | 0x30 {- 0 -} <= word && word <= {- 9 -} 0x39 214 | -------------------------------------------------------------------------------- /src/Compiler/Generate/JavaScript/Functions.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Generate.JavaScript.Functions exposing 3 | ( functions 4 | ) 5 | 6 | 7 | 8 | -- FUNCTIONS 9 | 10 | 11 | functions : String 12 | functions = """ 13 | 14 | function F(arity, fun, wrapper) { 15 | wrapper.a = arity; 16 | wrapper.f = fun; 17 | return wrapper; 18 | } 19 | 20 | function F2(fun) { 21 | return F(2, fun, function(a) { return function(b) { return fun(a,b); }; }) 22 | } 23 | function F3(fun) { 24 | return F(3, fun, function(a) { 25 | return function(b) { return function(c) { return fun(a, b, c); }; }; 26 | }); 27 | } 28 | function F4(fun) { 29 | return F(4, fun, function(a) { return function(b) { return function(c) { 30 | return function(d) { return fun(a, b, c, d); }; }; }; 31 | }); 32 | } 33 | function F5(fun) { 34 | return F(5, fun, function(a) { return function(b) { return function(c) { 35 | return function(d) { return function(e) { return fun(a, b, c, d, e); }; }; }; }; 36 | }); 37 | } 38 | function F6(fun) { 39 | return F(6, fun, function(a) { return function(b) { return function(c) { 40 | return function(d) { return function(e) { return function(f) { 41 | return fun(a, b, c, d, e, f); }; }; }; }; }; 42 | }); 43 | } 44 | function F7(fun) { 45 | return F(7, fun, function(a) { return function(b) { return function(c) { 46 | return function(d) { return function(e) { return function(f) { 47 | return function(g) { return fun(a, b, c, d, e, f, g); }; }; }; }; }; }; 48 | }); 49 | } 50 | function F8(fun) { 51 | return F(8, fun, function(a) { return function(b) { return function(c) { 52 | return function(d) { return function(e) { return function(f) { 53 | return function(g) { return function(h) { 54 | return fun(a, b, c, d, e, f, g, h); }; }; }; }; }; }; }; 55 | }); 56 | } 57 | function F9(fun) { 58 | return F(9, fun, function(a) { return function(b) { return function(c) { 59 | return function(d) { return function(e) { return function(f) { 60 | return function(g) { return function(h) { return function(i) { 61 | return fun(a, b, c, d, e, f, g, h, i); }; }; }; }; }; }; }; }; 62 | }); 63 | } 64 | 65 | function A2(fun, a, b) { 66 | return fun.a === 2 ? fun.f(a, b) : fun(a)(b); 67 | } 68 | function A3(fun, a, b, c) { 69 | return fun.a === 3 ? fun.f(a, b, c) : fun(a)(b)(c); 70 | } 71 | function A4(fun, a, b, c, d) { 72 | return fun.a === 4 ? fun.f(a, b, c, d) : fun(a)(b)(c)(d); 73 | } 74 | function A5(fun, a, b, c, d, e) { 75 | return fun.a === 5 ? fun.f(a, b, c, d, e) : fun(a)(b)(c)(d)(e); 76 | } 77 | function A6(fun, a, b, c, d, e, f) { 78 | return fun.a === 6 ? fun.f(a, b, c, d, e, f) : fun(a)(b)(c)(d)(e)(f); 79 | } 80 | function A7(fun, a, b, c, d, e, f, g) { 81 | return fun.a === 7 ? fun.f(a, b, c, d, e, f, g) : fun(a)(b)(c)(d)(e)(f)(g); 82 | } 83 | function A8(fun, a, b, c, d, e, f, g, h) { 84 | return fun.a === 8 ? fun.f(a, b, c, d, e, f, g, h) : fun(a)(b)(c)(d)(e)(f)(g)(h); 85 | } 86 | function A9(fun, a, b, c, d, e, f, g, h, i) { 87 | 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); 88 | } 89 | 90 | """ 91 | -------------------------------------------------------------------------------- /src/Compiler/Generate/Mode.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Generate.Mode exposing 3 | ( Mode(..) 4 | , isDebug 5 | , ShortFieldNames 6 | , shortenFieldNames 7 | -- 8 | , DevMode(..) 9 | , isAsync 10 | , isAsyncActive 11 | , deActivate 12 | ) 13 | 14 | 15 | import Compiler.AST.Optimized as Opt 16 | import Compiler.Generate.JavaScript.Name as JsName 17 | import Compiler.Data.Name as Name 18 | import Compiler.Elm.Compiler.Type.Extract as Extract 19 | import Extra.Type.List as MList exposing (TList) 20 | import Extra.Type.Map as Map 21 | import Extra.Type.Set as Set 22 | 23 | 24 | 25 | -- MODE 26 | 27 | 28 | type Mode 29 | = Dev DevMode 30 | | Prod ShortFieldNames 31 | 32 | 33 | {- NEW: DevMode -} 34 | type DevMode 35 | = DevNormal 36 | | DevDebug Extract.Types 37 | | DevAsync Bool (Set.Set Name.Name) 38 | 39 | 40 | isDebug : Mode -> Bool 41 | isDebug mode = 42 | case mode of 43 | Dev (DevDebug _) -> True 44 | _ -> False 45 | 46 | 47 | {- NEW: isAsyncActive -} 48 | isAsyncActive : Mode -> Bool 49 | isAsyncActive mode = 50 | case mode of 51 | Dev (DevAsync True _) -> True 52 | _ -> False 53 | 54 | 55 | {- NEW: isAsync -} 56 | isAsync : Mode -> Bool 57 | isAsync mode = 58 | case mode of 59 | Dev (DevAsync _ _) -> True 60 | _ -> False 61 | 62 | 63 | deActivate : Mode -> Mode 64 | deActivate mode = 65 | case mode of 66 | Dev (DevAsync True suspendFuns) -> Dev (DevAsync False suspendFuns) 67 | _ -> mode 68 | 69 | 70 | 71 | -- SHORTEN FIELD NAMES 72 | 73 | 74 | type alias ShortFieldNames = 75 | Map.Map Name.Name JsName.Name 76 | 77 | 78 | shortenFieldNames : Opt.GlobalGraph -> ShortFieldNames 79 | shortenFieldNames (Opt.GlobalGraph _ frequencies) = 80 | Map.foldr addToShortNames Map.empty <| 81 | Map.foldrWithKey addToBuckets Map.empty frequencies 82 | 83 | 84 | addToBuckets : Name.Name -> Int -> Map.Map Int (TList Name.Name) -> Map.Map Int (TList Name.Name) 85 | addToBuckets field frequency buckets = 86 | Map.insertWith (++) frequency [field] buckets 87 | 88 | 89 | addToShortNames : TList Name.Name -> ShortFieldNames -> ShortFieldNames 90 | addToShortNames fields shortNames = 91 | MList.foldl addField shortNames fields 92 | 93 | 94 | addField : ShortFieldNames -> Name.Name -> ShortFieldNames 95 | addField shortNames field = 96 | let rename = JsName.fromInt (Map.size shortNames) in 97 | Map.insert field rename shortNames 98 | -------------------------------------------------------------------------------- /src/Compiler/Json/Encode.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Json.Encode exposing 3 | ( write 4 | --, encode 5 | --, writeUgly 6 | , encodeUgly 7 | , Value(..) 8 | --, array 9 | , object 10 | , string 11 | , name 12 | , chars 13 | --, bool 14 | --, int 15 | --, number 16 | --, null 17 | , dict 18 | , list 19 | --, (==>) 20 | ) 21 | 22 | 23 | import Builder.File as File 24 | import Compiler.Data.Name as Name 25 | import Compiler.Json.String as Json 26 | import Extra.System.File as SysFile exposing (FilePath) 27 | import Extra.System.IO as IO 28 | import Extra.Type.List as MList exposing (TList) 29 | import Extra.Type.Map as Map 30 | 31 | 32 | -- PRIVATE IO 33 | 34 | 35 | type alias IO b c d e f g h v = 36 | IO.IO (SysFile.State b c d e f g h) v 37 | 38 | 39 | 40 | -- VALUES 41 | 42 | 43 | type Value 44 | = Array (TList Value) 45 | | Object (TList (Json.TString, Value)) 46 | | CString String 47 | 48 | 49 | object : TList (Json.TString, Value) -> Value 50 | object = 51 | Object 52 | 53 | 54 | string : Json.TString -> Value 55 | string str = 56 | CString ("\"" ++ Json.toBuilder str ++ "\"") 57 | 58 | 59 | name : Name.Name -> Value 60 | name nm = 61 | CString ("\"" ++ Name.toBuilder nm ++ "\"") 62 | 63 | 64 | dict : (comparable -> Json.TString) -> (v -> Value) -> Map.Map comparable v -> Value 65 | dict encodeKey encodeValue pairs = 66 | Object <| MList.map (\( k, v ) -> ( encodeKey k, encodeValue v )) (Map.toList pairs) 67 | 68 | 69 | list : (a -> Value) -> TList a -> Value 70 | list encodeEntry entries = 71 | Array <| MList.map encodeEntry entries 72 | 73 | 74 | 75 | -- CHARS 76 | 77 | 78 | chars : String -> Value 79 | chars chrs = 80 | -- PERF can this be done better? Look for examples. 81 | CString ("\"" ++ escape chrs ++ "\"") 82 | 83 | 84 | escape : String -> String 85 | escape chrs = 86 | case String.uncons chrs of 87 | Nothing -> 88 | "" 89 | 90 | Just ( c, cs ) -> 91 | if c == '\r' then String.cons '\\' (String.cons 'r' (escape cs)) 92 | else if c == '\n' then String.cons '\\' (String.cons 'n' (escape cs)) 93 | else if c == '\"' then String.cons '\\' (String.cons '"' (escape cs)) 94 | else if c == '\\' then String.cons '\\' (String.cons '\\' (escape cs)) 95 | else String.cons c (escape cs) 96 | 97 | 98 | 99 | -- WRITE TO FILE 100 | 101 | 102 | write : FilePath -> Value -> IO b c d e f g h () 103 | write path value = 104 | File.writeBuilder path (encode value ++ "\n") 105 | 106 | 107 | 108 | -- ENCODE UGLY 109 | 110 | 111 | encodeUgly : Value -> String 112 | encodeUgly value = 113 | case value of 114 | Array [] -> 115 | "[]" 116 | 117 | Array (first :: rest) -> 118 | let 119 | encodeEntry entry = 120 | "," ++ encodeUgly entry 121 | in 122 | "[" ++ encodeUgly first ++ String.concat (MList.map encodeEntry rest) ++ "]" 123 | 124 | Object [] -> 125 | "{}" 126 | 127 | Object (first :: rest) -> 128 | let 129 | encodeEntry char (key, entry) = 130 | String.fromChar char ++ "\"" ++ key ++ "\":" ++ encodeUgly entry 131 | in 132 | encodeEntry '{' first ++ String.concat (MList.map (encodeEntry ',') rest) ++ "}" 133 | 134 | CString builder -> 135 | builder 136 | 137 | 138 | 139 | -- ENCODE 140 | 141 | 142 | encode : Value -> String 143 | encode value = 144 | encodeHelp "" value 145 | 146 | 147 | encodeHelp : String -> Value -> String 148 | encodeHelp indent value = 149 | case value of 150 | Array [] -> 151 | "[]" 152 | 153 | Array (first :: rest) -> 154 | encodeArray indent first rest 155 | 156 | Object [] -> 157 | "{}" 158 | 159 | Object (first :: rest) -> 160 | encodeObject indent first rest 161 | 162 | CString builder -> 163 | builder 164 | 165 | 166 | 167 | -- ENCODE ARRAY 168 | 169 | 170 | encodeArray : String -> Value -> TList Value -> String 171 | encodeArray = 172 | encodeSequence arrayOpen arrayClose encodeHelp 173 | 174 | 175 | arrayOpen : String 176 | arrayOpen = 177 | "[\n" 178 | 179 | 180 | arrayClose : String 181 | arrayClose = 182 | "]" 183 | 184 | 185 | 186 | -- ENCODE OBJECT 187 | 188 | 189 | encodeObject : String -> (Json.TString, Value) -> (TList (Json.TString, Value)) -> String 190 | encodeObject = 191 | encodeSequence objectOpen objectClose encodeField 192 | 193 | 194 | objectOpen : String 195 | objectOpen = 196 | "{\n" 197 | 198 | 199 | objectClose : String 200 | objectClose = 201 | "}" 202 | 203 | 204 | encodeField : String -> (Json.TString, Value) -> String 205 | encodeField indent (key, value) = 206 | "\"" ++ key ++ "\": " ++ encodeHelp indent value 207 | 208 | 209 | 210 | -- ENCODE SEQUENCE 211 | 212 | 213 | encodeSequence : String -> String -> (String -> a -> String) -> String -> a -> TList a -> String 214 | encodeSequence open close encodeEntry indent first rest = 215 | let 216 | newIndent = 217 | indent ++ " " 218 | 219 | newIndentBuilder = 220 | newIndent 221 | 222 | closer = 223 | newline ++ indent ++ close 224 | 225 | addValue field builder = 226 | commaNewline 227 | ++ newIndentBuilder 228 | ++ encodeEntry newIndent field 229 | ++ builder 230 | in 231 | open 232 | ++ newIndentBuilder 233 | ++ encodeEntry newIndent first 234 | ++ MList.foldr addValue closer rest 235 | 236 | 237 | commaNewline : String 238 | commaNewline = 239 | ",\n" 240 | 241 | 242 | newline : String 243 | newline = 244 | "\n" 245 | -------------------------------------------------------------------------------- /src/Compiler/Json/String.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Json.String exposing 3 | ( TString 4 | --, isEmpty 5 | -- 6 | , fromPtr 7 | , fromName 8 | , fromChars 9 | , fromSnippet 10 | --, fromComment 11 | -- 12 | , toChars 13 | , toBuilder 14 | ) 15 | 16 | 17 | import Compiler.Data.Name as Name 18 | import Compiler.Data.Utf8 as Utf8 19 | import Compiler.Parse.Primitives as P 20 | 21 | 22 | 23 | -- JSON STRINGS 24 | 25 | 26 | -- INVARIANT: any Json.String is appropriately escaped already 27 | -- PERF: is this the right representation for Json.String? Maybe ByteString instead? 28 | -- 29 | type alias TString = 30 | Utf8.Utf8 31 | 32 | 33 | 34 | -- FROM 35 | 36 | 37 | fromPtr : String -> Int -> Int -> String 38 | fromPtr = 39 | Utf8.fromPtr 40 | 41 | 42 | fromChars : TString -> TString 43 | fromChars = 44 | identity 45 | 46 | 47 | fromSnippet : P.Snippet -> String 48 | fromSnippet = 49 | Utf8.fromSnippet 50 | 51 | 52 | fromName : Name.Name -> String 53 | fromName = 54 | identity 55 | 56 | 57 | 58 | -- TO 59 | 60 | 61 | toChars : String -> String 62 | toChars = 63 | identity 64 | 65 | 66 | toBuilder : String -> String 67 | toBuilder = 68 | identity 69 | -------------------------------------------------------------------------------- /src/Compiler/Nitpick/Debug.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Nitpick.Debug exposing 3 | ( hasDebugUses 4 | ) 5 | 6 | 7 | import Compiler.AST.Optimized as Opt 8 | import Extra.Type.List as MList 9 | import Extra.Type.Map as Map 10 | import Extra.Type.Maybe as MMaybe 11 | 12 | 13 | 14 | -- HAS DEBUG USES 15 | 16 | 17 | hasDebugUses : Opt.LocalGraph -> Bool 18 | hasDebugUses (Opt.LocalGraph _ graph _) = 19 | Map.any nodeHasDebug graph 20 | 21 | 22 | nodeHasDebug : Opt.Node -> Bool 23 | nodeHasDebug node = 24 | case node of 25 | Opt.Define expr _ -> hasDebug expr 26 | Opt.DefineTailFunc _ expr _ -> hasDebug expr 27 | Opt.Ctor _ _ -> False 28 | Opt.Enum _ -> False 29 | Opt.Box -> False 30 | Opt.Link _ -> False 31 | Opt.Cycle _ vs fs _ -> MList.any (hasDebug << Tuple.second) vs || MList.any defHasDebug fs 32 | Opt.Manager _ -> False 33 | Opt.Kernel _ _ -> False 34 | Opt.PortIncoming expr _ -> hasDebug expr 35 | Opt.PortOutgoing expr _ -> hasDebug expr 36 | 37 | 38 | hasDebug : Opt.Expr -> Bool 39 | hasDebug expression = 40 | case expression of 41 | Opt.CBool _ -> False 42 | Opt.Chr _ -> False 43 | Opt.Str _ -> False 44 | Opt.CInt _ -> False 45 | Opt.CFloat _ -> False 46 | Opt.VarLocal _ -> False 47 | Opt.VarGlobal _ -> False 48 | Opt.VarEnum _ _ -> False 49 | Opt.VarBox _ -> False 50 | Opt.VarCycle _ _ -> False 51 | Opt.VarDebug _ _ _ _ -> True 52 | Opt.VarKernel _ _ -> False 53 | Opt.CList exprs -> MList.any hasDebug exprs 54 | Opt.Function _ expr -> hasDebug expr 55 | Opt.Call e es -> hasDebug e || MList.any hasDebug es 56 | Opt.TailCall _ args -> MList.any (hasDebug << Tuple.second) args 57 | Opt.If conds finally -> MList.any (\(c,e) -> hasDebug c || hasDebug e) conds || hasDebug finally 58 | Opt.Let def body -> defHasDebug def || hasDebug body 59 | Opt.Destruct _ expr -> hasDebug expr 60 | Opt.Case _ _ d jumps -> deciderHasDebug d || MList.any (hasDebug << Tuple.second) jumps 61 | Opt.Accessor _ -> False 62 | Opt.Access r _ -> hasDebug r 63 | Opt.Update r fs -> hasDebug r || Map.any hasDebug fs 64 | Opt.Record fs -> Map.any hasDebug fs 65 | Opt.Unit -> False 66 | Opt.Tuple a b c -> hasDebug a || hasDebug b || MMaybe.maybe False hasDebug c 67 | Opt.Shader _ _ _ -> False 68 | 69 | 70 | defHasDebug : Opt.Def -> Bool 71 | defHasDebug def = 72 | case def of 73 | Opt.Def _ expr -> hasDebug expr 74 | Opt.TailDef _ _ expr -> hasDebug expr 75 | 76 | 77 | deciderHasDebug : Opt.Decider Opt.Choice -> Bool 78 | deciderHasDebug decider = 79 | case decider of 80 | Opt.Leaf (Opt.Inline expr) -> hasDebug expr 81 | Opt.Leaf (Opt.Jump _) -> False 82 | Opt.Chain _ success failure -> deciderHasDebug success || deciderHasDebug failure 83 | Opt.FanOut _ tests fallback -> MList.any (deciderHasDebug << Tuple.second) tests || deciderHasDebug fallback 84 | 85 | 86 | 87 | -- TODO: FIND GLOBALLY UNUSED DEFINITIONS? 88 | -- TODO: FIND PACKAGE USAGE STATS? (e.g. elm/core = 142, author/project = 2, etc.) 89 | -------------------------------------------------------------------------------- /src/Compiler/Optimize/Case.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Optimize.Case exposing 3 | ( optimize 4 | ) 5 | 6 | 7 | import Compiler.AST.Canonical as Can 8 | import Compiler.AST.Optimized as Opt 9 | import Compiler.Data.Name as Name 10 | import Compiler.Optimize.DecisionTree as DT 11 | import Extra.Type.List as MList exposing (TList) 12 | import Extra.Type.Map as Map 13 | import Extra.Type.Maybe as MMaybe 14 | 15 | 16 | 17 | -- OPTIMIZE A CASE EXPRESSION 18 | 19 | 20 | optimize : Name.Name -> Name.Name -> TList (Can.Pattern, Opt.Expr) -> Opt.Expr 21 | optimize temp root optBranches = 22 | let 23 | (patterns, indexedBranches) = 24 | MList.unzip (MList.zipWith indexify (MList.range 0 <| MList.length optBranches - 1) optBranches) 25 | 26 | decider = treeToDecider (DT.compile patterns) 27 | targetCounts = countTargets decider 28 | 29 | (choices, maybeJumps) = 30 | MList.unzip (MList.map (createChoices targetCounts) indexedBranches) 31 | in 32 | Opt.Case temp root 33 | (insertChoices (Map.fromList choices) decider) 34 | (MMaybe.catMaybes maybeJumps) 35 | 36 | 37 | indexify : Int -> (a,b) -> ((a,Int), (Int,b)) 38 | indexify index (pattern, branch) = 39 | ( (pattern, index) 40 | , (index, branch) 41 | ) 42 | 43 | 44 | 45 | -- TREE TO DECIDER 46 | -- 47 | -- Decision trees may have some redundancies, so we convert them to a Decider 48 | -- which has special constructs to avoid code duplication when possible. 49 | 50 | 51 | treeToDecider : DT.DecisionTree -> Opt.Decider Int 52 | treeToDecider tree = 53 | case tree of 54 | DT.Match target -> 55 | Opt.Leaf target 56 | 57 | -- zero options 58 | DT.Decision _ [] Nothing -> 59 | Debug.todo "compiler bug, somehow created an empty decision tree" 60 | 61 | -- one option 62 | DT.Decision _ [(_, subTree)] Nothing -> 63 | treeToDecider subTree 64 | 65 | DT.Decision _ [] (Just subTree) -> 66 | treeToDecider subTree 67 | 68 | -- two options 69 | DT.Decision path [(test, successTree)] (Just failureTree) -> 70 | toChain path test successTree failureTree 71 | 72 | DT.Decision path [(test, successTree), (_, failureTree)] Nothing -> 73 | toChain path test successTree failureTree 74 | 75 | -- many options 76 | DT.Decision path edges Nothing -> 77 | let 78 | (necessaryTests, fallback) = 79 | (MList.init edges, Tuple.second (MList.last edges)) 80 | in 81 | Opt.FanOut 82 | path 83 | (MList.map (Tuple.mapSecond treeToDecider) necessaryTests) 84 | (treeToDecider fallback) 85 | 86 | DT.Decision path edges (Just fallback) -> 87 | Opt.FanOut path (MList.map (Tuple.mapSecond treeToDecider) edges) (treeToDecider fallback) 88 | 89 | 90 | toChain : DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int 91 | toChain path test successTree failureTree = 92 | let 93 | failure = 94 | treeToDecider failureTree 95 | in 96 | let success_ = treeToDecider successTree 97 | otherwise () = Opt.Chain [(path, test)] success_ failure 98 | in 99 | case success_ of 100 | Opt.Chain testChain success subFailure -> if failure == subFailure then 101 | Opt.Chain ((path, test) :: testChain) success failure else otherwise () 102 | 103 | _ -> 104 | otherwise () 105 | 106 | 107 | 108 | -- INSERT CHOICES 109 | -- 110 | -- If a target appears exactly once in a Decider, the corresponding expression 111 | -- can be inlined. Whether things are inlined or jumps is called a "choice". 112 | 113 | 114 | countTargets : Opt.Decider Int -> Map.Map Int Int 115 | countTargets decisionTree = 116 | case decisionTree of 117 | Opt.Leaf target -> 118 | Map.singleton target 1 119 | 120 | Opt.Chain _ success failure -> 121 | Map.unionWith (+) (countTargets success) (countTargets failure) 122 | 123 | Opt.FanOut _ tests fallback -> 124 | Map.unionsWith MList.foldl (+) (MList.map countTargets (fallback :: MList.map Tuple.second tests)) 125 | 126 | 127 | createChoices 128 | : Map.Map Int Int 129 | -> (Int, Opt.Expr) 130 | -> ( (Int, Opt.Choice), Maybe (Int, Opt.Expr) ) 131 | createChoices targetCounts (target, branch) = 132 | if Map.ex targetCounts target == 1 then 133 | ( (target, Opt.Inline branch) 134 | , Nothing 135 | ) 136 | 137 | else 138 | ( (target, Opt.Jump target) 139 | , Just (target, branch) 140 | ) 141 | 142 | 143 | insertChoices 144 | : Map.Map Int Opt.Choice 145 | -> Opt.Decider Int 146 | -> Opt.Decider Opt.Choice 147 | insertChoices choiceDict decider = 148 | let 149 | go = 150 | insertChoices choiceDict 151 | in 152 | case decider of 153 | Opt.Leaf target -> 154 | Opt.Leaf (Map.ex choiceDict target) 155 | 156 | Opt.Chain testChain success failure -> 157 | Opt.Chain testChain (go success) (go failure) 158 | 159 | Opt.FanOut path tests fallback -> 160 | Opt.FanOut path (MList.map (Tuple.mapSecond go) tests) (go fallback) 161 | -------------------------------------------------------------------------------- /src/Compiler/Optimize/Names.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Optimize.Names exposing 3 | ( Tracker 4 | , run 5 | , generate 6 | , registerKernel 7 | , registerGlobal 8 | , registerDebug 9 | , registerCtor 10 | , registerField 11 | , registerFieldDict 12 | , registerFieldList 13 | , fmap, pure, andMap, liftA2, return, bind, andThen 14 | ) 15 | 16 | 17 | import Compiler.AST.Canonical as Can 18 | import Compiler.AST.Optimized as Opt 19 | import Compiler.Data.Index as Index 20 | import Compiler.Data.Name as Name 21 | import Compiler.Elm.ModuleName as ModuleName 22 | import Compiler.Reporting.Annotation as A 23 | import Extra.Class.Applicative as Applicative 24 | import Extra.Class.Functor as Functor 25 | import Extra.Class.Monad as Monad 26 | import Extra.Type.List as MList exposing (TList) 27 | import Extra.Type.Map as Map 28 | import Extra.Type.Set as Set 29 | import Compiler.AST.Optimized exposing (toGlobalComparable) 30 | 31 | 32 | 33 | -- GENERATOR 34 | 35 | 36 | type Tracker a = 37 | Tracker ( 38 | Int 39 | -> Set.Set Opt.GlobalComparable 40 | -> Map.Map Name.Name Int 41 | -> TStep a 42 | ) 43 | 44 | 45 | type TStep a = 46 | Cok Int (Set.Set Opt.GlobalComparable) (Map.Map Name.Name Int) a 47 | 48 | 49 | run : Tracker a -> (Set.Set Opt.GlobalComparable, Map.Map Name.Name Int, a) 50 | run (Tracker k) = 51 | case k 0 Set.empty Map.empty of 52 | Cok _ deps fields value -> (deps, fields, value) 53 | 54 | 55 | generate : Tracker Name.Name 56 | generate = 57 | Tracker <| \uid deps fields -> 58 | Cok (uid + 1) deps fields (Name.fromVarIndex uid) 59 | 60 | 61 | registerKernel : Name.Name -> a -> Tracker a 62 | registerKernel home value = 63 | Tracker <| \uid deps fields -> 64 | Cok uid (Set.insert (Opt.toGlobalComparable <| Opt.toKernelGlobal home) deps) fields value 65 | 66 | 67 | registerGlobal : ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr 68 | registerGlobal home name = 69 | Tracker <| \uid deps fields -> 70 | let global = Opt.Global home name in 71 | Cok uid (Set.insert (toGlobalComparable global) deps) fields (Opt.VarGlobal global) 72 | 73 | 74 | registerDebug : Name.Name -> ModuleName.Canonical -> A.Region -> Tracker Opt.Expr 75 | registerDebug name home region = 76 | Tracker <| \uid deps fields -> 77 | let global = Opt.Global ModuleName.debug name in 78 | Cok uid (Set.insert (toGlobalComparable global) deps) fields (Opt.VarDebug name home region Nothing) 79 | 80 | 81 | registerCtor : ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr 82 | registerCtor home name index opts = 83 | Tracker <| \uid deps fields -> 84 | let 85 | global = Opt.Global home name 86 | newDeps = Set.insert (toGlobalComparable global) deps 87 | in 88 | case opts of 89 | Can.Normal -> 90 | Cok uid newDeps fields (Opt.VarGlobal global) 91 | 92 | Can.Enum -> 93 | Cok uid newDeps fields <| 94 | let 95 | otherwise () = Opt.VarEnum global index 96 | in 97 | case name of 98 | "True" -> if home == ModuleName.basics then Opt.CBool True else otherwise () 99 | "False" -> if home == ModuleName.basics then Opt.CBool False else otherwise () 100 | _ -> otherwise () 101 | 102 | Can.Unbox -> 103 | Cok uid (Set.insert (toGlobalComparable identity_) newDeps) fields (Opt.VarBox global) 104 | 105 | 106 | identity_ : Opt.Global 107 | identity_ = 108 | Opt.Global ModuleName.basics Name.identity_ 109 | 110 | 111 | registerField : Name.Name -> a -> Tracker a 112 | registerField name value = 113 | Tracker <| \uid d fields -> 114 | Cok uid d (Map.insertWith (+) name 1 fields) value 115 | 116 | 117 | registerFieldDict : Map.Map Name.Name v -> a -> Tracker a 118 | registerFieldDict newFields value = 119 | Tracker <| \uid d fields -> 120 | Cok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value 121 | 122 | 123 | toOne : a -> Int 124 | toOne _ = 1 125 | 126 | 127 | registerFieldList : TList Name.Name -> a -> Tracker a 128 | registerFieldList names value = 129 | Tracker <| \uid deps fields -> 130 | Cok uid deps (MList.foldr addOne fields names) value 131 | 132 | 133 | addOne : Name.Name -> Map.Map Name.Name Int -> Map.Map Name.Name Int 134 | addOne name fields = 135 | Map.insertWith (+) name 1 fields 136 | 137 | 138 | 139 | -- INSTANCES 140 | 141 | 142 | fmap : Functor.Fmap a (Tracker a) b (Tracker b) 143 | fmap func (Tracker kv) = 144 | Tracker <| \n d f -> 145 | case kv n d f of 146 | Cok n1 d1 f1 value -> 147 | Cok n1 d1 f1 (func value) 148 | 149 | 150 | pure : Applicative.Pure a (Tracker a) 151 | pure value = 152 | Tracker <| \n d f -> Cok n d f value 153 | 154 | 155 | andMap : Applicative.AndMap (Tracker a) (Tracker (a -> b)) (Tracker b) 156 | andMap (Tracker kv) (Tracker kf) = 157 | Tracker <| \n d f -> 158 | case kf n d f of 159 | Cok n1 d1 f1 func -> 160 | case kv n1 d1 f1 of 161 | Cok n2 d2 f2 value -> 162 | Cok n2 d2 f2 (func value) 163 | 164 | 165 | liftA2 : Applicative.LiftA2 a (Tracker a) b (Tracker b) c (Tracker c) 166 | liftA2 = 167 | Applicative.liftA2 fmap andMap 168 | 169 | 170 | return : Monad.Return a (Tracker a) 171 | return = 172 | pure 173 | 174 | 175 | bind : Monad.Bind a (Tracker a) (Tracker b) 176 | bind (Tracker k) callback = 177 | Tracker <| \n d f -> 178 | case k n d f of 179 | Cok n1 d1 f1 a -> 180 | case callback a of 181 | Tracker kb -> kb n1 d1 f1 182 | 183 | 184 | andThen : Monad.AndThen a (Tracker a) (Tracker b) 185 | andThen = 186 | Monad.andThen bind 187 | -------------------------------------------------------------------------------- /src/Compiler/Parse/Shader.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Parse.Shader exposing 3 | ( shader 4 | ) 5 | 6 | 7 | import Compiler.AST.Source as Src 8 | import Compiler.AST.Utils.Shader as Shader 9 | import Compiler.Parse.Primitives as P 10 | import Compiler.Reporting.Annotation as A 11 | import Compiler.Reporting.Error.Syntax as E 12 | import Extra.Type.Set as Set 13 | 14 | 15 | 16 | -- SHADER 17 | 18 | 19 | shader : A.Position -> P.Parser E.Expr Src.Expr 20 | shader ((A.Position row col) as start) = 21 | P.bind parseBlock <| \block -> 22 | P.bind (parseGlsl row col block) <| \shdr -> 23 | P.bind P.getPosition <| \end -> 24 | P.return (A.at start end (Src.Shader (Shader.fromChars block) shdr)) 25 | 26 | 27 | 28 | -- BLOCK 29 | 30 | 31 | parseBlock : P.Parser E.Expr String 32 | parseBlock = 33 | P.Parser <| \(P.State src pos end indent row col) -> 34 | let 35 | pos6 = pos + 6 36 | in 37 | if pos6 <= end 38 | && P.unsafeIndex src (pos ) == 0x5B {- [ -} 39 | && P.unsafeIndex src (pos + 1) == 0x67 {- g -} 40 | && P.unsafeIndex src (pos + 2) == 0x6C {- l -} 41 | && P.unsafeIndex src (pos + 3) == 0x73 {- s -} 42 | && P.unsafeIndex src (pos + 4) == 0x6C {- l -} 43 | && P.unsafeIndex src (pos + 5) == 0x7C {- | -} 44 | then 45 | let 46 | ((status, newPos), (newRow, newCol)) = 47 | eatShader src pos6 end row (col + 6) 48 | in 49 | case status of 50 | Good -> 51 | let 52 | off = pos6 53 | len = newPos - pos6 54 | block = String.slice off (off + len) src 55 | newState = P.State src (newPos + 2) end indent newRow (newCol + 2) 56 | in 57 | P.Cok block newState 58 | 59 | Unending -> 60 | P.Cerr row col E.EndlessShader 61 | 62 | else 63 | P.Eerr row col E.Start 64 | 65 | 66 | type Status 67 | = Good 68 | | Unending 69 | 70 | 71 | eatShader : String -> Int -> Int -> P.Row -> P.Col -> ((Status, Int), (P.Row, P.Col)) 72 | eatShader src pos end row col = 73 | if pos >= end then 74 | ((Unending, pos), (row, col)) 75 | 76 | else 77 | let word = P.unsafeIndex src pos in 78 | if word == 0x007C {- | -} && P.isWord src (pos + 1) end 0x5D {- ] -} then 79 | ((Good, pos), (row, col)) 80 | 81 | else if word == 0x0A {- \n -} then 82 | eatShader src (pos + 1) end (row + 1) 1 83 | 84 | else 85 | let newPos = pos + (P.getCharWidth word) in 86 | eatShader src newPos end row (col + 1) 87 | 88 | 89 | 90 | -- GLSL 91 | 92 | 93 | parseGlsl : P.Row -> P.Col -> String -> P.Parser E.Expr Shader.Types 94 | parseGlsl _ _ _ = 95 | -- TODO: Parse.Shader.parseGlsl 96 | P.return <| Shader.Types Set.empty Set.empty Set.empty 97 | -------------------------------------------------------------------------------- /src/Compiler/Parse/Symbol.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Parse.Symbol exposing 3 | ( operator 4 | , BadOperator(..) 5 | -- 6 | , isBinopChar 7 | ) 8 | 9 | 10 | import Compiler.Data.Name as Name 11 | import Compiler.Parse.Primitives as P 12 | import Extra.Type.List as MList 13 | import Extra.Type.Set as Set exposing (Set) 14 | 15 | 16 | 17 | -- OPERATOR 18 | 19 | 20 | type BadOperator 21 | = BadDot 22 | | BadPipe 23 | | BadArrow 24 | | BadEquals 25 | | BadHasType 26 | 27 | 28 | operator : (P.Row -> P.Col -> x) -> (BadOperator -> P.Row -> P.Col -> x) -> P.Parser x Name.Name 29 | operator toExpectation toError = 30 | P.Parser <| \(P.State src pos end indent row col) -> 31 | let newPos = chompOps src pos end in 32 | if pos == newPos then 33 | P.Eerr row col toExpectation 34 | 35 | else 36 | case Name.fromPtr src pos newPos of 37 | "." -> P.Eerr row col (toError BadDot) 38 | "|" -> P.Cerr row col (toError BadPipe) 39 | "->" -> P.Cerr row col (toError BadArrow) 40 | "=" -> P.Cerr row col (toError BadEquals) 41 | ":" -> P.Cerr row col (toError BadHasType) 42 | op -> 43 | let 44 | newCol = col + newPos - pos 45 | newState = P.State src newPos end indent row newCol 46 | in 47 | P.Cok op newState 48 | 49 | 50 | chompOps : String -> Int -> Int -> Int 51 | chompOps src pos end = 52 | if pos < end && isBinopCharHelp (P.unsafeIndex src pos) then 53 | chompOps src (pos + 1) end 54 | else 55 | pos 56 | 57 | 58 | isBinopCharHelp : Int -> Bool 59 | isBinopCharHelp word = 60 | word < 128 && Set.member word binopCharSet 61 | 62 | 63 | binopCharSet : Set Int 64 | binopCharSet = 65 | Set.fromList (MList.map Char.toCode (String.toList "+-/*=.<>:&|^?%!")) 66 | 67 | 68 | isBinopChar : Char -> Bool 69 | isBinopChar char = 70 | isBinopCharHelp (Char.toCode char) 71 | -------------------------------------------------------------------------------- /src/Compiler/Reporting/Annotation.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Reporting.Annotation exposing 2 | ( Located(..) 3 | , Position(..) 4 | , Region(..) 5 | , at 6 | , bRegion 7 | , merge 8 | , mergeRegions 9 | , one 10 | , toRegion 11 | , toValue 12 | , traverse 13 | , zero 14 | ) 15 | 16 | import Extra.Class.Functor as Functor 17 | import Extra.Class.Traversable as Traversable 18 | import Extra.Data.Binary as B 19 | 20 | 21 | 22 | -- LOCATED 23 | 24 | 25 | type Located a 26 | = At Region a 27 | 28 | 29 | traverse : 30 | Functor.Fmap b fb (Located b) flb 31 | -> Traversable.Traverse a (Located a) fb flb 32 | traverse pFmap func (At region value) = 33 | pFmap (At region) <| func value 34 | 35 | 36 | toValue : Located a -> a 37 | toValue (At _ value) = 38 | value 39 | 40 | 41 | merge : Located a -> Located b -> value -> Located value 42 | merge (At r1 _) (At r2 _) value = 43 | At (mergeRegions r1 r2) value 44 | 45 | 46 | 47 | -- POSITION 48 | 49 | 50 | type Position 51 | = Position Int Int 52 | 53 | 54 | at : Position -> Position -> a -> Located a 55 | at start end a = 56 | At (Region start end) a 57 | 58 | 59 | 60 | -- REGION 61 | 62 | 63 | type Region 64 | = Region Position Position 65 | 66 | 67 | toRegion : Located a -> Region 68 | toRegion (At region _) = 69 | region 70 | 71 | 72 | mergeRegions : Region -> Region -> Region 73 | mergeRegions (Region start _) (Region _ end) = 74 | Region start end 75 | 76 | 77 | zero : Region 78 | zero = 79 | Region (Position 0 0) (Position 0 0) 80 | 81 | 82 | one : Region 83 | one = 84 | Region (Position 1 1) (Position 1 1) 85 | 86 | 87 | bRegion : B.Binary Region 88 | bRegion = 89 | B.bin2 Region (\(Region a b) -> B.T2 a b) bPosition bPosition 90 | 91 | 92 | bPosition : B.Binary Position 93 | bPosition = 94 | B.bin2 Position (\(Position a b) -> B.T2 a b) B.bWord16 B.bWord16 95 | -------------------------------------------------------------------------------- /src/Compiler/Reporting/Error.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Reporting.Error exposing 2 | ( Error(..) 3 | , Module(..) 4 | , toDoc 5 | , toClient 6 | ) 7 | 8 | import Builder.File as File 9 | import Compiler.Data.NonEmptyList as NE 10 | import Compiler.Data.OneOrMore as OneOrMore 11 | import Compiler.Elm.ModuleName as ModuleName 12 | import Compiler.Nitpick.PatternMatches as PatternMatches 13 | import Compiler.Reporting.Annotation as A 14 | import Compiler.Reporting.Doc as D exposing (d) 15 | import Compiler.Reporting.Error.Canonicalize as Canonicalize 16 | import Compiler.Reporting.Error.Import as Import 17 | import Compiler.Reporting.Error.Main as Main 18 | import Compiler.Reporting.Error.Pattern as Pattern 19 | import Compiler.Reporting.Error.Syntax as Syntax 20 | import Compiler.Reporting.Error.Type as Type 21 | import Compiler.Reporting.Render.Code as Code 22 | import Compiler.Reporting.Render.Type.Localizer as L 23 | import Compiler.Reporting.Report as Report 24 | import Elm.Error as Client 25 | import Extra.System.File as SysFile exposing (FilePath) 26 | import Extra.Type.List as MList exposing (TList) 27 | 28 | 29 | 30 | -- MODULE 31 | 32 | 33 | type Module 34 | = Module 35 | --{ name : ModuleName.Raw 36 | --, absolutePath : FilePath 37 | --, modificationTime : File.Time 38 | --, source : String 39 | --, error : Error 40 | --} 41 | ModuleName.Raw 42 | FilePath 43 | File.Time 44 | String 45 | Error 46 | 47 | 48 | 49 | -- ERRORS 50 | 51 | 52 | type Error 53 | = BadSyntax Syntax.Error 54 | | BadImports (NE.TList Import.Error) 55 | | BadNames (OneOrMore.OneOrMore Canonicalize.Error) 56 | | BadTypes L.Localizer (NE.TList Type.Error) 57 | | BadMains L.Localizer (OneOrMore.OneOrMore Main.Error) 58 | | BadPatterns (NE.TList PatternMatches.Error) 59 | 60 | 61 | 62 | -- TO REPORT 63 | 64 | 65 | toReports : Code.Source -> Error -> NE.TList Report.Report 66 | toReports source err = 67 | case err of 68 | BadSyntax syntaxError -> 69 | NE.CList (Syntax.toReport source syntaxError) [] 70 | 71 | BadImports errs -> 72 | NE.fmap (Import.toReport source) errs 73 | 74 | BadNames errs -> 75 | NE.fmap (Canonicalize.toReport source) (OneOrMore.destruct NE.CList errs) 76 | 77 | BadTypes localizer errs -> 78 | NE.fmap (Type.toReport source localizer) errs 79 | 80 | BadMains localizer errs -> 81 | NE.fmap (Main.toReport localizer source) (OneOrMore.destruct NE.CList errs) 82 | 83 | BadPatterns errs -> 84 | NE.fmap (Pattern.toReport source) errs 85 | 86 | 87 | 88 | -- TO DOC 89 | 90 | 91 | toDoc : FilePath -> Module -> TList Module -> D.Doc 92 | toDoc root err errs = 93 | let 94 | (NE.CList m ms) = NE.sortBy getModificationTime (NE.CList err errs) 95 | in 96 | D.vcat (toDocHelp root m ms) 97 | 98 | 99 | toDocHelp : FilePath -> Module -> TList Module -> TList D.Doc 100 | toDocHelp root module1 modules = 101 | case modules of 102 | [] -> 103 | [moduleToDoc root module1 104 | ,d"" 105 | ] 106 | 107 | module2 :: otherModules -> 108 | moduleToDoc root module1 109 | :: toSeparator module1 module2 110 | :: toDocHelp root module2 otherModules 111 | 112 | 113 | toSeparator : Module -> Module -> D.Doc 114 | toSeparator beforeModule afterModule = 115 | let 116 | before = ModuleName.toChars (getName beforeModule) ++ " ↑ " 117 | after = " ↓ " ++ ModuleName.toChars (getName afterModule) 118 | in 119 | D.dullred <| D.vcat <| 120 | [ D.indent (80 - String.length before) (D.fromChars before) 121 | , d"====o======================================================================o====" 122 | , D.fromChars after 123 | , d"" 124 | , d"" 125 | ] 126 | 127 | 128 | getName : Module -> ModuleName.Raw 129 | getName (Module name _ _ _ _) = 130 | name 131 | 132 | getModificationTime : Module -> Int 133 | getModificationTime (Module _ _ time _ _) = 134 | File.toMillis time 135 | 136 | 137 | 138 | -- MODULE TO DOC 139 | 140 | 141 | moduleToDoc : FilePath -> Module -> D.Doc 142 | moduleToDoc root (Module _ absolutePath _ source err) = 143 | let 144 | reports = 145 | toReports (Code.toSource source) err 146 | 147 | relativePath = 148 | SysFile.makeRelative root absolutePath 149 | in 150 | D.vcat <| MList.map (reportToDoc relativePath) (NE.toList reports) 151 | 152 | 153 | reportToDoc : FilePath -> Report.Report -> D.Doc 154 | reportToDoc relativePath (Report.Report title _ message) = 155 | D.vcat 156 | [ toMessageBar title relativePath 157 | , d"" 158 | , message 159 | , d"" 160 | ] 161 | 162 | 163 | toMessageBar : String -> FilePath -> D.Doc 164 | toMessageBar title filePath = 165 | let 166 | usedSpace = 167 | 4 + String.length title + 1 + String.length (SysFile.toString filePath) 168 | in 169 | D.dullcyan <| D.fromChars <| 170 | "-- " ++ title 171 | ++ " " ++ String.repeat (max 1 (80 - usedSpace)) "-" 172 | ++ " " ++ (SysFile.toString filePath) 173 | 174 | 175 | 176 | -- TO CLIENT (original: TO JSON) 177 | 178 | 179 | toClient : Module -> Client.BadModule 180 | toClient (Module name path _ source err) = 181 | let 182 | reports = 183 | toReports (Code.toSource source) err 184 | in 185 | { path = SysFile.toString path 186 | , name = name 187 | , problems = MList.map reportToClient (NE.toList reports) 188 | } 189 | 190 | 191 | reportToClient : Report.Report -> Client.Problem 192 | reportToClient (Report.Report title region message) = 193 | { title = title 194 | , region = toClientRegion region 195 | , message = D.toClient message 196 | } 197 | 198 | 199 | toClientRegion : A.Region -> Client.Region 200 | toClientRegion (A.Region (A.Position sr sc) (A.Position er ec)) = 201 | { start = { line = sr, column = sc } 202 | , end = { line = er, column = ec } 203 | } 204 | -------------------------------------------------------------------------------- /src/Compiler/Reporting/Error/Main.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Reporting.Error.Main exposing 3 | ( Error(..) 4 | , toReport 5 | ) 6 | 7 | 8 | import Compiler.AST.Canonical as Can 9 | import Compiler.Data.Name as Name 10 | import Compiler.Reporting.Annotation as A 11 | import Compiler.Reporting.Doc as D exposing (d) 12 | import Compiler.Reporting.Error.Canonicalize as E 13 | import Compiler.Reporting.Render.Code as Code 14 | import Compiler.Reporting.Render.Type as RT 15 | import Compiler.Reporting.Render.Type.Localizer as L 16 | import Compiler.Reporting.Report as Report 17 | import Extra.Type.List exposing (TList) 18 | 19 | 20 | 21 | -- ERROR 22 | 23 | 24 | type Error 25 | = BadType A.Region Can.Type 26 | | BadCycle A.Region Name.Name (TList Name.Name) 27 | | BadFlags A.Region E.InvalidPayload 28 | 29 | 30 | 31 | -- TO REPORT 32 | 33 | 34 | toReport : L.Localizer -> Code.Source -> Error -> Report.Report 35 | toReport localizer source err = 36 | case err of 37 | BadType region tipe -> 38 | Report.Report "BAD MAIN TYPE" region <| 39 | Code.toSnippet source region Nothing 40 | ( 41 | d"I cannot handle this type of `main` value:" 42 | , 43 | D.stack 44 | [ d"The type of `main` value I am seeing is:" 45 | , D.indent 4 <| D.dullyellow <| RT.canToDoc localizer RT.None tipe 46 | , D.reflow <| 47 | "I only know how to handle Html, Svg, and Programs" 48 | ++ " though. Modify `main` to be one of those types of values!" 49 | ] 50 | ) 51 | 52 | BadCycle region name names -> 53 | Report.Report "BAD MAIN" region <| 54 | Code.toSnippet source region Nothing 55 | ( 56 | d"A `main` definition cannot be defined in terms of itself." 57 | , 58 | D.stack 59 | [ D.reflow <| 60 | "It should be a boring value with no recursion. But" 61 | ++ " instead it is involved in this cycle of definitions:" 62 | , D.cycle 4 name names 63 | ] 64 | ) 65 | 66 | BadFlags region invalidPayload -> 67 | let 68 | formatDetails (aBadKindOfThing, butThatIsNoGood) = 69 | Report.Report "BAD FLAGS" region <| 70 | Code.toSnippet source region Nothing 71 | ( 72 | D.reflow <| 73 | "Your `main` program wants " ++ aBadKindOfThing ++ " from JavaScript." 74 | , 75 | butThatIsNoGood 76 | ) 77 | in 78 | formatDetails <| 79 | case invalidPayload of 80 | E.ExtendedRecord -> 81 | ( 82 | "an extended record" 83 | , 84 | D.reflow <| 85 | "But the exact shape of the record must be known at compile time. No type variables!" 86 | ) 87 | 88 | E.Function -> 89 | ( 90 | "a function" 91 | , 92 | D.reflow <| 93 | "But if I allowed functions from JS, it would be possible to sneak" 94 | ++ " side-effects and runtime exceptions into Elm!" 95 | ) 96 | 97 | E.TypeVariable name -> 98 | ( 99 | "an unspecified type" 100 | , 101 | D.reflow <| 102 | "But type variables like `" ++ name ++ "` cannot be given as flags." 103 | ++ " I need to know exactly what type of data I am getting, so I can guarantee that" 104 | ++ " unexpected data cannot sneak in and crash the Elm program." 105 | ) 106 | 107 | E.UnsupportedType name -> 108 | ( 109 | "a `" ++ name ++ "` value" 110 | , 111 | D.stack 112 | [ D.reflow <| "I cannot handle that. The types that CAN be in flags include:" 113 | , D.indent 4 <| 114 | D.reflow <| 115 | "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays," 116 | ++ " tuples, records, and JSON values." 117 | , D.reflow <| 118 | "Since JSON values can flow through, you can use JSON encoders and decoders" 119 | ++ " to allow other types through as well. More advanced users often just do" 120 | ++ " everything with encoders and decoders for more control and better errors." 121 | ] 122 | ) 123 | -------------------------------------------------------------------------------- /src/Compiler/Reporting/Render/Type/Localizer.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Reporting.Render.Type.Localizer exposing 3 | ( Localizer 4 | , toDoc 5 | , toChars 6 | , empty 7 | --, fromNames 8 | , fromModule 9 | ) 10 | 11 | 12 | import Compiler.AST.Source as Src 13 | import Compiler.Data.Name as Name 14 | import Compiler.Elm.ModuleName as ModuleName 15 | import Compiler.Reporting.Annotation as A 16 | import Compiler.Reporting.Doc as D 17 | import Extra.Type.List as MList 18 | import Extra.Type.Map as Map 19 | import Extra.Type.Maybe as MMaybe 20 | import Extra.Type.Set as Set 21 | 22 | 23 | 24 | -- LOCALIZER 25 | 26 | 27 | type Localizer = 28 | Localizer (Map.Map Name.Name Import) 29 | 30 | 31 | type Import = 32 | Import 33 | {- alias -} (Maybe Name.Name) 34 | {- exposing -} Exposing 35 | 36 | 37 | type Exposing 38 | = All 39 | | Only (Set.Set Name.Name) 40 | 41 | 42 | empty : Localizer 43 | empty = 44 | Localizer Map.empty 45 | 46 | 47 | 48 | -- LOCALIZE 49 | 50 | 51 | toDoc : Localizer -> ModuleName.Canonical -> Name.Name -> D.Doc 52 | toDoc localizer home name = 53 | D.fromChars (toChars localizer home name) 54 | 55 | 56 | toChars : Localizer -> ModuleName.Canonical -> Name.Name -> String 57 | toChars (Localizer localizer) ((ModuleName.Canonical _ home) as moduleName) name = 58 | case Map.lookup home localizer of 59 | Nothing -> 60 | home ++ "." ++ name 61 | 62 | Just (Import alias exposing_) -> 63 | case exposing_ of 64 | All -> 65 | name 66 | 67 | Only set -> 68 | if Set.member name set then 69 | name 70 | else if name == Name.list && moduleName == ModuleName.list then 71 | "List" 72 | else 73 | MMaybe.maybe home identity alias ++ "." ++ name 74 | 75 | 76 | 77 | -- FROM MODULE 78 | 79 | 80 | fromModule : Src.Module -> Localizer 81 | fromModule ((Src.Module _ _ imports _ _ _ _ _) as modul) = 82 | Localizer <| Map.fromList <| 83 | (Src.getName modul, Import Nothing All) :: MList.map toPair imports 84 | 85 | 86 | toPair : Src.Import -> (Name.Name, Import) 87 | toPair (Src.Import (A.At _ name) alias exposing_) = 88 | ( name 89 | , Import alias (toExposing exposing_) 90 | ) 91 | 92 | 93 | toExposing : Src.Exposing -> Exposing 94 | toExposing exposing_ = 95 | case exposing_ of 96 | Src.Open -> 97 | All 98 | 99 | Src.Explicit exposedList -> 100 | Only (MList.foldr addType Set.empty exposedList) 101 | 102 | 103 | addType : Src.Exposed -> Set.Set Name.Name -> Set.Set Name.Name 104 | addType exposed types = 105 | case exposed of 106 | Src.Lower _ -> types 107 | Src.Upper (A.At _ name) _ -> Set.insert name types 108 | Src.Operator _ _ -> types 109 | -------------------------------------------------------------------------------- /src/Compiler/Reporting/Report.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Reporting.Report exposing (Report(..)) 2 | 3 | import Compiler.Reporting.Annotation as A 4 | import Compiler.Reporting.Doc as D 5 | 6 | 7 | 8 | -- BUILD REPORTS 9 | 10 | 11 | type Report 12 | = Report 13 | --{ title : String 14 | --, region : A.Region 15 | --, message : D.Doc 16 | --} 17 | String 18 | A.Region 19 | D.Doc 20 | -------------------------------------------------------------------------------- /src/Compiler/Reporting/Suggest.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Reporting.Suggest exposing 2 | ( distance 3 | , sort 4 | ) 5 | 6 | import Extra.Type.List as MList exposing (TList) 7 | import Levenshtein 8 | 9 | 10 | 11 | -- DISTANCE 12 | 13 | 14 | distance : String -> String -> Int 15 | distance x y = 16 | Levenshtein.distance x y 17 | 18 | 19 | 20 | -- SORT 21 | 22 | 23 | sort : String -> (a -> String) -> TList a -> TList a 24 | sort target toString values = 25 | MList.sortOn (distance (String.toLower target) << String.toLower << toString) values 26 | -------------------------------------------------------------------------------- /src/Compiler/Reporting/Warning.elm: -------------------------------------------------------------------------------- 1 | module Compiler.Reporting.Warning exposing 2 | ( Context(..) 3 | , Warning(..) 4 | ) 5 | 6 | 7 | 8 | -- ALL POSSIBLE WARNINGS 9 | 10 | 11 | type Warning 12 | = UnusedVariable 13 | | MissingTypeAnnotation 14 | 15 | 16 | type Context 17 | = Def 18 | | Pattern 19 | -------------------------------------------------------------------------------- /src/Compiler/Type/Instantiate.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Type.Instantiate exposing 3 | ( {- FreeVars 4 | ,-} fromSrcType 5 | ) 6 | 7 | 8 | import Compiler.AST.Canonical as Can 9 | import Compiler.Data.Name as Name 10 | import Compiler.Type.Type as Type 11 | import Extra.System.IO.Pure as IO 12 | import Extra.Type.Map as Map 13 | import Extra.Type.Maybe as MMaybe 14 | import Extra.Type.Tuple as MTuple 15 | 16 | 17 | 18 | -- IO 19 | 20 | 21 | type alias IO t a = Type.IO t a 22 | 23 | 24 | 25 | -- FROM SOURCE TYPE 26 | 27 | 28 | fromSrcType : Map.Map Name.Name Type.Type -> Can.Type -> IO t Type.Type 29 | fromSrcType freeVars sourceType = 30 | case sourceType of 31 | Can.TLambda arg result -> 32 | IO.pure Type.FunN 33 | |> IO.andMap (fromSrcType freeVars arg) 34 | |> IO.andMap (fromSrcType freeVars result) 35 | 36 | Can.TVar name -> 37 | IO.return (Map.ex freeVars name) 38 | 39 | Can.TType home name args -> 40 | IO.fmap (Type.AppN home name) <| IO.traverseList (fromSrcType freeVars) args 41 | 42 | Can.TAlias home name args aliasedType -> 43 | IO.bind (IO.traverseList (MTuple.traverseSecond IO.fmap (fromSrcType freeVars)) args) <| \targs -> 44 | IO.fmap (Type.AliasN home name targs) <| 45 | case aliasedType of 46 | Can.Filled realType -> 47 | fromSrcType freeVars realType 48 | 49 | Can.Holey realType -> 50 | fromSrcType (Map.fromList targs) realType 51 | 52 | Can.TTuple a b maybeC -> 53 | IO.pure Type.TupleN 54 | |> IO.andMap (fromSrcType freeVars a) 55 | |> IO.andMap (fromSrcType freeVars b) 56 | |> IO.andMap (MMaybe.traverse IO.pure IO.fmap (fromSrcType freeVars) maybeC) 57 | 58 | Can.TUnit -> 59 | IO.return Type.UnitN 60 | 61 | Can.TRecord fields maybeExt -> 62 | IO.pure Type.RecordN 63 | |> IO.andMap (IO.traverseMap (fromSrcFieldType freeVars) fields) 64 | |> IO.andMap 65 | (case maybeExt of 66 | Nothing -> 67 | IO.return Type.EmptyRecordN 68 | 69 | Just ext -> 70 | IO.return (Map.ex freeVars ext)) 71 | 72 | 73 | fromSrcFieldType : Map.Map Name.Name Type.Type -> Can.FieldType -> IO t Type.Type 74 | fromSrcFieldType freeVars (Can.FieldType _ tipe) = 75 | fromSrcType freeVars tipe 76 | -------------------------------------------------------------------------------- /src/Compiler/Type/Occurs.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Type.Occurs exposing 3 | ( occurs 4 | ) 5 | 6 | 7 | import Compiler.Type.Type as Type 8 | import Compiler.Type.UnionFind as UF 9 | import Extra.System.IO.Pure as IO 10 | import Extra.Type.List as MList exposing (TList) 11 | import Extra.Type.Map as Map 12 | 13 | 14 | 15 | -- IO 16 | 17 | 18 | type alias IO t a = 19 | UF.IO Type.Descriptor t a 20 | 21 | 22 | 23 | -- OCCURS 24 | 25 | 26 | occurs : Type.Variable -> IO t Bool 27 | occurs var = 28 | occursHelp [] var False 29 | 30 | 31 | occursHelp : (TList Type.Variable) -> Type.Variable -> Bool -> IO t Bool 32 | occursHelp seen var foundCycle = 33 | if MList.elem var seen then 34 | IO.return True 35 | 36 | else 37 | IO.bind (UF.get var) <| \(Type.Descriptor content _ _ _) -> 38 | case content of 39 | Type.FlexVar _ -> 40 | IO.return foundCycle 41 | 42 | Type.FlexSuper _ _ -> 43 | IO.return foundCycle 44 | 45 | Type.RigidVar _ -> 46 | IO.return foundCycle 47 | 48 | Type.RigidSuper _ _ -> 49 | IO.return foundCycle 50 | 51 | Type.Structure term -> 52 | let newSeen = var :: seen in 53 | case term of 54 | Type.App1 _ _ args -> 55 | IO.foldrMList (occursHelp newSeen) foundCycle args 56 | 57 | Type.Fun1 a b -> 58 | IO.andThen (occursHelp newSeen a) <| 59 | occursHelp newSeen b foundCycle 60 | 61 | Type.EmptyRecord1 -> 62 | IO.return foundCycle 63 | 64 | Type.Record1 fields ext -> 65 | IO.andThen (occursHelp newSeen ext) <| 66 | IO.foldrMList (occursHelp newSeen) foundCycle (Map.elems fields) 67 | 68 | Type.Unit1 -> 69 | IO.return foundCycle 70 | 71 | Type.Tuple1 a b maybeC -> 72 | case maybeC of 73 | Nothing -> 74 | IO.andThen (occursHelp newSeen a) <| 75 | occursHelp newSeen b foundCycle 76 | 77 | Just c -> 78 | IO.andThen (occursHelp newSeen a) <| 79 | IO.andThen (occursHelp newSeen b) <| 80 | occursHelp newSeen c foundCycle 81 | 82 | Type.Alias _ _ args _ -> 83 | IO.foldrMList (occursHelp (var::seen)) foundCycle (MList.map Tuple.second args) 84 | 85 | Type.Error -> 86 | IO.return foundCycle 87 | -------------------------------------------------------------------------------- /src/Compiler/Type/UnionFind.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Compiler.Type.UnionFind exposing 3 | ( Point 4 | , fresh 5 | , union 6 | , equivalent 7 | , redundant 8 | , get 9 | , set 10 | , modify 11 | , IO 12 | , LocalState 13 | , init 14 | ) 15 | 16 | 17 | {- This is based on the following implementations: 18 | 19 | - https://hackage.haskell.org/package/union-find-0.2/docs/src/Data-UnionFind-IO.html 20 | - http://yann.regis-gianas.org/public/mini/code_UnionFind.html 21 | 22 | It seems like the OCaml one came first, but I am not sure. 23 | 24 | Compared to the Haskell implementation, the major changes here include: 25 | 26 | 1. No more reallocating PointInfo when changing the weight 27 | 2. Using the strict modifyIORef 28 | 29 | -} 30 | 31 | 32 | import Extra.System.IO.Pure as IO 33 | import Extra.System.IORef as IORef exposing (IORef) 34 | 35 | 36 | 37 | -- POINT 38 | 39 | 40 | type Point a = 41 | Pt (IORef (PointInfo a)) 42 | 43 | 44 | type PointInfo a 45 | = Info (IORef Int) (IORef a) 46 | | Link (Point a) 47 | 48 | 49 | 50 | -- IO 51 | 52 | 53 | type alias IO s t a = 54 | IO.IO (LocalState s, t) a 55 | 56 | 57 | type alias LocalState a = 58 | ( -- weights 59 | IORef.State Int 60 | , -- descs 61 | IORef.State a 62 | , -- infos 63 | IORef.State (PointInfo a) 64 | ) 65 | 66 | 67 | init : LocalState a 68 | init = 69 | ( -- weights 70 | IORef.init 71 | , -- descs 72 | IORef.init 73 | , -- infos 74 | IORef.init 75 | ) 76 | 77 | 78 | liftW : IORef.IO Int a -> IO s t a 79 | liftW = IO.liftS (\( ( x, _, _ ), _ ) -> x) (\x ( ( _, bi, ci ), b ) -> ( ( x, bi, ci ), b )) 80 | 81 | liftD : IORef.IO s a -> IO s t a 82 | liftD = IO.liftS (\( ( _, x, _ ), _ ) -> x) (\x ( ( ai, _, ci ), b ) -> ( ( ai, x, ci ), b )) 83 | 84 | liftI : IORef.IO (PointInfo s) a -> IO s t a 85 | liftI = IO.liftS (\( ( _, _, x ), _ ) -> x) (\x ( ( ai, bi, _ ), b ) -> ( ( ai, bi, x ), b )) 86 | 87 | 88 | 89 | -- HELPERS 90 | 91 | 92 | fresh : a -> IO a t (Point a) 93 | fresh value = 94 | IO.bind (liftW (IORef.new 1)) <| \weight -> 95 | IO.bind (liftD (IORef.new value)) <| \desc -> 96 | IO.bind (liftI (IORef.new (Info weight desc))) <| \link -> 97 | IO.return (Pt link) 98 | 99 | 100 | repr : Point a -> IO a t (Point a) 101 | repr ((Pt ref) as point) = 102 | IO.bind (liftI (IORef.read ref)) <| \pInfo -> 103 | case pInfo of 104 | Info _ _ -> 105 | IO.return point 106 | 107 | Link ((Pt ref1) as point1) -> 108 | IO.bind (repr point1) <| \point2 -> 109 | IO.bind (IO.when (point2 /= point1) <| \() -> 110 | (IO.bind (liftI (IORef.read ref1)) <| \pInfo1 -> 111 | liftI (IORef.write ref pInfo1))) <| \_ -> 112 | IO.return point2 113 | 114 | 115 | get : Point a -> IO a t a 116 | get ((Pt ref) as point) = 117 | IO.bind (liftI (IORef.read ref)) <| \pInfo -> 118 | case pInfo of 119 | Info _ descRef -> 120 | liftD (IORef.read descRef) 121 | 122 | Link (Pt ref1) -> 123 | IO.bind (liftI (IORef.read ref1)) <| \link -> 124 | case link of 125 | Info _ descRef -> 126 | liftD (IORef.read descRef) 127 | 128 | Link _ -> 129 | IO.andThen get <| repr point 130 | 131 | 132 | set : Point a -> a -> IO a t () 133 | set ((Pt ref) as point) newDesc = 134 | IO.bind (liftI (IORef.read ref)) <| \pInfo -> 135 | case pInfo of 136 | Info _ descRef -> 137 | liftD (IORef.write descRef newDesc) 138 | 139 | Link (Pt ref1) -> 140 | IO.bind (liftI (IORef.read ref1)) <| \link -> 141 | case link of 142 | Info _ descRef -> 143 | liftD (IORef.write descRef newDesc) 144 | 145 | Link _ -> 146 | IO.bind (repr point) <| \newPoint -> 147 | set newPoint newDesc 148 | 149 | 150 | modify : Point a -> (a -> a) -> IO a t () 151 | modify ((Pt ref) as point) func = 152 | IO.bind (liftI (IORef.read ref)) <| \pInfo -> 153 | case pInfo of 154 | Info _ descRef -> 155 | liftD (IORef.modify descRef func) 156 | 157 | Link (Pt ref1) -> 158 | IO.bind (liftI (IORef.read ref1)) <| \link -> 159 | case link of 160 | Info _ descRef -> 161 | liftD (IORef.modify descRef func) 162 | 163 | Link _ -> 164 | IO.bind (repr point) <| \newPoint -> 165 | modify newPoint func 166 | 167 | 168 | union : Point a -> Point a -> a -> IO a t () 169 | union p1 p2 newDesc = 170 | IO.bind (repr p1) <| \((Pt ref1) as point1) -> 171 | IO.bind (repr p2) <| \((Pt ref2) as point2) -> 172 | 173 | IO.bind (liftI (IORef.read ref1)) <| \info1 -> 174 | IO.bind (liftI (IORef.read ref2)) <| \info2 -> 175 | 176 | case (info1, info2) of 177 | ( Info w1 d1, Info w2 d2 ) -> 178 | 179 | if point1 == point2 180 | then liftD (IORef.write d1 newDesc) 181 | else 182 | IO.bind (liftW (IORef.read w1)) <| \weight1 -> 183 | IO.bind (liftW (IORef.read w2)) <| \weight2 -> 184 | 185 | let newWeight = weight1 + weight2 in 186 | 187 | if weight1 >= weight2 188 | then 189 | IO.bind (liftI (IORef.write ref2 (Link point1))) <| \() -> 190 | IO.bind (liftW (IORef.write w1 newWeight)) <| \() -> 191 | liftD (IORef.write d1 newDesc) 192 | else 193 | IO.bind (liftI (IORef.write ref1 (Link point2))) <| \() -> 194 | IO.bind (liftW (IORef.write w2 newWeight)) <| \() -> 195 | liftD (IORef.write d2 newDesc) 196 | 197 | _ -> Debug.todo "UnionFind.union: invalid PointInfos" 198 | 199 | 200 | equivalent : Point a -> Point a -> IO a t Bool 201 | equivalent p1 p2 = 202 | IO.bind (repr p1) <| \v1 -> 203 | IO.bind (repr p2) <| \v2 -> 204 | IO.return (v1 == v2) 205 | 206 | 207 | redundant : Point a -> IO a t Bool 208 | redundant (Pt ref) = 209 | IO.bind (liftI (IORef.read ref)) <| \pInfo -> 210 | case pInfo of 211 | Info _ _ -> 212 | IO.return False 213 | 214 | Link _ -> 215 | IO.return True 216 | -------------------------------------------------------------------------------- /src/Extra/Class/Applicative.elm: -------------------------------------------------------------------------------- 1 | module Extra.Class.Applicative exposing 2 | ( AndMap 3 | , DiscardFirst 4 | , LiftA2 5 | , Pure 6 | , When 7 | , andMap 8 | , discardFirst 9 | , liftA2 10 | , when 11 | ) 12 | 13 | import Extra.Class.Functor as Functor 14 | 15 | 16 | type alias Pure a fa = 17 | a -> fa 18 | 19 | 20 | type alias AndMap fa fab fb = 21 | -- flipped <*> 22 | fa -> fab -> fb 23 | 24 | 25 | andMap : 26 | LiftA2 (a -> b) fab a fa b fb 27 | -> AndMap fa fab fb 28 | andMap pLiftA2 fa fab = 29 | pLiftA2 identity fab fa 30 | 31 | 32 | type alias LiftA2 a fa b fb c fc = 33 | (a -> b -> c) -> fa -> fb -> fc 34 | 35 | 36 | liftA2 : 37 | Functor.Fmap a fa (b -> c) fbc 38 | -> AndMap fb fbc fc 39 | -> LiftA2 a fa b fb c fc 40 | liftA2 pFmap pAndMap func fa fb = 41 | pAndMap fb (pFmap func fa) 42 | 43 | 44 | type alias DiscardFirst fa fb = 45 | -- *> 46 | fa -> fb -> fb 47 | 48 | 49 | discardFirst : 50 | LiftA2 a fa b fb b fb 51 | -> DiscardFirst fa fb 52 | discardFirst pLiftA2 fa fb = 53 | pLiftA2 (\_ b -> b) fa fb 54 | 55 | 56 | type alias When fu = 57 | Bool -> (() -> fu) -> fu 58 | 59 | 60 | when : 61 | Pure () fu 62 | -> When fu 63 | when mPure c f = 64 | if c then 65 | f () 66 | 67 | else 68 | mPure () 69 | -------------------------------------------------------------------------------- /src/Extra/Class/Foldable.elm: -------------------------------------------------------------------------------- 1 | module Extra.Class.Foldable exposing 2 | ( All 3 | , Elem 4 | , Filter 5 | , Foldl 6 | , FoldlM 7 | , Foldr 8 | , Length 9 | , MapM_ 10 | , NotElem 11 | , Null 12 | , Sequence_ 13 | , Traverse_ 14 | , foldlM 15 | , mapM_ 16 | , sequence_ 17 | , traverse_ 18 | ) 19 | 20 | import Extra.Class.Applicative as Applicative 21 | import Extra.Class.Monad as Monad 22 | 23 | 24 | type alias FoldlM a ta b mb = 25 | (b -> a -> mb) -> b -> ta -> mb 26 | 27 | 28 | foldlM : 29 | Foldr a ta (b -> mb) 30 | -> Monad.Return b mb 31 | -> Monad.Bind b mb mb 32 | -> FoldlM a ta b mb 33 | foldlM pFoldr pReturn pBind f z0 xs = 34 | pFoldr (\x k z -> pBind (f z x) k) pReturn xs z0 35 | 36 | 37 | type alias Foldr a ta b = 38 | (a -> b -> b) -> b -> ta -> b 39 | 40 | 41 | type alias Foldl a ta b = 42 | (b -> a -> b) -> b -> ta -> b 43 | 44 | 45 | type alias Elem a ta = 46 | a -> ta -> Bool 47 | 48 | 49 | type alias MapM_ a ta mb mu = 50 | (a -> mb) -> ta -> mu 51 | 52 | 53 | mapM_ : 54 | Foldr a ta mu 55 | -> Monad.Return () mu 56 | -> Monad.Bind b mb mu 57 | -> MapM_ a ta mb mu 58 | mapM_ pFoldr pReturn pBind f t = 59 | pFoldr (\x k -> pBind (f x) (\_ -> k)) (pReturn ()) t 60 | 61 | 62 | type alias NotElem a ta = 63 | a -> ta -> Bool 64 | 65 | 66 | type alias Null ta = 67 | ta -> Bool 68 | 69 | 70 | type alias Length ta = 71 | ta -> Int 72 | 73 | 74 | type alias Traverse_ a ta fb fu = 75 | (a -> fb) -> ta -> fu 76 | 77 | 78 | traverse_ : 79 | Applicative.Pure () fu 80 | -> Applicative.LiftA2 b fb () fu () fu 81 | -> Foldr a ta fu 82 | -> Traverse_ a ta fb fu 83 | traverse_ pPure pLiftA2 pFoldr f t = 84 | pFoldr (pLiftA2 (\_ () -> ()) << f) (pPure ()) t 85 | 86 | 87 | type alias Sequence_ tma mu = 88 | tma -> mu 89 | 90 | 91 | sequence_ : 92 | Foldr mb tma mu 93 | -> Monad.Return () mu 94 | -> Monad.Bind b mb mu 95 | -> Sequence_ tma mu 96 | sequence_ pFoldr pReturn pBind t = 97 | pFoldr (\m k -> pBind m (\_ -> k)) (pReturn ()) t 98 | 99 | 100 | type alias All a ta = 101 | (a -> Bool) -> ta -> Bool 102 | 103 | 104 | type alias Filter a ta = 105 | (a -> Bool) -> ta -> ta 106 | -------------------------------------------------------------------------------- /src/Extra/Class/Functor.elm: -------------------------------------------------------------------------------- 1 | module Extra.Class.Functor exposing (Fmap) 2 | 3 | 4 | type alias Fmap a fa b fb = 5 | -- <$> 6 | (a -> b) -> fa -> fb 7 | -------------------------------------------------------------------------------- /src/Extra/Class/Monad.elm: -------------------------------------------------------------------------------- 1 | module Extra.Class.Monad exposing 2 | ( AndThen 3 | , Bind 4 | , Return 5 | , andThen 6 | ) 7 | 8 | import Extra.Class.Applicative as Applicative 9 | 10 | 11 | type alias Return a ma = 12 | Applicative.Pure a ma 13 | 14 | 15 | type alias Bind a ma mb = 16 | ma -> (a -> mb) -> mb 17 | 18 | 19 | type alias AndThen a ma mb = 20 | -- <<= 21 | (a -> mb) -> ma -> mb 22 | 23 | 24 | andThen : 25 | Bind a ma mb 26 | -> AndThen a ma mb 27 | andThen pBind f ma = 28 | pBind ma f 29 | -------------------------------------------------------------------------------- /src/Extra/Class/Monoid.elm: -------------------------------------------------------------------------------- 1 | module Extra.Class.Monoid exposing 2 | ( Mappend 3 | ) 4 | 5 | 6 | type alias Mappend a = 7 | a -> a -> a 8 | -------------------------------------------------------------------------------- /src/Extra/Class/StateT.elm: -------------------------------------------------------------------------------- 1 | module Extra.Class.StateT exposing 2 | ( StateT 3 | , andMap 4 | , bind 5 | , evalStateT 6 | , fmap 7 | , gets 8 | , liftA2 9 | , modify 10 | , pure 11 | , return 12 | ) 13 | 14 | import Extra.Class.Applicative as Applicative 15 | import Extra.Class.Functor as Functor 16 | import Extra.Class.Monad as Monad 17 | 18 | 19 | type alias StateT s mas = 20 | s -> mas 21 | 22 | 23 | andMap : 24 | Functor.Fmap ( a, s ) mas ( b, s ) mbs 25 | -> Monad.Bind ( a -> b, s ) mfs mbs 26 | -> Applicative.AndMap (StateT s mas) (StateT s mfs) (StateT s mbs) 27 | andMap pFmap pBind sa sf s0 = 28 | pBind (sf s0) <| 29 | \( f, s1 ) -> 30 | pFmap (\( a, s2 ) -> ( f a, s2 )) (sa s1) 31 | 32 | 33 | bind : 34 | Monad.Bind ( a, s ) mas mbs 35 | -> Monad.Bind a (StateT s mas) (StateT s mbs) 36 | bind pBind sa callback s0 = 37 | pBind (sa s0) (\( a, s1 ) -> callback a s1) 38 | 39 | 40 | evalStateT : 41 | Functor.Fmap ( a, s ) mas a ma 42 | -> (StateT s mas -> s -> ma) 43 | evalStateT pFmap sa s = 44 | pFmap Tuple.first (sa s) 45 | 46 | 47 | fmap : 48 | Functor.Fmap ( a, s ) mas ( b, s ) mbs 49 | -> Functor.Fmap a (StateT s mas) b (StateT s mbs) 50 | fmap pFmap f sa s0 = 51 | pFmap (\( a, s1 ) -> ( f a, s1 )) (sa s0) 52 | 53 | 54 | gets : 55 | Monad.Return ( a, s ) mas 56 | -> ((s -> a) -> StateT s mas) 57 | gets pReturn f s = 58 | pReturn ( f s, s ) 59 | 60 | 61 | liftA2 : 62 | Functor.Fmap ( a, s ) mas ( b -> c, s ) mfs 63 | -> Functor.Fmap ( b, s ) mbs ( c, s ) mcs 64 | -> Monad.Bind ( b -> c, s ) mfs mcs 65 | -> Applicative.LiftA2 a (StateT s mas) b (StateT s mbs) c (StateT s mcs) 66 | liftA2 pFmap1 pFmap2 pBind = 67 | Applicative.liftA2 (fmap pFmap1) (andMap pFmap2 pBind) 68 | 69 | 70 | modify : 71 | Monad.Return ( (), s ) mus 72 | -> ((s -> s) -> StateT s mus) 73 | modify pReturn f s = 74 | pReturn ( (), f s ) 75 | 76 | 77 | pure : 78 | Monad.Return ( a, s ) mas 79 | -> Applicative.Pure a (StateT s mas) 80 | pure pReturn a s = 81 | pReturn ( a, s ) 82 | 83 | 84 | return : 85 | Monad.Return ( a, s ) mas 86 | -> Monad.Return a (StateT s mas) 87 | return = 88 | pure 89 | -------------------------------------------------------------------------------- /src/Extra/Class/Traversable.elm: -------------------------------------------------------------------------------- 1 | module Extra.Class.Traversable exposing 2 | ( SequenceA 3 | , Traverse 4 | , sequenceA 5 | ) 6 | 7 | 8 | type alias Traverse a ta fb ftb = 9 | (a -> fb) -> ta -> ftb 10 | 11 | 12 | type alias SequenceA tfa fta = 13 | tfa -> fta 14 | 15 | 16 | sequenceA : 17 | Traverse fa tfa fa fta 18 | -> SequenceA tfa fta 19 | sequenceA pTraverse = 20 | pTraverse identity 21 | -------------------------------------------------------------------------------- /src/Extra/Data/Binary/Put.elm: -------------------------------------------------------------------------------- 1 | module Extra.Data.Binary.Put exposing 2 | ( Put 3 | , join 4 | , mappend 5 | , mempty 6 | , put2 7 | , put3 8 | , put4 9 | , put5 10 | , put6 11 | , putSequence 12 | , putString 13 | , putWord16 14 | , putWord32 15 | , putWord8 16 | , runPut 17 | ) 18 | 19 | import Bytes 20 | import Bytes.Encode 21 | import Extra.Type.List as MList exposing (TList) 22 | 23 | 24 | type alias Put = 25 | Bytes.Encode.Encoder 26 | 27 | 28 | mempty : Put 29 | mempty = 30 | join [] 31 | 32 | 33 | mappend : Put -> Put -> Put 34 | mappend p1 p2 = 35 | join [ p1, p2 ] 36 | 37 | 38 | join : TList Put -> Put 39 | join = 40 | Bytes.Encode.sequence 41 | 42 | 43 | runPut : Put -> Bytes.Bytes 44 | runPut = 45 | Bytes.Encode.encode 46 | 47 | 48 | 49 | -- PRIMITIVES 50 | 51 | 52 | putWord8 : Int -> Put 53 | putWord8 = 54 | Bytes.Encode.unsignedInt8 55 | 56 | 57 | putWord16 : Int -> Put 58 | putWord16 word = 59 | Bytes.Encode.unsignedInt16 Bytes.BE word 60 | 61 | 62 | putWord32 : Int -> Put 63 | putWord32 word = 64 | Bytes.Encode.unsignedInt32 Bytes.BE word 65 | 66 | 67 | putString : String -> Put 68 | putString = 69 | Bytes.Encode.string 70 | 71 | 72 | 73 | -- COMBINATORS 74 | 75 | 76 | put2 : 77 | (a -> Put) 78 | -> (b -> Put) 79 | -> (a -> b -> Put) 80 | put2 fa fb a b = 81 | join [ fa a, fb b ] 82 | 83 | 84 | put3 : 85 | (a -> Put) 86 | -> (b -> Put) 87 | -> (c -> Put) 88 | -> (a -> b -> c -> Put) 89 | put3 fa fb fc a b c = 90 | join [ fa a, fb b, fc c ] 91 | 92 | 93 | put4 : 94 | (a -> Put) 95 | -> (b -> Put) 96 | -> (c -> Put) 97 | -> (d -> Put) 98 | -> (a -> b -> c -> d -> Put) 99 | put4 fa fb fc fd a b c d = 100 | join [ fa a, fb b, fc c, fd d ] 101 | 102 | 103 | put5 : 104 | (a -> Put) 105 | -> (b -> Put) 106 | -> (c -> Put) 107 | -> (d -> Put) 108 | -> (e -> Put) 109 | -> (a -> b -> c -> d -> e -> Put) 110 | put5 fa fb fc fd fe a b c d e = 111 | join [ fa a, fb b, fc c, fd d, fe e ] 112 | 113 | 114 | put6 : 115 | (a -> Put) 116 | -> (b -> Put) 117 | -> (c -> Put) 118 | -> (d -> Put) 119 | -> (e -> Put) 120 | -> (f -> Put) 121 | -> (a -> b -> c -> d -> e -> f -> Put) 122 | put6 fa fb fc fd fe ff a b c d e f = 123 | join [ fa a, fb b, fc c, fd d, fe e, ff f ] 124 | 125 | 126 | putSequence : (a -> Put) -> List a -> Put 127 | putSequence fa list = 128 | join (MList.map fa list) 129 | -------------------------------------------------------------------------------- /src/Extra/Data/Pretty.elm: -------------------------------------------------------------------------------- 1 | module Extra.Data.Pretty exposing 2 | ( Doc 3 | , Renderer 4 | , Styles 5 | , align 6 | , blackS 7 | , blue 8 | , cat 9 | , cyan 10 | , cyanS 11 | , dullcyan 12 | , dullred 13 | , dullyellow 14 | , dullyellowS 15 | , empty 16 | , fillSep 17 | , green 18 | , greenS 19 | , hang 20 | , hcat 21 | , hsep 22 | , indent 23 | , pretty 24 | , red 25 | , redS 26 | , renderPretty 27 | , sep 28 | , text 29 | , underline 30 | , vcat 31 | , yellow 32 | ) 33 | 34 | -- Substitute for Text.PrettyPrint.ANSI.Leijen 35 | 36 | import Extra.Type.List exposing (TList) 37 | import Pretty as P 38 | import Pretty.Renderer as PR 39 | 40 | 41 | type alias Styles t = 42 | { underline : t 43 | , red : t 44 | , green : t 45 | , cyan : t 46 | , blue : t 47 | , black : t 48 | , yellow : t 49 | , dullcyan : t 50 | , dullred : t 51 | , dullyellow : t 52 | } 53 | 54 | 55 | type alias Doc t = 56 | P.Doc (Styles t -> t) 57 | 58 | 59 | type alias Renderer t a b = 60 | PR.Renderer (Styles t -> t) a b 61 | 62 | 63 | align : P.Doc t -> P.Doc t 64 | align = 65 | P.align 66 | 67 | 68 | blackS : String -> Doc t 69 | blackS str = 70 | P.taggedString str .black 71 | 72 | 73 | blue : String -> Doc t 74 | blue str = 75 | P.taggedString str .blue 76 | 77 | 78 | cat : TList (Doc t) -> Doc t 79 | cat = 80 | P.group << vcat 81 | 82 | 83 | cyan : Doc t -> Doc t 84 | cyan = 85 | P.setTag .cyan 86 | 87 | 88 | cyanS : String -> Doc t 89 | cyanS str = 90 | P.taggedString str .cyan 91 | 92 | 93 | dullcyan : Doc t -> Doc t 94 | dullcyan = 95 | P.setTag .dullcyan 96 | 97 | 98 | dullred : Doc t -> Doc t 99 | dullred = 100 | P.setTag .dullred 101 | 102 | 103 | dullyellow : Doc t -> Doc t 104 | dullyellow = 105 | P.setTag .dullyellow 106 | 107 | 108 | dullyellowS : String -> Doc t 109 | dullyellowS str = 110 | P.taggedString str .dullyellow 111 | 112 | 113 | empty : Doc t 114 | empty = 115 | P.empty 116 | 117 | 118 | fillSep : TList (Doc t) -> Doc t 119 | fillSep = 120 | P.softlines 121 | 122 | 123 | green : Doc t -> Doc t 124 | green = 125 | P.setTag .green 126 | 127 | 128 | greenS : String -> Doc t 129 | greenS str = 130 | P.taggedString str .green 131 | 132 | 133 | hang : Int -> P.Doc t -> P.Doc t 134 | hang = 135 | P.hang 136 | 137 | 138 | hcat : TList (Doc t) -> Doc t 139 | hcat docs = 140 | case docs of 141 | [] -> 142 | empty 143 | 144 | [ doc ] -> 145 | doc 146 | 147 | doc :: docs_ -> 148 | P.append doc (hcat docs_) 149 | 150 | 151 | 152 | -- join <+> --> P.words 153 | 154 | 155 | hsep : TList (Doc t) -> Doc t 156 | hsep = 157 | P.words 158 | 159 | 160 | indent : Int -> Doc t -> Doc t 161 | indent n doc = 162 | P.indent n doc 163 | 164 | 165 | red : Doc t -> Doc t 166 | red = 167 | P.setTag .red 168 | 169 | 170 | redS : String -> Doc t 171 | redS str = 172 | P.taggedString str .red 173 | 174 | 175 | sep : TList (P.Doc t) -> P.Doc t 176 | sep = 177 | P.group << vsep 178 | 179 | 180 | text : String -> P.Doc t 181 | text = 182 | P.string 183 | 184 | 185 | underline : String -> Doc t 186 | underline str = 187 | P.taggedString str .underline 188 | 189 | 190 | 191 | -- <$> line --> P.line 192 | -- <$$> linebreak --> P.tightline 193 | -- 194 | -- vsep = fold (<$>) --> P.lines 195 | -- vcat = fold (<$$>) 196 | 197 | 198 | vcat : TList (Doc t) -> Doc t 199 | vcat = 200 | P.join P.tightline 201 | 202 | 203 | vsep : TList (P.Doc t) -> P.Doc t 204 | vsep = 205 | P.lines 206 | 207 | 208 | yellow : Doc t -> Doc t 209 | yellow = 210 | P.setTag .yellow 211 | 212 | 213 | 214 | -- RENDERING 215 | 216 | 217 | pretty : Int -> Doc t -> String 218 | pretty n doc = 219 | P.pretty n doc 220 | 221 | 222 | renderPretty : Int -> PR.Renderer (Styles t -> t) a b -> Doc t -> b 223 | renderPretty = 224 | PR.pretty 225 | -------------------------------------------------------------------------------- /src/Extra/System/Exception.elm: -------------------------------------------------------------------------------- 1 | module Extra.System.Exception exposing (handle) 2 | 3 | import Extra.System.IO as IO exposing (IO) 4 | import Extra.Type.Either exposing (Either(..)) 5 | 6 | 7 | handle : (e1 -> IO s (Either e2 a)) -> IO s (Either e1 (Either e2 a)) -> IO s (Either e2 a) 8 | handle onError ia = 9 | IO.bind ia <| 10 | \result -> 11 | case result of 12 | Right a -> 13 | IO.return a 14 | 15 | Left e1 -> 16 | onError e1 17 | 18 | 19 | 20 | -- TODO: implement a replacement for Debug.todo 21 | -- 22 | --error : String -> a 23 | --error msg = 24 | -- if JE.object [ ( "keyatouterlevel", JE.object [ ( msg, JE.null ) ] ) ] == JE.object [] then 25 | -- error "yes" 26 | -- 27 | -- else 28 | -- error "no" 29 | -------------------------------------------------------------------------------- /src/Extra/System/File/Remote.elm: -------------------------------------------------------------------------------- 1 | module Extra.System.File.Remote exposing (getTree) 2 | 3 | import Bytes exposing (Bytes) 4 | import Extra.System.File.Util as Util 5 | import Extra.System.IO as IO exposing (IO) 6 | import Extra.Type.Either exposing (Either(..)) 7 | 8 | 9 | getTree : Maybe String -> String -> IO.IO s (Util.Tree s) 10 | getTree prefix remotePath = 11 | Util.requestString prefix remotePath <| 12 | \response -> 13 | case response of 14 | Right body -> 15 | processBody prefix remotePath body 16 | 17 | Left _ -> 18 | Util.getTreeError 19 | 20 | 21 | processBody : Maybe String -> String -> String -> IO s (Util.Tree s) 22 | processBody prefix remotePath body = 23 | Util.getTree (fileStep prefix) beforeDirStep afterDirStep remotePath body 24 | 25 | 26 | type alias Acc = 27 | String 28 | 29 | 30 | fileStep : Maybe String -> Util.FileStep s Acc 31 | fileStep prefix name _ dirPath = 32 | ( dirPath, getFile prefix (dirPath ++ "/" ++ name) ) 33 | 34 | 35 | beforeDirStep : Util.BeforeDirStep Acc 36 | beforeDirStep name dirPath = 37 | dirPath ++ "/" ++ name 38 | 39 | 40 | afterDirStep : Util.AfterDirStep Acc 41 | afterDirStep _ beforeFilePath _ = 42 | beforeFilePath 43 | 44 | 45 | getFile : Maybe String -> String -> IO s (Maybe Bytes) 46 | getFile prefix filePath = 47 | Util.requestBytes prefix filePath <| 48 | \response -> 49 | case response of 50 | Right body -> 51 | IO.return (Just body) 52 | 53 | Left _ -> 54 | IO.return Nothing 55 | -------------------------------------------------------------------------------- /src/Extra/System/File/Static.elm: -------------------------------------------------------------------------------- 1 | module Extra.System.File.Static exposing (getTree) 2 | 3 | import Bytes exposing (Bytes) 4 | import Bytes.Decode 5 | import Extra.System.File.Util as Util 6 | import Extra.System.IO as IO exposing (IO) 7 | import Extra.Type.Either exposing (Either(..)) 8 | 9 | 10 | getTree : Maybe String -> String -> IO s (Util.Tree s) 11 | getTree prefix remotePath = 12 | Util.requestBytes prefix remotePath <| 13 | \response -> 14 | case response of 15 | Right body -> 16 | processBodyBytes body 17 | 18 | Left _ -> 19 | Util.getTreeError 20 | 21 | 22 | processBodyBytes : Bytes -> IO s (Util.Tree s) 23 | processBodyBytes body = 24 | case Bytes.Decode.decode treeBytesDecoder body of 25 | Just ( contentOffset, tree ) -> 26 | Util.getTree fileStep beforeDirStep afterDirStep ( contentOffset, body ) tree 27 | 28 | Nothing -> 29 | Util.getTreeError 30 | 31 | 32 | treeBytesDecoder : Bytes.Decode.Decoder ( Int, String ) 33 | treeBytesDecoder = 34 | Bytes.Decode.andThen 35 | (\treeLength -> 36 | Bytes.Decode.map 37 | (\tree -> ( 4 + treeLength, tree )) 38 | (Bytes.Decode.string treeLength) 39 | ) 40 | (Bytes.Decode.unsignedInt32 Bytes.BE) 41 | 42 | 43 | type alias Acc = 44 | ( Int, Bytes ) 45 | 46 | 47 | fileStep : Util.FileStep s Acc 48 | fileStep _ size ( offset, bytes ) = 49 | ( ( offset + size, bytes ), IO.return (Util.sliceBytes offset size bytes) ) 50 | 51 | 52 | beforeDirStep : Util.BeforeDirStep Acc 53 | beforeDirStep _ acc = 54 | acc 55 | 56 | 57 | afterDirStep : Util.AfterDirStep Acc 58 | afterDirStep _ _ afterAcc = 59 | afterAcc 60 | -------------------------------------------------------------------------------- /src/Extra/System/Http.elm: -------------------------------------------------------------------------------- 1 | module Extra.System.Http exposing 2 | ( Exception 3 | , Header 4 | , Manager 5 | , Method 6 | , Request 7 | , methodGet 8 | , methodPost 9 | , newManager 10 | , parseUrlThrow 11 | , urlEncodeVars 12 | , userAgent 13 | , withBytesResponse 14 | , withStringResponse 15 | ) 16 | 17 | import Bytes exposing (Bytes) 18 | import Extra.System.IO as IO exposing (IO) 19 | import Extra.Type.Either exposing (Either(..)) 20 | import Extra.Type.List as MList exposing (TList) 21 | import Extra.Type.Map as Map 22 | import Http 23 | 24 | 25 | 26 | -- MANAGER 27 | 28 | 29 | type Manager 30 | = Manager (Maybe String) 31 | 32 | 33 | newManager : Maybe String -> IO s Manager 34 | newManager maybePrefix = 35 | IO.return (Manager maybePrefix) 36 | 37 | 38 | managedUrl : Manager -> String -> Maybe String 39 | managedUrl (Manager maybePrefix) url = 40 | Maybe.map (\prefix -> prefix ++ url) maybePrefix 41 | 42 | 43 | 44 | -- HEADERS 45 | 46 | 47 | type alias Header = 48 | Http.Header 49 | 50 | 51 | userAgent : String -> Header 52 | userAgent agent = 53 | Http.header "User-Agent" agent 54 | 55 | 56 | 57 | -- REQUEST 58 | 59 | 60 | type alias Method = 61 | String 62 | 63 | 64 | methodGet : Method 65 | methodGet = 66 | "GET" 67 | 68 | 69 | methodPost : Method 70 | methodPost = 71 | "POST" 72 | 73 | 74 | type alias Request = 75 | { method : Method 76 | , headers : TList Header 77 | , url : String 78 | , body : Http.Body 79 | } 80 | 81 | 82 | parseUrlThrow : String -> IO s Request 83 | parseUrlThrow url = 84 | IO.return 85 | { method = methodGet 86 | , headers = [] 87 | , url = url 88 | , body = Http.emptyBody 89 | } 90 | 91 | 92 | 93 | -- RESPONSE 94 | 95 | 96 | type alias Exception = 97 | Http.Error 98 | 99 | 100 | 101 | -- IO 102 | 103 | 104 | withStringResponse : Request -> Manager -> (Either Exception String -> IO s a) -> IO s a 105 | withStringResponse request manager handler = 106 | withExpect stringExpect request manager handler 107 | 108 | 109 | withBytesResponse : Request -> Manager -> (Either Exception Bytes -> IO s a) -> IO s a 110 | withBytesResponse request manager handler = 111 | withExpect bytesExpect request manager handler 112 | 113 | 114 | withExpect : ((Either Exception a -> IO s b) -> Http.Expect (IO s b)) -> Request -> Manager -> (Either Exception a -> IO s b) -> IO s b 115 | withExpect expectFun request manager handler = 116 | case managedUrl manager request.url of 117 | Just url -> 118 | Http.request 119 | { method = request.method 120 | , headers = request.headers 121 | , url = url 122 | , body = request.body 123 | , expect = expectFun handler 124 | , timeout = Nothing 125 | , tracker = Nothing 126 | } 127 | |> IO.liftCmdIO 128 | 129 | Nothing -> 130 | handler (Left Http.NetworkError) 131 | 132 | 133 | stringExpect : (Either Exception String -> IO s a) -> Http.Expect (IO s a) 134 | stringExpect handler = 135 | Http.expectString (mapHandler handler) 136 | 137 | 138 | bytesExpect : (Either Exception Bytes -> IO s a) -> Http.Expect (IO s a) 139 | bytesExpect handler = 140 | Http.expectBytesResponse (mapHandler handler) toResult 141 | 142 | 143 | mapHandler : (Either Exception a -> IO s b) -> Result Http.Error a -> IO s b 144 | mapHandler handler result = 145 | handler <| 146 | case result of 147 | Ok a -> 148 | Right a 149 | 150 | Err error -> 151 | Left error 152 | 153 | 154 | toResult : Http.Response Bytes -> Result Http.Error Bytes 155 | toResult response = 156 | case response of 157 | Http.BadUrl_ url -> 158 | Err (Http.BadUrl url) 159 | 160 | Http.Timeout_ -> 161 | Err Http.Timeout 162 | 163 | Http.NetworkError_ -> 164 | Err Http.NetworkError 165 | 166 | Http.BadStatus_ metadata _ -> 167 | Err (Http.BadStatus metadata.statusCode) 168 | 169 | Http.GoodStatus_ _ body -> 170 | Ok body 171 | 172 | 173 | 174 | -- URL ENCODING 175 | 176 | 177 | urlEncode : String -> String 178 | urlEncode string = 179 | string |> String.toList |> MList.map urlEncodeChar |> String.join "" 180 | 181 | 182 | urlEncodeVars : TList ( String, String ) -> String 183 | urlEncodeVars vars = 184 | MList.map (\( key, value ) -> urlEncode key ++ "=" ++ urlEncode value) vars 185 | |> String.join "&" 186 | 187 | 188 | urlEncodeChar : Char -> String 189 | urlEncodeChar char = 190 | case Map.lookup char specialChars of 191 | Just replacement -> 192 | replacement 193 | 194 | Nothing -> 195 | String.fromChar char 196 | 197 | 198 | specialChars : Map.Map Char String 199 | specialChars = 200 | Map.fromList 201 | [ ( ' ', "%20" ) 202 | , ( '!', "%21" ) 203 | , ( '#', "%23" ) 204 | , ( '$', "%24" ) 205 | , ( '%', "%25" ) 206 | , ( '&', "%26" ) 207 | , ( '\'', "%27" ) 208 | , ( '(', "%28" ) 209 | , ( ')', "%29" ) 210 | , ( '*', "%2A" ) 211 | , ( '+', "%2B" ) 212 | , ( ',', "%2C" ) 213 | , ( '/', "%2F" ) 214 | , ( ':', "%3A" ) 215 | , ( ';', "%3B" ) 216 | , ( '=', "%3D" ) 217 | , ( '?', "%3F" ) 218 | , ( '@', "%40" ) 219 | , ( '[', "%5B" ) 220 | , ( ']', "%5D" ) 221 | ] 222 | -------------------------------------------------------------------------------- /src/Extra/System/IO.elm: -------------------------------------------------------------------------------- 1 | module Extra.System.IO exposing 2 | ( Cont 3 | , IO 4 | , ION(..) 5 | , andThen 6 | , bind 7 | , bindSequence 8 | , fmap 9 | , get 10 | , getLens 11 | , join 12 | , liftA2 13 | , liftCmd 14 | , liftCmdIO 15 | , liftCont 16 | , log 17 | , modify 18 | , modifyLens 19 | , noOp 20 | , now 21 | , pure 22 | , put 23 | , putLens 24 | , return 25 | , rmap 26 | , sequence 27 | , sleep 28 | , when 29 | ) 30 | 31 | -- impure IO implemented as the State monad with an explicit state type and impure TEA commands 32 | 33 | import Extra.Class.Applicative as Applicative 34 | import Extra.Class.Functor as Functor 35 | import Extra.Class.Monad as Monad 36 | import Extra.Type.Lens as Lens exposing (Lens) 37 | import Extra.Type.List as MList exposing (TList) 38 | import Process 39 | import Task 40 | import Time 41 | 42 | 43 | 44 | -- TYPES 45 | 46 | 47 | type alias IO s a = 48 | -- FreeT (Sum Cmd (ContT () (IO s))) (State s) a 49 | s -> ( ION s a, s ) 50 | 51 | 52 | type ION s a 53 | = Pure a 54 | | ImpureCmd (Cmd (IO s a)) 55 | | ImpureCont (Cont s (IO s a)) 56 | 57 | 58 | 59 | -- MISC 60 | 61 | 62 | bindSequence : TList (IO s ()) -> IO s a -> IO s a 63 | bindSequence ms ma = 64 | bind (sequence ms) (\_ -> ma) 65 | 66 | 67 | sequence : TList (IO s ()) -> IO s () 68 | sequence ms = 69 | MList.foldr (\m acc -> bind m (\() -> acc)) noOp ms 70 | 71 | 72 | sleep : Float -> IO s () 73 | sleep time = 74 | liftTask (Process.sleep time) 75 | 76 | 77 | now : IO s Time.Posix 78 | now = 79 | liftTask Time.now 80 | 81 | 82 | log : String -> a -> IO s () 83 | log msg a s = 84 | ( (\_ -> Pure ()) (Debug.log msg a), s ) 85 | 86 | 87 | noOp : IO s () 88 | noOp = 89 | return () 90 | 91 | 92 | 93 | -- LIFT 94 | 95 | 96 | liftCmd : Cmd a -> IO s a 97 | liftCmd cmd = 98 | liftCmdIO (Cmd.map return cmd) 99 | 100 | 101 | liftCmdIO : Cmd (IO s a) -> IO s a 102 | liftCmdIO cmd s = 103 | ( ImpureCmd cmd, s ) 104 | 105 | 106 | liftCont : Cont s a -> IO s a 107 | liftCont cont = 108 | liftContIO (contFmap return cont) 109 | 110 | 111 | liftContIO : Cont s (IO s a) -> IO s a 112 | liftContIO cont s = 113 | ( ImpureCont cont, s ) 114 | 115 | 116 | liftTask : Task.Task Never a -> IO s a 117 | liftTask task = 118 | liftCmdIO (Task.perform return task) 119 | 120 | 121 | 122 | -- STATE OPERATIONS 123 | 124 | 125 | get : IO s s 126 | get s = 127 | ( Pure s, s ) 128 | 129 | 130 | getLens : Lens s2 s1 -> IO s2 s1 131 | getLens lens = 132 | rmap get lens.getter 133 | 134 | 135 | modify : (s -> s) -> IO s () 136 | modify f s = 137 | ( Pure (), f s ) 138 | 139 | 140 | modifyLens : Lens s2 s1 -> (s1 -> s1) -> IO s2 () 141 | modifyLens lens f = 142 | modify (Lens.modify lens f) 143 | 144 | 145 | put : s -> IO s () 146 | put s _ = 147 | ( Pure (), s ) 148 | 149 | 150 | putLens : Lens s2 s1 -> s1 -> IO s2 () 151 | putLens lens s1 = 152 | modify (lens.setter s1) 153 | 154 | 155 | 156 | -- TYPE CLASS INSTANCES 157 | 158 | 159 | andThen : Monad.AndThen a (IO s a) (IO s b) 160 | andThen f ma = 161 | bind ma f 162 | 163 | 164 | bind : Monad.Bind a (IO s a) (IO s b) 165 | bind ma f s0 = 166 | case ma s0 of 167 | ( Pure a, s1 ) -> 168 | f a s1 169 | 170 | ( ImpureCmd cmd, s1 ) -> 171 | ( ImpureCmd (Cmd.map (\ima -> bind ima f) cmd), s1 ) 172 | 173 | ( ImpureCont cont, s1 ) -> 174 | ( ImpureCont (contFmap (\ima -> bind ima f) cont), s1 ) 175 | 176 | 177 | fmap : Functor.Fmap a (IO s a) b (IO s b) 178 | fmap f ma = 179 | bind ma (\a -> return (f a)) 180 | 181 | 182 | join : IO s (IO s a) -> IO s a 183 | join mma = 184 | bind mma identity 185 | 186 | 187 | liftA2 : Applicative.LiftA2 a (IO s a) b (IO s b) c (IO s c) 188 | liftA2 f ma mb = 189 | bind ma (\a -> bind mb (\b -> return (f a b))) 190 | 191 | 192 | pure : Applicative.Pure a (IO s a) 193 | pure = 194 | return 195 | 196 | 197 | return : Monad.Return a (IO s a) 198 | return a s = 199 | ( Pure a, s ) 200 | 201 | 202 | rmap : IO s a -> (a -> b) -> IO s b 203 | rmap ma f = 204 | fmap f ma 205 | 206 | 207 | when : Applicative.When (IO s ()) 208 | when c f = 209 | Applicative.when return c f 210 | 211 | 212 | 213 | -- 214 | 215 | 216 | type alias Cont s a = 217 | -- ContT () (IO s) a 218 | (a -> IO s ()) -> IO s () 219 | 220 | 221 | contFmap : Functor.Fmap a (Cont s a) b (Cont s b) 222 | contFmap f ca ret = 223 | ca (\a -> ret (f a)) 224 | -------------------------------------------------------------------------------- /src/Extra/System/IORef.elm: -------------------------------------------------------------------------------- 1 | module Extra.System.IORef exposing 2 | ( IO 3 | , IORef 4 | , State 5 | , init 6 | , modify 7 | , new 8 | , read 9 | , write 10 | ) 11 | 12 | import Extra.System.IO.Pure as IO 13 | import Extra.Type.Map as Map exposing (Map) 14 | 15 | 16 | type IORef a 17 | = -- index into the state map 18 | IORef Int 19 | 20 | 21 | type alias IO s a = 22 | IO.IO (State s) a 23 | 24 | 25 | type alias State a = 26 | -- next index, map of indexes to values 27 | ( Int, Map Int a ) 28 | 29 | 30 | init : State a 31 | init = 32 | ( 0, Map.empty ) 33 | 34 | 35 | new : a -> IO a (IORef a) 36 | new a ( nextId, map ) = 37 | ( IORef nextId, ( nextId + 1, Map.insert nextId a map ) ) 38 | 39 | 40 | read : IORef a -> IO a a 41 | read (IORef id) (( _, map ) as state) = 42 | case Map.lookup id map of 43 | Just a -> 44 | ( a, state ) 45 | 46 | Nothing -> 47 | Debug.todo "IORef.read: id not found" 48 | 49 | 50 | write : IORef a -> a -> IO a () 51 | write (IORef id) a ( nextId, map ) = 52 | ( (), ( nextId, Map.insert id a map ) ) 53 | 54 | 55 | modify : IORef a -> (a -> a) -> IO a () 56 | modify ref f state = 57 | let 58 | ( a, state_ ) = 59 | read ref state 60 | in 61 | write ref (f a) state_ 62 | -------------------------------------------------------------------------------- /src/Extra/System/MVar.elm: -------------------------------------------------------------------------------- 1 | module Extra.System.MVar exposing 2 | ( Lens 3 | , MVar 4 | , State 5 | , initialState 6 | , new 7 | , newEmpty 8 | , newWaiting 9 | , read 10 | , wait 11 | , write 12 | ) 13 | 14 | import Extra.System.IO as IO 15 | import Extra.Type.Lens as Lens 16 | import Extra.Type.Map as Map 17 | 18 | 19 | 20 | -- TYPES 21 | 22 | 23 | type alias Lens gs a = 24 | Lens.Lens gs (State gs a) 25 | 26 | 27 | type MVar a 28 | = -- index into the state map 29 | MVar Int 30 | 31 | 32 | type alias State gs v = 33 | -- next index, map of indexes to values 34 | ( Int, Map.Map Int (Entry gs v), String ) 35 | 36 | 37 | type Entry gs a 38 | = Waiting (() -> IO.IO gs a) 39 | | Done a 40 | 41 | 42 | initialState : String -> State gs a 43 | initialState name = 44 | ( 0, Map.empty, name ) 45 | 46 | 47 | 48 | -- INTERFACE 49 | 50 | 51 | newEmpty : Lens gs a -> IO.IO gs (MVar a) 52 | newEmpty { getter, setter } = 53 | IO.bind IO.get <| 54 | \gs -> 55 | let 56 | ( mvar, state ) = 57 | newEmptyMVar (getter gs) 58 | in 59 | IO.put (setter state gs) 60 | |> IO.fmap (\() -> mvar) 61 | 62 | 63 | newWaiting : Lens gs a -> (() -> IO.IO gs a) -> IO.IO gs (MVar a) 64 | newWaiting lens f = 65 | IO.bind (newEmpty lens) <| 66 | \mvar -> 67 | wait lens mvar f 68 | |> IO.fmap (\() -> mvar) 69 | 70 | 71 | new : Lens gs a -> a -> IO.IO gs (MVar a) 72 | new lens a = 73 | IO.bind (newEmpty lens) <| 74 | \mvar -> 75 | write lens mvar a 76 | |> IO.fmap (\() -> mvar) 77 | 78 | 79 | read : Lens gs a -> MVar a -> IO.IO gs a 80 | read ({ getter } as lens) mvar = 81 | IO.bind IO.get <| 82 | \gs0 -> 83 | case getEntry mvar (getter gs0) of 84 | Waiting f -> 85 | IO.bind (f ()) <| 86 | \a -> 87 | write lens mvar a 88 | |> IO.fmap (\() -> a) 89 | 90 | Done a -> 91 | IO.return a 92 | 93 | 94 | wait : Lens gs a -> MVar a -> (() -> IO.IO gs a) -> IO.IO gs () 95 | wait lens mvar f = 96 | modify lens <| setEntry mvar (Waiting f) 97 | 98 | 99 | write : Lens gs a -> MVar a -> a -> IO.IO gs () 100 | write lens mvar a = 101 | modify lens <| setEntry mvar (Done a) 102 | 103 | 104 | 105 | -- PRIMITIVES 106 | 107 | 108 | modify : Lens gs a -> (State gs a -> State gs a) -> IO.IO gs () 109 | modify { getter, setter } f = 110 | IO.modify (\gs -> setter (f (getter gs)) gs) 111 | 112 | 113 | getEntry : MVar a -> State gs a -> Entry gs a 114 | getEntry (MVar id) ( _, map, _ ) = 115 | Map.ex map id 116 | 117 | 118 | setEntry : MVar a -> Entry gs a -> State gs a -> State gs a 119 | setEntry (MVar id) entry ( nextId, map, name ) = 120 | ( nextId, Map.insert id entry map, name ) 121 | 122 | 123 | newEmptyMVar : State gs a -> ( MVar a, State gs a ) 124 | newEmptyMVar ( nextId, map, name ) = 125 | ( MVar nextId, ( nextId + 1, map, name ) ) 126 | -------------------------------------------------------------------------------- /src/Extra/System/MVector.elm: -------------------------------------------------------------------------------- 1 | module Extra.System.MVector exposing 2 | ( IO 3 | , MVector 4 | , State 5 | , grow 6 | , init 7 | , length 8 | , modify 9 | , read 10 | , replicate 11 | , unsafeFreeze 12 | , write 13 | ) 14 | 15 | import Extra.System.IO.Pure as IO 16 | import Extra.System.IORef as IORef exposing (IORef) 17 | import Extra.Type.List exposing (TList) 18 | import Extra.Type.Map as Map exposing (Map) 19 | 20 | 21 | type MVector a 22 | = -- id in the state map and length 23 | MVector Int Int 24 | 25 | 26 | type alias IO s a = 27 | IO.IO (State s) a 28 | 29 | 30 | type alias State a = 31 | -- next id, map of ids to vectors, IORef state 32 | ( Int, Map Int (Map Int (IORef a)), IORef.State a ) 33 | 34 | 35 | init : State a 36 | init = 37 | ( 0, Map.empty, IORef.init ) 38 | 39 | 40 | grow : MVector a -> Int -> IO a (MVector a) 41 | grow ((MVector id len) as mv) n (( nextId, map, refState ) as state) = 42 | case Map.lookup id map of 43 | Just vec -> 44 | ( MVector nextId (len + n) 45 | , let 46 | ( copy, nextRefState ) = 47 | IO.traverseMap (\r -> IO.bind (IORef.read r) IORef.new) vec refState 48 | in 49 | ( nextId + 1 50 | , Map.insert nextId copy map 51 | , nextRefState 52 | ) 53 | ) 54 | 55 | Nothing -> 56 | ( mv, state ) 57 | 58 | 59 | length : MVector a -> Int 60 | length (MVector _ len) = 61 | len 62 | 63 | 64 | modify : MVector a -> (a -> a) -> Int -> IO a () 65 | modify (MVector id _) f i (( nextId, map, refState ) as state) = 66 | case getRef id i map of 67 | Just ref -> 68 | liftResult nextId map <| IORef.modify ref f refState 69 | 70 | Nothing -> 71 | ( (), state ) 72 | 73 | 74 | read : MVector a -> Int -> IO a a 75 | read (MVector id _) i ( nextId, map, refState ) = 76 | case getRef id i map of 77 | Just ref -> 78 | liftResult nextId map <| IORef.read ref refState 79 | 80 | Nothing -> 81 | Debug.todo "MVector.read: id not found" 82 | 83 | 84 | replicate : Int -> a -> IO a (MVector a) 85 | replicate n a ( nextId, map, refState ) = 86 | let 87 | go : Int -> IORef.IO a (Map Int (IORef a)) -> IORef.IO a (Map Int (IORef a)) 88 | go i vecIO = 89 | if i < n then 90 | go (i + 1) (IO.liftA2 (Map.insert i) (IORef.new a) vecIO) 91 | 92 | else 93 | vecIO 94 | 95 | ( vec, nextRefState ) = 96 | go 0 (IO.pure Map.empty) refState 97 | in 98 | ( MVector nextId n 99 | , ( nextId + 1 100 | , Map.insert nextId vec map 101 | , nextRefState 102 | ) 103 | ) 104 | 105 | 106 | unsafeFreeze : MVector a -> IO a (TList a) 107 | unsafeFreeze (MVector id _) (( nextId, map, refState ) as state) = 108 | case Map.lookup id map of 109 | Just vec -> 110 | liftResult nextId map <| IO.traverseList IORef.read (Map.elems vec) refState 111 | 112 | Nothing -> 113 | ( [], state ) 114 | 115 | 116 | write : MVector a -> Int -> a -> IO a () 117 | write (MVector id _) i a (( nextId, map, refState ) as state) = 118 | case getRef id i map of 119 | Just ref -> 120 | liftResult nextId map <| IORef.write ref a refState 121 | 122 | Nothing -> 123 | ( (), state ) 124 | 125 | 126 | getRef : Int -> Int -> Map Int (Map Int (IORef a)) -> Maybe (IORef a) 127 | getRef id i map = 128 | Map.lookup id map |> Maybe.andThen (\vec -> Map.lookup i vec) 129 | 130 | 131 | liftResult : Int -> Map Int (Map Int (IORef s)) -> ( a, IORef.State s ) -> ( a, State s ) 132 | liftResult nextId map ( a, refState ) = 133 | ( a, ( nextId, map, refState ) ) 134 | -------------------------------------------------------------------------------- /src/Extra/Type/Either.elm: -------------------------------------------------------------------------------- 1 | module Extra.Type.Either exposing 2 | ( Either(..) 3 | , andThen 4 | , bind 5 | , fmap 6 | , lefts 7 | , liftA2 8 | , pure 9 | ) 10 | 11 | import Extra.Class.Applicative as Applicative 12 | import Extra.Class.Functor as Functor 13 | import Extra.Class.Monad as Monad 14 | import Extra.Type.List as MList exposing (TList) 15 | 16 | 17 | type Either a b 18 | = Left a 19 | | Right b 20 | 21 | 22 | andThen : Monad.AndThen a (Either x a) (Either x b) 23 | andThen callback ea = 24 | bind ea callback 25 | 26 | 27 | bind : Monad.Bind a (Either x a) (Either x b) 28 | bind ea callback = 29 | case ea of 30 | Left x -> 31 | Left x 32 | 33 | Right a -> 34 | callback a 35 | 36 | 37 | fmap : Functor.Fmap a (Either x a) b (Either x b) 38 | fmap f ea = 39 | case ea of 40 | Left x -> 41 | Left x 42 | 43 | Right a -> 44 | Right (f a) 45 | 46 | 47 | lefts : TList (Either a b) -> TList a 48 | lefts eithers = 49 | MList.foldr 50 | (\either acc -> 51 | case either of 52 | Left x -> 53 | x :: acc 54 | 55 | Right _ -> 56 | acc 57 | ) 58 | [] 59 | eithers 60 | 61 | 62 | liftA2 : Applicative.LiftA2 a (Either x a) b (Either x b) c (Either x c) 63 | liftA2 f ea eb = 64 | case ea of 65 | Left x -> 66 | Left x 67 | 68 | Right a -> 69 | case eb of 70 | Left x -> 71 | Left x 72 | 73 | Right b -> 74 | Right (f a b) 75 | 76 | 77 | pure : Applicative.Pure a (Either x a) 78 | pure = 79 | Right 80 | -------------------------------------------------------------------------------- /src/Extra/Type/Lens.elm: -------------------------------------------------------------------------------- 1 | module Extra.Type.Lens exposing 2 | ( Lens 3 | , modify 4 | ) 5 | 6 | 7 | type alias Lens whole part = 8 | { getter : whole -> part 9 | , setter : part -> whole -> whole 10 | } 11 | 12 | 13 | modify : Lens a b -> (b -> b) -> a -> a 14 | modify lens f a = 15 | lens.setter (f (lens.getter a)) a 16 | -------------------------------------------------------------------------------- /src/Extra/Type/Maybe.elm: -------------------------------------------------------------------------------- 1 | module Extra.Type.Maybe exposing 2 | ( bind 3 | , catMaybes 4 | , isJust 5 | , mapMaybe 6 | , maybe 7 | , maybeToList 8 | , sequenceA 9 | , traverse 10 | ) 11 | 12 | import Extra.Class.Applicative as Applicative 13 | import Extra.Class.Functor as Functor 14 | import Extra.Class.Traversable as Traversable 15 | import Extra.Type.List exposing (TList) 16 | 17 | 18 | bind : Maybe a -> (a -> Maybe b) -> Maybe b 19 | bind ma f = 20 | Maybe.andThen f ma 21 | 22 | 23 | catMaybes : TList (Maybe a) -> TList a 24 | catMaybes = 25 | mapMaybe identity 26 | 27 | 28 | isJust : Maybe a -> Bool 29 | isJust l = 30 | l /= Nothing 31 | 32 | 33 | mapMaybe : (a -> Maybe b) -> TList a -> TList b 34 | mapMaybe f l = 35 | case l of 36 | [] -> 37 | [] 38 | 39 | x :: xs -> 40 | let 41 | rs = 42 | mapMaybe f xs 43 | in 44 | case f x of 45 | Nothing -> 46 | rs 47 | 48 | Just r -> 49 | r :: rs 50 | 51 | 52 | maybe : b -> (a -> b) -> Maybe a -> b 53 | maybe b f ma = 54 | case ma of 55 | Just a -> 56 | f a 57 | 58 | Nothing -> 59 | b 60 | 61 | 62 | maybeToList : Maybe a -> TList a 63 | maybeToList l = 64 | case l of 65 | Nothing -> 66 | [] 67 | 68 | Just x -> 69 | [ x ] 70 | 71 | 72 | sequenceA : 73 | Applicative.Pure (Maybe a) fma 74 | -> Functor.Fmap a fa (Maybe a) fma 75 | -> Traversable.SequenceA (Maybe fa) fma 76 | sequenceA pPure pFmap mfa = 77 | Traversable.sequenceA (traverse pPure pFmap) mfa 78 | 79 | 80 | traverse : 81 | Applicative.Pure (Maybe b) fmb 82 | -> Functor.Fmap b fb (Maybe b) fmb 83 | -> Traversable.Traverse a (Maybe a) fb fmb 84 | traverse pPure pFmap f ma = 85 | case ma of 86 | Just a -> 87 | pFmap Just (f a) 88 | 89 | Nothing -> 90 | pPure Nothing 91 | -------------------------------------------------------------------------------- /src/Extra/Type/Set.elm: -------------------------------------------------------------------------------- 1 | module Extra.Type.Set exposing 2 | ( Set 3 | , difference 4 | , empty 5 | , foldl 6 | , foldr 7 | , fromList 8 | , insert 9 | , member 10 | , null 11 | , toList 12 | , union 13 | , unions 14 | ) 15 | 16 | import Extra.Class.Foldable as Foldable 17 | import Extra.Type.List as MList exposing (TList) 18 | import Set 19 | 20 | 21 | type alias Set comparable = 22 | Set.Set comparable 23 | 24 | 25 | difference : Set comparable -> Set comparable -> Set comparable 26 | difference = 27 | Set.diff 28 | 29 | 30 | empty : Set comparable 31 | empty = 32 | Set.empty 33 | 34 | 35 | foldl : Foldable.Foldl comparable (Set comparable) a 36 | foldl f z s = 37 | Set.foldl (\e acc -> f acc e) z s 38 | 39 | 40 | foldr : Foldable.Foldr comparable (Set comparable) a 41 | foldr = 42 | Set.foldr 43 | 44 | 45 | fromList : TList comparable -> Set comparable 46 | fromList = 47 | Set.fromList 48 | 49 | 50 | insert : comparable -> Set comparable -> Set comparable 51 | insert = 52 | Set.insert 53 | 54 | 55 | member : comparable -> Set comparable -> Bool 56 | member = 57 | Set.member 58 | 59 | 60 | null : Foldable.Null (Set comparable) 61 | null = 62 | Set.isEmpty 63 | 64 | 65 | toList : Set a -> TList a 66 | toList = 67 | Set.toList 68 | 69 | 70 | union : Set comparable -> Set comparable -> Set comparable 71 | union = 72 | Set.union 73 | 74 | 75 | unions : TList (Set comparable) -> Set comparable 76 | unions = 77 | MList.foldl union empty 78 | -------------------------------------------------------------------------------- /src/Extra/Type/String.elm: -------------------------------------------------------------------------------- 1 | module Extra.Type.String exposing 2 | ( dropWhile 3 | , takeWhile 4 | ) 5 | 6 | 7 | dropWhile : (Char -> Bool) -> String -> String 8 | dropWhile predicate string = 9 | case String.uncons string of 10 | Nothing -> 11 | string 12 | 13 | Just ( char, rest ) -> 14 | if predicate char then 15 | dropWhile predicate rest 16 | 17 | else 18 | string 19 | 20 | 21 | takeWhile : (Char -> Bool) -> String -> String 22 | takeWhile predicate string = 23 | let 24 | go : String -> String -> String 25 | go rest acc = 26 | case String.uncons rest of 27 | Nothing -> 28 | acc 29 | 30 | Just ( char, rest_ ) -> 31 | if predicate char then 32 | go rest_ (acc ++ String.fromChar char) 33 | 34 | else 35 | acc 36 | in 37 | go string "" 38 | -------------------------------------------------------------------------------- /src/Extra/Type/Tuple.elm: -------------------------------------------------------------------------------- 1 | module Extra.Type.Tuple exposing (mappend, traverseSecond) 2 | 3 | import Extra.Class.Functor as Functor 4 | import Extra.Class.Monoid as Monoid 5 | import Extra.Class.Traversable as Traversable 6 | 7 | 8 | mappend : Monoid.Mappend a -> Monoid.Mappend b -> Monoid.Mappend ( a, b ) 9 | mappend pMappendA pMappendB ( a1, b1 ) ( a2, b2 ) = 10 | ( pMappendA a1 a2, pMappendB b1 b2 ) 11 | 12 | 13 | traverseSecond : 14 | Functor.Fmap b fb ( x, b ) fxb 15 | -> Traversable.Traverse a ( x, a ) fb fxb 16 | traverseSecond pFmap f ( x, a ) = 17 | pFmap (\b -> ( x, b )) (f a) 18 | -------------------------------------------------------------------------------- /src/Global.elm: -------------------------------------------------------------------------------- 1 | module Global exposing (State(..)) 2 | 3 | 4 | type State a b c d e f g h 5 | = State 6 | -- SysFile 7 | a 8 | -- Http 9 | b 10 | -- Details 11 | c 12 | -- Build 13 | d 14 | -- Generate 15 | e 16 | -- Terminal 17 | f 18 | -- Repl 19 | g 20 | -- App 21 | h 22 | -------------------------------------------------------------------------------- /src/Terminal/Helpers.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Terminal.Helpers exposing 3 | ( {-version 4 | , elmFile 5 | ,-} parsePackage 6 | ) 7 | 8 | 9 | import Compiler.Elm.Package as Pkg 10 | import Compiler.Parse.Primitives as P 11 | import Extra.Type.Either exposing (Either(..)) 12 | 13 | 14 | 15 | -- PACKAGE 16 | 17 | 18 | parsePackage : String -> Maybe Pkg.Name 19 | parsePackage chars = 20 | case P.fromByteString Pkg.parser Tuple.pair chars of 21 | Right pkg -> Just pkg 22 | Left _ -> Nothing 23 | -------------------------------------------------------------------------------- /src/Terminal/Init.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Terminal.Init exposing 3 | ( run 4 | ) 5 | 6 | 7 | import Builder.Deps.Solver as Solver 8 | import Builder.Elm.Outline as Outline 9 | import Builder.Reporting.Exit as Exit 10 | import Compiler.Data.NonEmptyList as NE 11 | import Compiler.Elm.Constraint as Con 12 | import Compiler.Elm.Package as Pkg 13 | import Compiler.Elm.Version as V 14 | import Compiler.Reporting.Doc as D exposing (d) 15 | import Extra.System.File as SysFile 16 | import Extra.System.IO as IO 17 | import Extra.Type.Either exposing (Either(..)) 18 | import Extra.Type.List as MList 19 | import Extra.Type.Map as Map 20 | import Terminal.Command as Command 21 | 22 | 23 | 24 | -- PRIVATE IO 25 | 26 | 27 | type alias IO g h v = 28 | IO.IO (Command.State g h) v 29 | 30 | 31 | 32 | -- RUN 33 | 34 | 35 | run : IO g h (Either Exit.Init ()) 36 | run = 37 | IO.bind (SysFile.doesFileExist (SysFile.fromString "elm.json")) <| \exists -> 38 | if exists 39 | then IO.return (Left Exit.InitAlreadyExists) 40 | else 41 | IO.bind (Command.ask question) <| \approved -> 42 | if approved 43 | then init 44 | else 45 | IO.bind (Command.putLine "Okay, I did not make any changes!") <| \_ -> 46 | IO.return (Right ()) 47 | 48 | 49 | question : D.Doc 50 | question = 51 | D.stack 52 | [ D.fillSep 53 | [d"Hello!" 54 | ,d"Elm",d"projects",d"always",d"start",d"with",d"an",D.greenS "elm.json",d"file." 55 | ,d"I",d"can",d"create",d"them!" 56 | ] 57 | , D.reflow <| 58 | "Now you may be wondering, what will be in this file? How do I add Elm files to" 59 | ++ " my project? How do I see it in the browser? How will my code grow? Do I need" 60 | ++ " more directories? What about tests? Etc." 61 | , D.fillSep 62 | [d"Check",d"out",D.cyan (D.fromChars (D.makeLink "init")) 63 | ,d"for",d"all",d"the",d"answers!" 64 | ] 65 | , d"Knowing all that, would you like me to create an elm.json file now? [Y/n]: " 66 | ] 67 | 68 | 69 | 70 | -- INIT 71 | 72 | 73 | init : IO g h (Either Exit.Init ()) 74 | init = 75 | IO.bind Solver.initEnv <| \eitherEnv -> 76 | case eitherEnv of 77 | Left problem -> 78 | IO.return (Left (Exit.InitRegistryProblem problem)) 79 | 80 | Right (Solver.Env cache _ connection registry) -> 81 | IO.bind (Solver.verify cache connection registry defaults) <| \result -> 82 | case result of 83 | Solver.Err exit -> 84 | IO.return (Left (Exit.InitSolverProblem exit)) 85 | 86 | Solver.NoSolution -> 87 | IO.return (Left (Exit.InitNoSolution (Map.keys defaults |> MList.map Pkg.fromComparable))) 88 | 89 | Solver.NoOfflineSolution -> 90 | IO.return (Left (Exit.InitNoOfflineSolution (Map.keys defaults |> MList.map Pkg.fromComparable))) 91 | 92 | Solver.Ok details -> 93 | let 94 | solution = Map.map (\(Solver.Details vsn _) -> vsn) details 95 | directs = Map.intersection solution defaults 96 | indirects = Map.difference solution defaults 97 | in 98 | IO.bind (SysFile.createDirectoryIfMissing True (SysFile.fromString "src")) <| \_ -> 99 | IO.bind (Outline.write (SysFile.fromString "") <| Outline.App <| 100 | Outline.AppOutline V.compiler (NE.CList (Outline.RelativeSrcDir (SysFile.fromString "src")) []) directs indirects Map.empty Map.empty) <| \_ -> 101 | IO.bind (Command.putLine "Okay, I created it. Now read that link!") <| \_ -> 102 | IO.return (Right ()) 103 | 104 | 105 | defaults : Map.Map Pkg.Comparable Con.Constraint 106 | defaults = 107 | Map.fromList 108 | [ (Pkg.toComparable Pkg.core, Con.anything) 109 | , (Pkg.toComparable Pkg.browser, Con.anything) 110 | , (Pkg.toComparable Pkg.html, Con.anything) 111 | ] 112 | -------------------------------------------------------------------------------- /src/Terminal/Main.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Terminal.Main exposing 3 | ( runMain 4 | ) 5 | 6 | 7 | import Compiler.Elm.Version as V 8 | import Compiler.Reporting.Doc as D exposing (d, da) 9 | import Extra.System.IO as IO 10 | import Extra.Type.List as MList 11 | import Terminal.Command as Command 12 | import Terminal.Terminal as Terminal 13 | 14 | 15 | 16 | -- PRIVATE IO 17 | 18 | 19 | type alias IO g h v = 20 | IO.IO (Command.State g h) v 21 | 22 | 23 | 24 | -- RUN 25 | 26 | 27 | runMain : IO g h () 28 | runMain = 29 | Terminal.app intro outro 30 | [ init 31 | , install 32 | , make 33 | , bump 34 | , diff 35 | , publish 36 | , reactor 37 | , repl 38 | ] 39 | 40 | 41 | intro : D.Doc 42 | intro = 43 | D.vcat 44 | [ D.fillSep 45 | [d"Hi,",d"thank",d"you",d"for",d"trying",d"out" 46 | ,D.greenS "Elm" 47 | ,da[D.greenS (V.toChars V.compiler), d"."] 48 | ,d"I hope you like it!" 49 | ] 50 | , d"" 51 | , D.blackS "-------------------------------------------------------------------------------" 52 | , D.blackS "I highly recommend working through to get started." 53 | , D.blackS "It teaches many important concepts, including how to use `elm` in the terminal." 54 | , D.blackS "-------------------------------------------------------------------------------" 55 | ] 56 | 57 | 58 | outro : D.Doc 59 | outro = 60 | D.fillSep <| MList.map D.fromChars <| String.words <| 61 | "Be sure to ask on the Elm slack if you run into trouble! Folks are friendly and" 62 | ++ " happy to help out. They hang out there because it is fun, so be kind to get the" 63 | ++ " best results!" 64 | 65 | 66 | 67 | -- INIT 68 | 69 | 70 | init : Terminal.Command 71 | init = 72 | let 73 | summary = 74 | "Start an Elm project. It creates a starter elm.json file and" 75 | ++ " provides a link explaining what to do from there." 76 | in 77 | Terminal.command "init" (Terminal.common summary) 78 | 79 | 80 | 81 | -- REPL 82 | 83 | 84 | repl : Terminal.Command 85 | repl = 86 | let 87 | summary = 88 | "Open up an interactive programming session. Type in Elm expressions" 89 | ++ " like (2 + 2) or (String.length \"test\") and see if they equal four!" 90 | in 91 | Terminal.command "repl" (Terminal.common summary) 92 | 93 | 94 | 95 | -- REACTOR 96 | 97 | 98 | reactor : Terminal.Command 99 | reactor = 100 | let 101 | summary = 102 | "Compile code with a click. It opens a file viewer in your browser, and" 103 | ++ " when you click on an Elm file, it compiles and you see the result." 104 | in 105 | Terminal.command "reactor" (Terminal.common summary) 106 | 107 | 108 | 109 | -- MAKE 110 | 111 | 112 | make : Terminal.Command 113 | make = 114 | Terminal.command "make" Terminal.uncommon 115 | 116 | 117 | 118 | -- INSTALL 119 | 120 | 121 | install : Terminal.Command 122 | install = 123 | Terminal.command "install" Terminal.uncommon 124 | 125 | 126 | 127 | -- PUBLISH 128 | 129 | 130 | publish : Terminal.Command 131 | publish = 132 | Terminal.command "publish" Terminal.uncommon 133 | 134 | 135 | 136 | -- BUMP 137 | 138 | 139 | bump : Terminal.Command 140 | bump = 141 | Terminal.command "bump" Terminal.uncommon 142 | 143 | 144 | 145 | -- DIFF 146 | 147 | 148 | diff : Terminal.Command 149 | diff = 150 | Terminal.command "diff" Terminal.uncommon 151 | -------------------------------------------------------------------------------- /src/Terminal/Make.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Terminal.Make exposing 3 | ( {-Flags(..) 4 | , Output(..) 5 | , ReportType(..) 6 | ,-} run, IO 7 | --, reportType 8 | --, output 9 | --, docsFile 10 | ) 11 | 12 | 13 | import Builder.Build as Build 14 | import Builder.Elm.Details as Details 15 | import Builder.File as File 16 | import Builder.Generate as Generate 17 | import Builder.Reporting.Exit as Exit 18 | import Builder.Reporting.Task as Task 19 | import Compiler.AST.Optimized as Opt 20 | import Compiler.Data.NonEmptyList as NE 21 | import Compiler.Elm.ModuleName as ModuleName 22 | import Extra.System.File as SysFile exposing (FilePath) 23 | import Extra.System.IO as IO 24 | import Extra.Type.Either exposing (Either) 25 | import Extra.Type.List as MList exposing (TList) 26 | import Extra.Type.Maybe as MMaybe 27 | import Terminal.Command as Command 28 | 29 | 30 | 31 | -- PRIVATE IO 32 | 33 | 34 | type alias IO g h v = 35 | IO.IO (Command.State g h) v 36 | 37 | 38 | 39 | -- RUN 40 | 41 | 42 | type alias Task z g h v = 43 | Task.Task z (Command.State g h) Exit.Make v 44 | 45 | 46 | {- NEW: async -} 47 | run : FilePath -> TList FilePath -> Bool -> Bool -> Bool -> FilePath -> IO g h (Either Exit.Make ()) 48 | run root paths debug optimize async target = 49 | Task.run <| 50 | Task.bind (getMode debug optimize async) <| \desiredMode -> 51 | Task.bind (Task.eio Exit.MakeBadDetails (Details.load root)) <| \details -> 52 | case paths of 53 | [] -> 54 | Task.bind (getExposed details) <| \exposed -> 55 | buildExposed root details exposed 56 | 57 | p::ps -> 58 | Task.bind (buildPaths root details (NE.CList p ps)) <| \artifacts -> 59 | case getNoMains artifacts of 60 | [] -> 61 | Task.bind (toBuilder root details desiredMode artifacts) <| \builder -> 62 | generate target builder 63 | 64 | name::names -> 65 | Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) 66 | 67 | 68 | 69 | -- GET INFORMATION 70 | 71 | 72 | getMode : Bool -> Bool -> Bool -> Task z g h DesiredMode 73 | getMode debug optimize async = 74 | case (debug, optimize, async) of 75 | (True , True , _ ) -> Task.throw Exit.MakeCannotOptimizeAndDebug 76 | (True , False, _ ) -> Task.return Debug 77 | (False, False, True ) -> Task.return Async 78 | (False, False, False) -> Task.return Dev 79 | (False, True , _ ) -> Task.return Prod 80 | 81 | 82 | getExposed : Details.Details -> Task z g h (NE.TList ModuleName.Raw) 83 | getExposed (Details.Details _ validOutline _ _ _ _) = 84 | case validOutline of 85 | Details.ValidApp _ -> 86 | Task.throw Exit.MakeAppNeedsFileNames 87 | 88 | Details.ValidPkg _ exposed _ -> 89 | case exposed of 90 | [] -> Task.throw Exit.MakePkgNeedsExposing 91 | m::ms -> Task.return (NE.CList m ms) 92 | 93 | 94 | 95 | -- BUILD PROJECTS 96 | 97 | 98 | buildExposed : FilePath -> Details.Details -> NE.TList ModuleName.Raw -> Task z g h () 99 | buildExposed root details exposed = 100 | let 101 | docsGoal = Build.ignoreDocs 102 | in 103 | Task.eio Exit.MakeCannotBuild <| 104 | Build.fromExposed root details docsGoal exposed 105 | 106 | 107 | buildPaths : FilePath -> Details.Details -> NE.TList FilePath -> Task z g h Build.Artifacts 108 | buildPaths root details paths = 109 | Task.eio Exit.MakeCannotBuild <| 110 | Build.fromPaths root details paths 111 | 112 | 113 | 114 | -- GET MAINS 115 | 116 | 117 | isMain : ModuleName.Raw -> Build.Module -> Bool 118 | isMain targetName modul = 119 | case modul of 120 | Build.Fresh name _ (Opt.LocalGraph maybeMain _ _) -> 121 | MMaybe.isJust maybeMain && name == targetName 122 | 123 | Build.Cached name mainIsDefined _ -> 124 | mainIsDefined && name == targetName 125 | 126 | 127 | 128 | -- GET MAINLESS 129 | 130 | 131 | getNoMains : Build.Artifacts -> TList ModuleName.Raw 132 | getNoMains (Build.Artifacts _ _ roots modules) = 133 | MMaybe.mapMaybe (getNoMain modules) (NE.toList roots) 134 | 135 | 136 | getNoMain : TList Build.Module -> Build.Root -> Maybe ModuleName.Raw 137 | getNoMain modules root = 138 | case root of 139 | Build.Inside name -> 140 | if MList.any (isMain name) modules 141 | then Nothing 142 | else Just name 143 | 144 | Build.Outside name (Opt.LocalGraph maybeMain _ _) -> 145 | case maybeMain of 146 | Just _ -> Nothing 147 | Nothing -> Just name 148 | 149 | 150 | 151 | -- GENERATE 152 | 153 | 154 | generate : FilePath -> String -> Task z g h () 155 | generate target builder = 156 | Task.io <| 157 | IO.bind (SysFile.createDirectoryIfMissing True (SysFile.dropLastName target)) <| \_ -> 158 | File.writeUtf8 target builder 159 | 160 | 161 | 162 | -- TO BUILDER 163 | 164 | 165 | type DesiredMode = Debug | Async | Dev | Prod 166 | 167 | 168 | toBuilder : FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task z g h String 169 | toBuilder root details desiredMode artifacts = 170 | Task.mapError Exit.MakeBadGenerate <| 171 | case desiredMode of 172 | Debug -> Generate.debug root details artifacts 173 | Async -> Generate.async root details artifacts 174 | Dev -> Generate.dev root details artifacts 175 | Prod -> Generate.prod root details artifacts 176 | -------------------------------------------------------------------------------- /src/Terminal/Reactor.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Terminal.Reactor exposing 3 | ( compile 4 | ) 5 | 6 | 7 | import Builder.Build as Build 8 | import Builder.Elm.Details as Details 9 | import Builder.Generate as Generate 10 | import Builder.Reporting.Exit as Exit 11 | import Builder.Reporting.Task as Task 12 | import Builder.Stuff as Stuff 13 | import Compiler.Data.NonEmptyList as NE 14 | import Extra.System.File exposing (FilePath) 15 | import Extra.System.IO as IO 16 | import Extra.Type.Either exposing (Either(..)) 17 | import Terminal.Command as Command 18 | 19 | 20 | 21 | -- PRIVATE IO 22 | 23 | 24 | type alias IO g h v = 25 | IO.IO (Command.State g h) v 26 | 27 | 28 | 29 | -- SERVE ELM 30 | 31 | 32 | compile : FilePath -> IO g h (Either Exit.Reactor String) 33 | compile path = 34 | IO.bind Stuff.findRoot <| \maybeRoot -> 35 | case maybeRoot of 36 | Nothing -> 37 | IO.return <| Left <| Exit.ReactorNoOutline 38 | 39 | Just root -> 40 | Task.run <| 41 | Task.bind (Task.eio Exit.ReactorBadDetails <| Details.load root) <| \details -> 42 | Task.bind (Task.eio Exit.ReactorBadBuild <| Build.fromPaths root details (NE.CList path [])) <| \artifacts -> 43 | Task.mapError Exit.ReactorBadGenerate <| Generate.dev root details artifacts 44 | -------------------------------------------------------------------------------- /src/Terminal/Terminal.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Terminal.Terminal exposing 3 | ( app 4 | , Command, command 5 | , Summary, common, uncommon 6 | --, Flags, noFlags, flags, (|--) 7 | --, Flag, flag, onOff 8 | --, Parser(..) 9 | --, Args, noArgs, required, optional, zeroOrMore, oneOrMore, oneOf 10 | --, require0, require1, require2, require3, require4, require5 11 | --, RequiredArgs, args, exactly, (!), (?), (...) 12 | ) 13 | 14 | 15 | import Compiler.Reporting.Doc as D 16 | import Extra.System.IO as IO 17 | import Extra.Type.List exposing (TList) 18 | import Terminal.Command 19 | import Terminal.Terminal.Error as Error 20 | import Terminal.Terminal.Internal as Internal 21 | 22 | 23 | 24 | -- FROM INTERNAL 25 | 26 | 27 | type alias Command = Internal.Command 28 | command = Internal.Command 29 | 30 | type alias Summary = Internal.Summary 31 | common = Internal.Common 32 | uncommon = Internal.Uncommon 33 | 34 | 35 | 36 | -- PRIVATE IO 37 | 38 | 39 | type alias IO g h v = 40 | IO.IO (Terminal.Command.State g h) v 41 | 42 | 43 | 44 | -- APP 45 | 46 | 47 | app : D.Doc -> D.Doc -> TList Command -> IO g h () 48 | app intro outro commands = 49 | Error.exitWithOverview intro outro commands 50 | -------------------------------------------------------------------------------- /src/Terminal/Terminal/Error.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Terminal.Terminal.Error exposing 3 | ( {-Error(..) 4 | , ArgError(..) 5 | , FlagError(..) 6 | , Expectation(..) 7 | , exitWithHelp 8 | , exitWithError 9 | , exitWithUnknown 10 | ,-} exitWithOverview 11 | ) 12 | 13 | 14 | import Compiler.Reporting.Doc as D exposing (d) 15 | import Extra.System.IO as IO 16 | import Extra.Type.List as MList exposing (TList) 17 | import Extra.Type.Maybe as MMaybe 18 | import Terminal.Command 19 | import Terminal.Terminal.Internal as Internal 20 | 21 | 22 | 23 | -- PRIVATE IO 24 | 25 | 26 | type alias IO g h v = 27 | IO.IO (Terminal.Command.State g h) v 28 | 29 | 30 | 31 | -- EXIT 32 | 33 | 34 | exitSuccess : TList D.Doc -> IO g h () 35 | exitSuccess = 36 | exitWith -- Exit.ExitSuccess 37 | 38 | 39 | exitWith : TList D.Doc -> IO g h () 40 | exitWith docs = 41 | Terminal.Command.putDoc <| 42 | D.vcat <| MList.concatMap (\doc -> [doc,d""]) docs 43 | 44 | 45 | getExeName : IO g h String 46 | getExeName = 47 | -- hard coded 48 | IO.return "elm" 49 | 50 | 51 | stack : TList D.Doc -> D.Doc 52 | stack docs = 53 | D.vcat <| MList.intersperse (d"") docs 54 | 55 | 56 | 57 | -- HELP 58 | 59 | 60 | argsToDoc : String -> D.Doc 61 | argsToDoc command = 62 | argsToDocHelp command 63 | 64 | 65 | argsToDocHelp : String -> D.Doc 66 | argsToDocHelp command = 67 | D.hang 4 <| D.hsep <| MList.map D.fromChars <| 68 | [ command ] 69 | 70 | 71 | 72 | -- OVERVIEW 73 | 74 | 75 | exitWithOverview : D.Doc -> D.Doc -> TList Internal.Command -> IO g h () 76 | exitWithOverview intro outro commands = 77 | IO.bind getExeName <| \exeName -> 78 | exitSuccess 79 | [ intro 80 | , d"The most common commands are:" 81 | , D.indent 4 <| stack <| MMaybe.mapMaybe (toSummary exeName) commands 82 | , d"There are a bunch of other commands as well though. Here is a full list:" 83 | , D.indent 4 <| D.dullcyan <| toCommandList exeName commands 84 | , d"Adding the --help flag gives a bunch of additional details about each one." 85 | , outro 86 | ] 87 | 88 | 89 | toSummary : String -> Internal.Command -> Maybe D.Doc 90 | toSummary exeName (Internal.Command name summary) = 91 | case summary of 92 | Internal.Uncommon -> 93 | Nothing 94 | 95 | Internal.Common summaryString -> 96 | Just <| 97 | D.vcat 98 | [ D.cyan <| argsToDoc (exeName ++ " " ++ name) 99 | , D.indent 4 <| D.reflow summaryString 100 | ] 101 | 102 | 103 | toCommandList : String -> TList Internal.Command -> D.Doc 104 | toCommandList exeName commands = 105 | let 106 | names = MList.map Internal.toName commands 107 | width = MList.maximum (MList.map String.length names) 108 | 109 | toExample name = 110 | D.fromChars <| exeName ++ " " ++ name ++ String.repeat (width - String.length name) " " ++ " --help" 111 | in 112 | D.vcat (MList.map toExample names) 113 | -------------------------------------------------------------------------------- /src/Terminal/Terminal/Internal.elm: -------------------------------------------------------------------------------- 1 | {- MANUALLY FORMATTED -} 2 | module Terminal.Terminal.Internal exposing 3 | ( Command(..) 4 | , toName 5 | , Summary(..) 6 | --, Flags(..) 7 | --, Flag(..) 8 | --, Parser(..) 9 | --, Args(..) 10 | --, CompleteArgs(..) 11 | --, RequiredArgs(..) 12 | ) 13 | 14 | 15 | 16 | -- COMMAND 17 | 18 | 19 | type Command = 20 | Command 21 | String 22 | Summary 23 | 24 | 25 | toName : Command -> String 26 | toName (Command name _) = 27 | name 28 | 29 | 30 | 31 | {-| The information that shows when you run the executable with no arguments. 32 | If you say it is `Common`, you need to tell people what it does. Try to keep 33 | it to two or three lines. If you say it is `Uncommon` you can rely on `Details` 34 | for a more complete explanation. 35 | -} 36 | type Summary = Common String | Uncommon 37 | -------------------------------------------------------------------------------- /src/Test/Main.elm: -------------------------------------------------------------------------------- 1 | module Test.Main exposing (main) 2 | 3 | import Builder.Build 4 | import Builder.Elm.Details 5 | import Builder.Generate 6 | import Builder.Http 7 | import Extra.System.File 8 | import Global 9 | import Terminal.Command 10 | import Terminal.Repl 11 | 12 | 13 | main : Program () (Terminal.Repl.GlobalState ()) () 14 | main = 15 | Platform.worker 16 | { init = 17 | \_ -> 18 | ( Global.State 19 | Extra.System.File.initialState 20 | Builder.Http.initialState 21 | Builder.Elm.Details.initialState 22 | Builder.Build.initialState 23 | Builder.Generate.initialState 24 | Terminal.Command.initialState 25 | Terminal.Repl.initialLocalState 26 | () 27 | , Cmd.none 28 | ) 29 | , subscriptions = \_ -> Sub.none 30 | , update = \_ m -> ( m, Cmd.none ) 31 | } 32 | --------------------------------------------------------------------------------