├── installers ├── npm │ ├── .gitignore │ ├── .npmignore │ ├── index.js │ ├── package.json │ ├── README.md │ └── bin │ │ └── elm ├── mac │ ├── helper-scripts │ │ ├── elm-startup.sh │ │ └── uninstall.sh │ ├── postinstall │ ├── Resources │ │ └── en.lproj │ │ │ ├── background.png │ │ │ ├── welcome.rtf │ │ │ └── conclusion.rtf │ ├── preinstall │ ├── make-installer.sh │ └── Distribution.xml └── win │ ├── file.ico │ ├── logo.ico │ ├── welcome.bmp │ ├── inst.dat │ ├── uninst.dat │ ├── README.md │ ├── CreateInternetShortcut.nsh │ ├── make_installer.cmd │ ├── updatepath.vbs │ └── removefrompath.vbs ├── ContributorAgreement.pdf ├── .gitignore ├── reactor ├── assets │ ├── favicon.ico │ ├── waiting.gif │ ├── source-code-pro.ttf │ ├── source-sans-pro.ttf │ └── styles.css ├── src │ ├── NotFound.elm │ ├── Index │ │ ├── Skeleton.elm │ │ ├── Navigator.elm │ │ └── Icon.elm │ └── Errors.elm ├── elm.json └── check.py ├── terminal └── src │ ├── Diff.hs │ ├── Bump.hs │ ├── Publish.hs │ ├── Install.hs │ ├── Develop │ ├── Socket.hs │ ├── StaticFiles │ │ └── Build.hs │ ├── Generate │ │ ├── Help.hs │ │ └── Index.hs │ └── StaticFiles.hs │ ├── Terminal │ └── Args │ │ ├── Internal.hs │ │ └── Helpers.hs │ ├── Make.hs │ └── Init.hs ├── compiler └── src │ ├── AST │ ├── Utils │ │ ├── Shader.hs │ │ ├── Binop.hs │ │ └── Type.hs │ ├── Valid.hs │ ├── Source.hs │ └── Module │ │ └── Name.hs │ ├── Elm │ ├── Compiler │ │ ├── Version.hs │ │ ├── Imports.hs │ │ ├── Module.hs │ │ ├── Objects.hs │ │ └── Type.hs │ ├── Header.hs │ ├── Compiler.hs │ └── Interface.hs │ ├── Data │ ├── OneOrMore.hs │ ├── Bag.hs │ └── Index.hs │ ├── Reporting │ ├── Suggest.hs │ ├── Annotation.hs │ ├── Error.hs │ ├── Region.hs │ ├── Report.hs │ ├── Result.hs │ ├── Render │ │ ├── Type │ │ │ └── Localizer.hs │ │ └── Code.hs │ ├── Warning.hs │ └── Error │ │ ├── Main.hs │ │ └── Docs.hs │ ├── Parse │ ├── Parse.hs │ ├── Primitives │ │ ├── Shader.hs │ │ ├── Kernel.hs │ │ └── Keyword.hs │ ├── Repl.hs │ ├── Shader.hs │ ├── Declaration.hs │ └── Primitives.hs │ ├── Type │ ├── Instantiate.hs │ ├── Occurs.hs │ └── UnionFind.hs │ ├── Generate │ └── JavaScript │ │ └── Mode.hs │ ├── Canonicalize │ ├── Environment │ │ └── Dups.hs │ ├── Type.hs │ └── Pattern.hs │ ├── Compile.hs │ └── Optimize │ ├── Case.hs │ └── Names.hs ├── .github ├── ISSUE_TEMPLATE.md └── CONTRIBUTING.md ├── LICENSE ├── docs └── elm.json │ ├── application.md │ └── package.md └── README.md /installers/npm/.gitignore: -------------------------------------------------------------------------------- 1 | node_modules/ 2 | -------------------------------------------------------------------------------- /installers/npm/.npmignore: -------------------------------------------------------------------------------- 1 | README.md 2 | .gitignore 3 | .git 4 | -------------------------------------------------------------------------------- /installers/mac/helper-scripts/elm-startup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | open 'http://elm-lang.org' 4 | -------------------------------------------------------------------------------- /ContributorAgreement.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/ContributorAgreement.pdf -------------------------------------------------------------------------------- /installers/mac/postinstall: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -ex 4 | 5 | echo "$(date)" > /tmp/elm-installer.log 6 | -------------------------------------------------------------------------------- /installers/win/file.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/installers/win/file.ico -------------------------------------------------------------------------------- /installers/win/logo.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/installers/win/logo.ico -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | elm-stuff 2 | dist 3 | cabal-dev 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | .DS_Store 7 | *~ 8 | -------------------------------------------------------------------------------- /installers/win/welcome.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/installers/win/welcome.bmp -------------------------------------------------------------------------------- /reactor/assets/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/reactor/assets/favicon.ico -------------------------------------------------------------------------------- /reactor/assets/waiting.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/reactor/assets/waiting.gif -------------------------------------------------------------------------------- /reactor/assets/source-code-pro.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/reactor/assets/source-code-pro.ttf -------------------------------------------------------------------------------- /reactor/assets/source-sans-pro.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/reactor/assets/source-sans-pro.ttf -------------------------------------------------------------------------------- /installers/mac/Resources/en.lproj/background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CurrySoftware/compiler/HEAD/installers/mac/Resources/en.lproj/background.png -------------------------------------------------------------------------------- /installers/win/inst.dat: -------------------------------------------------------------------------------- 1 | SetOutPath "$INSTDIR\bin" 2 | File "${FILES_SOURCE_PATH}\bin\elm.exe" 3 | 4 | SetOutPath "$INSTDIR" 5 | File "file.ico" 6 | File "updatepath.vbs" 7 | File "removefrompath.vbs" -------------------------------------------------------------------------------- /installers/win/uninst.dat: -------------------------------------------------------------------------------- 1 | Delete "$INSTDIR\bin\elm.exe" 2 | RmDir "$INSTDIR\bin" 3 | 4 | Delete "$INSTDIR\file.ico" 5 | Delete "$INSTDIR\updatepath.vbs" 6 | Delete "$INSTDIR\removefrompath.vbs" 7 | RmDir "$INSTDIR" -------------------------------------------------------------------------------- /installers/win/README.md: -------------------------------------------------------------------------------- 1 | # Building Windows installer 2 | 3 | You will need the [NSIS installer](http://nsis.sourceforge.net/Download) to be installed. 4 | 5 | Once everything is installed, run something like this command: 6 | 7 | make_installer.cmd 0.19 8 | 9 | It will build an installer called `Elm-0.19-setup.exe`. -------------------------------------------------------------------------------- /installers/win/CreateInternetShortcut.nsh: -------------------------------------------------------------------------------- 1 | !macro CreateInternetShortcut FILENAME URL ICONFILE ICONINDEX 2 | WriteINIStr "${FILENAME}.url" "InternetShortcut" "URL" "${URL}" 3 | WriteINIStr "${FILENAME}.url" "InternetShortcut" "IconFile" "${ICONFILE}" 4 | WriteINIStr "${FILENAME}.url" "InternetShortcut" "IconIndex" "${ICONINDEX}" 5 | !macroend -------------------------------------------------------------------------------- /terminal/src/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Diff (run) where 3 | 4 | 5 | import qualified Elm.Diff as Diff 6 | import qualified Reporting.Task as Task 7 | import qualified Reporting.Progress.Terminal as Terminal 8 | 9 | 10 | 11 | -- RUN 12 | 13 | 14 | run :: Diff.Args -> () -> IO () 15 | run args () = 16 | do reporter <- Terminal.create 17 | Task.run reporter $ Diff.diff args 18 | -------------------------------------------------------------------------------- /installers/mac/Resources/en.lproj/welcome.rtf: -------------------------------------------------------------------------------- 1 | {\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf400 2 | {\fonttbl\f0\fswiss\fcharset0 Helvetica;} 3 | {\colortbl;\red255\green255\blue255;} 4 | \paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0 5 | \pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural 6 | 7 | \f0\fs28 \cf0 This package will install Elm on your machine.} -------------------------------------------------------------------------------- /installers/mac/preinstall: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | installdir=/usr/local/bin 6 | 7 | for bin in elm elm-compiler elm-package elm-reactor elm-repl 8 | do 9 | if [ -f $installdir/$bin ]; then 10 | sudo rm -f $installdir/$bin 11 | fi 12 | if [ -f $installdir/$bin-unwrapped ]; then 13 | sudo rm -f $installdir/$bin-unwrapped 14 | fi 15 | done 16 | 17 | sharedir=/usr/local/share/elm 18 | sudo rm -rf $sharedir 19 | -------------------------------------------------------------------------------- /installers/win/make_installer.cmd: -------------------------------------------------------------------------------- 1 | 2 | set version=%1 3 | 4 | mkdir files 5 | mkdir files\bin 6 | 7 | xcopy ..\..\dist\build\elm\elm.exe files\bin /s /e 8 | xcopy updatepath.vbs files 9 | 10 | if EXIST "%ProgramFiles%\NSIS" ( 11 | set nsis="%ProgramFiles%\NSIS\makensis.exe" 12 | ) else ( 13 | set nsis="%ProgramFiles(x86)%\NSIS\makensis.exe" 14 | ) 15 | 16 | %nsis% /DPLATFORM_VERSION=%version% Nsisfile.nsi 17 | 18 | rd /s /q files 19 | -------------------------------------------------------------------------------- /terminal/src/Bump.hs: -------------------------------------------------------------------------------- 1 | module Bump (run) where 2 | 3 | 4 | import qualified Elm.Bump as Bump 5 | import qualified Elm.Project as Project 6 | import qualified Reporting.Task as Task 7 | import qualified Reporting.Progress.Terminal as Terminal 8 | 9 | 10 | 11 | -- RUN 12 | 13 | 14 | run :: () -> () -> IO () 15 | run () () = 16 | do reporter <- Terminal.create 17 | Task.run reporter $ 18 | do summary <- Project.getRoot 19 | Bump.bump summary 20 | -------------------------------------------------------------------------------- /terminal/src/Publish.hs: -------------------------------------------------------------------------------- 1 | module Publish (run) where 2 | 3 | 4 | import qualified Elm.Project as Project 5 | import qualified Elm.Publish as Publish 6 | import qualified Reporting.Task as Task 7 | import qualified Reporting.Progress.Terminal as Terminal 8 | 9 | 10 | 11 | -- RUN 12 | 13 | 14 | run :: () -> () -> IO () 15 | run () () = 16 | do reporter <- Terminal.create 17 | Task.run reporter $ 18 | do summary <- Project.getRoot 19 | Publish.publish summary 20 | -------------------------------------------------------------------------------- /installers/win/updatepath.vbs: -------------------------------------------------------------------------------- 1 | Set WshShell = CreateObject("WScript.Shell") 2 | elmPath = WScript.Arguments(0) 3 | 'const PathRegKey = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path" 4 | const PathRegKey = "HKCU\Environment\Path" 5 | 6 | on error resume next 7 | path = WshShell.RegRead(PathRegKey) 8 | if err.number <> 0 then 9 | path = "" 10 | end if 11 | on error goto 0 12 | 13 | newPath = elmPath & ";" & path 14 | Call WshShell.RegWrite(PathRegKey, newPath, "REG_EXPAND_SZ") 15 | -------------------------------------------------------------------------------- /installers/mac/helper-scripts/uninstall.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | echo "Warning: You are about to remove all Elm executables!" 6 | 7 | installdir=/usr/local/bin 8 | 9 | for bin in elm elm-compiler elm-get elm-reactor elm-repl elm-doc elm-server elm-package elm-make 10 | do 11 | if [ -f $installdir/$bin ]; then 12 | sudo rm -f $installdir/$bin 13 | fi 14 | if [ -f $installdir/$bin-unwrapped ]; then 15 | sudo rm -f $installdir/$bin-unwrapped 16 | fi 17 | 18 | done 19 | 20 | sharedir=/usr/local/share/elm 21 | sudo rm -rf $sharedir 22 | -------------------------------------------------------------------------------- /installers/mac/Resources/en.lproj/conclusion.rtf: -------------------------------------------------------------------------------- 1 | {\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf400 2 | {\fonttbl\f0\fswiss\fcharset0 Helvetica;} 3 | {\colortbl;\red255\green255\blue255;} 4 | \paperw11900\paperh16840\margl1440\margr1440\vieww10800\viewh8400\viewkind0 5 | \pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardirnatural 6 | 7 | \f0\fs26 \cf0 A bunch of useful programs were just placed in /usr/local/bin/\ 8 | \ 9 | Check out {\field{\*\fldinst HYPERLINK "http://elm-lang.org/Get-Started.elm"}{\fldrslt this tutorial}} to learn how to use them!} -------------------------------------------------------------------------------- /compiler/src/AST/Utils/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module AST.Utils.Shader 3 | ( Shader(..) 4 | , Type(..) 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.Map as Map 10 | import qualified Elm.Name as N 11 | 12 | 13 | 14 | -- SHADERS 15 | 16 | 17 | data Shader = 18 | Shader 19 | { _attribute :: Map.Map N.Name Type 20 | , _uniform :: Map.Map N.Name Type 21 | , _varying :: Map.Map N.Name Type 22 | } 23 | 24 | 25 | 26 | -- GL TYPES 27 | 28 | 29 | data Type 30 | = Int 31 | | Float 32 | | V2 33 | | V3 34 | | V4 35 | | M4 36 | | Texture 37 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | BEFORE DELETING THIS: 2 | 3 | - Runtime error? https://github.com/elm-lang/elm-compiler/issues/1591 4 | - Type annotations? https://github.com/elm-lang/elm-compiler/issues/1214 5 | - Core libraries? https://github.com/elm-lang/core/issues 6 | - Bad error message? https://github.com/elm-lang/error-message-catalog/issues 7 | - Compiler hangs? https://github.com/elm-lang/elm-compiler/issues/1240 8 | - Parser / code gen problem? https://github.com/elm-lang/elm-compiler/labels/meta 9 | 10 | 11 | If none of that applies, write up a report that satisfies this checklist: 12 | 13 | https://github.com/process-bot/contribution-checklist/blob/master/issues.md 14 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Version.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Compiler.Version (version) where 3 | 4 | import qualified Data.Version as Version 5 | import qualified Paths_elm 6 | import Elm.Package (Version(Version)) 7 | 8 | 9 | 10 | -- VERSION 11 | 12 | 13 | version :: Version 14 | version = 15 | case map fromIntegral (Version.versionBranch Paths_elm.version) of 16 | major : minor : patch : _ -> 17 | Version major minor patch 18 | 19 | [major, minor] -> 20 | Version major minor 0 21 | 22 | [major] -> 23 | Version major 0 0 24 | 25 | [] -> 26 | error "could not detect version of elm-compiler you are using" 27 | 28 | -------------------------------------------------------------------------------- /reactor/src/NotFound.elm: -------------------------------------------------------------------------------- 1 | module NotFound exposing (main) 2 | 3 | 4 | import Browser 5 | import Html exposing (..) 6 | import Html.Attributes exposing (..) 7 | 8 | 9 | 10 | main : Program () () () 11 | main = 12 | Browser.document 13 | { init = \_ -> ((), Cmd.none) 14 | , update = \_ _ -> ((), Cmd.none) 15 | , subscriptions = \_ -> Sub.none 16 | , view = \_ -> page 17 | } 18 | 19 | 20 | page : Browser.Document () 21 | page = 22 | { title = "Page not found" 23 | , body = 24 | [ div [ class "not-found" ] 25 | [ div [ style "font-size" "12em" ] [ text "404" ] 26 | , div [ style "font-size" "3em" ] [ text "Page not found" ] 27 | ] 28 | ] 29 | } -------------------------------------------------------------------------------- /installers/npm/index.js: -------------------------------------------------------------------------------- 1 | var binwrap = require("binwrap"); 2 | var path = require("path"); 3 | 4 | var packageInfo = require(path.join(__dirname, "package.json")); 5 | // Use major.minor.patch from version string - e.g. "1.2.3" from "1.2.3-alpha" 6 | var binVersion = packageInfo.version.replace(/^(\d+\.\d+\.\d+).*$/, "$1"); 7 | 8 | var root = 9 | "https://github.com/elm/compiler/releases/download/" + 10 | binVersion + 11 | "/binaries-for-"; 12 | 13 | module.exports = binwrap({ 14 | binaries: ["elm"], 15 | urls: { 16 | "darwin-x64": root + "mac.tar.gz", 17 | "win32-x64": root + "windows.tar.gz", 18 | "win32-ia32": root + "windows.tar.gz", 19 | "linux-x64": root + "linux.tar.gz" 20 | } 21 | }); 22 | -------------------------------------------------------------------------------- /installers/win/removefrompath.vbs: -------------------------------------------------------------------------------- 1 | Set WshShell = CreateObject("WScript.Shell") 2 | ' Make sure there is no trailing slash at the end of elmBasePath 3 | elmBasePath = WScript.Arguments(0) 4 | 'const PathRegKey = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path" 5 | const PathRegKey = "HKCU\Environment\Path" 6 | 7 | on error resume next 8 | path = WshShell.RegRead(PathRegKey) 9 | if err.number = 0 then 10 | Set regEx = New RegExp 11 | elmBasePath = Replace(Replace(Replace(elmBasePath, "\", "\\"), "(", "\("), ")", "\)") 12 | regEx.Pattern = elmBasePath & "\\\d+\.\d+(\.\d+|)\\bin(;|)" 13 | regEx.Global = True 14 | newPath = regEx.Replace(path, "") 15 | Call WshShell.RegWrite(PathRegKey, newPath, "REG_EXPAND_SZ") 16 | end if 17 | on error goto 0 18 | -------------------------------------------------------------------------------- /reactor/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.0", 7 | "dependencies": { 8 | "direct": { 9 | "elm/browser": "1.0.0", 10 | "elm/core": "1.0.0", 11 | "elm/html": "1.0.0", 12 | "elm/http": "1.0.0", 13 | "elm/json": "1.0.0", 14 | "elm/project-metadata-utils": "1.0.0", 15 | "elm/svg": "1.0.0", 16 | "elm-explorations/markdown": "1.0.0" 17 | }, 18 | "indirect": { 19 | "elm/parser": "1.0.0", 20 | "elm/time": "1.0.0", 21 | "elm/url": "1.0.0", 22 | "elm/virtual-dom": "1.0.0" 23 | } 24 | }, 25 | "test-dependencies": { 26 | "direct": {}, 27 | "indirect": {} 28 | } 29 | } -------------------------------------------------------------------------------- /terminal/src/Install.hs: -------------------------------------------------------------------------------- 1 | module Install 2 | ( Args(..) 3 | , run 4 | ) 5 | where 6 | 7 | 8 | import Control.Monad.Trans (liftIO) 9 | 10 | import qualified Elm.Install as Install 11 | import qualified Elm.PerUserCache as PerUserCache 12 | import qualified Elm.Package as Pkg 13 | import qualified Reporting.Exit as Exit 14 | import qualified Reporting.Exit.Install as E 15 | import qualified Reporting.Task as Task 16 | import qualified Reporting.Progress.Terminal as Terminal 17 | 18 | 19 | 20 | -- RUN 21 | 22 | 23 | data Args 24 | = NoArgs 25 | | Install Pkg.Name 26 | 27 | 28 | run :: Args -> () -> IO () 29 | run args () = 30 | do reporter <- Terminal.create 31 | Task.run reporter $ 32 | case args of 33 | NoArgs -> 34 | do elmHome <- liftIO PerUserCache.getElmHome 35 | Task.throw (Exit.Install (E.NoArgs elmHome)) 36 | 37 | Install pkg -> 38 | Install.install pkg 39 | -------------------------------------------------------------------------------- /compiler/src/AST/Utils/Binop.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module AST.Utils.Binop 3 | ( Precedence(..) 4 | , Associativity(..) 5 | ) 6 | where 7 | 8 | 9 | import Prelude hiding (Either(..)) 10 | import Control.Monad (liftM) 11 | import Data.Binary 12 | 13 | 14 | 15 | -- BINOP STUFF 16 | 17 | 18 | newtype Precedence = Precedence Int 19 | deriving (Eq, Ord) 20 | 21 | 22 | data Associativity 23 | = Left 24 | | Non 25 | | Right 26 | deriving (Eq) 27 | 28 | 29 | 30 | -- BINARY 31 | 32 | 33 | instance Binary Precedence where 34 | get = 35 | liftM Precedence get 36 | 37 | put (Precedence n) = 38 | put n 39 | 40 | 41 | instance Binary Associativity where 42 | get = 43 | do n <- getWord8 44 | return $ 45 | case n of 46 | 0 -> Left 47 | 1 -> Non 48 | 2 -> Right 49 | _ -> error "Error reading valid associativity from serialized string" 50 | 51 | put assoc = 52 | putWord8 $ 53 | case assoc of 54 | Left -> 0 55 | Non -> 1 56 | Right -> 2 57 | -------------------------------------------------------------------------------- /compiler/src/Data/OneOrMore.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Data.OneOrMore 3 | ( OneOrMore(..) 4 | , one 5 | , more 6 | , toList 7 | , map 8 | ) 9 | where 10 | 11 | 12 | import Prelude hiding (map) 13 | 14 | 15 | 16 | -- ONE OR MORE 17 | 18 | 19 | data OneOrMore a 20 | = One a 21 | | More (OneOrMore a) (OneOrMore a) 22 | 23 | 24 | one :: a -> OneOrMore a 25 | one = 26 | One 27 | 28 | 29 | more :: OneOrMore a -> OneOrMore a -> OneOrMore a 30 | more = 31 | More 32 | 33 | 34 | 35 | -- TO LIST 36 | 37 | 38 | toList :: OneOrMore a -> [a] 39 | toList oneOrMore = 40 | toListHelp oneOrMore [] 41 | 42 | 43 | toListHelp :: OneOrMore a -> [a] -> [a] 44 | toListHelp oneOrMore list = 45 | case oneOrMore of 46 | One x -> 47 | x : list 48 | 49 | More a b -> 50 | toListHelp a (toListHelp b list) 51 | 52 | 53 | 54 | -- MAP 55 | 56 | 57 | map :: (a -> b) -> OneOrMore a -> OneOrMore b 58 | map func oneOrMore = 59 | case oneOrMore of 60 | One value -> 61 | One (func value) 62 | 63 | More left right -> 64 | More (map func left) (map func right) 65 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Suggest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Suggest 4 | ( distance 5 | , sort 6 | , rank 7 | ) 8 | where 9 | 10 | 11 | import qualified Data.Char as Char 12 | import qualified Data.List as List 13 | import qualified Text.EditDistance as Dist 14 | 15 | 16 | 17 | -- DISTANCE 18 | 19 | 20 | distance :: String -> String -> Int 21 | distance x y = 22 | Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y 23 | 24 | 25 | 26 | -- SORT 27 | 28 | 29 | sort :: String -> (a -> String) -> [a] -> [a] 30 | sort target toString values = 31 | List.sortOn (distance (toLower target) . toLower . toString) values 32 | 33 | 34 | toLower :: String -> String 35 | toLower string = 36 | map Char.toLower string 37 | 38 | 39 | 40 | -- RANK 41 | 42 | 43 | rank :: String -> (a -> String) -> [a] -> [(Int,a)] 44 | rank target toString values = 45 | let 46 | toRank v = 47 | distance (toLower target) (toLower (toString v)) 48 | 49 | addRank v = 50 | (toRank v, v) 51 | in 52 | List.sortOn fst (map addRank values) 53 | -------------------------------------------------------------------------------- /installers/npm/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "elm", 3 | "version": "0.19.0-bugfix2", 4 | "description": "The Elm Platform: Binaries for the Elm programming language.", 5 | "main": "index.js", 6 | "preferGlobal": true, 7 | "license": "BSD-3-Clause", 8 | "repository": { 9 | "type": "git", 10 | "url": "https://github.com/elm/compiler.git" 11 | }, 12 | "homepage": "https://github.com/elm/compiler/tree/master/installers/npm", 13 | "bugs": "https://github.com/elm/compiler/issues", 14 | "author": { 15 | "name": "Richard Feldman", 16 | "email": "richard.t.feldman@gmail.com", 17 | "url": "https://github.com/rtfeldman" 18 | }, 19 | "engines": { 20 | "node": ">=4.0.0" 21 | }, 22 | "scripts": { 23 | "install": "binwrap-install", 24 | "prepublishOnly": "binwrap-test" 25 | }, 26 | "files": [ 27 | "index.js", 28 | "bin", 29 | "bin/elm" 30 | ], 31 | "keywords": [ 32 | "bin", 33 | "binary", 34 | "binaries", 35 | "elm", 36 | "platform" 37 | ], 38 | "bin": { 39 | "elm": "bin/elm" 40 | }, 41 | "dependencies": { 42 | "binwrap": "0.1.4" 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /installers/mac/make-installer.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Run the following command to create an installer: 3 | # 4 | # bash make-installer.sh 5 | # 6 | 7 | 8 | 9 | #### SETUP #### 10 | 11 | set -e 12 | 13 | # Create directory structure for new pkgs 14 | pkg_root=$(mktemp -d -t package-artifacts) 15 | pkg_binaries=$pkg_root 16 | pkg_scripts=$pkg_root/Scripts 17 | 18 | mkdir -p $pkg_binaries 19 | mkdir -p $pkg_scripts 20 | 21 | usr_binaries=/usr/local/bin 22 | 23 | 24 | #### BUILD ASSETS #### 25 | 26 | cp ../../dist/build/elm/elm $pkg_binaries/elm 27 | 28 | cp $(pwd)/preinstall $pkg_scripts 29 | cp $(pwd)/postinstall $pkg_scripts 30 | 31 | pkgbuild \ 32 | --identifier org.elm-lang.binaries.pkg \ 33 | --install-location $usr_binaries \ 34 | --scripts $pkg_scripts \ 35 | --filter 'Scripts.*' \ 36 | --root $pkg_root \ 37 | binaries.pkg 38 | 39 | 40 | #### BUNDLE ASSETS #### 41 | 42 | rm -f Elm.pkg 43 | 44 | productbuild \ 45 | --distribution Distribution.xml \ 46 | --package-path . \ 47 | --resources Resources \ 48 | Elm.pkg 49 | 50 | 51 | #### CLEAN UP #### 52 | 53 | rm binaries.pkg 54 | rm -rf $pkg_root 55 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Annotation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Reporting.Annotation 3 | ( Located(..) 4 | , at, merge 5 | , map 6 | , toValue 7 | , toRegion 8 | , traverse 9 | ) 10 | where 11 | 12 | 13 | import Prelude hiding (map, traverse) 14 | import qualified Reporting.Region as R 15 | 16 | 17 | 18 | -- ANNOTATION 19 | 20 | 21 | data Located a = 22 | At R.Region a 23 | 24 | 25 | 26 | -- CREATE 27 | 28 | 29 | at :: R.Position -> R.Position -> a -> Located a 30 | at start end value = 31 | At (R.Region start end) value 32 | 33 | 34 | merge :: Located a -> Located b -> value -> Located value 35 | merge (At region1 _) (At region2 _) value = 36 | At (R.merge region1 region2) value 37 | 38 | 39 | 40 | -- MANIPULATE 41 | 42 | 43 | map :: (a -> b) -> Located a -> Located b 44 | map f (At info value) = 45 | At info (f value) 46 | 47 | 48 | toValue :: Located a -> a 49 | toValue (At _ value) = 50 | value 51 | 52 | 53 | toRegion :: Located a -> R.Region 54 | toRegion (At region _) = 55 | region 56 | 57 | 58 | traverse :: (Functor f) => (a -> f b) -> Located a -> f (Located b) 59 | traverse func (At region value) = 60 | At region <$> func value 61 | -------------------------------------------------------------------------------- /terminal/src/Develop/Socket.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Develop.Socket (watchFile) where 4 | 5 | import Control.Concurrent (forkIO, threadDelay) 6 | import Control.Exception (SomeException, catch) 7 | import qualified Data.ByteString.Char8 as BS 8 | import qualified Network.WebSockets as WS 9 | import qualified System.FSNotify.Devel as Notify 10 | import qualified System.FSNotify as Notify 11 | 12 | 13 | 14 | watchFile :: FilePath -> WS.PendingConnection -> IO () 15 | watchFile watchedFile pendingConnection = 16 | do connection <- WS.acceptRequest pendingConnection 17 | 18 | Notify.withManager $ \mgmt -> 19 | do stop <- Notify.treeExtAny mgmt "." ".elm" print 20 | tend connection 21 | stop 22 | 23 | 24 | tend :: WS.Connection -> IO () 25 | tend connection = 26 | let 27 | pinger :: Integer -> IO a 28 | pinger n = 29 | do threadDelay (5 * 1000 * 1000) 30 | WS.sendPing connection (BS.pack (show n)) 31 | pinger (n + 1) 32 | 33 | receiver :: IO () 34 | receiver = 35 | do _ <- WS.receiveDataMessage connection 36 | receiver 37 | 38 | shutdown :: SomeException -> IO () 39 | shutdown _ = 40 | return () 41 | in 42 | do _pid <- forkIO (receiver `catch` shutdown) 43 | pinger 1 `catch` shutdown 44 | -------------------------------------------------------------------------------- /reactor/check.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | import os 4 | import sys 5 | 6 | 7 | ## FIGURE OUT NEW MODIFICATION TIME 8 | 9 | def mostRecentModification(directory): 10 | mostRecent = 0 11 | 12 | for dirpath, dirs, files in os.walk(directory): 13 | for f in files: 14 | lastModified = os.path.getmtime(dirpath + '/' + f) 15 | mostRecent = max(int(lastModified), mostRecent) 16 | 17 | return mostRecent 18 | 19 | 20 | srcTime = mostRecentModification('ui/src') 21 | assetTime = mostRecentModification('ui/assets') 22 | mostRecent = max(srcTime, assetTime) 23 | 24 | 25 | ## FIGURE OUT OLD MODIFICATION TIME 26 | 27 | with open('ui/last-modified', 'a') as handle: 28 | pass 29 | 30 | 31 | prevMostRecent = 0 32 | 33 | 34 | with open('ui/last-modified', 'r+') as handle: 35 | line = handle.read() 36 | prevMostRecent = int(line) if line else 0 37 | 38 | 39 | ## TOUCH FILES IF NECESSARY 40 | 41 | if mostRecent > prevMostRecent: 42 | print "+------------------------------------------------------------+" 43 | print "| Some ui/ code changed. Touching src/Reactor/StaticFiles.hs |" 44 | print "| to trigger a recompilation of the Template Haskell stuff. |" 45 | print "+------------------------------------------------------------+" 46 | os.utime('src/Reactor/StaticFiles.hs', None) 47 | with open('ui/last-modified', 'w') as handle: 48 | handle.write(str(mostRecent)) 49 | -------------------------------------------------------------------------------- /reactor/src/Index/Skeleton.elm: -------------------------------------------------------------------------------- 1 | module Index.Skeleton exposing 2 | ( box 3 | , readmeBox 4 | ) 5 | 6 | import Html exposing (..) 7 | import Html.Attributes exposing (..) 8 | import Markdown 9 | 10 | import Index.Icon as Icon 11 | 12 | 13 | 14 | -- VIEW BOXES 15 | 16 | 17 | type alias BoxArgs msg = 18 | { title : String 19 | , items : List (List (Html msg)) 20 | , footer : Maybe (String, String) 21 | } 22 | 23 | 24 | box : BoxArgs msg -> Html msg 25 | box { title, items, footer } = 26 | let 27 | realItems = 28 | List.map (div [ class "box-item" ]) items 29 | in 30 | boxHelp title realItems footer 31 | 32 | 33 | readmeBox : String -> Html msg 34 | readmeBox markdown = 35 | let 36 | readme = 37 | Markdown.toHtml [ class "box-item" ] markdown 38 | in 39 | boxHelp "README" [readme] Nothing 40 | 41 | 42 | boxHelp : String -> List (Html msg) -> Maybe (String, String) -> Html msg 43 | boxHelp boxTitle items footer = 44 | div [ class "box" ] <| 45 | div [ class "box-header" ] [ text boxTitle ] 46 | :: items 47 | ++ [ boxFooter footer ] 48 | 49 | 50 | boxFooter : Maybe (String, String) -> Html msg 51 | boxFooter maybeFooter = 52 | case maybeFooter of 53 | Nothing -> 54 | text "" 55 | 56 | Just (path, description) -> 57 | a [ href path 58 | , title description 59 | ] 60 | [ div [ class "box-footer" ] [ Icon.plus ] 61 | ] 62 | -------------------------------------------------------------------------------- /installers/mac/Distribution.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | Elm Platform 4 | 5 | 6 | 7 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | binaries.pkg 31 | 32 | -------------------------------------------------------------------------------- /terminal/src/Develop/StaticFiles/Build.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Develop.StaticFiles.Build 3 | ( readAsset 4 | , compile 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.ByteString as BS 10 | import qualified System.Directory as Dir 11 | import System.FilePath (()) 12 | 13 | import qualified Elm.Project as Project 14 | import qualified Generate.Output as Output 15 | import qualified Reporting.Task as Task 16 | import qualified Reporting.Progress.Terminal as Terminal 17 | 18 | 19 | 20 | -- ASSETS 21 | 22 | 23 | readAsset :: FilePath -> IO BS.ByteString 24 | readAsset path = 25 | BS.readFile ("reactor" "assets" path) 26 | 27 | 28 | 29 | -- COMPILE 30 | 31 | 32 | compile :: IO BS.ByteString 33 | compile = 34 | Dir.withCurrentDirectory "reactor" $ 35 | do reporter <- Terminal.create 36 | Task.run reporter $ 37 | do summary <- Project.getRoot 38 | let jsOutput = Just (Output.JavaScript Nothing tempFileName) 39 | Project.compile Output.Prod Output.Client jsOutput Nothing summary rootPaths 40 | 41 | result <- BS.readFile tempFileName 42 | seq (BS.length result) (Dir.removeFile tempFileName) 43 | return result 44 | 45 | 46 | tempFileName :: FilePath 47 | tempFileName = 48 | "elm.js" 49 | 50 | 51 | rootPaths :: [FilePath] 52 | rootPaths = 53 | [ "src" "Errors.elm" 54 | , "src" "Index.elm" 55 | , "src" "NotFound.elm" 56 | ] 57 | -------------------------------------------------------------------------------- /installers/npm/README.md: -------------------------------------------------------------------------------- 1 | npm install elm [![Travis build Status](https://travis-ci.org/elm-lang/elm-platform.svg?branch=master)](http://travis-ci.org/elm-lang/elm-platform) [![AppVeyor build status](https://ci.appveyor.com/api/projects/status/6mcub79i04ianpm9/branch/master?svg=true)](https://ci.appveyor.com/project/rtfeldman/elm-platform/branch/master) 2 | =============== 3 | 4 | Install the [Elm Platform](https://github.com/elm-lang/elm-platform) via [`npm`](https://www.npmjs.com). 5 | 6 | ## Installing 7 | 8 | Run this to get the binaries: 9 | 10 | ``` 11 | $ npm install -g elm 12 | ``` 13 | 14 | ## Installing behind a proxy server 15 | 16 | If you are behind a proxy server, set the environment variable "HTTPS_PROXY". 17 | 18 | ``` 19 | $ export HTTPS_PROXY=$YourProxyServer$ 20 | $ npm install -g elm 21 | ``` 22 | 23 | Or on Windows: 24 | 25 | ``` 26 | $ set HTTPS_PROXY=$YourProxyServer$ 27 | $ npm install -g elm 28 | ``` 29 | 30 | ## Troubleshooting 31 | 32 | 1. [Troubleshooting npm](https://github.com/npm/npm/wiki/Troubleshooting) 33 | 2. On Debian/Ubuntu systems, you may have to install the nodejs-legacy package: `apt-get install nodejs-legacy`. 34 | 3. If the installer says that it cannot find any usable binaries for your operating system and architecture, check the [Build from Source](https://github.com/elm-lang/elm-platform/blob/master/README.md#build-from-source) documentation. 35 | 36 | ## Getting Started 37 | 38 | Once everything has installed successfully, head over to the [Get Started](http://elm-lang.org/Get-Started.elm) page! 39 | -------------------------------------------------------------------------------- /reactor/src/Index/Navigator.elm: -------------------------------------------------------------------------------- 1 | module Index.Navigator exposing (view) 2 | 3 | 4 | import Html exposing (..) 5 | import Html.Attributes exposing (..) 6 | import Index.Icon as Icon 7 | 8 | 9 | 10 | -- VIEW 11 | 12 | 13 | view : String -> List String -> Html msg 14 | view root dirs = 15 | div 16 | [ style "font-size" "2em" 17 | , style "padding" "20px 0" 18 | , style "display" "flex" 19 | , style "align-items" "center" 20 | , style "height" "40px" 21 | ] 22 | (makeLinks root dirs "/" []) 23 | 24 | 25 | makeLinks : String -> List String -> String -> List (Html msg) -> List (Html msg) 26 | makeLinks root dirs oldPath revAnchors = 27 | case dirs of 28 | dir :: otherDirs -> 29 | let 30 | newPath = 31 | oldPath ++ "/" ++ dir 32 | 33 | anchor = 34 | a [ href newPath ] [ text dir ] 35 | in 36 | makeLinks root otherDirs newPath (anchor :: revAnchors) 37 | 38 | [] -> 39 | let 40 | home = 41 | a [ href "/" 42 | , title root 43 | , style "display" "inherit" 44 | ] 45 | [ Icon.home 46 | ] 47 | in 48 | case revAnchors of 49 | [] -> 50 | [home] 51 | 52 | lastAnchor :: otherRevAnchors -> 53 | home :: slash :: List.foldl addSlash [lastAnchor] otherRevAnchors 54 | 55 | 56 | addSlash : Html msg -> List (Html msg) -> List (Html msg) 57 | addSlash front back = 58 | front :: slash :: back 59 | 60 | 61 | slash : Html msg 62 | slash = 63 | span [ style "padding" "0 8px" ] [ text "/" ] 64 | -------------------------------------------------------------------------------- /compiler/src/Elm/Header.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Header 3 | ( Tag(..) 4 | , parse 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.ByteString as B 10 | 11 | import qualified AST.Source as Src 12 | import qualified Elm.Compiler.Module as M 13 | import qualified Elm.Name as N 14 | import qualified Elm.Package as Pkg 15 | import qualified Parse.Primitives as Parser 16 | import qualified Parse.Module as Module 17 | import qualified Reporting.Annotation as A 18 | import qualified Reporting.Error as Error 19 | 20 | 21 | 22 | -- HEADER TAGS 23 | 24 | 25 | data Tag = Normal | Effect | Port 26 | 27 | 28 | 29 | -- PARSE 30 | 31 | 32 | parse :: Pkg.Name -> B.ByteString -> Either Error.Error (Maybe (Tag, M.Raw), [M.Raw]) 33 | parse pkgName sourceCode = 34 | let 35 | headerParser = 36 | Module.module_ pkgName (return ()) 37 | in 38 | case Parser.run headerParser sourceCode of 39 | Right (Src.Module header imports _) -> 40 | Right 41 | ( fmap simplifyHeader header 42 | , map getName imports 43 | ) 44 | 45 | Left err -> 46 | Left (Error.Syntax err) 47 | 48 | 49 | getName :: Src.Import -> N.Name 50 | getName (Src.Import (A.At _ name) _ _) = 51 | name 52 | 53 | 54 | 55 | -- TO HEADER 56 | 57 | 58 | simplifyHeader :: Src.Header -> (Tag, N.Name) 59 | simplifyHeader (Src.Header name effects _ _) = 60 | ( toTag effects, name ) 61 | 62 | 63 | toTag :: Src.Effects -> Tag 64 | toTag effects = 65 | case effects of 66 | Src.NoEffects -> 67 | Normal 68 | 69 | Src.Ports _ -> 70 | Port 71 | 72 | Src.Manager _ _ -> 73 | Effect 74 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-present, Evan Czaplicki 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Czaplicki nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Error.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Error 4 | ( Error(..) 5 | , toReports 6 | ) 7 | where 8 | 9 | 10 | import qualified Reporting.Error.Canonicalize as Canonicalize 11 | import qualified Reporting.Error.Docs as Docs 12 | import qualified Reporting.Error.Main as Main 13 | import qualified Reporting.Error.Pattern as Pattern 14 | import qualified Reporting.Error.Syntax as Syntax 15 | import qualified Reporting.Error.Type as Type 16 | import qualified Reporting.Render.Code as Code 17 | import qualified Reporting.Render.Type.Localizer as L 18 | import qualified Reporting.Report as Report 19 | 20 | 21 | 22 | -- ALL POSSIBLE ERRORS 23 | 24 | 25 | data Error 26 | = Syntax Syntax.Error 27 | | Canonicalize Canonicalize.Error 28 | | Type L.Localizer [Type.Error] 29 | | Main L.Localizer Main.Error 30 | | Pattern [Pattern.Error] 31 | | Docs Docs.Error 32 | 33 | 34 | 35 | -- TO REPORT 36 | 37 | 38 | toReports :: Code.Source -> Error -> [Report.Report] 39 | toReports source err = 40 | case err of 41 | Syntax syntaxError -> 42 | [Syntax.toReport source syntaxError] 43 | 44 | Canonicalize canonicalizeError -> 45 | [Canonicalize.toReport source canonicalizeError] 46 | 47 | Type localizer typeErrors -> 48 | map (Type.toReport source localizer) typeErrors 49 | 50 | Main localizer mainError -> 51 | [Main.toReport localizer source mainError] 52 | 53 | Pattern patternErrors -> 54 | map (Pattern.toReport source) patternErrors 55 | 56 | Docs docsError -> 57 | [Docs.toReport source docsError] 58 | -------------------------------------------------------------------------------- /compiler/src/Parse/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Parse.Parse 3 | ( program 4 | ) 5 | where 6 | 7 | 8 | import qualified Data.ByteString as B 9 | 10 | import qualified AST.Source as Src 11 | import qualified AST.Valid as Valid 12 | import qualified Elm.Package as Pkg 13 | import qualified Parse.Declaration as Decl 14 | import qualified Parse.Module as Module 15 | import qualified Parse.Primitives as P 16 | import qualified Reporting.Error.Syntax as Error 17 | import qualified Reporting.Result as Result 18 | import qualified Validate 19 | 20 | 21 | 22 | -- PROGRAM 23 | 24 | 25 | program :: Pkg.Name -> B.ByteString -> Result.Result i w Error.Error Valid.Module 26 | program pkg src = 27 | let 28 | bodyParser = 29 | if Pkg.isKernel pkg then 30 | chompDeclarations =<< chompInfixes [] 31 | else 32 | chompDeclarations [] 33 | 34 | parser = 35 | Module.module_ pkg bodyParser <* P.endOfFile 36 | in 37 | case P.run parser src of 38 | Right modul -> 39 | Validate.validate modul 40 | 41 | Left syntaxError -> 42 | Result.throw syntaxError 43 | 44 | 45 | 46 | -- CHOMP DECLARATIONS 47 | 48 | 49 | chompDeclarations :: [Src.Decl] -> P.Parser [Src.Decl] 50 | chompDeclarations decls = 51 | do (decl, _, pos) <- Decl.declaration 52 | P.oneOf 53 | [ do P.checkFreshLine pos 54 | chompDeclarations (decl:decls) 55 | , return (reverse (decl:decls)) 56 | ] 57 | 58 | 59 | chompInfixes :: [Src.Decl] -> P.Parser [Src.Decl] 60 | chompInfixes decls = 61 | P.oneOf 62 | [ do decl <- Decl.infix_ 63 | chompInfixes (decl:decls) 64 | , return decls 65 | ] 66 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Region.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Region 3 | ( Region(..) 4 | , Position(..) 5 | , zero 6 | , one 7 | , merge 8 | , encode 9 | ) 10 | where 11 | 12 | 13 | import qualified Json.Encode as Json 14 | import Data.Binary (Binary, get, put) 15 | 16 | 17 | 18 | -- REGION 19 | 20 | 21 | data Region = 22 | Region 23 | { _start :: !Position 24 | , _end :: !Position 25 | } 26 | deriving (Eq, Ord) 27 | 28 | 29 | data Position = 30 | Position 31 | { _line :: !Int 32 | , _column :: !Int 33 | } 34 | deriving (Eq, Ord) 35 | 36 | 37 | merge :: Region -> Region -> Region 38 | merge (Region start _) (Region _ end) = 39 | Region start end 40 | 41 | 42 | {-# NOINLINE zero #-} 43 | zero :: Region 44 | zero = 45 | Region (Position 0 0) (Position 0 0) 46 | 47 | 48 | {-# NOINLINE one #-} 49 | one :: Region 50 | one = 51 | Region (Position 1 1) (Position 1 1) 52 | 53 | 54 | 55 | -- JSON 56 | 57 | 58 | encode :: Region -> Json.Value 59 | encode (Region start end) = 60 | Json.object 61 | [ ("start", encodePosition start) 62 | , ("end", encodePosition end) 63 | ] 64 | 65 | 66 | encodePosition :: Position -> Json.Value 67 | encodePosition (Position line column) = 68 | Json.object 69 | [ ("line", Json.int line) 70 | , ("column", Json.int column) 71 | ] 72 | 73 | 74 | 75 | -- BINARY 76 | 77 | 78 | instance Binary Region where 79 | get = 80 | Region <$> get <*> get 81 | 82 | put (Region start end) = 83 | do put start 84 | put end 85 | 86 | 87 | instance Binary Position where 88 | get = 89 | Position <$> get <*> get 90 | 91 | put (Position line column) = 92 | do put line 93 | put column 94 | -------------------------------------------------------------------------------- /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Elm 2 | 3 | Thanks helping with the development of Elm! This document describes the basic 4 | standards for opening pull requests and making the review process as smooth as 5 | possible. 6 | 7 | ## Licensing 8 | 9 | You need to sign the [contributor agreement](ContributorAgreement.pdf) 10 | and send it to before opening your pull request. 11 | 12 | ## Style Guide 13 | 14 | * Haskell — conform to [these guidelines][haskell] 15 | * JavaScript — use [Google's JS style guide][js] 16 | 17 | [haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be 18 | [js]: https://google.github.io/styleguide/javascriptguide.xml 19 | 20 | ## Branches 21 | 22 | * [The master branch][master] is the home of the next release of the compiler 23 | so new features and improvements get merged there. Most pull requests 24 | should target this branch! 25 | 26 | * [The stable branch][stable] is for tagging releases and critical bug fixes. 27 | This branch is handy for folks who want to build the most recent public 28 | release from source. 29 | 30 | [master]: http://github.com/elm-lang/elm/tree/master 31 | [stable]: http://github.com/elm-lang/elm/tree/stable 32 | 33 | If you are working on a fairly large feature, we will probably want to merge it 34 | in as its own branch and do some testing before bringing it into the master 35 | branch. This way we can keep releases of the master branch independent of new 36 | features. 37 | 38 | Note that the master branch of the compiler should always be in sync with the 39 | master branch of the [website][], and the stable branch of the compiler should 40 | always be in sync with the stable branch of the [website][]. Make sure that 41 | your changes maintain this compatibility. 42 | 43 | [website]: https://github.com/elm-lang/elm-lang.org 44 | -------------------------------------------------------------------------------- /terminal/src/Develop/Generate/Help.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | module Develop.Generate.Help 5 | ( makePageHtml 6 | , makeCodeHtml 7 | ) 8 | where 9 | 10 | 11 | import qualified Data.ByteString.Builder as B 12 | import Data.Monoid ((<>)) 13 | import Text.RawString.QQ (r) 14 | 15 | import qualified Elm.Name as N 16 | import qualified Json.Encode as Encode 17 | 18 | 19 | 20 | -- PAGES 21 | 22 | 23 | makePageHtml :: N.Name -> Maybe Encode.Value -> B.Builder 24 | makePageHtml moduleName maybeFlags = 25 | [r| 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 36 | 37 | 38 | |] 39 | 40 | 41 | 42 | -- CODE 43 | 44 | 45 | makeCodeHtml :: FilePath -> B.Builder -> B.Builder 46 | makeCodeHtml title code = 47 | [r| 48 | 49 | 50 | 51 | |] <> B.stringUtf8 title <> [r| 52 | 57 | 58 | 59 | 60 | 61 | 62 | 
|] <> code <> [r|
63 | 64 | 65 | |] 66 | -------------------------------------------------------------------------------- /compiler/src/Data/Bag.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Data.Bag 3 | ( Bag(..) 4 | , empty 5 | , one 6 | , append 7 | , map 8 | , toList 9 | , fromList 10 | ) 11 | where 12 | 13 | 14 | import Prelude hiding (map) 15 | import qualified Data.List as List 16 | 17 | 18 | 19 | -- BAGS 20 | 21 | 22 | data Bag a 23 | = Empty 24 | | One a 25 | | Two (Bag a) (Bag a) 26 | 27 | 28 | 29 | -- HELPERS 30 | 31 | 32 | empty :: Bag a 33 | empty = 34 | Empty 35 | 36 | 37 | one :: a -> Bag a 38 | one = 39 | One 40 | 41 | 42 | append :: Bag a -> Bag a -> Bag a 43 | append left right = 44 | case (left, right) of 45 | (other, Empty) -> 46 | other 47 | 48 | (Empty, other) -> 49 | other 50 | 51 | (_, _) -> 52 | Two left right 53 | 54 | 55 | 56 | -- MAP 57 | 58 | 59 | map :: (a -> b) -> Bag a -> Bag b 60 | map func bag = 61 | case bag of 62 | Empty -> 63 | Empty 64 | 65 | One a -> 66 | One (func a) 67 | 68 | Two left right -> 69 | Two (map func left) (map func right) 70 | 71 | 72 | 73 | -- TO LIST 74 | 75 | 76 | toList :: Bag a -> [a] 77 | toList bag = 78 | toListHelp bag [] 79 | 80 | 81 | toListHelp :: Bag a -> [a] -> [a] 82 | toListHelp bag list = 83 | case bag of 84 | Empty -> 85 | list 86 | 87 | One x -> 88 | x : list 89 | 90 | Two a b -> 91 | toListHelp a (toListHelp b list) 92 | 93 | 94 | 95 | -- FROM LIST 96 | 97 | 98 | fromList :: (a -> b) -> [a] -> Bag b 99 | fromList func list = 100 | case list of 101 | [] -> 102 | Empty 103 | 104 | first : rest -> 105 | List.foldl' (add func) (One (func first)) rest 106 | 107 | 108 | add :: (a -> b) -> Bag b -> a -> Bag b 109 | add func bag value = 110 | Two (One (func value)) bag 111 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Report.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Reporting.Report 3 | ( Report(..) 4 | , toDoc 5 | , toCodeSnippet 6 | , toCodePair 7 | ) 8 | where 9 | 10 | 11 | import qualified Reporting.Doc as D 12 | import qualified Reporting.Region as R 13 | import qualified Reporting.Render.Code as Code 14 | 15 | 16 | 17 | -- BUILD REPORTS 18 | 19 | 20 | data Report = 21 | Report 22 | { _title :: String 23 | , _region :: R.Region 24 | , _sgstns :: [String] 25 | , _message :: D.Doc 26 | } 27 | 28 | 29 | toDoc :: FilePath -> Report -> D.Doc 30 | toDoc filePath (Report title _ _ message) = 31 | D.vcat 32 | [ messageBar title filePath 33 | , "" 34 | , message 35 | , "" 36 | ] 37 | 38 | 39 | messageBar :: String -> FilePath -> D.Doc 40 | messageBar title filePath = 41 | let 42 | usedSpace = 43 | 4 + length title + 1 + length filePath 44 | in 45 | D.dullcyan $ D.fromString $ 46 | "-- " ++ title 47 | ++ " " ++ replicate (max 1 (80 - usedSpace)) '-' 48 | ++ " " ++ filePath 49 | 50 | 51 | 52 | -- CODE FORMATTING 53 | 54 | 55 | toCodeSnippet :: Code.Source -> R.Region -> Maybe R.Region -> (D.Doc, D.Doc) -> D.Doc 56 | toCodeSnippet source region highlight (preHint, postHint) = 57 | D.vcat 58 | [ preHint 59 | , "" 60 | , Code.render source region highlight 61 | , postHint 62 | ] 63 | 64 | 65 | toCodePair :: Code.Source -> R.Region -> R.Region -> (D.Doc, D.Doc) -> (D.Doc, D.Doc, D.Doc) -> D.Doc 66 | toCodePair source r1 r2 (oneStart, oneEnd) (twoStart, twoMiddle, twoEnd) = 67 | case Code.renderPair source r1 r2 of 68 | Code.OneLine codeDocs -> 69 | D.vcat 70 | [ oneStart 71 | , "" 72 | , codeDocs 73 | , oneEnd 74 | ] 75 | 76 | Code.TwoChunks code1 code2 -> 77 | D.vcat 78 | [ twoStart 79 | , "" 80 | , code1 81 | , twoMiddle 82 | , "" 83 | , code2 84 | , twoEnd 85 | ] 86 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Elm.Compiler.Imports 4 | ( addDefaults 5 | ) 6 | where 7 | 8 | 9 | import qualified AST.Source as Src 10 | import qualified AST.Module.Name as Module 11 | import qualified Elm.Name as N 12 | import qualified Elm.Package as Pkg 13 | import qualified Reporting.Annotation as A 14 | import qualified Reporting.Region as R 15 | 16 | 17 | 18 | -- ADD DEFAULTS 19 | 20 | 21 | addDefaults :: Pkg.Name -> [Src.Import] -> [Src.Import] 22 | addDefaults pkgName imports = 23 | if pkgName == Pkg.core 24 | then imports 25 | else defaults ++ imports 26 | 27 | 28 | 29 | -- DEFAULTS 30 | 31 | 32 | defaults :: [Src.Import] 33 | defaults = 34 | [ import_ Module.basics Nothing Src.Open 35 | , import_ Module.debug Nothing closed 36 | , import_ Module.list Nothing (operator "::") 37 | , import_ Module.maybe Nothing (typeOpen N.maybe) 38 | , import_ Module.result Nothing (typeOpen N.result) 39 | , import_ Module.string Nothing (typeClosed N.string) 40 | , import_ Module.char Nothing (typeClosed N.char) 41 | , import_ Module.tuple Nothing closed 42 | , import_ Module.platform Nothing (typeClosed N.program) 43 | , import_ Module.cmd (Just N.cmd) (typeClosed N.cmd) 44 | , import_ Module.sub (Just N.sub) (typeClosed N.sub) 45 | ] 46 | 47 | 48 | import_ :: Module.Canonical -> Maybe N.Name -> Src.Exposing -> Src.Import 49 | import_ (Module.Canonical _ name) maybeAlias exposing = 50 | Src.Import (A.At R.zero name) maybeAlias exposing 51 | 52 | 53 | 54 | -- EXPOSING 55 | 56 | 57 | closed :: Src.Exposing 58 | closed = 59 | Src.Explicit [] 60 | 61 | 62 | typeOpen :: N.Name -> Src.Exposing 63 | typeOpen name = 64 | Src.Explicit [ A.At R.zero (Src.Upper name Src.Public) ] 65 | 66 | 67 | typeClosed :: N.Name -> Src.Exposing 68 | typeClosed name = 69 | Src.Explicit [ A.At R.zero (Src.Upper name Src.Private) ] 70 | 71 | 72 | operator :: N.Name -> Src.Exposing 73 | operator op = 74 | Src.Explicit [ A.At R.zero (Src.Operator op) ] 75 | -------------------------------------------------------------------------------- /installers/npm/bin/elm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | 3 | // This file exists for the benefit of npm users who have --ignore-scripts 4 | // enabled. (Enabling this flag globally is a good security measure.) 5 | // Since they won't run the post-install hook, the binaries won't be downloaded 6 | // and installed. 7 | // 8 | // Since this file is included in "bin" in package.json, npm will install 9 | // it automatically in a place that should be on the PATH. All the file does 10 | // is to download the appropriate binary (just like the post-install hook would 11 | // have), replace this file with that binary, and run the binary. 12 | // 13 | // In this way, the first time a user with --ignore-scripts enabled runs this 14 | // binary, it will download and install itself, and then run as normal. From 15 | // then on, it will run as normal without re-downloading. 16 | 17 | var install = require("..").install; 18 | var child_process = require("child_process"); 19 | var path = require("path"); 20 | var fs = require("fs"); 21 | 22 | // Make sure we get the right path even if we're executing from the symlinked 23 | // node_modules/.bin/ executable 24 | var interpreter = fs.realpathSync(process.argv[0]); 25 | var targetPath = fs.realpathSync(process.argv[1]); 26 | 27 | // Figure out the binary name as we'll eventually want to execute 28 | // this. Re-executing this script doesn't always work because of varying 29 | // permissions and modes of operation across platforms (for example, Windows has 30 | // some interesting edge cases here.) 31 | var binaryName = path.join( 32 | __dirname, 33 | "..", 34 | "unpacked_bin", 35 | path.basename(targetPath) 36 | ); 37 | if (process.platform === "win") { 38 | binaryName += ".exe"; 39 | } 40 | 41 | // cd into the directory above bin/ so install() puts bin/ in the right place. 42 | process.chdir(path.join(path.dirname(targetPath), "..")); 43 | 44 | install(process.platform, process.arch).then(function() { 45 | child_process 46 | .spawn(binaryName, process.argv.slice(2), { stdio: "inherit" }) 47 | .on("exit", process.exit); 48 | }); 49 | -------------------------------------------------------------------------------- /compiler/src/Type/Instantiate.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Type.Instantiate 4 | ( FreeVars 5 | , fromSrcType 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.Map.Strict as Map 11 | import Data.Map.Strict ((!)) 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified Elm.Name as N 15 | import Type.Type 16 | 17 | 18 | 19 | -- FREE VARS 20 | 21 | 22 | type FreeVars = 23 | Map.Map N.Name Type 24 | 25 | 26 | 27 | -- FROM SOURCE TYPE 28 | 29 | 30 | fromSrcType :: Map.Map N.Name Type -> Can.Type -> IO Type 31 | fromSrcType freeVars sourceType = 32 | case sourceType of 33 | Can.TLambda arg result -> 34 | FunN 35 | <$> fromSrcType freeVars arg 36 | <*> fromSrcType freeVars result 37 | 38 | Can.TVar name -> 39 | return (freeVars ! name) 40 | 41 | Can.TType home name args -> 42 | AppN home name <$> traverse (fromSrcType freeVars) args 43 | 44 | Can.TAlias home name args aliasedType -> 45 | do targs <- traverse (traverse (fromSrcType freeVars)) args 46 | AliasN home name targs <$> 47 | case aliasedType of 48 | Can.Filled realType -> 49 | fromSrcType freeVars realType 50 | 51 | Can.Holey realType -> 52 | fromSrcType (Map.fromList targs) realType 53 | 54 | Can.TTuple a b maybeC -> 55 | TupleN 56 | <$> fromSrcType freeVars a 57 | <*> fromSrcType freeVars b 58 | <*> traverse (fromSrcType freeVars) maybeC 59 | 60 | Can.TUnit -> 61 | return UnitN 62 | 63 | Can.TRecord fields maybeExt -> 64 | RecordN 65 | <$> traverse (fromSrcFieldType freeVars) fields 66 | <*> 67 | case maybeExt of 68 | Nothing -> 69 | return EmptyRecordN 70 | 71 | Just ext -> 72 | return (freeVars ! ext) 73 | 74 | 75 | fromSrcFieldType :: Map.Map N.Name Type -> Can.FieldType -> IO Type 76 | fromSrcFieldType freeVars (Can.FieldType _ tipe) = 77 | fromSrcType freeVars tipe 78 | -------------------------------------------------------------------------------- /terminal/src/Terminal/Args/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module Terminal.Args.Internal 3 | ( Interface(..) 4 | , toName 5 | , Summary(..) 6 | , Flags(..) 7 | , Flag(..) 8 | , Parser(..) 9 | , Args(..) 10 | , CompleteArgs(..) 11 | , RequiredArgs(..) 12 | ) 13 | where 14 | 15 | 16 | import Text.PrettyPrint.ANSI.Leijen (Doc) 17 | 18 | 19 | 20 | -- INTERFACE 21 | 22 | 23 | data Interface where 24 | Interface 25 | :: String 26 | -> Summary 27 | -> String 28 | -> Doc 29 | -> Args args 30 | -> Flags flags 31 | -> (args -> flags -> IO ()) 32 | -> Interface 33 | 34 | 35 | toName :: Interface -> String 36 | toName (Interface name _ _ _ _ _ _) = 37 | name 38 | 39 | 40 | 41 | {-| The information that shows when you run the executable with no arguments. 42 | If you say it is `Common`, you need to tell people what it does. Try to keep 43 | it to two or three lines. If you say it is `Uncommon` you can rely on `Details` 44 | for a more complete explanation. 45 | -} 46 | data Summary = Common String | Uncommon 47 | 48 | 49 | 50 | -- FLAGS 51 | 52 | 53 | data Flags a where 54 | FDone :: a -> Flags a 55 | FMore :: Flags (a -> b) -> Flag a -> Flags b 56 | 57 | 58 | data Flag a where 59 | Flag :: String -> Parser a -> String -> Flag (Maybe a) 60 | OnOff :: String -> String -> Flag Bool 61 | 62 | 63 | 64 | -- PARSERS 65 | 66 | 67 | data Parser a = 68 | Parser 69 | { _singular :: String 70 | , _plural :: String 71 | , _parser :: String -> Maybe a 72 | , _suggest :: String -> IO [String] 73 | , _examples :: String -> IO [String] 74 | } 75 | 76 | 77 | 78 | -- ARGS 79 | 80 | 81 | newtype Args a = 82 | Args [CompleteArgs a] 83 | 84 | 85 | data CompleteArgs args where 86 | Exactly :: RequiredArgs args -> CompleteArgs args 87 | Multiple :: RequiredArgs ([a] -> args) -> Parser a -> CompleteArgs args 88 | Optional :: RequiredArgs (Maybe a -> args) -> Parser a -> CompleteArgs args 89 | 90 | 91 | data RequiredArgs a where 92 | Done :: a -> RequiredArgs a 93 | Required :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b 94 | -------------------------------------------------------------------------------- /compiler/src/Parse/Primitives/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | module Parse.Primitives.Shader 4 | ( block 5 | , failure 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.ByteString.Internal as B 11 | import qualified Data.Text as Text 12 | import qualified Data.Text.Encoding as Text 13 | import Foreign.ForeignPtr (ForeignPtr) 14 | import GHC.Word (Word8) 15 | 16 | import Parse.Primitives.Internals (Parser(..), State(..), noError) 17 | import qualified Parse.Primitives.Internals as I 18 | import qualified Parse.Primitives.Symbol as Symbol 19 | import qualified Reporting.Error.Syntax as E 20 | 21 | 22 | 23 | -- SHADER 24 | 25 | 26 | failure :: Int -> Int -> Text.Text -> Parser a 27 | failure row col msg = 28 | Parser $ \_ _ cerr _ _ -> 29 | cerr (E.ParseError row col (E.BadShader msg)) 30 | 31 | 32 | block :: Parser Text.Text 33 | block = 34 | do Symbol.shaderBlockOpen 35 | Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ -> 36 | case eatShader fp offset terminal row col of 37 | Err -> 38 | cerr (E.ParseError row col E.EndOfFile_Shader) 39 | 40 | Ok newOffset newRow newCol -> 41 | let 42 | !size = newOffset - offset 43 | !shader = Text.decodeUtf8 (B.PS fp offset size) 44 | !newState = State fp (newOffset + 2) terminal indent newRow newCol ctx 45 | in 46 | cok shader newState noError 47 | 48 | 49 | data Result 50 | = Err 51 | | Ok Int Int Int 52 | 53 | 54 | eatShader :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result 55 | eatShader fp offset terminal row col = 56 | if offset >= terminal then 57 | Err 58 | 59 | else 60 | let !word = I.unsafeIndex fp offset in 61 | if word == 0x007C {- | -} && I.isWord fp (offset + 1) terminal 0x5D {- ] -} then 62 | Ok offset row (col + 2) 63 | 64 | else if word == 0x0A {- \n -} then 65 | eatShader fp (offset + 1) terminal (row + 1) 1 66 | 67 | else 68 | let !newOffset = offset + I.getCharWidth fp offset terminal word in 69 | eatShader fp newOffset terminal row (col + 1) 70 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Module.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Elm.Compiler.Module 4 | -- interfaces 5 | ( I.Interface 6 | , I.Interfaces 7 | 8 | -- module names 9 | , Raw 10 | , nameToString 11 | , nameToSlashPath 12 | , nameToHyphenPath 13 | , fromHyphenPath 14 | , encode 15 | , decoder 16 | 17 | -- canonical names 18 | , ModuleName.Canonical(..) 19 | ) 20 | where 21 | 22 | 23 | import qualified Data.Char as Char 24 | import qualified Data.List as List 25 | import qualified Data.Text as Text 26 | import System.FilePath (()) 27 | 28 | import qualified AST.Module.Name as ModuleName 29 | import qualified Elm.Interface as I 30 | import qualified Elm.Name as N 31 | import qualified Json.Decode as Decode 32 | import qualified Json.Encode as Encode 33 | 34 | 35 | 36 | -- NAMES 37 | 38 | 39 | type Raw = N.Name 40 | 41 | 42 | nameToString :: Raw -> String 43 | nameToString = 44 | N.toString 45 | 46 | 47 | nameToSlashPath :: Raw -> FilePath 48 | nameToSlashPath name = 49 | List.foldl1 () (map Text.unpack (Text.splitOn "." (N.toText name))) 50 | 51 | 52 | nameToHyphenPath :: Raw -> FilePath 53 | nameToHyphenPath name = 54 | Text.unpack (Text.replace "." "-" (N.toText name)) 55 | 56 | 57 | fromHyphenPath :: Text.Text -> Maybe Raw 58 | fromHyphenPath txt = 59 | if all isGoodChunk (Text.splitOn "-" txt) 60 | then Just (N.fromText (Text.replace "-" "." txt)) 61 | else Nothing 62 | 63 | 64 | 65 | -- JSON 66 | 67 | 68 | encode :: Raw -> Encode.Value 69 | encode = 70 | Encode.name 71 | 72 | 73 | decoder :: Decode.Decoder Text.Text Raw 74 | decoder = 75 | do txt <- Decode.text 76 | let chunks = Text.splitOn "." txt 77 | if all isGoodChunk chunks 78 | then Decode.succeed (N.fromText txt) 79 | else Decode.fail txt 80 | 81 | 82 | isGoodChunk :: Text.Text -> Bool 83 | isGoodChunk chunk = 84 | case Text.uncons chunk of 85 | Nothing -> 86 | False 87 | 88 | Just (first, rest) -> 89 | Char.isUpper first && Text.all isGoodChar rest 90 | 91 | 92 | isGoodChar :: Char -> Bool 93 | isGoodChar char = 94 | Char.isAlphaNum char || char == '_' 95 | 96 | 97 | -------------------------------------------------------------------------------- /compiler/src/Type/Occurs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Type.Occurs 4 | ( occurs 5 | ) 6 | where 7 | 8 | 9 | import Data.Foldable (foldrM) 10 | import qualified Data.Map.Strict as Map 11 | 12 | import Type.Type as Type 13 | import qualified Type.UnionFind as UF 14 | 15 | 16 | 17 | -- OCCURS 18 | 19 | 20 | occurs :: Type.Variable -> IO Bool 21 | occurs var = 22 | occursHelp [] var False 23 | 24 | 25 | occursHelp :: [Type.Variable] -> Type.Variable -> Bool -> IO Bool 26 | occursHelp seen var foundCycle = 27 | if elem var seen then 28 | return True 29 | 30 | else 31 | do (Descriptor content _ _ _) <- UF.get var 32 | case content of 33 | FlexVar _ -> 34 | return foundCycle 35 | 36 | FlexSuper _ _ -> 37 | return foundCycle 38 | 39 | RigidVar _ -> 40 | return foundCycle 41 | 42 | RigidSuper _ _ -> 43 | return foundCycle 44 | 45 | Structure term -> 46 | let newSeen = var : seen in 47 | case term of 48 | App1 _ _ args -> 49 | foldrM (occursHelp newSeen) foundCycle args 50 | 51 | Fun1 a b -> 52 | occursHelp newSeen a =<< 53 | occursHelp newSeen b foundCycle 54 | 55 | EmptyRecord1 -> 56 | return foundCycle 57 | 58 | Record1 fields ext -> 59 | occursHelp newSeen ext =<< 60 | foldrM (occursHelp newSeen) foundCycle (Map.elems fields) 61 | 62 | Unit1 -> 63 | return foundCycle 64 | 65 | Tuple1 a b maybeC -> 66 | case maybeC of 67 | Nothing -> 68 | occursHelp newSeen a =<< 69 | occursHelp newSeen b foundCycle 70 | 71 | Just c -> 72 | occursHelp newSeen a =<< 73 | occursHelp newSeen b =<< 74 | occursHelp newSeen c foundCycle 75 | 76 | Alias _ _ args _ -> 77 | foldrM (occursHelp (var:seen)) foundCycle (map snd args) 78 | 79 | Error -> 80 | return foundCycle 81 | -------------------------------------------------------------------------------- /docs/elm.json/application.md: -------------------------------------------------------------------------------- 1 | # `elm.json` for applications 2 | 3 | This is a decent baseline for pretty much any applications made with Elm. You will need these dependencies or more. 4 | 5 | ```json 6 | { 7 | "type": "application", 8 | "source-directories": [ 9 | "src" 10 | ], 11 | "elm-version": "0.19.0", 12 | "dependencies": { 13 | "direct": { 14 | "elm/browser": "1.0.0", 15 | "elm/core": "1.0.0", 16 | "elm/html": "1.0.0", 17 | "elm/json": "1.0.0" 18 | }, 19 | "indirect": { 20 | "elm/time": "1.0.0", 21 | "elm/url": "1.0.0", 22 | "elm/virtual-dom": "1.0.0" 23 | } 24 | }, 25 | "test-dependencies": { 26 | "direct": {}, 27 | "indirect": {} 28 | } 29 | } 30 | ``` 31 | 32 |
33 | 34 | 35 | ## `"type"` 36 | 37 | Either `"application"` or `"package"`. All the other fields are based on this choice! 38 | 39 |
40 | 41 | 42 | ## `"source-directories"` 43 | 44 | A list of directories where Elm code lives. Most projects just use `"src"` for everything. 45 | 46 |
47 | 48 | 49 | ## `"elm-version"` 50 | 51 | The exact version of Elm this builds with. Should be `"0.19.0"` for most people! 52 | 53 |
54 | 55 | 56 | ## `"dependencies"` 57 | 58 | All the packages you depend upon. We use exact versions, so your `elm.json` file doubles as a "lock file" that ensures reliable builds. 59 | 60 | You can use modules from any `"direct"` dependency in your code. Some `"direct"` dependencies have their own dependencies that folks typically do not care about. These are the `"indirect"` dependencies. They are listed explicitly so that (1) builds are reproducible and (2) you can easily review the quantity and quality of dependencies. 61 | 62 | **Note:** We plan to eventually have a screen in `reactor` that helps add, remove, and upgrade packages. It can sometimes be tricky to keep all of the constraints happy, so we think having a UI will help a lot. If you get into trouble in the meantime, adding things back one-by-one often helps, and I hope you do not get into trouble! 63 | 64 |
65 | 66 | 67 | ## `"test-dependencies"` 68 | 69 | All the packages that you use in `tests/` with `elm-test` but not in the application you actually want to ship. This also uses exact versions to make tests more reliable. 70 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The Elm Compiler 2 | 3 | Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/). 4 | 5 | This is a fork of the Elm Compiler maintained by CurrySoftware GmbH. 6 | We merged a few bug fixes by the community and also expanded the reactor. 7 | 8 | ## Build 9 | 10 | With Stack: 11 | 12 | 1. Install Stack (https://www.haskellstack.org) 13 | 2. Clone the repo 14 | 3. `cd compiler` 15 | 4. `stack init` 16 | 5. `stack build` 17 | 18 | 19 | ## Install 20 | 21 | 22 | The built Elm executable will reside inside `.stack-work/dist///build/elm/elm`. 23 | To install it link or copy it to the `/usr/bin/` folder. 24 | 25 | For example: 26 | 27 | `copy .stack-work/dist/x86_64-linux-tinfo6/Cabal-2.0.1.0/build/elm/elm /usr/bin/elm-dev` 28 | 29 | or 30 | `ln -s .stack-work/dist/x86_64-linux-tinfo6/Cabal-2.0.1.0/build/elm/elm /usr/bin/elm-dev` 31 | 32 | 33 | ## Using the new Features in Elm Reactor 34 | 35 | This Elm-fork contains two new features in the Elm reactor: 36 | 37 | 1. The reactor can now emit compiled JavaScript instead of Html with the `output=js` parameter: 38 | 39 | ```html 40 | 41 | ``` 42 | 43 | 2. The reactor can now emit code compiled in debug mode with the `debug=true` parameter: 44 | 45 | `http://localhost:8000/src/Main.elm?debug=true` 46 | 47 | or in combination with JavaScript output: 48 | ```html 49 | 50 | ``` 51 | 52 | 53 | For a working example check out [elm-reactor-example](https://github.com/CurrySoftware/elm-reactor-example). 54 | 55 | 56 | ## Future 57 | 58 | We are currently exploring the idea of building a private Elm package repository to facilitate usage of Elm in corporate environments. 59 | 60 | Currently, it is not possible to use either local packages or another package repository than `package.elm-lang.org`. 61 | 62 | We want to change that! 63 | 64 | If you are a corporate Elm-user and want to support us or if you are interested in a closed beta please contact us through [elm@curry-software.com](mailto:elm@curry-software.com). 65 | 66 | ## Support 67 | 68 | Please contact [elm@curry-software.com](mailto:elm@curry-software.com) for support. 69 | 70 | We also offer [Elm Consulting Services](https://www.curry-software.com/en/elm-services/) for general help with Elm. 71 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Elm.Compiler 3 | ( version 4 | , Compile.DocsFlag(..) 5 | , Compile.Artifacts(..) 6 | , compile 7 | , Error.Error 8 | , errorsToDoc 9 | , errorsToJson 10 | , Warning.Warning 11 | ) 12 | where 13 | 14 | 15 | import qualified Data.ByteString as BS 16 | import qualified Data.Map as Map 17 | import qualified Data.Text as Text 18 | 19 | import qualified Compile 20 | import qualified Elm.Compiler.Module as M 21 | import qualified Elm.Compiler.Version 22 | import qualified Elm.Package as Pkg 23 | import qualified Json.Encode as Encode 24 | import qualified Reporting.Doc as D 25 | import qualified Reporting.Error as Error 26 | import qualified Reporting.Render.Code as Code 27 | import qualified Reporting.Region as Region 28 | import qualified Reporting.Report as Report 29 | import qualified Reporting.Result as Result 30 | import qualified Reporting.Warning as Warning 31 | 32 | 33 | 34 | -- VERSION 35 | 36 | 37 | version :: Pkg.Version 38 | version = 39 | Elm.Compiler.Version.version 40 | 41 | 42 | 43 | -- COMPILE 44 | 45 | 46 | compile 47 | :: Compile.DocsFlag 48 | -> Pkg.Name 49 | -> Map.Map M.Raw M.Canonical 50 | -> M.Interfaces 51 | -> BS.ByteString 52 | -> ( [Warning.Warning], Either [Error.Error] Compile.Artifacts ) 53 | compile docsFlag pkg importDict interfaces source = 54 | Result.run $ Compile.compile docsFlag pkg importDict interfaces source 55 | 56 | 57 | 58 | -- ERRORS TO DOC 59 | 60 | 61 | errorsToDoc :: FilePath -> Text.Text -> [Error.Error] -> D.Doc 62 | errorsToDoc filePath source errors = 63 | let 64 | reports = 65 | concatMap (Error.toReports (Code.toSource source)) errors 66 | in 67 | D.vcat $ map (Report.toDoc filePath) reports 68 | 69 | 70 | 71 | -- ERRORS TO JSON 72 | 73 | 74 | errorsToJson :: M.Raw -> FilePath -> Text.Text -> [Error.Error] -> Encode.Value 75 | errorsToJson moduleName filePath source errors = 76 | let 77 | reports = 78 | concatMap (Error.toReports (Code.toSource source)) errors 79 | in 80 | Encode.object 81 | [ ("path", Encode.text (Text.pack filePath)) 82 | , ("name", Encode.name moduleName) 83 | , ("problems", Encode.array (map reportToJson reports)) 84 | ] 85 | 86 | 87 | reportToJson :: Report.Report -> Encode.Value 88 | reportToJson (Report.Report title region _sgstns message) = 89 | Encode.object 90 | [ ("title", Encode.text (Text.pack title)) 91 | , ("region", Region.encode region) 92 | , ("message", D.encode message) 93 | ] -------------------------------------------------------------------------------- /terminal/src/Make.hs: -------------------------------------------------------------------------------- 1 | module Make 2 | ( Flags(..) 3 | , run 4 | , ReportType(..) 5 | , reportType 6 | , docsFile 7 | ) 8 | where 9 | 10 | 11 | import qualified System.FilePath as FP 12 | 13 | import qualified Elm.Project as Project 14 | import qualified Generate.Output as Output 15 | import qualified Reporting.Exit as Exit 16 | import qualified Reporting.Exit.Make as E 17 | import qualified Reporting.Task as Task 18 | import qualified Reporting.Progress as Progress 19 | import qualified Reporting.Progress.Json as Json 20 | import qualified Reporting.Progress.Terminal as Terminal 21 | import Terminal.Args (Parser(..)) 22 | 23 | 24 | 25 | -- RUN 26 | 27 | 28 | data Flags = 29 | Flags 30 | { _debug :: Bool 31 | , _optimize :: Bool 32 | , _output :: Maybe Output.Output 33 | , _report :: Maybe ReportType 34 | , _docs :: Maybe FilePath 35 | } 36 | 37 | 38 | run :: [FilePath] -> Flags -> IO () 39 | run paths (Flags debug optimize output report docs) = 40 | do reporter <- toReporter report 41 | Task.run reporter $ 42 | do mode <- toMode debug optimize 43 | summary <- Project.getRoot 44 | Project.compile mode Output.Client output docs summary paths 45 | 46 | 47 | toMode :: Bool -> Bool -> Task.Task Output.Mode 48 | toMode debug optimize = 49 | case (debug, optimize) of 50 | (True , True ) -> Task.throw $ Exit.Make E.CannotOptimizeAndDebug 51 | (False, True ) -> return Output.Prod 52 | (False, False) -> return Output.Dev 53 | (True , False) -> return Output.Debug 54 | 55 | 56 | toReporter :: Maybe ReportType -> IO Progress.Reporter 57 | toReporter report = 58 | case report of 59 | Nothing -> Terminal.create 60 | Just Json -> return Json.reporter 61 | 62 | 63 | 64 | -- REPORT 65 | 66 | 67 | data ReportType 68 | = Json 69 | 70 | 71 | reportType :: Parser ReportType 72 | reportType = 73 | Parser 74 | { _singular = "report type" 75 | , _plural = "report types" 76 | , _parser = \string -> if string == "json" then Just Json else Nothing 77 | , _suggest = \_ -> return ["json"] 78 | , _examples = \_ -> return ["json"] 79 | } 80 | 81 | 82 | 83 | -- DOCS 84 | 85 | 86 | docsFile :: Parser FilePath 87 | docsFile = 88 | Parser 89 | { _singular = "json file" 90 | , _plural = "json files" 91 | , _parser = \string -> if FP.takeExtension string == ".json" then Just string else Nothing 92 | , _suggest = \_ -> return [] 93 | , _examples = \_ -> return ["docs.json","documentation.json"] 94 | } 95 | -------------------------------------------------------------------------------- /compiler/src/Generate/JavaScript/Mode.hs: -------------------------------------------------------------------------------- 1 | module Generate.JavaScript.Mode 2 | ( Mode(..) 3 | , Target(..) 4 | , debug 5 | , dev 6 | , prod 7 | , isDebug 8 | , isServer 9 | ) 10 | where 11 | 12 | 13 | import qualified Data.List as List 14 | import qualified Data.Map as Map 15 | import qualified Data.Maybe as Maybe 16 | 17 | import qualified AST.Optimized as Opt 18 | import qualified Elm.Interface as I 19 | import qualified Elm.Name as N 20 | import qualified Generate.JavaScript.Name as Name 21 | 22 | 23 | 24 | -- MODE 25 | 26 | 27 | data Mode 28 | = Dev Target (Maybe I.Interfaces) 29 | | Prod Target ShortFieldNames 30 | 31 | 32 | data Target = Client | Server 33 | 34 | 35 | debug :: Target -> I.Interfaces -> Mode 36 | debug target interfaces = 37 | Dev target (Just interfaces) 38 | 39 | 40 | dev :: Target -> Mode 41 | dev target = 42 | Dev target Nothing 43 | 44 | 45 | prod :: Target -> Opt.Graph -> Mode 46 | prod target (Opt.Graph _ _ fieldCounts) = 47 | Prod target (shortenFieldNames fieldCounts) 48 | 49 | 50 | 51 | -- IS DEBUG? 52 | 53 | 54 | isDebug :: Mode -> Bool 55 | isDebug mode = 56 | case mode of 57 | Dev _ mi -> Maybe.isJust mi 58 | Prod _ _ -> False 59 | 60 | 61 | -- IS SERVER? 62 | 63 | 64 | isServer :: Mode -> Bool 65 | isServer mode = 66 | case mode of 67 | Dev target _ -> isServerHelp target 68 | Prod target _ -> isServerHelp target 69 | 70 | 71 | isServerHelp :: Target -> Bool 72 | isServerHelp target = 73 | case target of 74 | Client -> False 75 | Server -> True 76 | 77 | 78 | 79 | -- SHORTEN FIELD NAMES 80 | 81 | 82 | type ShortFieldNames = 83 | Map.Map N.Name Name.Name 84 | 85 | 86 | shortenFieldNames :: Map.Map N.Name Int -> ShortFieldNames 87 | shortenFieldNames frequencies = 88 | Map.foldr addToShortNames Map.empty $ 89 | Map.foldrWithKey addToBuckets Map.empty frequencies 90 | 91 | 92 | addToBuckets :: N.Name -> Int -> Map.Map Int [N.Name] -> Map.Map Int [N.Name] 93 | addToBuckets field frequency buckets = 94 | -- TODO try using an IntMap for buckets 95 | Map.insertWith (++) frequency [field] buckets 96 | 97 | 98 | addToShortNames :: [N.Name] -> ShortFieldNames -> ShortFieldNames 99 | addToShortNames fields shortNames = 100 | List.foldl' addField shortNames fields 101 | 102 | 103 | addField :: ShortFieldNames -> N.Name -> ShortFieldNames 104 | addField shortNames field = 105 | let rename = Name.fromInt (Map.size shortNames) in 106 | Map.insert field rename shortNames 107 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Objects.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Compiler.Objects 3 | ( JS.Output(..) 4 | , JS.generate 5 | , JS.generateForRepl 6 | , Opt.Graph 7 | , empty 8 | , union 9 | , unions 10 | , Kernel(..) 11 | , fromKernels 12 | ) 13 | where 14 | 15 | 16 | import qualified Data.List as List 17 | import qualified Data.Map as Map 18 | 19 | import qualified AST.Optimized as Opt 20 | import qualified AST.Module.Name as ModuleName 21 | import qualified Elm.Name as N 22 | import qualified Elm.Package as Pkg 23 | import qualified Generate.JavaScript as JS 24 | 25 | 26 | 27 | -- COMBINE GRAPHS 28 | 29 | 30 | {-# NOINLINE empty #-} 31 | empty :: Opt.Graph 32 | empty = 33 | Opt.Graph Map.empty Map.empty Map.empty 34 | 35 | 36 | union :: Opt.Graph -> Opt.Graph -> Opt.Graph 37 | union (Opt.Graph mains1 graph1 fields1) (Opt.Graph mains2 graph2 fields2) = 38 | Opt.Graph 39 | (Map.union mains1 mains2) 40 | (Map.union graph1 graph2) 41 | (Map.union fields1 fields2) 42 | 43 | 44 | unions :: [Opt.Graph] -> Opt.Graph 45 | unions graphs = 46 | case graphs of 47 | [] -> 48 | empty 49 | 50 | g:gs -> 51 | List.foldl' union g gs 52 | 53 | 54 | 55 | -- KERNEL GRAPHS 56 | 57 | 58 | data Kernel = 59 | Kernel 60 | { _client :: Opt.KContent 61 | , _server :: Maybe Opt.KContent 62 | } 63 | 64 | 65 | fromKernels :: Map.Map N.Name Kernel -> Opt.Graph 66 | fromKernels kernels = 67 | Opt.Graph 68 | Map.empty 69 | (Map.mapKeys toGlobal (Map.map toNode kernels)) 70 | (Map.foldl' addKernel Map.empty kernels) 71 | 72 | 73 | 74 | -- KERNEL TO NODES 75 | 76 | 77 | toGlobal :: N.Name -> Opt.Global 78 | toGlobal home = 79 | Opt.Global (ModuleName.Canonical Pkg.kernel (ModuleName.getKernel home)) N.dollar 80 | 81 | 82 | toNode :: Kernel -> Opt.Node 83 | toNode (Kernel client server) = 84 | Opt.Kernel client server 85 | 86 | 87 | 88 | -- KERNEL TO ELM FIELDS 89 | 90 | 91 | addKernel :: Map.Map N.Name Int -> Kernel -> Map.Map N.Name Int 92 | addKernel fields (Kernel client maybeServer) = 93 | addContent (maybe fields (addContent fields) maybeServer) client 94 | 95 | 96 | addContent :: Map.Map N.Name Int -> Opt.KContent -> Map.Map N.Name Int 97 | addContent fields (Opt.KContent chunks _) = 98 | List.foldl' addChunk fields chunks 99 | 100 | 101 | addChunk :: Map.Map N.Name Int -> Opt.KChunk -> Map.Map N.Name Int 102 | addChunk fields chunk = 103 | case chunk of 104 | Opt.ElmField name -> 105 | Map.insertWith (+) name 1 fields 106 | 107 | _ -> 108 | fields 109 | -------------------------------------------------------------------------------- /terminal/src/Develop/StaticFiles.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | module Develop.StaticFiles 5 | ( lookup 6 | , cssPath 7 | , elmPath 8 | , waitingPath 9 | ) 10 | where 11 | 12 | import Prelude hiding (lookup) 13 | import qualified Data.ByteString as BS 14 | import Data.FileEmbed (bsToExp) 15 | import qualified Data.HashMap.Strict as HM 16 | import Language.Haskell.TH (runIO) 17 | import System.FilePath (()) 18 | 19 | import qualified Develop.StaticFiles.Build as Build 20 | 21 | 22 | 23 | -- FILE LOOKUP 24 | 25 | 26 | type MimeType = 27 | BS.ByteString 28 | 29 | 30 | lookup :: FilePath -> Maybe (BS.ByteString, MimeType) 31 | lookup path = 32 | HM.lookup path dict 33 | 34 | 35 | dict :: HM.HashMap FilePath (BS.ByteString, MimeType) 36 | dict = 37 | HM.fromList 38 | [ faviconPath ==> (favicon , "image/x-icon") 39 | , waitingPath ==> (waiting , "image/gif") 40 | , elmPath ==> (elm , "application/javascript") 41 | , cssPath ==> (css , "text/css") 42 | , codeFontPath ==> (codeFont, "font/ttf") 43 | , sansFontPath ==> (sansFont, "font/ttf") 44 | ] 45 | 46 | 47 | (==>) :: a -> b -> (a,b) 48 | (==>) a b = 49 | (a, b) 50 | 51 | 52 | 53 | -- PATHS 54 | 55 | 56 | faviconPath :: FilePath 57 | faviconPath = 58 | "favicon.ico" 59 | 60 | 61 | waitingPath :: FilePath 62 | waitingPath = 63 | "_elm" "waiting.gif" 64 | 65 | 66 | elmPath :: FilePath 67 | elmPath = 68 | "_elm" "elm.js" 69 | 70 | 71 | cssPath :: FilePath 72 | cssPath = 73 | "_elm" "styles.css" 74 | 75 | 76 | codeFontPath :: FilePath 77 | codeFontPath = 78 | "_elm" "source-code-pro.ttf" 79 | 80 | 81 | sansFontPath :: FilePath 82 | sansFontPath = 83 | "_elm" "source-sans-pro.ttf" 84 | 85 | 86 | 87 | -- ELM 88 | 89 | 90 | elm :: BS.ByteString 91 | elm = 92 | $(bsToExp =<< runIO Build.compile) 93 | 94 | 95 | 96 | -- CSS 97 | 98 | 99 | css :: BS.ByteString 100 | css = 101 | $(bsToExp =<< runIO (Build.readAsset "styles.css")) 102 | 103 | 104 | 105 | -- FONTS 106 | 107 | 108 | codeFont :: BS.ByteString 109 | codeFont = 110 | $(bsToExp =<< runIO (Build.readAsset "source-code-pro.ttf")) 111 | 112 | 113 | sansFont :: BS.ByteString 114 | sansFont = 115 | $(bsToExp =<< runIO (Build.readAsset "source-sans-pro.ttf")) 116 | 117 | 118 | 119 | -- IMAGES 120 | 121 | 122 | favicon :: BS.ByteString 123 | favicon = 124 | $(bsToExp =<< runIO (Build.readAsset "favicon.ico")) 125 | 126 | 127 | waiting :: BS.ByteString 128 | waiting = 129 | $(bsToExp =<< runIO (Build.readAsset "waiting.gif")) 130 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Result.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | module Reporting.Result 4 | ( Result(..) 5 | , run 6 | , ok 7 | , warn 8 | , throw 9 | , mapError 10 | ) 11 | where 12 | 13 | 14 | import qualified Data.OneOrMore as OneOrMore 15 | import qualified Reporting.Warning as Warning 16 | 17 | 18 | 19 | -- RESULT 20 | 21 | 22 | newtype Result info warnings error a = 23 | Result ( 24 | forall result. 25 | info 26 | -> warnings 27 | -> (info -> warnings -> OneOrMore.OneOrMore error -> result) 28 | -> (info -> warnings -> a -> result) 29 | -> result 30 | ) 31 | 32 | 33 | run :: Result () [w] e a -> ([w], Either [e] a) 34 | run (Result k) = 35 | k () [] 36 | (\() w e -> (reverse w, Left (OneOrMore.toList e))) 37 | (\() w a -> (reverse w, Right a)) 38 | 39 | 40 | 41 | -- HELPERS 42 | 43 | 44 | ok :: a -> Result i w e a 45 | ok a = 46 | Result $ \i w _ good -> 47 | good i w a 48 | 49 | 50 | warn :: Warning.Warning -> Result i [Warning.Warning] e () 51 | warn warning = 52 | Result $ \i warnings _ good -> 53 | good i (warning:warnings) () 54 | 55 | 56 | throw :: e -> Result i w e a 57 | throw e = 58 | Result $ \i w bad _ -> 59 | bad i w (OneOrMore.one e) 60 | 61 | 62 | mapError :: (e -> e') -> Result i w e a -> Result i w e' a 63 | mapError func (Result k) = 64 | Result $ \i w bad good -> 65 | let 66 | bad1 i1 w1 e1 = 67 | bad i1 w1 (OneOrMore.map func e1) 68 | in 69 | k i w bad1 good 70 | 71 | 72 | 73 | -- FANCY INSTANCE STUFF 74 | 75 | 76 | instance Functor (Result i w e) where 77 | fmap func (Result k) = 78 | Result $ \i w bad good -> 79 | let 80 | good1 i1 w1 value = 81 | good i1 w1 (func value) 82 | in 83 | k i w bad good1 84 | 85 | 86 | instance Applicative (Result i w e) where 87 | pure = ok 88 | 89 | (<*>) (Result kf) (Result kv) = 90 | Result $ \i w bad good -> 91 | let 92 | bad1 i1 w1 e1 = 93 | let 94 | bad2 i2 w2 e2 = bad i2 w2 (OneOrMore.more e1 e2) 95 | good2 i2 w2 _value = bad i2 w2 e1 96 | in 97 | kv i1 w1 bad2 good2 98 | 99 | good1 i1 w1 func = 100 | let 101 | bad2 i2 w2 e2 = bad i2 w2 e2 102 | good2 i2 w2 value = good i2 w2 (func value) 103 | in 104 | kv i1 w1 bad2 good2 105 | in 106 | kf i w bad1 good1 107 | 108 | 109 | instance Monad (Result i w e) where 110 | return = ok 111 | 112 | (>>=) (Result ka) callback = 113 | Result $ \i w bad good -> 114 | let 115 | good1 i1 w1 a = 116 | case callback a of 117 | Result kb -> kb i1 w1 bad good 118 | in 119 | ka i w bad good1 120 | -------------------------------------------------------------------------------- /terminal/src/Terminal/Args/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Terminal.Args.Helpers 3 | ( version 4 | , elmFile 5 | , package 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.Char as Char 11 | import qualified Data.Text as Text 12 | import qualified System.FilePath as FP 13 | 14 | import Terminal.Args (Parser(..)) 15 | import qualified Elm.Package as Pkg 16 | 17 | 18 | 19 | -- VERSION 20 | 21 | 22 | version :: Parser Pkg.Version 23 | version = 24 | Parser 25 | { _singular = "version" 26 | , _plural = "versions" 27 | , _parser = parseVersion 28 | , _suggest = suggestVersion 29 | , _examples = return . exampleVersions 30 | } 31 | 32 | 33 | parseVersion :: String -> Maybe Pkg.Version 34 | parseVersion str = 35 | Pkg.versionFromText (Text.pack str) 36 | 37 | 38 | suggestVersion :: String -> IO [String] 39 | suggestVersion _ = 40 | return [] 41 | 42 | 43 | exampleVersions :: String -> [String] 44 | exampleVersions string = 45 | let 46 | chunks = map Text.unpack (Text.splitOn "." (Text.pack string)) 47 | isNumber str = not (null str) && all Char.isDigit str 48 | in 49 | if all isNumber chunks then 50 | case chunks of 51 | [x] -> [ x ++ ".0.0" ] 52 | [x,y] -> [ x ++ "." ++ y ++ ".0" ] 53 | x:y:z:_ -> [ x ++ "." ++ y ++ "." ++ z ] 54 | _ -> ["1.0.0", "2.0.3"] 55 | 56 | else 57 | ["1.0.0", "2.0.3"] 58 | 59 | 60 | 61 | -- ELM FILE 62 | 63 | 64 | elmFile :: Parser FilePath 65 | elmFile = 66 | Parser 67 | { _singular = "elm file" 68 | , _plural = "elm files" 69 | , _parser = parseElmFile 70 | , _suggest = \_ -> return [] 71 | , _examples = exampleElmFiles 72 | } 73 | 74 | 75 | parseElmFile :: String -> Maybe FilePath 76 | parseElmFile string = 77 | if FP.takeExtension string == ".elm" then 78 | Just string 79 | else 80 | Nothing 81 | 82 | 83 | exampleElmFiles :: String -> IO [String] 84 | exampleElmFiles _ = 85 | return ["Main.elm","src/Main.elm"] 86 | 87 | 88 | 89 | -- PACKAGE 90 | 91 | 92 | package :: Parser Pkg.Name 93 | package = 94 | Parser 95 | { _singular = "package" 96 | , _plural = "packages" 97 | , _parser = parsePackage 98 | , _suggest = suggestPackages 99 | , _examples = examplePackages 100 | } 101 | 102 | 103 | parsePackage :: String -> Maybe Pkg.Name 104 | parsePackage string = 105 | either (const Nothing) Just $ 106 | Pkg.fromText (Text.pack string) 107 | 108 | 109 | suggestPackages :: String -> IO [String] 110 | suggestPackages _ = 111 | return [] 112 | 113 | 114 | examplePackages :: String -> IO [String] 115 | examplePackages string = 116 | case Pkg.fromText (Text.pack string) of 117 | Left (_, suggestions@(_:_)) -> 118 | return suggestions 119 | 120 | _ -> 121 | return 122 | [ "elm/http" 123 | , "elm/json" 124 | , "elm-community/random-extra" 125 | ] 126 | -------------------------------------------------------------------------------- /compiler/src/AST/Utils/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module AST.Utils.Type 4 | ( delambda 5 | , dealias 6 | , deepDealias 7 | , iteratedDealias 8 | ) 9 | where 10 | 11 | 12 | import qualified Data.Map as Map 13 | 14 | import AST.Canonical (Type(..), AliasType(..), FieldType(..)) 15 | import qualified Elm.Name as N 16 | 17 | 18 | 19 | -- DELAMBDA 20 | 21 | 22 | delambda :: Type -> [Type] 23 | delambda tipe = 24 | case tipe of 25 | TLambda arg result -> 26 | arg : delambda result 27 | 28 | _ -> 29 | [tipe] 30 | 31 | 32 | 33 | -- DEALIAS 34 | 35 | 36 | dealias :: [(N.Name, Type)] -> AliasType -> Type 37 | dealias args aliasType = 38 | case aliasType of 39 | Holey tipe -> 40 | dealiasHelp (Map.fromList args) tipe 41 | 42 | Filled tipe -> 43 | tipe 44 | 45 | 46 | dealiasHelp :: Map.Map N.Name Type -> Type -> Type 47 | dealiasHelp typeTable tipe = 48 | case tipe of 49 | TLambda a b -> 50 | TLambda 51 | (dealiasHelp typeTable a) 52 | (dealiasHelp typeTable b) 53 | 54 | TVar x -> 55 | Map.findWithDefault tipe x typeTable 56 | 57 | TRecord fields ext -> 58 | TRecord (Map.map (dealiasField typeTable) fields) ext 59 | 60 | TAlias home name args t' -> 61 | TAlias home name (map (fmap (dealiasHelp typeTable)) args) t' 62 | 63 | TType home name args -> 64 | TType home name (map (dealiasHelp typeTable) args) 65 | 66 | TUnit -> 67 | TUnit 68 | 69 | TTuple a b maybeC -> 70 | TTuple 71 | (dealiasHelp typeTable a) 72 | (dealiasHelp typeTable b) 73 | (fmap (dealiasHelp typeTable) maybeC) 74 | 75 | 76 | dealiasField :: Map.Map N.Name Type -> FieldType -> FieldType 77 | dealiasField typeTable (FieldType index tipe) = 78 | FieldType index (dealiasHelp typeTable tipe) 79 | 80 | 81 | 82 | -- DEEP DEALIAS 83 | 84 | 85 | deepDealias :: Type -> Type 86 | deepDealias tipe = 87 | case tipe of 88 | TLambda a b -> 89 | TLambda (deepDealias a) (deepDealias b) 90 | 91 | TVar _ -> 92 | tipe 93 | 94 | TRecord fields ext -> 95 | TRecord (Map.map deepDealiasField fields) ext 96 | 97 | TAlias _ _ args tipe' -> 98 | deepDealias (dealias args tipe') 99 | 100 | TType home name args -> 101 | TType home name (map deepDealias args) 102 | 103 | TUnit -> 104 | TUnit 105 | 106 | TTuple a b c -> 107 | TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c) 108 | 109 | 110 | deepDealiasField :: FieldType -> FieldType 111 | deepDealiasField (FieldType index tipe) = 112 | FieldType index (deepDealias tipe) 113 | 114 | 115 | 116 | -- ITERATED DEALIAS 117 | 118 | 119 | iteratedDealias :: Type -> Type 120 | iteratedDealias tipe = 121 | case tipe of 122 | TAlias _ _ args realType -> 123 | iteratedDealias (dealias args realType) 124 | 125 | _ -> 126 | tipe 127 | -------------------------------------------------------------------------------- /compiler/src/Data/Index.hs: -------------------------------------------------------------------------------- 1 | module Data.Index 2 | ( ZeroBased 3 | , first 4 | , second 5 | , third 6 | , next 7 | , toMachine 8 | , toHuman 9 | , indexedMap 10 | , indexedTraverse 11 | , indexedForA 12 | , VerifiedList(..) 13 | , indexedZipWith 14 | , indexedZipWithA 15 | ) 16 | where 17 | 18 | 19 | import Control.Monad (liftM) 20 | import Data.Binary 21 | 22 | 23 | 24 | -- ZERO BASED 25 | 26 | 27 | newtype ZeroBased = ZeroBased Int 28 | deriving (Eq, Ord) 29 | 30 | 31 | first :: ZeroBased 32 | first = 33 | ZeroBased 0 34 | 35 | 36 | second :: ZeroBased 37 | second = 38 | ZeroBased 1 39 | 40 | 41 | third :: ZeroBased 42 | third = 43 | ZeroBased 2 44 | 45 | 46 | {-# INLINE next #-} 47 | next :: ZeroBased -> ZeroBased 48 | next (ZeroBased i) = 49 | ZeroBased (i + 1) 50 | 51 | 52 | 53 | -- DESTRUCT 54 | 55 | 56 | toMachine :: ZeroBased -> Int 57 | toMachine (ZeroBased index) = 58 | index 59 | 60 | 61 | toHuman :: ZeroBased -> Int 62 | toHuman (ZeroBased index) = 63 | index + 1 64 | 65 | 66 | 67 | -- INDEXED MAP 68 | 69 | 70 | {-# INLINE indexedMap #-} 71 | indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b] 72 | indexedMap func xs = 73 | zipWith func (map ZeroBased [0 .. length xs]) xs 74 | 75 | 76 | {-# INLINE indexedTraverse #-} 77 | indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b] 78 | indexedTraverse func xs = 79 | sequenceA (indexedMap func xs) 80 | 81 | 82 | {-# INLINE indexedForA #-} 83 | indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b] 84 | indexedForA xs func = 85 | sequenceA (indexedMap func xs) 86 | 87 | 88 | 89 | -- VERIFIED/INDEXED ZIP 90 | 91 | 92 | data VerifiedList a 93 | = LengthMatch [a] 94 | | LengthMismatch Int Int 95 | 96 | 97 | indexedZipWith :: (ZeroBased -> a -> b -> c) -> [a] -> [b] -> VerifiedList c 98 | indexedZipWith func listX listY = 99 | indexedZipWithHelp func 0 listX listY [] 100 | 101 | 102 | indexedZipWithHelp :: (ZeroBased -> a -> b -> c) -> Int -> [a] -> [b] -> [c] -> VerifiedList c 103 | indexedZipWithHelp func index listX listY revListZ = 104 | case (listX, listY) of 105 | ([], []) -> 106 | LengthMatch (reverse revListZ) 107 | 108 | (x:xs, y:ys) -> 109 | indexedZipWithHelp func (index + 1) xs ys $ 110 | func (ZeroBased index) x y : revListZ 111 | 112 | (_, _) -> 113 | LengthMismatch (index + length listX) (index + length listY) 114 | 115 | 116 | indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c) 117 | indexedZipWithA func listX listY = 118 | case indexedZipWith func listX listY of 119 | LengthMatch xs -> 120 | LengthMatch <$> sequenceA xs 121 | 122 | LengthMismatch x y -> 123 | pure (LengthMismatch x y) 124 | 125 | 126 | 127 | -- BINARY 128 | 129 | 130 | instance Binary ZeroBased where 131 | get = liftM ZeroBased get 132 | put (ZeroBased n) = put n 133 | -------------------------------------------------------------------------------- /reactor/assets/styles.css: -------------------------------------------------------------------------------- 1 | @charset "UTF-8"; 2 | 3 | 4 | /* FONTS */ 5 | 6 | @font-face { 7 | font-family: 'Source Code Pro'; 8 | font-style: normal; 9 | font-weight: 400; 10 | src: local('Source Code Pro'), local('SourceCodePro-Regular'), url(/_elm/source-code-pro.ttf) format('truetype'); 11 | } 12 | 13 | @font-face { 14 | font-family: 'Source Sans Pro'; 15 | font-style: normal; 16 | font-weight: 400; 17 | src: local('Source Sans Pro'), local('SourceSansPro-Regular'), url(/_elm/source-sans-pro.ttf) format('truetype'); 18 | } 19 | 20 | 21 | /* GENERIC STUFF */ 22 | 23 | html, head, body { 24 | margin: 0; 25 | height: 100%; 26 | } 27 | 28 | body { 29 | font-family: 'Source Sans Pro', 'Trebuchet MS', 'Lucida Grande', 'Bitstream Vera Sans', 'Helvetica Neue', sans-serif; 30 | color: #293c4b; 31 | } 32 | 33 | a { 34 | color: #60B5CC; 35 | text-decoration: none; 36 | } 37 | 38 | a:hover { 39 | text-decoration: underline; 40 | } 41 | 42 | 43 | /* INDEX */ 44 | 45 | .header { 46 | width: 100%; 47 | background-color: #60B5CC; 48 | height: 8px; 49 | } 50 | 51 | .content { 52 | width: 960px; 53 | margin-left: auto; 54 | margin-right: auto; 55 | } 56 | 57 | 58 | /* COLUMNS */ 59 | 60 | .left-column { 61 | float: left; 62 | width: 600px; 63 | padding-bottom: 80px; 64 | } 65 | 66 | .right-column { 67 | float: right; 68 | width: 300px; 69 | padding-bottom: 80px; 70 | } 71 | 72 | 73 | /* BOXES */ 74 | 75 | .box { 76 | border: 1px solid #c7c7c7; 77 | border-radius: 5px; 78 | margin-bottom: 40px; 79 | } 80 | 81 | .box-header { 82 | display: block; 83 | overflow: hidden; 84 | padding: 7px 12px; 85 | background-color: #fafafa; 86 | text-align: center; 87 | border-radius: 5px; 88 | } 89 | 90 | .box-item { 91 | display: block; 92 | overflow: hidden; 93 | padding: 7px 12px; 94 | border-top: 1px solid #e1e1e1; 95 | } 96 | 97 | .box-footer { 98 | display: block; 99 | overflow: hidden; 100 | padding: 2px 12px; 101 | border-top: 1px solid #e1e1e1; 102 | text-align: center; 103 | background-color: #fafafa; 104 | height: 16px; 105 | } 106 | 107 | 108 | /* ICONS */ 109 | 110 | .icon { 111 | display: inline-block; 112 | vertical-align: middle; 113 | padding-right: 0.5em; 114 | } 115 | 116 | 117 | /* PAGES */ 118 | 119 | .page-name { 120 | float: left; 121 | } 122 | 123 | .page-size { 124 | float: right; 125 | color: #293c4b; 126 | } 127 | 128 | .page-size:hover { 129 | color: #60B5CC; 130 | } 131 | 132 | 133 | /* WAITING */ 134 | 135 | .waiting { 136 | width: 100%; 137 | height: 100%; 138 | display: flex; 139 | flex-direction: column; 140 | justify-content: center; 141 | align-items: center; 142 | color: #9A9A9A; 143 | } 144 | 145 | 146 | /* NOT FOUND */ 147 | 148 | .not-found { 149 | width: 100%; 150 | height: 100%; 151 | display: flex; 152 | flex-direction: column; 153 | justify-content: center; 154 | align-items: center; 155 | background-color: #F5F5F5; 156 | color: #9A9A9A; 157 | } 158 | -------------------------------------------------------------------------------- /compiler/src/Parse/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Parse.Repl 4 | ( Entry(..) 5 | , parseEntry 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.ByteString.UTF8 as Utf8 11 | import qualified Data.Text as Text 12 | import Data.Text (Text) 13 | 14 | import qualified AST.Source as Src 15 | import qualified Elm.Name as N 16 | import qualified Parse.Module as Module 17 | import Parse.Primitives 18 | import qualified Parse.Primitives.Keyword as Keyword 19 | import qualified Parse.Primitives.Symbol as Symbol 20 | import qualified Parse.Primitives.Variable as Var 21 | import qualified Parse.Pattern as Pattern 22 | import qualified Reporting.Annotation as A 23 | 24 | 25 | 26 | -- ENTRY 27 | 28 | 29 | data Entry 30 | = Import N.Name (Maybe N.Name) Src.Exposing Text 31 | | Type N.Name Text 32 | | Def (Maybe N.Name) Text 33 | | Other Text 34 | | Annotation 35 | | Port 36 | 37 | 38 | 39 | -- PARSE 40 | 41 | 42 | parseEntry :: String -> Entry 43 | parseEntry rawEntry = 44 | let 45 | source = 46 | Text.pack rawEntry 47 | in 48 | case run (entryParser source) (Utf8.fromString rawEntry) of 49 | Right entry -> 50 | entry 51 | 52 | Left _ -> 53 | Other source 54 | 55 | 56 | entryParser :: Text -> Parser Entry 57 | entryParser source = 58 | oneOf 59 | [ do Keyword.import_ 60 | spaces 61 | name <- Var.moduleName 62 | alias <- tryAlias 63 | exposing <- tryExposing 64 | return (Import name alias exposing source) 65 | 66 | , do Keyword.port_ 67 | return Port 68 | 69 | , do Keyword.type_ 70 | spaces 71 | oneOf 72 | [ do Keyword.alias_ 73 | spaces 74 | , return () 75 | ] 76 | name <- Var.upper 77 | return (Type name source) 78 | 79 | , do root <- Pattern.term 80 | spaces 81 | case A.toValue root of 82 | Src.PVar name -> 83 | oneOf 84 | [ do Symbol.hasType 85 | return Annotation 86 | , do chompArgs 87 | return (Def (Just name) source) 88 | ] 89 | 90 | _ -> 91 | do Symbol.equals 92 | return (Def Nothing source) 93 | ] 94 | 95 | 96 | chompArgs :: Parser () 97 | chompArgs = 98 | oneOf 99 | [ do Pattern.term 100 | spaces 101 | chompArgs 102 | , do Symbol.equals 103 | return () 104 | ] 105 | 106 | 107 | tryAlias :: Parser (Maybe N.Name) 108 | tryAlias = 109 | oneOf 110 | [ try $ 111 | do spaces 112 | Keyword.as_ 113 | spaces 114 | Just <$> Var.upper 115 | , return Nothing 116 | ] 117 | 118 | 119 | tryExposing :: Parser Src.Exposing 120 | tryExposing = 121 | oneOf 122 | [ try $ 123 | do spaces 124 | Keyword.exposing_ 125 | spaces 126 | Module.exposing 127 | , return (Src.Explicit []) 128 | ] 129 | -------------------------------------------------------------------------------- /compiler/src/Canonicalize/Environment/Dups.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Canonicalize.Environment.Dups 4 | ( detect 5 | , checkFields 6 | , checkFields' 7 | , Dict 8 | , none 9 | , one 10 | , insert 11 | , union 12 | , unions 13 | ) 14 | where 15 | 16 | 17 | import qualified Data.Map as Map 18 | 19 | import qualified Data.OneOrMore as OneOrMore 20 | import qualified Elm.Name as N 21 | import qualified Reporting.Annotation as A 22 | import qualified Reporting.Error.Canonicalize as Error 23 | import qualified Reporting.Region as R 24 | import qualified Reporting.Result as Result 25 | 26 | 27 | 28 | -- DUPLICATE TRACKER 29 | 30 | 31 | type Dict value = 32 | Map.Map N.Name (OneOrMore.OneOrMore (Info value)) 33 | 34 | 35 | data Info value = 36 | Info 37 | { _region :: R.Region 38 | , _value :: value 39 | } 40 | 41 | 42 | 43 | -- DETECT 44 | 45 | 46 | type ToError = 47 | N.Name -> R.Region -> R.Region -> Error.Error 48 | 49 | 50 | detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map N.Name a) 51 | detect toError dict = 52 | Map.traverseWithKey (detectHelp toError) dict 53 | 54 | 55 | detectHelp :: ToError -> N.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a 56 | detectHelp toError name values = 57 | case values of 58 | OneOrMore.One (Info _ value) -> 59 | return value 60 | 61 | OneOrMore.More _ _ -> 62 | let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in 63 | Result.throw (toError name r1 r2) 64 | 65 | 66 | 67 | -- CHECK FIELDS 68 | 69 | 70 | checkFields :: [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name a) 71 | checkFields fields = 72 | detect Error.DuplicateField (foldr addField none fields) 73 | 74 | 75 | addField :: (A.Located N.Name, a) -> Dict a -> Dict a 76 | addField (A.At region name, value) dups = 77 | Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups 78 | 79 | 80 | checkFields' :: (R.Region -> a -> b) -> [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name b) 81 | checkFields' toValue fields = 82 | detect Error.DuplicateField (foldr (addField' toValue) none fields) 83 | 84 | 85 | addField' :: (R.Region -> a -> b) -> (A.Located N.Name, a) -> Dict b -> Dict b 86 | addField' toValue (A.At region name, value) dups = 87 | Map.insertWith OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups 88 | 89 | 90 | 91 | -- BUILDING DICTIONARIES 92 | 93 | 94 | none :: Dict a 95 | none = 96 | Map.empty 97 | 98 | 99 | one :: N.Name -> R.Region -> value -> Dict value 100 | one name region value = 101 | Map.singleton name (OneOrMore.one (Info region value)) 102 | 103 | 104 | insert :: N.Name -> R.Region -> a -> Dict a -> Dict a 105 | insert name region value dict = 106 | Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict 107 | 108 | 109 | union :: Dict a -> Dict a -> Dict a 110 | union a b = 111 | Map.unionWith OneOrMore.more a b 112 | 113 | 114 | unions :: [Dict a] -> Dict a 115 | unions dicts = 116 | Map.unionsWith OneOrMore.more dicts 117 | -------------------------------------------------------------------------------- /terminal/src/Init.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Init 3 | ( run 4 | ) 5 | where 6 | 7 | 8 | import Prelude hiding (init) 9 | import Control.Monad.Trans (liftIO) 10 | import qualified Data.Map as Map 11 | import qualified System.Directory as Dir 12 | 13 | import qualified Deps.Cache as Cache 14 | import qualified Deps.Explorer as Explorer 15 | import qualified Deps.Solver as Solver 16 | import qualified Elm.Compiler.Version as Compiler 17 | import qualified Elm.Package as Pkg 18 | import qualified Elm.Project.Constraint as Con 19 | import qualified Elm.Project.Json as Project 20 | import qualified Reporting.Doc as D 21 | import qualified Reporting.Exit as Exit 22 | import qualified Reporting.Exit.Init as E 23 | import qualified Reporting.Task as Task 24 | import qualified Reporting.Progress.Terminal as Terminal 25 | 26 | 27 | 28 | -- RUN 29 | 30 | 31 | run :: () -> () -> IO () 32 | run () () = 33 | do reporter <- Terminal.create 34 | exists <- Dir.doesFileExist "elm.json" 35 | Task.run reporter $ 36 | if exists then 37 | Task.throw (Exit.Init E.AlreadyStarted) 38 | else 39 | do approved <- Task.getApproval question 40 | if approved 41 | then 42 | do init 43 | liftIO $ putStrLn "Okay, I created it. Now read that link!" 44 | else 45 | liftIO $ putStrLn "Okay, I did not make any changes!" 46 | 47 | 48 | question :: D.Doc 49 | question = 50 | D.stack 51 | [ D.fillSep 52 | ["Hello!" 53 | ,"Elm","projects","always","start","with","an",D.green "elm.json","file." 54 | ,"I","can","create","them!" 55 | ] 56 | , D.reflow 57 | "Now you may be wondering, what will be in this file? How do I add Elm files to\ 58 | \ my project? How do I see it in the browser? How will my code grow? Do I need\ 59 | \ more directories? What about tests? Etc." 60 | , D.fillSep 61 | ["Check","out",D.cyan (D.fromString (D.makeLink "init")) 62 | ,"for","all","the","answers!" 63 | ] 64 | , "Knowing all that, would you like me to create an elm.json file now? [Y/n]: " 65 | ] 66 | 67 | 68 | 69 | -- INIT 70 | 71 | 72 | init :: Task.Task () 73 | init = 74 | do registry <- Cache.optionalUpdate 75 | 76 | maybeSolution <- 77 | Explorer.run registry $ Solver.run $ Solver.solve defaults 78 | 79 | case maybeSolution of 80 | Just solution -> 81 | let 82 | directs = Map.intersection solution defaults 83 | indirects = Map.difference solution defaults 84 | in 85 | liftIO $ 86 | do Dir.createDirectoryIfMissing True "src" 87 | Project.write "." $ Project.App $ 88 | Project.AppInfo Compiler.version ["src"] directs indirects Map.empty Map.empty 89 | 90 | Nothing -> 91 | Task.throw (Exit.Init (E.NoSolution (Map.keys defaults))) 92 | 93 | 94 | defaults :: Map.Map Pkg.Name Con.Constraint 95 | defaults = 96 | Map.fromList 97 | [ (Pkg.core, Con.anything) 98 | , (Pkg.browser, Con.anything) 99 | , (Pkg.html, Con.anything) 100 | ] 101 | -------------------------------------------------------------------------------- /compiler/src/AST/Valid.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module AST.Valid 4 | ( Expr, Expr_(..) 5 | , Def(..) 6 | , Module(..) 7 | , Decl(..) 8 | , Union(..) 9 | , Alias(..) 10 | , Binop(..) 11 | , Effects(..) 12 | , Port(..) 13 | , Manager(..) 14 | , defaultModule 15 | ) 16 | where 17 | 18 | 19 | import qualified Data.Map as Map 20 | import Data.Text (Text) 21 | 22 | import qualified AST.Utils.Binop as Binop 23 | import qualified AST.Source as Src 24 | import qualified AST.Utils.Shader as Shader 25 | import qualified Elm.Name as N 26 | import qualified Reporting.Annotation as A 27 | import qualified Reporting.Region as R 28 | 29 | 30 | 31 | -- EXPRESSIONS 32 | 33 | 34 | type Expr = A.Located Expr_ 35 | 36 | 37 | data Expr_ 38 | = Chr Text 39 | | Str Text 40 | | Int Int 41 | | Float Double 42 | | Var Src.VarType N.Name 43 | | VarQual Src.VarType N.Name N.Name 44 | | List [Expr] 45 | | Op N.Name 46 | | Negate Expr 47 | | Binops [(Expr, A.Located N.Name)] Expr 48 | | Lambda [Src.Pattern] Expr 49 | | Call Expr [Expr] 50 | | If [(Expr, Expr)] Expr 51 | | Let [Def] Expr 52 | | Case Expr [(Src.Pattern, Expr)] 53 | | Accessor N.Name 54 | | Access Expr (A.Located N.Name) 55 | | Update (A.Located N.Name) [(A.Located N.Name, Expr)] 56 | | Record [(A.Located N.Name, Expr)] 57 | | Unit 58 | | Tuple Expr Expr [Expr] 59 | | Shader Text Text Shader.Shader 60 | 61 | 62 | 63 | -- DEFINITIONS 64 | 65 | 66 | data Def 67 | = Define R.Region (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type) 68 | | Destruct R.Region Src.Pattern Expr 69 | 70 | 71 | 72 | -- MODULE 73 | 74 | 75 | data Module = 76 | Module 77 | { _name :: N.Name 78 | , _overview :: Src.Docs 79 | , _docs :: Map.Map N.Name Text 80 | , _exports :: A.Located Src.Exposing 81 | , _imports :: [Src.Import] 82 | , _decls :: [A.Located Decl] 83 | , _unions :: [Union] 84 | , _aliases :: [Alias] 85 | , _binop :: [Binop] 86 | , _effects :: Effects 87 | } 88 | 89 | 90 | data Decl = Decl (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type) 91 | data Union = Union R.Region (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Src.Type])] 92 | data Alias = Alias R.Region (A.Located N.Name) [A.Located N.Name] Src.Type 93 | data Binop = Binop N.Name Binop.Associativity Binop.Precedence N.Name 94 | 95 | 96 | data Effects 97 | = NoEffects 98 | | Ports [Port] 99 | | Manager R.Region Manager 100 | 101 | 102 | data Manager 103 | = Cmd (A.Located N.Name) 104 | | Sub (A.Located N.Name) 105 | | Fx (A.Located N.Name) (A.Located N.Name) 106 | 107 | 108 | data Port = Port (A.Located N.Name) Src.Type 109 | 110 | 111 | defaultModule :: Map.Map N.Name Text -> [Src.Import] -> [A.Located Decl] -> [Union] -> [Alias] -> [Binop] -> Module 112 | defaultModule docs imports decls unions aliases binop = 113 | Module 114 | { _name = "Main" 115 | , _overview = Src.NoDocs R.one 116 | , _docs = docs 117 | , _exports = A.At R.one Src.Open 118 | , _imports = imports 119 | , _decls = decls 120 | , _unions = unions 121 | , _aliases = aliases 122 | , _binop = binop 123 | , _effects = NoEffects 124 | } 125 | -------------------------------------------------------------------------------- /compiler/src/Parse/Primitives/Kernel.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} 3 | module Parse.Primitives.Kernel 4 | ( Special(..) 5 | , chunk 6 | ) 7 | where 8 | 9 | 10 | import Prelude hiding (length) 11 | import qualified Data.ByteString.Internal as B 12 | import Data.Word (Word8) 13 | import Foreign.ForeignPtr (ForeignPtr) 14 | 15 | import qualified Elm.Name as N 16 | import Parse.Primitives.Internals (Parser(..), State(..), noError) 17 | import qualified Parse.Primitives.Internals as I 18 | import qualified Parse.Primitives.Variable as Var 19 | 20 | 21 | 22 | -- SPECIAL 23 | 24 | 25 | data Special 26 | = Enum Word8 N.Name 27 | | Prod 28 | | Debug 29 | | Import N.Name 30 | | JsField N.Name 31 | | ElmField N.Name 32 | 33 | 34 | 35 | -- CHUNK 36 | 37 | 38 | chunk :: Parser (B.ByteString, Maybe Special) 39 | chunk = 40 | Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ -> 41 | let 42 | (# maybeSpecial, jsOffset, newOffset, newRow, newCol #) = 43 | chompChunk fp offset terminal row col 44 | 45 | !javascript = B.PS fp offset (jsOffset - offset) 46 | !newState = State fp newOffset terminal indent newRow newCol ctx 47 | in 48 | cok (javascript, maybeSpecial) newState noError 49 | 50 | 51 | 52 | -- CHOMP CHUNK 53 | 54 | 55 | chompChunk :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #) 56 | chompChunk fp offset terminal row col = 57 | if offset >= terminal then 58 | (# Nothing, offset, offset, row, col #) 59 | 60 | else 61 | let !word = I.unsafeIndex fp offset in 62 | if word == 0x5F {- _ -} then 63 | 64 | let 65 | !offset1 = offset + 1 66 | !offset3 = offset + 3 67 | in 68 | if offset3 <= terminal && I.unsafeIndex fp offset1 == 0x5F {- _ -} then 69 | chompSpecial fp offset3 terminal row (col + 3) offset 70 | else 71 | chompChunk fp offset1 terminal row (col + 1) 72 | 73 | else if word == 0x0A {- \n -} then 74 | chompChunk fp (offset + 1) terminal (row + 1) 1 75 | 76 | else 77 | let !newOffset = offset + I.getCharWidth fp offset terminal word in 78 | chompChunk fp newOffset terminal row (col + 1) 79 | 80 | 81 | 82 | -- CHOMP TAG 83 | 84 | 85 | -- relies on external checks in chompChunk 86 | chompSpecial :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #) 87 | chompSpecial fp offset terminal row col jsOffset = 88 | let 89 | (# newOffset, newCol #) = 90 | Var.chompInnerChars fp offset terminal col 91 | 92 | !tagOffset = offset - 1 93 | !word = I.unsafeIndex fp tagOffset 94 | 95 | !special = 96 | if word == 0x24 {- $ -} then 97 | ElmField (N.fromForeignPtr fp offset (newOffset - offset)) 98 | 99 | else 100 | let !name = N.fromForeignPtr fp tagOffset (newOffset - tagOffset) in 101 | if 0x30 <= word && word <= 0x39 then 102 | Enum (fromIntegral (word - 0x30)) name 103 | 104 | else if 0x61 {- a -} <= word && word <= 0x7A {- z -} then 105 | JsField name 106 | 107 | else if name == "DEBUG" then 108 | Debug 109 | 110 | else if name == "PROD" then 111 | Prod 112 | 113 | else 114 | Import name 115 | in 116 | (# Just special, jsOffset, newOffset, row, newCol #) 117 | -------------------------------------------------------------------------------- /compiler/src/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} 2 | module Compile 3 | ( DocsFlag(..) 4 | , compile 5 | , Artifacts(..) 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.ByteString as BS 11 | import qualified Data.Map as Map 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified AST.Optimized as Opt 15 | import qualified AST.Module.Name as ModuleName 16 | import qualified Canonicalize.Module as Canonicalize 17 | import qualified Elm.Docs as Docs 18 | import qualified Elm.Interface as I 19 | import qualified Elm.Name as N 20 | import qualified Elm.Package as Pkg 21 | import qualified Nitpick.PatternMatches as PatternMatches 22 | import qualified Optimize.Module as Optimize 23 | import qualified Parse.Parse as Parse 24 | import qualified Reporting.Error as Error 25 | import qualified Reporting.Render.Type.Localizer as L 26 | import qualified Reporting.Result as Result 27 | import qualified Reporting.Warning as Warning 28 | import qualified Type.Constrain.Module as Type 29 | import qualified Type.Solve as Type 30 | 31 | import System.IO.Unsafe (unsafePerformIO) 32 | 33 | 34 | 35 | -- COMPILE 36 | 37 | 38 | type Result i a = 39 | Result.Result i [Warning.Warning] Error.Error a 40 | 41 | 42 | type ImportDict = 43 | Map.Map N.Name ModuleName.Canonical 44 | 45 | 46 | data Artifacts = 47 | Artifacts 48 | { _elmi :: I.Interface 49 | , _elmo :: Opt.Graph 50 | , _docs :: Maybe Docs.Module 51 | } 52 | 53 | 54 | compile :: DocsFlag -> Pkg.Name -> ImportDict -> I.Interfaces -> BS.ByteString -> Result i Artifacts 55 | compile flag pkg importDict interfaces source = 56 | do 57 | valid <- Result.mapError Error.Syntax $ 58 | Parse.program pkg source 59 | 60 | canonical <- Result.mapError Error.Canonicalize $ 61 | Canonicalize.canonicalize pkg importDict interfaces valid 62 | 63 | let localizer = L.fromModule valid -- TODO should this be strict for GC? 64 | 65 | annotations <- 66 | runTypeInference localizer canonical 67 | 68 | () <- 69 | exhaustivenessCheck canonical 70 | 71 | graph <- Result.mapError (Error.Main localizer) $ 72 | Optimize.optimize annotations canonical 73 | 74 | documentation <- 75 | genarateDocs flag canonical 76 | 77 | Result.ok $ 78 | Artifacts 79 | { _elmi = I.fromModule annotations canonical 80 | , _elmo = graph 81 | , _docs = documentation 82 | } 83 | 84 | 85 | 86 | -- TYPE INFERENCE 87 | 88 | 89 | runTypeInference :: L.Localizer -> Can.Module -> Result i (Map.Map N.Name Can.Annotation) 90 | runTypeInference localizer canonical = 91 | case unsafePerformIO (Type.run =<< Type.constrain canonical) of 92 | Right annotations -> 93 | Result.ok annotations 94 | 95 | Left errors -> 96 | Result.throw (Error.Type localizer errors) 97 | 98 | 99 | 100 | -- EXHAUSTIVENESS CHECK 101 | 102 | 103 | exhaustivenessCheck :: Can.Module -> Result i () 104 | exhaustivenessCheck canonical = 105 | case PatternMatches.check canonical of 106 | Left errors -> 107 | Result.throw (Error.Pattern errors) 108 | 109 | Right () -> 110 | Result.ok () 111 | 112 | 113 | 114 | -- DOCUMENTATION 115 | 116 | 117 | data DocsFlag = YesDocs | NoDocs 118 | 119 | 120 | genarateDocs :: DocsFlag -> Can.Module -> Result.Result i w Error.Error (Maybe Docs.Module) 121 | genarateDocs flag modul = 122 | case flag of 123 | NoDocs -> 124 | Result.ok Nothing 125 | 126 | YesDocs -> 127 | Just <$> Docs.fromModule modul 128 | -------------------------------------------------------------------------------- /docs/elm.json/package.md: -------------------------------------------------------------------------------- 1 | # `elm.json` for packages 2 | 3 | This is roughly `elm.json` for the `elm/json` package: 4 | 5 | ```json 6 | { 7 | "type": "package", 8 | "name": "elm/json", 9 | "summary": "Encode and decode JSON values", 10 | "license": "BSD-3-Clause", 11 | "version": "1.0.0", 12 | "exposed-modules": [ 13 | "Json.Decode", 14 | "Json.Encode" 15 | ], 16 | "elm-version": "0.19.0 <= v < 0.20.0", 17 | "dependencies": { 18 | "elm/core": "1.0.0 <= v < 2.0.0" 19 | }, 20 | "test-dependencies": {} 21 | } 22 | ``` 23 | 24 |
25 | 26 | 27 | ## `"type"` 28 | 29 | Either `"application"` or `"package"`. All the other fields are based on this choice. 30 | 31 |
32 | 33 | 34 | ## `"name"` 35 | 36 | The name of a GitHub repo like `"elm-lang/core"` or `"rtfeldman/elm-css"`. 37 | 38 | > **Note:** We currently only support GitHub repos to ensure that there are no author name collisions. This seems like a pretty tricky problem to solve in a pleasant way. For example, do we have to keep an author name registry and give them out as we see them? But if someone is the same person on two platforms? And how to make this all happen in a way this is really nice for typical Elm users? Etc. So adding other hosting endpoints is harder than it sounds. 39 | 40 |
41 | 42 | 43 | ## `"summary"` 44 | 45 | A short summary that will appear on [`package.elm-lang.org`](https://package.elm-lang.org/) that describes what the package is for. Must be under 80 characters. 46 | 47 |
48 | 49 | 50 | ## `"license"` 51 | 52 | An OSI approved SPDX code like `"BSD-3-Clause"` or `"MIT"`. These are the two most common licenses in the Elm ecosystem, but you can see the full list of options [here](https://spdx.org/licenses/). 53 | 54 |
55 | 56 | 57 | ## `"version"` 58 | 59 | All packages start at `"1.0.0"` and from there, Elm automatically enforces semantic versioning by comparing API changes. 60 | 61 | So if you make a PATCH change and call `elm bump` it will update you to `"1.0.1"`. And if you then decide to remove a function (a MAJOR change) and call `elm bump` it will update you to `"2.0.0"`. Etc. 62 | 63 |
64 | 65 | 66 | ## `"exposed-modules"` 67 | 68 | A list of modules that will be exposed to people using your package. The order you list them will be the order they appear on [`package.elm-lang.org`](https://package.elm-lang.org/). 69 | 70 | **Note:** If you have five or more modules, you can use a labelled list like [this](https://github.com/elm-lang/core/blob/master/elm.json). We show the labels on the package website to help people sort through larger packages with distinct categories. Labels must be under 20 characters. 71 | 72 |
73 | 74 | 75 | ## `"elm-version"` 76 | 77 | The range of Elm compilers that work with your package. Right now `"0.19.0 <= v < 0.20.0"` is always what you want for this. 78 | 79 |
80 | 81 | 82 | ## `"dependencies"` 83 | 84 | A list of packages that you depend upon. In each application, there can only be one version of each package, so wide ranges are great. Fewer dependencies is even better though! 85 | 86 | > **Note:** Dependency ranges should only express _tested_ ranges. It is not nice to use optimistic ranges and end up causing build failures for your users down the line. Eventually we would like to have an automated system that tries to build and test packages as new packages come out. If it all works, we could send a PR to the author widening the range. 87 | 88 |
89 | 90 | 91 | ## `"test-dependencies"` 92 | 93 | Dependencies that are only used in the `tests/` directory by `elm test`. Values from these packages will not appear in any final build artifacts. 94 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Render/Type/Localizer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Render.Type.Localizer 4 | ( Localizer 5 | , toDoc 6 | , toString 7 | , empty 8 | , fromNames 9 | , fromModule 10 | , replEmpty 11 | , replAdd 12 | ) 13 | where 14 | 15 | 16 | import qualified Data.Map as Map 17 | import qualified Data.Set as Set 18 | 19 | import qualified AST.Source as Src 20 | import qualified AST.Module.Name as ModuleName 21 | import qualified AST.Valid as Valid 22 | import qualified Elm.Compiler.Imports as Imports 23 | import qualified Elm.Name as N 24 | import qualified Elm.Package as Pkg 25 | import Reporting.Doc ((<>)) 26 | import qualified Reporting.Doc as D 27 | import qualified Reporting.Annotation as A 28 | 29 | 30 | 31 | -- LOCALIZER 32 | 33 | 34 | newtype Localizer = 35 | Localizer (Map.Map N.Name Import) 36 | 37 | 38 | data Import = 39 | Import 40 | { _alias :: Maybe N.Name 41 | , _exposing :: Exposing 42 | } 43 | 44 | 45 | data Exposing 46 | = All 47 | | Only (Set.Set N.Name) 48 | 49 | 50 | empty :: Localizer 51 | empty = 52 | Localizer Map.empty 53 | 54 | 55 | 56 | -- LOCALIZE 57 | 58 | 59 | toDoc :: Localizer -> ModuleName.Canonical -> N.Name -> D.Doc 60 | toDoc localizer home name = 61 | D.fromString (toString localizer home name) 62 | 63 | 64 | toString :: Localizer -> ModuleName.Canonical -> N.Name -> String 65 | toString (Localizer localizer) moduleName@(ModuleName.Canonical _ home) name = 66 | case Map.lookup home localizer of 67 | Nothing -> 68 | N.toString home <> "." <> N.toString name 69 | 70 | Just (Import alias exposing) -> 71 | case exposing of 72 | All -> 73 | N.toString name 74 | 75 | Only set -> 76 | if Set.member name set then 77 | N.toString name 78 | else if name == N.list && moduleName == ModuleName.list then 79 | "List" 80 | else 81 | N.toString (maybe home id alias) <> "." <> N.toString name 82 | 83 | 84 | 85 | -- FROM NAMES 86 | 87 | 88 | fromNames :: Map.Map N.Name a -> Localizer 89 | fromNames names = 90 | Localizer $ Map.map (\_ -> Import Nothing All) names 91 | 92 | 93 | 94 | -- FROM MODULE 95 | 96 | 97 | fromModule :: Valid.Module -> Localizer 98 | fromModule (Valid.Module name _ _ _ imports _ _ _ _ _) = 99 | Localizer $ Map.fromList $ 100 | (name, Import Nothing All) : map toPair imports 101 | 102 | 103 | toPair :: Src.Import -> (N.Name, Import) 104 | toPair (Src.Import (A.At _ name) alias exposing) = 105 | ( name 106 | , Import alias (toExposing exposing) 107 | ) 108 | 109 | 110 | toExposing :: Src.Exposing -> Exposing 111 | toExposing exposing = 112 | case exposing of 113 | Src.Open -> 114 | All 115 | 116 | Src.Explicit exposedList -> 117 | Only (foldr addType Set.empty exposedList) 118 | 119 | 120 | addType :: A.Located Src.Exposed -> Set.Set N.Name -> Set.Set N.Name 121 | addType (A.At _ exposed) types = 122 | case exposed of 123 | Src.Lower _ -> types 124 | Src.Upper name _ -> Set.insert name types 125 | Src.Operator _ -> types 126 | 127 | 128 | 129 | -- REPL STUFF 130 | 131 | 132 | replEmpty :: Localizer 133 | replEmpty = 134 | Localizer $ 135 | Map.insert N.replModule (Import Nothing All) $ 136 | Map.fromList $ map toPair $ Imports.addDefaults Pkg.dummyName [] 137 | 138 | 139 | replAdd :: N.Name -> Maybe N.Name -> Src.Exposing -> Localizer -> Localizer 140 | replAdd name alias exposing (Localizer localizer) = 141 | Localizer $ Map.insert name (Import alias (toExposing exposing)) localizer 142 | 143 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Warning.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Warning 4 | ( Warning(..) 5 | , Context(..) 6 | , toReport 7 | ) 8 | where 9 | 10 | 11 | import Data.Monoid ((<>)) 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified AST.Utils.Type as Type 15 | import qualified Elm.Name as N 16 | import qualified Reporting.Doc as D 17 | import qualified Reporting.Region as R 18 | import qualified Reporting.Report as Report 19 | import qualified Reporting.Render.Code as Code 20 | import qualified Reporting.Render.Type as RT 21 | import qualified Reporting.Render.Type.Localizer as L 22 | 23 | 24 | 25 | -- ALL POSSIBLE WARNINGS 26 | 27 | 28 | data Warning 29 | = UnusedImport R.Region N.Name 30 | | UnusedVariable R.Region Context N.Name 31 | | MissingTypeAnnotation R.Region N.Name Can.Type 32 | 33 | 34 | data Context = Def | Pattern 35 | 36 | 37 | 38 | -- TO REPORT 39 | 40 | 41 | toReport :: L.Localizer -> Code.Source -> Warning -> Report.Report 42 | toReport localizer source warning = 43 | case warning of 44 | UnusedImport region moduleName -> 45 | Report.Report "unused import" region [] $ 46 | Report.toCodeSnippet source region Nothing 47 | ( 48 | D.reflow $ 49 | "Nothing from the `" <> N.toString moduleName <> "` module is used in this file." 50 | , 51 | "I recommend removing unused imports." 52 | ) 53 | 54 | UnusedVariable region context name -> 55 | let title = defOrPat context "unused definition" "unused variable" in 56 | Report.Report title region [] $ 57 | Report.toCodeSnippet source region Nothing 58 | ( 59 | D.reflow $ 60 | "You are not using `" <> N.toString name <> "` anywhere." 61 | , 62 | D.stack 63 | [ D.reflow $ 64 | "Is there a typo? Maybe you intended to use `" <> N.toString name 65 | <> "` somewhere but typed another name instead?" 66 | , D.reflow $ 67 | defOrPat context 68 | ( "If you are sure there is no typo, remove the definition.\ 69 | \ This way future readers will not have to wonder why it is there!" 70 | ) 71 | ( "If you are sure there is no typo, replace `" <> N.toString name 72 | <> "` with _ so future readers will not have to wonder why it is there!" 73 | ) 74 | ] 75 | ) 76 | 77 | MissingTypeAnnotation region name inferredType -> 78 | Report.Report "missing type annotation" region [] $ 79 | Report.toCodeSnippet source region Nothing 80 | ( 81 | D.reflow $ 82 | case Type.deepDealias inferredType of 83 | Can.TLambda _ _ -> 84 | "The `" <> N.toString name <> "` function has no type annotation." 85 | 86 | _ -> 87 | "The `" <> N.toString name <> "` definition has no type annotation." 88 | , 89 | D.stack 90 | [ "I inferred the type annotation myself though! You can copy it into your code:" 91 | , D.green $ D.hang 4 $ D.sep $ 92 | [ D.fromName name <> " :" 93 | , RT.canToDoc localizer RT.None inferredType 94 | ] 95 | ] 96 | ) 97 | 98 | 99 | defOrPat :: Context -> a -> a -> a 100 | defOrPat context def pat = 101 | case context of 102 | Def -> def 103 | Pattern -> pat 104 | 105 | -------------------------------------------------------------------------------- /compiler/src/Parse/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Parse.Shader 4 | ( shader 5 | ) 6 | where 7 | 8 | 9 | import qualified Data.List as List 10 | import qualified Data.Map as Map 11 | import qualified Data.Text as Text 12 | import qualified Language.GLSL.Parser as GLP 13 | import qualified Language.GLSL.Syntax as GLS 14 | import qualified Text.Parsec as Parsec 15 | import qualified Text.Parsec.Error as Parsec 16 | 17 | import qualified AST.Source as Src 18 | import qualified AST.Utils.Shader as Shader 19 | import qualified Elm.Name as N 20 | import qualified Reporting.Annotation as A 21 | import qualified Reporting.Region as R 22 | import Parse.Primitives (Parser, getPosition) 23 | import qualified Parse.Primitives.Shader as Shader 24 | 25 | 26 | 27 | -- SHADERS 28 | 29 | 30 | shader :: R.Position -> Parser Src.Expr 31 | shader start@(R.Position row col) = 32 | do block <- Shader.block 33 | shdr <- parseSource row col (Text.unpack block) 34 | end@(R.Position row2 col2) <- getPosition 35 | let uid = List.intercalate ":" (map show [row, col, row2, col2]) 36 | let src = Text.replace "\n" "\\n" (Text.replace "\r\n" "\\n" block) 37 | return (A.at start end (Src.Shader (Text.pack uid) src shdr)) 38 | 39 | 40 | parseSource :: Int -> Int -> String -> Parser Shader.Shader 41 | parseSource startRow startCol src = 42 | case GLP.parse src of 43 | Right (GLS.TranslationUnit decls) -> 44 | return (foldr addInput emptyShader (concatMap extractInputs decls)) 45 | 46 | Left err -> 47 | let 48 | pos = Parsec.errorPos err 49 | row = Parsec.sourceLine pos 50 | col = Parsec.sourceColumn pos 51 | msg = 52 | Parsec.showErrorMessages 53 | "or" 54 | "unknown parse error" 55 | "expecting" 56 | "unexpected" 57 | "end of input" 58 | (Parsec.errorMessages err) 59 | in 60 | if row == 1 then 61 | Shader.failure startRow (startCol + 6 + col) (Text.pack msg) 62 | else 63 | Shader.failure (startRow + row - 1) col (Text.pack msg) 64 | 65 | 66 | emptyShader :: Shader.Shader 67 | emptyShader = 68 | Shader.Shader Map.empty Map.empty Map.empty 69 | 70 | 71 | addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Shader -> Shader.Shader 72 | addInput (qual, tipe, name) glDecls = 73 | case qual of 74 | GLS.Attribute -> glDecls { Shader._attribute = Map.insert (N.fromString name) tipe (Shader._attribute glDecls) } 75 | GLS.Uniform -> glDecls { Shader._uniform = Map.insert (N.fromString name) tipe (Shader._uniform glDecls) } 76 | GLS.Varying -> glDecls { Shader._varying = Map.insert (N.fromString name) tipe (Shader._varying glDecls) } 77 | _ -> error "Should never happen due to `extractInputs` function" 78 | 79 | 80 | extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, String)] 81 | extractInputs decl = 82 | case decl of 83 | GLS.Declaration 84 | (GLS.InitDeclaration 85 | (GLS.TypeDeclarator 86 | (GLS.FullType 87 | (Just (GLS.TypeQualSto qual)) 88 | (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1)))) 89 | [GLS.InitDecl name _mexpr2 _mexpr3] 90 | ) -> 91 | case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of 92 | False -> [] 93 | True -> 94 | case tipe of 95 | GLS.Vec2 -> [(qual, Shader.V2, name)] 96 | GLS.Vec3 -> [(qual, Shader.V3, name)] 97 | GLS.Vec4 -> [(qual, Shader.V4, name)] 98 | GLS.Mat4 -> [(qual, Shader.M4, name)] 99 | GLS.Int -> [(qual, Shader.Int, name)] 100 | GLS.Float -> [(qual, Shader.Float, name)] 101 | GLS.Sampler2D -> [(qual, Shader.Texture, name)] 102 | _ -> [] 103 | _ -> [] 104 | -------------------------------------------------------------------------------- /compiler/src/AST/Source.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module AST.Source 3 | ( Expr, Expr_(..), VarType(..) 4 | , Decl, Decl_(..) 5 | , Def(..) 6 | , Pattern, Pattern_(..) 7 | , Type, Type_(..) 8 | , Module(..) 9 | , Header(..) 10 | , Docs(..) 11 | , Import(..) 12 | , Effects(..) 13 | , Manager(..) 14 | , Exposing(..) 15 | , Exposed(..) 16 | , Privacy(..) 17 | ) 18 | where 19 | 20 | 21 | import qualified Data.ByteString as B 22 | import Data.Text (Text) 23 | 24 | import qualified AST.Utils.Binop as Binop 25 | import qualified AST.Utils.Shader as Shader 26 | import qualified Elm.Name as N 27 | import qualified Reporting.Annotation as A 28 | import qualified Reporting.Region as R 29 | 30 | 31 | 32 | -- EXPRESSIONS 33 | 34 | 35 | type Expr = A.Located Expr_ 36 | 37 | 38 | data Expr_ 39 | = Chr Text 40 | | Str Text 41 | | Int Int 42 | | Float Double 43 | | Var VarType N.Name 44 | | VarQual VarType N.Name N.Name 45 | | List [Expr] 46 | | Op N.Name 47 | | Negate Expr 48 | | Binops [(Expr, A.Located N.Name)] Expr 49 | | Lambda [Pattern] Expr 50 | | Call Expr [Expr] 51 | | If [(Expr, Expr)] Expr 52 | | Let [A.Located Def] Expr 53 | | Case Expr [(Pattern, Expr)] 54 | | Accessor N.Name 55 | | Access Expr (A.Located N.Name) 56 | | Update (A.Located N.Name) [(A.Located N.Name, Expr)] 57 | | Record [(A.Located N.Name, Expr)] 58 | | Unit 59 | | Tuple Expr Expr [Expr] 60 | | Shader Text Text Shader.Shader 61 | 62 | 63 | data VarType = Value | Ctor 64 | 65 | 66 | 67 | -- DEFINITIONS 68 | 69 | 70 | data Def 71 | = Annotate N.Name Type 72 | | Define (A.Located N.Name) [Pattern] Expr 73 | | Destruct Pattern Expr 74 | 75 | 76 | 77 | -- PATTERN 78 | 79 | 80 | type Pattern = A.Located Pattern_ 81 | 82 | 83 | data Pattern_ 84 | = PAnything 85 | | PVar N.Name 86 | | PRecord [A.Located N.Name] 87 | | PAlias Pattern (A.Located N.Name) 88 | | PUnit 89 | | PTuple Pattern Pattern [Pattern] 90 | | PCtor R.Region N.Name [Pattern] 91 | | PCtorQual R.Region N.Name N.Name [Pattern] 92 | | PList [Pattern] 93 | | PCons Pattern Pattern 94 | | PChr Text 95 | | PStr Text 96 | | PInt Int 97 | 98 | 99 | 100 | -- TYPE 101 | 102 | 103 | type Type = 104 | A.Located Type_ 105 | 106 | 107 | data Type_ 108 | = TLambda Type Type 109 | | TVar N.Name 110 | | TType R.Region N.Name [Type] 111 | | TTypeQual R.Region N.Name N.Name [Type] 112 | | TRecord [(A.Located N.Name, Type)] (Maybe (A.Located N.Name)) 113 | | TUnit 114 | | TTuple Type Type [Type] 115 | 116 | 117 | 118 | -- DECLARATIONS 119 | 120 | 121 | type Decl = A.Located Decl_ 122 | 123 | 124 | data Decl_ 125 | = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Type])] 126 | | Alias (A.Located N.Name) [A.Located N.Name] Type 127 | | Binop N.Name Binop.Associativity Binop.Precedence N.Name 128 | | Port (A.Located N.Name) Type 129 | | Docs Text 130 | | Annotation (A.Located N.Name) Type 131 | | Definition (A.Located N.Name) [Pattern] Expr 132 | 133 | 134 | 135 | -- MODULE 136 | 137 | 138 | data Module decls = 139 | Module (Maybe Header) [Import] decls 140 | 141 | 142 | data Header 143 | = Header 144 | { _name :: N.Name 145 | , _effects :: Effects 146 | , _exports :: A.Located Exposing 147 | , _docs :: Docs 148 | } 149 | 150 | 151 | data Import = 152 | Import 153 | { _import :: A.Located N.Name 154 | , _alias :: Maybe N.Name 155 | , _exposing :: Exposing 156 | } 157 | 158 | 159 | data Docs 160 | = NoDocs R.Region 161 | | YesDocs R.Region B.ByteString 162 | 163 | 164 | data Effects 165 | = NoEffects 166 | | Ports R.Region 167 | | Manager R.Region Manager 168 | 169 | 170 | data Manager 171 | = Cmd (A.Located N.Name) 172 | | Sub (A.Located N.Name) 173 | | Fx (A.Located N.Name) (A.Located N.Name) 174 | 175 | 176 | 177 | -- EXPOSING 178 | 179 | 180 | data Exposing 181 | = Open 182 | | Explicit ![A.Located Exposed] 183 | 184 | 185 | data Exposed 186 | = Lower !N.Name 187 | | Upper !N.Name !Privacy 188 | | Operator !N.Name 189 | 190 | 191 | data Privacy 192 | = Public 193 | | Private 194 | -------------------------------------------------------------------------------- /terminal/src/Develop/Generate/Index.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Develop.Generate.Index 4 | ( get 5 | ) 6 | where 7 | 8 | 9 | import Control.Monad (filterM) 10 | import qualified Data.ByteString.Builder as B 11 | import qualified Data.Map as Map 12 | import qualified Data.Text as Text 13 | import qualified Data.Text.IO as Text 14 | import qualified System.Directory as Dir 15 | import System.FilePath ((), splitDirectories, takeExtension) 16 | 17 | import qualified Develop.Generate.Help as Help 18 | import qualified Elm.Package as Pkg 19 | import qualified Elm.Project.Json as Project 20 | import qualified Elm.Project.Summary as Summary 21 | import qualified Json.Encode as E 22 | import qualified Reporting.Progress as Progress 23 | import qualified Reporting.Task as Task 24 | import qualified Stuff.Verify as Verify 25 | 26 | 27 | 28 | -- GET 29 | 30 | 31 | get :: FilePath -> FilePath -> IO B.Builder 32 | get root pwd = 33 | do flags <- getFlags root pwd 34 | return $ Help.makePageHtml "Index" (Just (encode flags)) 35 | 36 | 37 | 38 | -- FLAGS 39 | 40 | 41 | data Flags = 42 | Flags 43 | { _root :: FilePath 44 | , _pwd :: [String] 45 | , _dirs :: [FilePath] 46 | , _files :: [(FilePath, Bool)] 47 | , _readme :: Maybe Text.Text 48 | , _project :: Maybe Project.Project 49 | , _exactDeps :: Map.Map Pkg.Name Pkg.Version 50 | } 51 | 52 | 53 | 54 | -- JSON 55 | 56 | 57 | encode :: Flags -> E.Value 58 | encode (Flags root pwd dirs files readme project exactDeps) = 59 | E.object 60 | [ ( "root", encodeFilePath root ) 61 | , ( "pwd", E.list encodeFilePath pwd ) 62 | , ( "dirs", E.list encodeFilePath dirs ) 63 | , ( "files", E.list encodeFile files ) 64 | , ( "readme", maybe E.null E.text readme ) 65 | , ( "project", maybe E.null Project.encode project ) 66 | , ( "exactDeps", E.dict Pkg.toText Pkg.encodeVersion exactDeps) 67 | ] 68 | 69 | 70 | encodeFilePath :: FilePath -> E.Value 71 | encodeFilePath filePath = 72 | E.text (Text.pack filePath) 73 | 74 | 75 | encodeFile :: (FilePath, Bool) -> E.Value 76 | encodeFile (file, hasMain) = 77 | E.object 78 | [ ("name", encodeFilePath file) 79 | , ("runnable", E.bool hasMain) 80 | ] 81 | 82 | 83 | 84 | -- GET FLAGS 85 | 86 | 87 | getFlags :: FilePath -> FilePath -> IO Flags 88 | getFlags root pwd = 89 | do (dirs, files) <- getDirsAndFiles pwd 90 | readme <- getReadme pwd 91 | exists <- Dir.doesFileExist (root "elm.json") 92 | 93 | maybeSummary <- 94 | if exists then 95 | Task.try Progress.silentReporter $ 96 | Verify.verify root =<< Project.read (root "elm.json") 97 | else 98 | return Nothing 99 | 100 | return $ 101 | Flags 102 | { _root = root 103 | , _pwd = dropWhile ("." ==) (splitDirectories pwd) 104 | , _dirs = dirs 105 | , _files = files 106 | , _readme = readme 107 | , _project = fmap Summary._project maybeSummary 108 | , _exactDeps = maybe Map.empty (Map.map fst . Summary._depsGraph) maybeSummary 109 | } 110 | 111 | 112 | getReadme :: FilePath -> IO (Maybe Text.Text) 113 | getReadme dir = 114 | do let readmePath = dir "README.md" 115 | exists <- Dir.doesFileExist readmePath 116 | if exists 117 | then Just <$> Text.readFile readmePath 118 | else return Nothing 119 | 120 | 121 | getDirsAndFiles :: FilePath -> IO ([FilePath], [(FilePath, Bool)]) 122 | getDirsAndFiles pwd = 123 | do contents <- Dir.getDirectoryContents pwd 124 | dirs <- filterM (Dir.doesDirectoryExist . (pwd )) contents 125 | filePaths <- filterM (Dir.doesFileExist . (pwd )) contents 126 | files <- mapM (inspectFile pwd) filePaths 127 | return (dirs, files) 128 | 129 | 130 | inspectFile :: FilePath -> FilePath -> IO (FilePath, Bool) 131 | inspectFile pwd path = 132 | if takeExtension path == ".elm" then 133 | do source <- Text.readFile (pwd path) 134 | let hasMain = Text.isInfixOf "\nmain " source 135 | return (path, hasMain) 136 | 137 | else 138 | return (path, False) 139 | -------------------------------------------------------------------------------- /compiler/src/AST/Module/Name.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module AST.Module.Name 4 | ( Canonical(..) 5 | , basics, char, string 6 | , maybe, result, list, array, dict, tuple 7 | , platform, cmd, sub 8 | , virtualDom, debug, bitwise 9 | , jsonDecode, jsonEncode 10 | , webgl, texture, vector2, vector3, vector4, matrix4 11 | , isKernel, getKernel, canonicalIsKernel 12 | ) 13 | where 14 | 15 | 16 | import Prelude hiding (maybe) 17 | import Control.Monad (liftM2) 18 | import Data.Binary 19 | 20 | import qualified Elm.Name as N 21 | import qualified Elm.Package as Pkg 22 | 23 | 24 | 25 | -- NAMES 26 | 27 | 28 | data Canonical = 29 | Canonical 30 | { _package :: !Pkg.Name 31 | , _module :: !N.Name 32 | } 33 | deriving (Ord) 34 | 35 | 36 | instance Eq Canonical where 37 | (==) (Canonical pkg home) (Canonical pkg' home') = 38 | home == home' && pkg == pkg' 39 | 40 | 41 | 42 | -- PRIMITIVES 43 | 44 | 45 | {-# NOINLINE basics #-} 46 | basics :: Canonical 47 | basics = Canonical Pkg.core "Basics" 48 | 49 | 50 | {-# NOINLINE char #-} 51 | char :: Canonical 52 | char = Canonical Pkg.core N.char 53 | 54 | 55 | {-# NOINLINE string #-} 56 | string :: Canonical 57 | string = Canonical Pkg.core N.string 58 | 59 | 60 | 61 | -- CONTAINERS 62 | 63 | 64 | {-# NOINLINE maybe #-} 65 | maybe :: Canonical 66 | maybe = Canonical Pkg.core N.maybe 67 | 68 | 69 | {-# NOINLINE result #-} 70 | result :: Canonical 71 | result = Canonical Pkg.core N.result 72 | 73 | 74 | {-# NOINLINE list #-} 75 | list :: Canonical 76 | list = Canonical Pkg.core N.list 77 | 78 | 79 | {-# NOINLINE array #-} 80 | array :: Canonical 81 | array = Canonical Pkg.core N.array 82 | 83 | 84 | {-# NOINLINE dict #-} 85 | dict :: Canonical 86 | dict = Canonical Pkg.core N.dict 87 | 88 | 89 | {-# NOINLINE tuple #-} 90 | tuple :: Canonical 91 | tuple = Canonical Pkg.core N.tuple 92 | 93 | 94 | 95 | -- EFFECTS 96 | 97 | 98 | {-# NOINLINE platform #-} 99 | platform :: Canonical 100 | platform = Canonical Pkg.core N.platform 101 | 102 | 103 | {-# NOINLINE cmd #-} 104 | cmd :: Canonical 105 | cmd = Canonical Pkg.core "Platform.Cmd" 106 | 107 | 108 | {-# NOINLINE sub #-} 109 | sub :: Canonical 110 | sub = Canonical Pkg.core "Platform.Sub" 111 | 112 | 113 | 114 | -- MISC 115 | 116 | 117 | {-# NOINLINE virtualDom #-} 118 | virtualDom :: Canonical 119 | virtualDom = Canonical Pkg.virtualDom N.virtualDom 120 | 121 | 122 | {-# NOINLINE debug #-} 123 | debug :: Canonical 124 | debug = Canonical Pkg.core N.debug 125 | 126 | 127 | {-# NOINLINE bitwise #-} 128 | bitwise :: Canonical 129 | bitwise = Canonical Pkg.core N.bitwise 130 | 131 | 132 | 133 | -- JSON 134 | 135 | 136 | {-# NOINLINE jsonDecode #-} 137 | jsonDecode :: Canonical 138 | jsonDecode = Canonical Pkg.json "Json.Decode" 139 | 140 | 141 | {-# NOINLINE jsonEncode #-} 142 | jsonEncode :: Canonical 143 | jsonEncode = Canonical Pkg.json "Json.Encode" 144 | 145 | 146 | 147 | -- WEBGL 148 | 149 | 150 | {-# NOINLINE webgl #-} 151 | webgl :: Canonical 152 | webgl = Canonical Pkg.webgl "WebGL" 153 | 154 | 155 | {-# NOINLINE texture #-} 156 | texture :: Canonical 157 | texture = Canonical Pkg.webgl "WebGL.Texture" 158 | 159 | 160 | {-# NOINLINE vector2 #-} 161 | vector2 :: Canonical 162 | vector2 = Canonical Pkg.linearAlgebra "Math.Vector2" 163 | 164 | 165 | {-# NOINLINE vector3 #-} 166 | vector3 :: Canonical 167 | vector3 = Canonical Pkg.linearAlgebra "Math.Vector3" 168 | 169 | 170 | {-# NOINLINE vector4 #-} 171 | vector4 :: Canonical 172 | vector4 = Canonical Pkg.linearAlgebra "Math.Vector4" 173 | 174 | 175 | {-# NOINLINE matrix4 #-} 176 | matrix4 :: Canonical 177 | matrix4 = Canonical Pkg.linearAlgebra "Math.Matrix4" 178 | 179 | 180 | 181 | -- IS KERNEL 182 | 183 | 184 | isKernel :: N.Name -> Bool 185 | isKernel name = 186 | N.startsWith "Elm.Kernel." name 187 | 188 | 189 | getKernel :: N.Name -> N.Name 190 | getKernel name = 191 | N.drop 11 name 192 | 193 | 194 | canonicalIsKernel :: Canonical -> Bool 195 | canonicalIsKernel (Canonical _ name) = 196 | isKernel name 197 | 198 | 199 | 200 | -- BINARY 201 | 202 | 203 | instance Binary Canonical where 204 | put (Canonical a b) = 205 | put a >> put b 206 | 207 | get = 208 | liftM2 Canonical get get 209 | -------------------------------------------------------------------------------- /reactor/src/Index/Icon.elm: -------------------------------------------------------------------------------- 1 | module Index.Icon exposing 2 | ( home 3 | , image 4 | , file 5 | , gift 6 | , folder 7 | , package 8 | , plus 9 | , lookup 10 | ) 11 | 12 | import Dict 13 | import Html exposing (Html) 14 | import Svg exposing (..) 15 | import Svg.Attributes exposing (class, width, height, viewBox, d, fill) 16 | 17 | 18 | 19 | -- ICON 20 | 21 | 22 | icon : String -> String -> String -> Html msg 23 | icon color size pathString = 24 | svg 25 | [ class "icon" 26 | , width size 27 | , height size 28 | , viewBox "0 0 1792 1792" 29 | ] 30 | [ path [ fill color, d pathString ] [] 31 | ] 32 | 33 | 34 | 35 | -- NECESSARY ICONS 36 | 37 | 38 | home : Html msg 39 | home = 40 | icon "#babdb6" "36px" "M1472 992v480q0 26-19 45t-45 19h-384v-384h-256v384h-384q-26 0-45-19t-19-45v-480q0-1 .5-3t.5-3l575-474 575 474q1 2 1 6zm223-69l-62 74q-8 9-21 11h-3q-13 0-21-7l-692-577-692 577q-12 8-24 7-13-2-21-11l-62-74q-8-10-7-23.5t11-21.5l719-599q32-26 76-26t76 26l244 204v-195q0-14 9-23t23-9h192q14 0 23 9t9 23v408l219 182q10 8 11 21.5t-7 23.5z" 41 | 42 | 43 | image : Html msg 44 | image = 45 | icon "#babdb6" "16px" "M1596 380q28 28 48 76t20 88v1152q0 40-28 68t-68 28h-1344q-40 0-68-28t-28-68v-1600q0-40 28-68t68-28h896q40 0 88 20t76 48zm-444-244v376h376q-10-29-22-41l-313-313q-12-12-41-22zm384 1528v-1024h-416q-40 0-68-28t-28-68v-416h-768v1536h1280zm-128-448v320h-1024v-192l192-192 128 128 384-384zm-832-192q-80 0-136-56t-56-136 56-136 136-56 136 56 56 136-56 136-136 56z" 46 | 47 | 48 | file : Html msg 49 | file = 50 | icon "#babdb6" "16px" "M1596 380q28 28 48 76t20 88v1152q0 40-28 68t-68 28h-1344q-40 0-68-28t-28-68v-1600q0-40 28-68t68-28h896q40 0 88 20t76 48zm-444-244v376h376q-10-29-22-41l-313-313q-12-12-41-22zm384 1528v-1024h-416q-40 0-68-28t-28-68v-416h-768v1536h1280zm-1024-864q0-14 9-23t23-9h704q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64zm736 224q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h704zm0 256q14 0 23 9t9 23v64q0 14-9 23t-23 9h-704q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h704z" 51 | 52 | 53 | gift : Html msg 54 | gift = 55 | icon "#babdb6" "16px" "M1056 1356v-716h-320v716q0 25 18 38.5t46 13.5h192q28 0 46-13.5t18-38.5zm-456-844h195l-126-161q-26-31-69-31-40 0-68 28t-28 68 28 68 68 28zm688-96q0-40-28-68t-68-28q-43 0-69 31l-125 161h194q40 0 68-28t28-68zm376 256v320q0 14-9 23t-23 9h-96v416q0 40-28 68t-68 28h-1088q-40 0-68-28t-28-68v-416h-96q-14 0-23-9t-9-23v-320q0-14 9-23t23-9h440q-93 0-158.5-65.5t-65.5-158.5 65.5-158.5 158.5-65.5q107 0 168 77l128 165 128-165q61-77 168-77 93 0 158.5 65.5t65.5 158.5-65.5 158.5-158.5 65.5h440q14 0 23 9t9 23z" 56 | 57 | 58 | folder : Html msg 59 | folder = 60 | icon "#babdb6" "16px" "M1728 608v704q0 92-66 158t-158 66h-1216q-92 0-158-66t-66-158v-960q0-92 66-158t158-66h320q92 0 158 66t66 158v32h672q92 0 158 66t66 158z" 61 | 62 | 63 | package : Html msg 64 | package = 65 | icon "#babdb6" "16px" "M1088 832q0-26-19-45t-45-19h-256q-26 0-45 19t-19 45 19 45 45 19h256q26 0 45-19t19-45zm576-192v960q0 26-19 45t-45 19h-1408q-26 0-45-19t-19-45v-960q0-26 19-45t45-19h1408q26 0 45 19t19 45zm64-448v256q0 26-19 45t-45 19h-1536q-26 0-45-19t-19-45v-256q0-26 19-45t45-19h1536q26 0 45 19t19 45z" 66 | 67 | 68 | plus : Html msg 69 | plus = 70 | icon "#babdb6" "16px" "M1600 736v192q0 40-28 68t-68 28h-416v416q0 40-28 68t-68 28h-192q-40 0-68-28t-28-68v-416h-416q-40 0-68-28t-28-68v-192q0-40 28-68t68-28h416v-416q0-40 28-68t68-28h192q40 0 68 28t28 68v416h416q40 0 68 28t28 68z" 71 | 72 | 73 | 74 | -- LOOKUP 75 | 76 | 77 | lookup : String -> Html msg 78 | lookup fileName = 79 | let 80 | extension = 81 | getExtension fileName 82 | in 83 | Maybe.withDefault file (Dict.get extension extensionIcons) 84 | 85 | 86 | extensionIcons : Dict.Dict String (Html msg) 87 | extensionIcons = 88 | Dict.fromList 89 | [ ("jpg" , image) 90 | , ("jpeg", image) 91 | , ("png" , image) 92 | , ("gif" , image) 93 | ] 94 | 95 | 96 | getExtension : String -> String 97 | getExtension str = 98 | getExtensionHelp (String.split "." str) 99 | 100 | 101 | getExtensionHelp : List String -> String 102 | getExtensionHelp segments = 103 | case segments of 104 | [] -> 105 | "" 106 | 107 | [ext] -> 108 | String.toLower ext 109 | 110 | _ :: rest -> 111 | getExtensionHelp rest 112 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Render/Code.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Render.Code 4 | ( Source 5 | , toSource 6 | , render 7 | , CodePair(..) 8 | , renderPair 9 | ) 10 | where 11 | 12 | 13 | import qualified Data.List as List 14 | import qualified Data.Text as Text 15 | 16 | import Reporting.Doc (Doc, (<>)) 17 | import qualified Reporting.Doc as D 18 | import qualified Reporting.Region as R 19 | 20 | 21 | 22 | -- CODE 23 | 24 | 25 | newtype Source = 26 | Source [(Int, Text.Text)] 27 | 28 | 29 | toSource :: Text.Text -> Source 30 | toSource source = 31 | Source $ zip [1..] $ 32 | Text.lines source ++ [Text.empty] 33 | 34 | 35 | 36 | -- RENDER 37 | 38 | 39 | (|>) :: a -> (a -> b) -> b 40 | (|>) a f = 41 | f a 42 | 43 | 44 | render :: Source -> R.Region -> Maybe R.Region -> Doc 45 | render (Source sourceLines) region@(R.Region start end) maybeSubRegion = 46 | let 47 | (R.Position startLine _) = start 48 | (R.Position endLine _) = end 49 | 50 | relevantLines = 51 | sourceLines 52 | |> drop (startLine - 1) 53 | |> take (1 + endLine - startLine) 54 | 55 | width = 56 | length (show (fst (last relevantLines))) 57 | 58 | smallerRegion = 59 | maybe region id maybeSubRegion 60 | in 61 | case makeUnderline width endLine smallerRegion of 62 | Nothing -> 63 | drawLines True width smallerRegion relevantLines D.empty 64 | 65 | Just underline -> 66 | drawLines False width smallerRegion relevantLines underline 67 | 68 | 69 | makeUnderline :: Int -> Int -> R.Region -> Maybe Doc 70 | makeUnderline width realEndLine (R.Region (R.Position start c1) (R.Position end c2)) = 71 | if start /= end || end < realEndLine then 72 | Nothing 73 | 74 | else 75 | let 76 | spaces = replicate (c1 + width + 1) ' ' 77 | zigzag = replicate (max 1 (c2 - c1)) '^' 78 | in 79 | Just (D.fromString spaces <> D.dullred (D.fromString zigzag)) 80 | 81 | 82 | drawLines :: Bool -> Int -> R.Region -> [(Int, Text.Text)] -> Doc -> Doc 83 | drawLines addZigZag width (R.Region start end) sourceLines finalLine = 84 | let 85 | (R.Position startLine _) = start 86 | (R.Position endLine _) = end 87 | in 88 | D.vcat $ 89 | map (drawLine addZigZag width startLine endLine) sourceLines 90 | ++ [finalLine] 91 | 92 | 93 | drawLine :: Bool -> Int -> Int -> Int -> (Int, Text.Text) -> Doc 94 | drawLine addZigZag width startLine endLine (n, line) = 95 | addLineNumber addZigZag width startLine endLine n (D.fromText line) 96 | 97 | 98 | addLineNumber :: Bool -> Int -> Int -> Int -> Int -> Doc -> Doc 99 | addLineNumber addZigZag width start end n line = 100 | let 101 | number = 102 | if n < 0 then " " else show n 103 | 104 | lineNumber = 105 | replicate (width - length number) ' ' ++ number ++ "|" 106 | 107 | spacer = 108 | if addZigZag && start <= n && n <= end then 109 | D.dullred ">" 110 | else 111 | " " 112 | in 113 | D.fromString lineNumber <> spacer <> line 114 | 115 | 116 | 117 | -- RENDER PAIR 118 | 119 | 120 | data CodePair 121 | = OneLine Doc 122 | | TwoChunks Doc Doc 123 | 124 | 125 | renderPair :: Source -> R.Region -> R.Region -> CodePair 126 | renderPair source@(Source sourceLines) region1 region2 = 127 | let 128 | (R.Region (R.Position startRow1 startCol1) (R.Position endRow1 endCol1)) = region1 129 | (R.Region (R.Position startRow2 startCol2) (R.Position endRow2 endCol2)) = region2 130 | in 131 | if startRow1 == endRow1 && endRow1 == startRow2 && startRow2 == endRow2 then 132 | let 133 | lineNumber = show startRow1 134 | spaces1 = replicate (startCol1 + length lineNumber + 1) ' ' 135 | zigzag1 = replicate (endCol1 - startCol1) '^' 136 | spaces2 = replicate (startCol2 - endCol1) ' ' 137 | zigzag2 = replicate (endCol2 - startCol2) '^' 138 | 139 | (Just line) = List.lookup startRow1 sourceLines 140 | in 141 | OneLine $ 142 | D.vcat 143 | [ D.fromString lineNumber <> "| " <> D.fromText line 144 | , D.fromString spaces1 <> D.dullred (D.fromString zigzag1) <> 145 | D.fromString spaces2 <> D.dullred (D.fromString zigzag2) 146 | ] 147 | 148 | else 149 | TwoChunks 150 | (render source region1 Nothing) 151 | (render source region2 Nothing) 152 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Error/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Error.Main 4 | ( Error(..) 5 | , toReport 6 | ) 7 | where 8 | 9 | 10 | import qualified AST.Canonical as Can 11 | import qualified Elm.Name as N 12 | import qualified Reporting.Doc as D 13 | import qualified Reporting.Error.Canonicalize as E 14 | import qualified Reporting.Region as R 15 | import qualified Reporting.Render.Code as Code 16 | import qualified Reporting.Render.Type as RT 17 | import qualified Reporting.Render.Type.Localizer as L 18 | import qualified Reporting.Report as Report 19 | 20 | 21 | 22 | -- ERROR 23 | 24 | 25 | data Error 26 | = BadType R.Region Can.Type 27 | | BadCycle R.Region [N.Name] 28 | | BadFlags R.Region Can.Type E.InvalidPayload 29 | 30 | 31 | 32 | -- TO REPORT 33 | 34 | 35 | toReport :: L.Localizer -> Code.Source -> Error -> Report.Report 36 | toReport localizer source err = 37 | case err of 38 | BadType region tipe -> 39 | Report.Report "BAD MAIN TYPE" region [] $ 40 | Report.toCodeSnippet source region Nothing 41 | ( 42 | "I cannot handle this type of `main` value:" 43 | , 44 | D.stack 45 | [ "The type of `main` value I am seeing is:" 46 | , D.indent 4 $ D.dullyellow $ RT.canToDoc localizer RT.None tipe 47 | , D.reflow $ 48 | "I only know how to handle Html, Svg, and Programs\ 49 | \ though. Modify `main` to be one of those types of values!" 50 | ] 51 | ) 52 | 53 | BadCycle region cycleNames -> 54 | Report.Report "BAD MAIN" region [] $ 55 | Report.toCodeSnippet source region Nothing 56 | ( 57 | "A `main` definition cannot be defined in terms of itself." 58 | , 59 | D.stack 60 | [ D.reflow $ 61 | "It should be a boring value with no recursion. But\ 62 | \ instead it is involved in this cycle of definitions:" 63 | , D.cycle 4 cycleNames 64 | ] 65 | ) 66 | 67 | BadFlags region _badType invalidPayload -> 68 | let 69 | formatDetails (aBadKindOfThing, butThatIsNoGood) = 70 | Report.Report "BAD FLAGS" region [] $ 71 | Report.toCodeSnippet source region Nothing 72 | ( 73 | D.reflow $ 74 | "Your `main` program wants " ++ aBadKindOfThing ++ " from JavaScript." 75 | , 76 | butThatIsNoGood 77 | ) 78 | in 79 | formatDetails $ 80 | case invalidPayload of 81 | E.ExtendedRecord -> 82 | ( 83 | "an extended record" 84 | , 85 | D.reflow $ 86 | "But the exact shape of the record must be known at compile time. No type variables!" 87 | ) 88 | 89 | E.Function -> 90 | ( 91 | "a function" 92 | , 93 | D.reflow $ 94 | "But if I allowed functions from JS, it would be possible to sneak\ 95 | \ side-effects and runtime exceptions into Elm!" 96 | ) 97 | 98 | E.TypeVariable name -> 99 | ( 100 | "an unspecified type" 101 | , 102 | D.reflow $ 103 | "But type variables like `" ++ N.toString name ++ "` cannot be given as flags.\ 104 | \ I need to know exactly what type of data I am getting, so I can guarantee that\ 105 | \ unexpected data cannot sneak in and crash the Elm program." 106 | ) 107 | 108 | E.UnsupportedType name -> 109 | ( 110 | "a `" ++ N.toString name ++ "` value" 111 | , 112 | D.stack 113 | [ D.reflow $ "I cannot handle that. The types that CAN be in flags include:" 114 | , D.indent 4 $ 115 | D.reflow $ 116 | "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\ 117 | \ tuples, records, and JSON values." 118 | , D.reflow $ 119 | "Since JSON values can flow through, you can use JSON encoders and decoders\ 120 | \ to allow other types through as well. More advanced users often just do\ 121 | \ everything with encoders and decoders for more control and better errors." 122 | ] 123 | ) 124 | -------------------------------------------------------------------------------- /compiler/src/Type/UnionFind.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -funbox-strict-fields #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | module Type.UnionFind 4 | ( Point 5 | , fresh 6 | , union 7 | , equivalent 8 | , redundant 9 | , get 10 | , set 11 | , modify 12 | ) 13 | where 14 | 15 | 16 | {- This is based on the following implementations: 17 | 18 | - https://hackage.haskell.org/package/union-find-0.2/docs/src/Data-UnionFind-IO.html 19 | - http://yann.regis-gianas.org/public/mini/code_UnionFind.html 20 | 21 | It seems like the OCaml one came first, but I am not sure. 22 | 23 | Compared to the Haskell implementation, the major changes here include: 24 | 25 | 1. No more reallocating PointInfo when changing the weight 26 | 2. Using the strict modifyIORef 27 | 28 | -} 29 | 30 | 31 | import Control.Monad ( when ) 32 | import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) 33 | import Data.Word (Word32) 34 | 35 | 36 | 37 | -- POINT 38 | 39 | 40 | newtype Point a = 41 | Pt (IORef (PointInfo a)) 42 | deriving Eq 43 | 44 | 45 | data PointInfo a 46 | = Info {-# UNPACK #-} !(IORef Word32) {-# UNPACK #-} !(IORef a) 47 | | Link {-# UNPACK #-} !(Point a) 48 | 49 | 50 | 51 | -- HELPERS 52 | 53 | 54 | fresh :: a -> IO (Point a) 55 | fresh value = 56 | do weight <- newIORef 1 57 | desc <- newIORef value 58 | link <- newIORef (Info weight desc) 59 | return (Pt link) 60 | 61 | 62 | repr :: Point a -> IO (Point a) 63 | repr point@(Pt ref) = 64 | do pInfo <- readIORef ref 65 | case pInfo of 66 | Info _ _ -> 67 | return point 68 | 69 | Link point1@(Pt ref1) -> 70 | do point2 <- repr point1 71 | when (point2 /= point1) $ 72 | do pInfo1 <- readIORef ref1 73 | writeIORef ref pInfo1 74 | return point2 75 | 76 | 77 | get :: Point a -> IO a 78 | get point@(Pt ref) = 79 | do pInfo <- readIORef ref 80 | case pInfo of 81 | Info _ descRef -> 82 | readIORef descRef 83 | 84 | Link (Pt ref1) -> 85 | do link' <- readIORef ref1 86 | case link' of 87 | Info _ descRef -> 88 | readIORef descRef 89 | 90 | Link _ -> 91 | get =<< repr point 92 | 93 | 94 | set :: Point a -> a -> IO () 95 | set point@(Pt ref) newDesc = 96 | do pInfo <- readIORef ref 97 | case pInfo of 98 | Info _ descRef -> 99 | writeIORef descRef newDesc 100 | 101 | Link (Pt ref1) -> 102 | do link' <- readIORef ref1 103 | case link' of 104 | Info _ descRef -> 105 | writeIORef descRef newDesc 106 | 107 | Link _ -> 108 | do newPoint <- repr point 109 | set newPoint newDesc 110 | 111 | 112 | modify :: Point a -> (a -> a) -> IO () 113 | modify point@(Pt ref) func = 114 | do pInfo <- readIORef ref 115 | case pInfo of 116 | Info _ descRef -> 117 | modifyIORef' descRef func 118 | 119 | Link (Pt ref1) -> 120 | do link' <- readIORef ref1 121 | case link' of 122 | Info _ descRef -> 123 | modifyIORef' descRef func 124 | 125 | Link _ -> 126 | do newPoint <- repr point 127 | modify newPoint func 128 | 129 | 130 | union :: Point a -> Point a -> a -> IO () 131 | union p1 p2 newDesc = 132 | do point1@(Pt ref1) <- repr p1 133 | point2@(Pt ref2) <- repr p2 134 | 135 | Info w1 d1 <- readIORef ref1 136 | Info w2 d2 <- readIORef ref2 137 | 138 | if point1 == point2 139 | then writeIORef d1 newDesc 140 | else do 141 | weight1 <- readIORef w1 142 | weight2 <- readIORef w2 143 | 144 | let !newWeight = weight1 + weight2 145 | 146 | if weight1 >= weight2 147 | then 148 | do writeIORef ref2 (Link point1) 149 | writeIORef w1 newWeight 150 | writeIORef d1 newDesc 151 | else 152 | do writeIORef ref1 (Link point2) 153 | writeIORef w2 newWeight 154 | writeIORef d2 newDesc 155 | 156 | 157 | equivalent :: Point a -> Point a -> IO Bool 158 | equivalent p1 p2 = 159 | do v1 <- repr p1 160 | v2 <- repr p2 161 | return (v1 == v2) 162 | 163 | 164 | redundant :: Point a -> IO Bool 165 | redundant (Pt ref) = 166 | do pInfo <- readIORef ref 167 | case pInfo of 168 | Info _ _ -> 169 | return False 170 | 171 | Link _ -> 172 | return True 173 | -------------------------------------------------------------------------------- /compiler/src/Parse/Primitives/Keyword.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE BangPatterns, OverloadedStrings #-} 3 | module Parse.Primitives.Keyword 4 | ( type_, alias_, port_ 5 | , if_, then_, else_ 6 | , case_, of_ 7 | , let_, in_ 8 | , infix_, left_, right_, non_ 9 | , module_, import_, exposing_, as_, where_, effect_ 10 | , command_, subscription_ 11 | , jsonTrue, jsonFalse, jsonNull 12 | ) 13 | where 14 | 15 | 16 | import Control.Exception (assert) 17 | import qualified Data.ByteString.Internal as B 18 | import qualified Data.ByteString.Char8 as Char8 19 | 20 | import Parse.Primitives.Internals (Parser(..), State(..), expect, noError) 21 | import qualified Parse.Primitives.Internals as I 22 | import qualified Parse.Primitives.Variable as Var 23 | import qualified Reporting.Error.Syntax as E 24 | 25 | 26 | 27 | -- PRIVATE IMPLEMENTATION 28 | 29 | 30 | {- We can some avoid allocation by declaring all available keywords here. 31 | That means the `keyword` function should only be used within this file on 32 | values tagged as NOINLINE. 33 | -} 34 | keyword :: B.ByteString -> Parser () 35 | keyword kwd@(B.PS kwdFp kwdOffset kwdLength) = 36 | let 37 | !theory = 38 | assert 39 | (I.isNonNewlineAscii kwdFp kwdOffset (kwdOffset + kwdLength)) 40 | (E.Keyword (Char8.unpack kwd)) 41 | in 42 | Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> 43 | if I.isSubstring kwdFp kwdOffset kwdLength fp offset terminal 44 | && Var.getInnerWidth fp (offset + kwdLength) terminal == 0 45 | then 46 | let 47 | !newState = 48 | State fp (offset + kwdLength) terminal indent row (col + kwdLength) ctx 49 | in 50 | cok () newState noError 51 | 52 | else 53 | eerr (expect row col ctx theory) 54 | 55 | 56 | 57 | -- DECLARATIONS 58 | 59 | 60 | {-# NOINLINE type_ #-} 61 | type_ :: Parser () 62 | type_ = 63 | keyword "type" 64 | 65 | 66 | {-# NOINLINE alias_ #-} 67 | alias_ :: Parser () 68 | alias_ = 69 | keyword "alias" 70 | 71 | 72 | {-# NOINLINE port_ #-} 73 | port_ :: Parser () 74 | port_ = 75 | keyword "port" 76 | 77 | 78 | 79 | -- IF EXPRESSIONS 80 | 81 | 82 | {-# NOINLINE if_ #-} 83 | if_ :: Parser () 84 | if_ = 85 | keyword "if" 86 | 87 | 88 | {-# NOINLINE then_ #-} 89 | then_ :: Parser () 90 | then_ = 91 | keyword "then" 92 | 93 | 94 | {-# NOINLINE else_ #-} 95 | else_ :: Parser () 96 | else_ = 97 | keyword "else" 98 | 99 | 100 | 101 | -- CASE EXPRESSIONS 102 | 103 | 104 | {-# NOINLINE case_ #-} 105 | case_ :: Parser () 106 | case_ = 107 | keyword "case" 108 | 109 | 110 | {-# NOINLINE of_ #-} 111 | of_ :: Parser () 112 | of_ = 113 | keyword "of" 114 | 115 | 116 | 117 | -- LET EXPRESSIONS 118 | 119 | 120 | {-# NOINLINE let_ #-} 121 | let_ :: Parser () 122 | let_ = 123 | keyword "let" 124 | 125 | 126 | {-# NOINLINE in_ #-} 127 | in_ :: Parser () 128 | in_ = 129 | keyword "in" 130 | 131 | 132 | 133 | -- INFIXES 134 | 135 | 136 | {-# NOINLINE infix_ #-} 137 | infix_ :: Parser () 138 | infix_ = 139 | keyword "infix" 140 | 141 | 142 | {-# NOINLINE left_ #-} 143 | left_ :: Parser () 144 | left_ = 145 | keyword "left" 146 | 147 | 148 | {-# NOINLINE right_ #-} 149 | right_ :: Parser () 150 | right_ = 151 | keyword "right" 152 | 153 | 154 | {-# NOINLINE non_ #-} 155 | non_ :: Parser () 156 | non_ = 157 | keyword "non" 158 | 159 | 160 | 161 | -- IMPORTS 162 | 163 | 164 | {-# NOINLINE module_ #-} 165 | module_ :: Parser () 166 | module_ = 167 | keyword "module" 168 | 169 | 170 | {-# NOINLINE import_ #-} 171 | import_ :: Parser () 172 | import_ = 173 | keyword "import" 174 | 175 | 176 | {-# NOINLINE exposing_ #-} 177 | exposing_ :: Parser () 178 | exposing_ = 179 | keyword "exposing" 180 | 181 | 182 | {-# NOINLINE as_ #-} 183 | as_ :: Parser () 184 | as_ = 185 | keyword "as" 186 | 187 | 188 | {-# NOINLINE where_ #-} 189 | where_ :: Parser () 190 | where_ = 191 | keyword "where" 192 | 193 | 194 | {-# NOINLINE effect_ #-} 195 | effect_ :: Parser () 196 | effect_ = 197 | keyword "effect" 198 | 199 | 200 | 201 | -- EFFECTS 202 | 203 | 204 | {-# NOINLINE command_ #-} 205 | command_ :: Parser () 206 | command_ = 207 | keyword "command" 208 | 209 | 210 | {-# NOINLINE subscription_ #-} 211 | subscription_ :: Parser () 212 | subscription_ = 213 | keyword "subscription" 214 | 215 | 216 | 217 | -- JSON 218 | 219 | 220 | {-# NOINLINE jsonTrue #-} 221 | jsonTrue :: Parser () 222 | jsonTrue = 223 | keyword "true" 224 | 225 | 226 | {-# NOINLINE jsonFalse #-} 227 | jsonFalse :: Parser () 228 | jsonFalse = 229 | keyword "false" 230 | 231 | 232 | {-# NOINLINE jsonNull #-} 233 | jsonNull :: Parser () 234 | jsonNull = 235 | keyword "null" 236 | -------------------------------------------------------------------------------- /compiler/src/Optimize/Case.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Optimize.Case 3 | ( optimize 4 | ) 5 | where 6 | 7 | 8 | import Control.Arrow (second) 9 | import qualified Data.Map as Map 10 | import Data.Map ((!)) 11 | import qualified Data.Maybe as Maybe 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified AST.Optimized as Opt 15 | import qualified Elm.Name as N 16 | import qualified Optimize.DecisionTree as DT 17 | 18 | 19 | 20 | -- OPTIMIZE A CASE EXPRESSION 21 | 22 | 23 | optimize :: N.Name -> N.Name -> [(Can.Pattern, Opt.Expr)] -> Opt.Expr 24 | optimize temp root optBranches = 25 | let 26 | (patterns, indexedBranches) = 27 | unzip (zipWith indexify [0..] optBranches) 28 | 29 | decider = treeToDecider (DT.compile patterns) 30 | targetCounts = countTargets decider 31 | 32 | (choices, maybeJumps) = 33 | unzip (map (createChoices targetCounts) indexedBranches) 34 | in 35 | Opt.Case temp root 36 | (insertChoices (Map.fromList choices) decider) 37 | (Maybe.catMaybes maybeJumps) 38 | 39 | 40 | indexify :: Int -> (a,b) -> ((a,Int), (Int,b)) 41 | indexify index (pattern, branch) = 42 | ( (pattern, index) 43 | , (index, branch) 44 | ) 45 | 46 | 47 | 48 | -- TREE TO DECIDER 49 | -- 50 | -- Decision trees may have some redundancies, so we convert them to a Decider 51 | -- which has special constructs to avoid code duplication when possible. 52 | 53 | 54 | treeToDecider :: DT.DecisionTree -> Opt.Decider Int 55 | treeToDecider tree = 56 | case tree of 57 | DT.Match target -> 58 | Opt.Leaf target 59 | 60 | -- zero options 61 | DT.Decision _ [] Nothing -> 62 | error "compiler bug, somehow created an empty decision tree" 63 | 64 | -- one option 65 | DT.Decision _ [(_, subTree)] Nothing -> 66 | treeToDecider subTree 67 | 68 | DT.Decision _ [] (Just subTree) -> 69 | treeToDecider subTree 70 | 71 | -- two options 72 | DT.Decision path [(test, successTree)] (Just failureTree) -> 73 | toChain path test successTree failureTree 74 | 75 | DT.Decision path [(test, successTree), (_, failureTree)] Nothing -> 76 | toChain path test successTree failureTree 77 | 78 | -- many options 79 | DT.Decision path edges Nothing -> 80 | let 81 | (necessaryTests, fallback) = 82 | (init edges, snd (last edges)) 83 | in 84 | Opt.FanOut 85 | path 86 | (map (second treeToDecider) necessaryTests) 87 | (treeToDecider fallback) 88 | 89 | DT.Decision path edges (Just fallback) -> 90 | Opt.FanOut path (map (second treeToDecider) edges) (treeToDecider fallback) 91 | 92 | 93 | toChain :: DT.Path -> DT.Test -> DT.DecisionTree -> DT.DecisionTree -> Opt.Decider Int 94 | toChain path test successTree failureTree = 95 | let 96 | failure = 97 | treeToDecider failureTree 98 | in 99 | case treeToDecider successTree of 100 | Opt.Chain testChain success subFailure | failure == subFailure -> 101 | Opt.Chain ((path, test) : testChain) success failure 102 | 103 | success -> 104 | Opt.Chain [(path, test)] success failure 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 (+) (map countTargets (fallback : map snd 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 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 (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 (map (second go) tests) (go fallback) 161 | 162 | -------------------------------------------------------------------------------- /compiler/src/Canonicalize/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Canonicalize.Type 4 | ( toAnnotation 5 | , canonicalize 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.List as List 11 | import qualified Data.Map as Map 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified AST.Source as Src 15 | import qualified Canonicalize.Environment as Env 16 | import qualified Canonicalize.Environment.Dups as Dups 17 | import qualified Elm.Name as N 18 | import qualified Reporting.Annotation as A 19 | import qualified Reporting.Error.Canonicalize as Error 20 | import qualified Reporting.Region as R 21 | import qualified Reporting.Result as Result 22 | 23 | 24 | 25 | -- RESULT 26 | 27 | 28 | type Result i w a = 29 | Result.Result i w Error.Error a 30 | 31 | 32 | 33 | -- TO ANNOTATION 34 | 35 | 36 | toAnnotation :: Env.Env -> Src.Type -> Result i w Can.Annotation 37 | toAnnotation env srcType = 38 | do tipe <- canonicalize env srcType 39 | Result.ok $ Can.Forall (addFreeVars Map.empty tipe) tipe 40 | 41 | 42 | 43 | -- CANONICALIZE TYPES 44 | 45 | 46 | canonicalize :: Env.Env -> Src.Type -> Result i w Can.Type 47 | canonicalize env (A.At typeRegion tipe) = 48 | case tipe of 49 | Src.TVar x -> 50 | Result.ok (Can.TVar x) 51 | 52 | Src.TType region name args -> 53 | canonicalizeType env typeRegion name args =<< 54 | Env.findType region env name 55 | 56 | Src.TTypeQual region home name args -> 57 | canonicalizeType env typeRegion name args =<< 58 | Env.findTypeQual region env home name 59 | 60 | Src.TLambda a b -> 61 | Can.TLambda 62 | <$> canonicalize env a 63 | <*> canonicalize env b 64 | 65 | Src.TRecord fields ext -> 66 | do cfields <- sequenceA =<< Dups.checkFields (canonicalizeFields env fields) 67 | return $ Can.TRecord cfields (fmap A.toValue ext) 68 | 69 | Src.TUnit -> 70 | Result.ok Can.TUnit 71 | 72 | Src.TTuple a b cs -> 73 | Can.TTuple 74 | <$> canonicalize env a 75 | <*> canonicalize env b 76 | <*> 77 | case cs of 78 | [] -> 79 | Result.ok Nothing 80 | 81 | [c] -> 82 | Just <$> canonicalize env c 83 | 84 | _ -> 85 | Result.throw $ Error.TupleLargerThanThree typeRegion 86 | 87 | 88 | canonicalizeFields :: Env.Env -> [(A.Located N.Name, Src.Type)] -> [(A.Located N.Name, Result i w Can.FieldType)] 89 | canonicalizeFields env fields = 90 | let 91 | len = fromIntegral (length fields) 92 | canonicalizeField index (name, srcType) = 93 | (name, Can.FieldType index <$> canonicalize env srcType) 94 | in 95 | zipWith canonicalizeField [0..len] fields 96 | 97 | 98 | 99 | -- CANONICALIZE TYPE 100 | 101 | 102 | canonicalizeType :: Env.Env -> R.Region -> N.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type 103 | canonicalizeType env region name args info = 104 | do cargs <- traverse (canonicalize env) args 105 | case info of 106 | Env.Alias arity home argNames aliasedType -> 107 | checkArity arity region name args $ 108 | Can.TAlias home name (zip argNames cargs) (Can.Holey aliasedType) 109 | 110 | Env.Union arity home -> 111 | checkArity arity region name args $ 112 | Can.TType home name cargs 113 | 114 | 115 | checkArity :: Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer 116 | checkArity expected region name args answer = 117 | let actual = length args in 118 | if expected == actual then 119 | Result.ok answer 120 | else 121 | Result.throw (Error.BadArity region Error.TypeArity name expected actual) 122 | 123 | 124 | 125 | -- ADD FREE VARS 126 | 127 | 128 | addFreeVars :: Map.Map N.Name () -> Can.Type -> Map.Map N.Name () 129 | addFreeVars freeVars tipe = 130 | case tipe of 131 | Can.TLambda arg result -> 132 | addFreeVars (addFreeVars freeVars result) arg 133 | 134 | Can.TVar var -> 135 | Map.insert var () freeVars 136 | 137 | Can.TType _ _ args -> 138 | List.foldl' addFreeVars freeVars args 139 | 140 | Can.TRecord fields Nothing -> 141 | Map.foldl addFieldFreeVars freeVars fields 142 | 143 | Can.TRecord fields (Just ext) -> 144 | Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields 145 | 146 | Can.TUnit -> 147 | freeVars 148 | 149 | Can.TTuple a b maybeC -> 150 | case maybeC of 151 | Nothing -> 152 | addFreeVars (addFreeVars freeVars a) b 153 | 154 | Just c -> 155 | addFreeVars (addFreeVars (addFreeVars freeVars a) b) c 156 | 157 | Can.TAlias _ _ args _ -> 158 | List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args 159 | 160 | 161 | addFieldFreeVars :: Map.Map N.Name () -> Can.FieldType -> Map.Map N.Name () 162 | addFieldFreeVars freeVars (Can.FieldType _ tipe) = 163 | addFreeVars freeVars tipe 164 | -------------------------------------------------------------------------------- /compiler/src/Optimize/Names.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | module Optimize.Names 5 | ( Tracker 6 | , run 7 | , generate 8 | , registerKernel 9 | , registerGlobal 10 | , registerDebug 11 | , registerCtor 12 | , registerField 13 | , registerFieldDict 14 | , registerFieldList 15 | ) 16 | where 17 | 18 | 19 | import qualified Data.Map as Map 20 | import qualified Data.Set as Set 21 | 22 | import qualified AST.Canonical as Can 23 | import qualified AST.Optimized as Opt 24 | import qualified AST.Module.Name as ModuleName 25 | import qualified Data.Index as Index 26 | import qualified Elm.Name as N 27 | import qualified Elm.Package as Pkg 28 | import qualified Reporting.Region as R 29 | 30 | 31 | 32 | -- GENERATOR 33 | 34 | 35 | newtype Tracker a = 36 | Tracker ( 37 | forall r. 38 | Int 39 | -> Set.Set Opt.Global 40 | -> Map.Map N.Name Int 41 | -> (Int -> Set.Set Opt.Global -> Map.Map N.Name Int -> a -> r) 42 | -> r 43 | ) 44 | 45 | 46 | run :: Tracker a -> (Set.Set Opt.Global, Map.Map N.Name Int, a) 47 | run (Tracker k) = 48 | k 0 Set.empty Map.empty 49 | (\_uid deps fields value -> (deps, fields, value)) 50 | 51 | 52 | generate :: Tracker N.Name 53 | generate = 54 | Tracker $ \uid deps fields ok -> 55 | ok (uid + 1) deps fields (N.addIndex "_n" uid) 56 | 57 | 58 | registerKernel :: N.Name -> a -> Tracker a 59 | registerKernel home value = 60 | Tracker $ \uid deps fields ok -> 61 | ok uid (Set.insert (toKernelGlobal home) deps) fields value 62 | 63 | 64 | toKernelGlobal :: N.Name -> Opt.Global 65 | toKernelGlobal home = 66 | Opt.Global (ModuleName.Canonical Pkg.kernel home) N.dollar 67 | 68 | 69 | registerGlobal :: ModuleName.Canonical -> N.Name -> Tracker Opt.Expr 70 | registerGlobal home name = 71 | Tracker $ \uid deps fields ok -> 72 | let global = Opt.Global home name in 73 | ok uid (Set.insert global deps) fields (Opt.VarGlobal global) 74 | 75 | 76 | registerDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Tracker Opt.Expr 77 | registerDebug name home region = 78 | Tracker $ \uid deps fields ok -> 79 | let global = Opt.Global ModuleName.debug name in 80 | ok uid (Set.insert global deps) fields (Opt.VarDebug name home region Nothing) 81 | 82 | 83 | registerCtor :: ModuleName.Canonical -> N.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr 84 | registerCtor home name index opts = 85 | Tracker $ \uid deps fields ok -> 86 | let 87 | global = Opt.Global home name 88 | newDeps = Set.insert global deps 89 | in 90 | case opts of 91 | Can.Normal -> 92 | ok uid newDeps fields (Opt.VarGlobal global) 93 | 94 | Can.Enum -> 95 | ok uid newDeps fields $ 96 | case name of 97 | "True" | home == ModuleName.basics -> Opt.Bool True 98 | "False" | home == ModuleName.basics -> Opt.Bool False 99 | _ -> Opt.VarEnum global index 100 | 101 | Can.Unbox -> 102 | ok uid (Set.insert identity newDeps) fields (Opt.VarBox global) 103 | 104 | 105 | identity :: Opt.Global 106 | identity = 107 | Opt.Global ModuleName.basics N.identity 108 | 109 | 110 | registerField :: N.Name -> a -> Tracker a 111 | registerField name value = 112 | Tracker $ \uid d fields ok -> 113 | ok uid d (Map.insertWith (+) name 1 fields) value 114 | 115 | 116 | registerFieldDict :: Map.Map N.Name v -> a -> Tracker a 117 | registerFieldDict newFields value = 118 | Tracker $ \uid d fields ok -> 119 | ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value 120 | 121 | 122 | toOne :: a -> Int 123 | toOne _ = 1 124 | 125 | 126 | registerFieldList :: [N.Name] -> a -> Tracker a 127 | registerFieldList names value = 128 | Tracker $ \uid deps fields ok -> 129 | ok uid deps (foldr addOne fields names) value 130 | 131 | 132 | addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int 133 | addOne name fields = 134 | Map.insertWith (+) name 1 fields 135 | 136 | 137 | 138 | -- INSTANCES 139 | 140 | 141 | instance Functor Tracker where 142 | fmap func (Tracker kv) = 143 | Tracker $ \n d f ok -> 144 | let 145 | ok1 n1 d1 f1 value = 146 | ok n1 d1 f1 (func value) 147 | in 148 | kv n d f ok1 149 | 150 | 151 | instance Applicative Tracker where 152 | {-# INLINE pure #-} 153 | pure value = 154 | Tracker $ \n d f ok -> ok n d f value 155 | 156 | (<*>) (Tracker kf) (Tracker kv) = 157 | Tracker $ \n d f ok -> 158 | let 159 | ok1 n1 d1 f1 func = 160 | let 161 | ok2 n2 d2 f2 value = 162 | ok n2 d2 f2 (func value) 163 | in 164 | kv n1 d1 f1 ok2 165 | in 166 | kf n d f ok1 167 | 168 | 169 | instance Monad Tracker where 170 | return = pure 171 | 172 | (>>=) (Tracker k) callback = 173 | Tracker $ \n d f ok -> 174 | let 175 | ok1 n1 d1 f1 a = 176 | case callback a of 177 | Tracker kb -> kb n1 d1 f1 ok 178 | in 179 | k n d f ok1 180 | -------------------------------------------------------------------------------- /compiler/src/Elm/Compiler/Type.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Elm.Compiler.Type 4 | ( Type(..) 5 | , RT.Context(..) 6 | , toDoc 7 | , DebugMetadata(..) 8 | , Alias(..) 9 | , Union(..) 10 | , encode 11 | , decoder 12 | , encodeMetadata 13 | ) 14 | where 15 | 16 | 17 | import qualified Data.Text as Text 18 | import qualified Data.Text.Encoding as Text 19 | 20 | import qualified AST.Source as Src 21 | import qualified Elm.Name as N 22 | import qualified Parse.Primitives as Parse 23 | import qualified Parse.Type as Type 24 | import qualified Reporting.Annotation as A 25 | import qualified Reporting.Doc as D 26 | import qualified Reporting.Render.Type as RT 27 | import qualified Reporting.Render.Type.Localizer as L 28 | 29 | import qualified Json.Decode as Decode 30 | import qualified Json.Encode as Encode 31 | import Json.Encode ((==>)) 32 | 33 | 34 | 35 | -- TYPES 36 | 37 | 38 | data Type 39 | = Lambda Type Type 40 | | Var N.Name 41 | | Type N.Name [Type] 42 | | Record [(N.Name, Type)] (Maybe N.Name) 43 | | Unit 44 | | Tuple Type Type [Type] 45 | 46 | 47 | data DebugMetadata = 48 | DebugMetadata 49 | { _message :: Type 50 | , _aliases :: [Alias] 51 | , _unions :: [Union] 52 | } 53 | 54 | 55 | data Alias = Alias N.Name [N.Name] Type 56 | data Union = Union N.Name [N.Name] [(N.Name, [Type])] 57 | 58 | 59 | 60 | -- TO DOC 61 | 62 | 63 | toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc 64 | toDoc localizer context tipe = 65 | case tipe of 66 | Lambda _ _ -> 67 | let 68 | a:b:cs = 69 | map (toDoc localizer RT.Func) (collectLambdas tipe) 70 | in 71 | RT.lambda context a b cs 72 | 73 | Var name -> 74 | D.fromName name 75 | 76 | Unit -> 77 | "()" 78 | 79 | Tuple a b cs -> 80 | RT.tuple 81 | (toDoc localizer RT.None a) 82 | (toDoc localizer RT.None b) 83 | (map (toDoc localizer RT.None) cs) 84 | 85 | Type name args -> 86 | RT.apply 87 | context 88 | (D.fromName name) 89 | (map (toDoc localizer RT.App) args) 90 | 91 | Record fields ext -> 92 | RT.record 93 | (map (entryToDoc localizer) fields) 94 | (fmap D.fromName ext) 95 | 96 | 97 | entryToDoc :: L.Localizer -> (N.Name, Type) -> (D.Doc, D.Doc) 98 | entryToDoc localizer (field, fieldType) = 99 | ( D.fromName field, toDoc localizer RT.None fieldType ) 100 | 101 | 102 | collectLambdas :: Type -> [Type] 103 | collectLambdas tipe = 104 | case tipe of 105 | Lambda arg body -> 106 | arg : collectLambdas body 107 | 108 | _ -> 109 | [tipe] 110 | 111 | 112 | 113 | -- JSON for TYPE 114 | 115 | 116 | encode :: Type -> Encode.Value 117 | encode tipe = 118 | Encode.text $ Text.pack $ D.toLine (toDoc L.empty RT.None tipe) 119 | 120 | 121 | decoder :: Decode.Decoder () Type 122 | decoder = 123 | do txt <- Decode.text 124 | case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of 125 | Left _ -> 126 | Decode.fail () 127 | 128 | Right (tipe, _, _) -> 129 | Decode.succeed (fromRawType tipe) 130 | 131 | 132 | fromRawType :: Src.Type -> Type 133 | fromRawType (A.At _ astType) = 134 | case astType of 135 | Src.TLambda t1 t2 -> 136 | Lambda (fromRawType t1) (fromRawType t2) 137 | 138 | Src.TVar x -> 139 | Var x 140 | 141 | Src.TUnit -> 142 | Unit 143 | 144 | Src.TTuple a b cs -> 145 | Tuple 146 | (fromRawType a) 147 | (fromRawType b) 148 | (map fromRawType cs) 149 | 150 | Src.TType _ name args -> 151 | Type name (map fromRawType args) 152 | 153 | Src.TTypeQual _ _ name args -> 154 | Type name (map fromRawType args) 155 | 156 | Src.TRecord fields ext -> 157 | let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in 158 | Record 159 | (map fromField fields) 160 | (fmap A.toValue ext) 161 | 162 | 163 | 164 | -- JSON for PROGRAM 165 | 166 | 167 | encodeMetadata :: DebugMetadata -> Encode.Value 168 | encodeMetadata (DebugMetadata msg aliases unions) = 169 | Encode.object 170 | [ "message" ==> encode msg 171 | , "aliases" ==> Encode.object (map toAliasField aliases) 172 | , "unions" ==> Encode.object (map toUnionField unions) 173 | ] 174 | 175 | 176 | toAliasField :: Alias -> ( Text.Text, Encode.Value ) 177 | toAliasField (Alias name args tipe) = 178 | N.toText name ==> 179 | Encode.object 180 | [ "args" ==> Encode.list Encode.name args 181 | , "type" ==> encode tipe 182 | ] 183 | 184 | 185 | toUnionField :: Union -> ( Text.Text, Encode.Value ) 186 | toUnionField (Union name args constructors) = 187 | N.toText name ==> 188 | Encode.object 189 | [ "args" ==> Encode.list Encode.name args 190 | , "tags" ==> Encode.object (map toCtorObject constructors) 191 | ] 192 | 193 | 194 | toCtorObject :: (N.Name, [Type]) -> ( Text.Text, Encode.Value ) 195 | toCtorObject (name, args) = 196 | N.toText name ==> Encode.list encode args 197 | -------------------------------------------------------------------------------- /compiler/src/Reporting/Error/Docs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Error.Docs 4 | ( Error(..) 5 | , toReport 6 | ) 7 | where 8 | 9 | 10 | import qualified Elm.Name as N 11 | import Reporting.Doc ((<>)) 12 | import qualified Reporting.Doc as D 13 | import qualified Reporting.Region as R 14 | import qualified Reporting.Render.Code as Code 15 | import qualified Reporting.Report as Report 16 | 17 | 18 | 19 | data Error 20 | = NoDocs R.Region 21 | | ImplicitExposing R.Region 22 | | Duplicate N.Name R.Region R.Region 23 | | OnlyInDocs N.Name R.Region 24 | | OnlyInExports N.Name R.Region 25 | | NoComment N.Name R.Region 26 | | NoAnnotation N.Name R.Region 27 | 28 | 29 | 30 | -- TO REPORT 31 | 32 | 33 | toReport :: Code.Source -> Error -> Report.Report 34 | toReport source err = 35 | case err of 36 | NoDocs region -> 37 | Report.Report "NO DOCS" region [] $ 38 | D.stack 39 | [ 40 | D.reflow $ 41 | "You must have a documentation comment between the module\ 42 | \ declaration and the imports." 43 | , 44 | D.reflow 45 | "Learn more at " 46 | ] 47 | 48 | ImplicitExposing region -> 49 | Report.Report "IMPLICIT EXPOSING" region [] $ 50 | D.stack 51 | [ 52 | D.reflow $ 53 | "I need you to be explicit about what this module exposes:" 54 | , 55 | D.reflow $ 56 | "A great API usually hides some implementation details, so it is rare that\ 57 | \ everything in the file should be exposed. And requiring package authors\ 58 | \ to be explicit about this is a way of adding another quality check before\ 59 | \ code gets published. So as you write out the public API, ask yourself if\ 60 | \ it will be easy to understand as people read the documentation!" 61 | ] 62 | 63 | Duplicate name r1 r2 -> 64 | Report.Report "DUPLICATE DOCS" r2 [] $ 65 | Report.toCodePair source r1 r2 66 | ( 67 | D.reflow $ 68 | "There can only be one `" <> N.toString name 69 | <> "` in your module documentation, but it is listed twice:" 70 | , 71 | "Remove one of them!" 72 | ) 73 | ( 74 | D.reflow $ 75 | "There can only be one `" <> N.toString name 76 | <> "` in your module documentation, but I see two. One here:" 77 | , 78 | "And another one over here:" 79 | , 80 | "Remove one of them!" 81 | ) 82 | 83 | OnlyInDocs name region -> 84 | Report.Report "DOCS MISTAKE" region [] $ 85 | Report.toCodeSnippet source region Nothing 86 | ( 87 | D.reflow $ 88 | "I do not see `" <> N.toString name 89 | <> "` in the `exposing` list, but it is in your module documentation:" 90 | , 91 | D.reflow $ 92 | "Does it need to be added to the `exposing` list as well? Or maybe you removed `" 93 | <> N.toString name <> "` and forgot to delete it here?" 94 | ) 95 | 96 | OnlyInExports name region -> 97 | Report.Report "DOCS MISTAKE" region [] $ 98 | Report.toCodeSnippet source region Nothing 99 | ( 100 | D.reflow $ 101 | "I do not see `" <> N.toString name 102 | <> "` in your module documentation, but it is in your `exposing` list:" 103 | , 104 | D.stack 105 | [ D.reflow $ 106 | "Add a line like `@docs " <> N.toString name 107 | <> "` to your module documentation!" 108 | , D.link "Note" "See" "docs" "for more guidance on writing high quality docs." 109 | ] 110 | ) 111 | 112 | NoComment name region -> 113 | Report.Report "NO DOCS" region [] $ 114 | Report.toCodeSnippet source region Nothing 115 | ( 116 | D.reflow $ 117 | "The `" <> N.toString name <> "` definition does not have a documentation comment." 118 | , 119 | D.stack 120 | [ D.reflow $ 121 | "Add documentation with nice examples of how to use it!" 122 | , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!" 123 | ] 124 | ) 125 | 126 | NoAnnotation name region -> 127 | Report.Report "NO TYPE ANNOTATION" region [] $ 128 | Report.toCodeSnippet source region Nothing 129 | ( 130 | D.reflow $ 131 | "The `" <> N.toString name <> "` definition does not have a type annotation." 132 | , 133 | D.stack 134 | [ D.reflow $ 135 | "I use the type variable names from your annotations when generating docs. So if\ 136 | \ you say `Html msg` in your type annotation, I can use `msg` in the docs and make\ 137 | \ them a bit clearer. So add an annotation and try to use nice type variables!" 138 | , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!" 139 | ] 140 | ) 141 | -------------------------------------------------------------------------------- /compiler/src/Canonicalize/Pattern.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Canonicalize.Pattern 3 | ( verify 4 | , Bindings 5 | , DupsDict 6 | , canonicalize 7 | ) 8 | where 9 | 10 | 11 | import qualified Data.Map.Strict as Map 12 | 13 | import qualified AST.Canonical as Can 14 | import qualified AST.Module.Name as ModuleName 15 | import qualified AST.Source as Src 16 | import qualified Canonicalize.Environment as Env 17 | import qualified Canonicalize.Environment.Dups as Dups 18 | import qualified Data.Index as Index 19 | import qualified Elm.Name as N 20 | import qualified Reporting.Annotation as A 21 | import qualified Reporting.Error.Canonicalize as Error 22 | import qualified Reporting.Region as R 23 | import qualified Reporting.Result as Result 24 | 25 | 26 | 27 | -- RESULTS 28 | 29 | 30 | type Result i w a = 31 | Result.Result i w Error.Error a 32 | 33 | 34 | type Bindings = 35 | Map.Map N.Name R.Region 36 | 37 | 38 | 39 | -- VERIFY 40 | 41 | 42 | verify :: Error.DuplicatePatternContext -> Result DupsDict w a -> Result i w (a, Bindings) 43 | verify context (Result.Result k) = 44 | Result.Result $ \info warnings bad good -> 45 | k Dups.none warnings 46 | (\_ warnings1 errors -> 47 | bad info warnings1 errors 48 | ) 49 | (\bindings warnings1 value -> 50 | case Dups.detect (Error.DuplicatePattern context) bindings of 51 | Result.Result k1 -> 52 | k1 () () 53 | (\() () errs -> bad info warnings1 errs) 54 | (\() () dict -> good info warnings1 (value, dict)) 55 | ) 56 | 57 | 58 | 59 | -- CANONICALIZE 60 | 61 | 62 | type DupsDict = 63 | Dups.Dict R.Region 64 | 65 | 66 | canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern 67 | canonicalize env (A.At region pattern) = 68 | A.At region <$> 69 | case pattern of 70 | Src.PAnything -> 71 | Result.ok Can.PAnything 72 | 73 | Src.PVar name -> 74 | logVar name region (Can.PVar name) 75 | 76 | Src.PRecord fields -> 77 | logFields fields (Can.PRecord (map A.toValue fields)) 78 | 79 | Src.PUnit -> 80 | Result.ok Can.PUnit 81 | 82 | Src.PTuple a b cs -> 83 | Can.PTuple 84 | <$> canonicalize env a 85 | <*> canonicalize env b 86 | <*> canonicalizeTuple region env cs 87 | 88 | Src.PCtor nameRegion name patterns -> 89 | canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name 90 | 91 | Src.PCtorQual nameRegion home name patterns -> 92 | canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name 93 | 94 | Src.PList patterns -> 95 | Can.PList <$> canonicalizeList env patterns 96 | 97 | Src.PCons first rest -> 98 | Can.PCons 99 | <$> canonicalize env first 100 | <*> canonicalize env rest 101 | 102 | Src.PAlias ptrn (A.At reg name) -> 103 | do cpattern <- canonicalize env ptrn 104 | logVar name reg (Can.PAlias cpattern name) 105 | 106 | Src.PChr chr -> 107 | Result.ok (Can.PChr chr) 108 | 109 | Src.PStr str -> 110 | Result.ok (Can.PStr str) 111 | 112 | Src.PInt int -> 113 | Result.ok (Can.PInt int) 114 | 115 | 116 | canonicalizeCtor :: Env.Env -> R.Region -> N.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_ 117 | canonicalizeCtor env region name patterns ctor = 118 | case ctor of 119 | Env.Ctor home tipe union index args -> 120 | let 121 | toCanonicalArg argIndex argPattern argTipe = 122 | Can.PatternCtorArg argIndex argTipe <$> canonicalize env argPattern 123 | in 124 | do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args 125 | case verifiedList of 126 | Index.LengthMatch cargs -> 127 | if tipe == N.bool && home == ModuleName.basics then 128 | Result.ok (Can.PBool union (name == N.true)) 129 | else 130 | Result.ok (Can.PCtor home tipe union name index cargs) 131 | 132 | Index.LengthMismatch actualLength expectedLength -> 133 | Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength) 134 | 135 | Env.RecordCtor _ _ _ -> 136 | Result.throw (Error.PatternHasRecordCtor region name) 137 | 138 | 139 | canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern) 140 | canonicalizeTuple tupleRegion env extras = 141 | case extras of 142 | [] -> 143 | Result.ok Nothing 144 | 145 | [three] -> 146 | Just <$> canonicalize env three 147 | 148 | _ -> 149 | Result.throw $ Error.TupleLargerThanThree tupleRegion 150 | 151 | 152 | canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern] 153 | canonicalizeList env list = 154 | case list of 155 | [] -> 156 | Result.ok [] 157 | 158 | pattern : otherPatterns -> 159 | (:) 160 | <$> canonicalize env pattern 161 | <*> canonicalizeList env otherPatterns 162 | 163 | 164 | 165 | -- LOG BINDINGS 166 | 167 | 168 | logVar :: N.Name -> R.Region -> a -> Result DupsDict w a 169 | logVar name region value = 170 | Result.Result $ \bindings warnings _ ok -> 171 | ok (Dups.insert name region region bindings) warnings value 172 | 173 | 174 | logFields :: [A.Located N.Name] -> a -> Result DupsDict w a 175 | logFields fields value = 176 | let 177 | addField (A.At region name) dict = 178 | Dups.insert name region region dict 179 | in 180 | Result.Result $ \bindings warnings _ ok -> 181 | ok (foldr addField bindings fields) warnings value 182 | -------------------------------------------------------------------------------- /reactor/src/Errors.elm: -------------------------------------------------------------------------------- 1 | module Errors exposing (main) 2 | 3 | 4 | import Browser 5 | import Char 6 | import Html exposing (..) 7 | import Html.Attributes exposing (..) 8 | import String 9 | import Json.Decode as D 10 | import Elm.Error as Error 11 | 12 | 13 | 14 | -- MAIN 15 | 16 | 17 | main = 18 | Browser.document 19 | { init = \flags -> (D.decodeValue Error.decoder flags, Cmd.none) 20 | , update = \_ exit -> (exit, Cmd.none) 21 | , view = view 22 | , subscriptions = \_ -> Sub.none 23 | } 24 | 25 | 26 | 27 | -- VIEW 28 | 29 | 30 | view : Result D.Error Error.Error -> Browser.Document msg 31 | view result = 32 | { title = "Problem!" 33 | , body = 34 | case result of 35 | Err err -> 36 | [ text (D.errorToString err) ] 37 | 38 | Ok error -> 39 | [ viewError error ] 40 | } 41 | 42 | 43 | viewError : Error.Error -> Html msg 44 | viewError error = 45 | div 46 | [ style "width" "100%" 47 | , style "min-height" "100%" 48 | , style "display" "flex" 49 | , style "flex-direction" "column" 50 | , style "align-items" "center" 51 | , style "background-color" "rgb(39, 40, 34)" 52 | , style "color" "rgb(233, 235, 235)" 53 | , style "font-family" "monospace" 54 | ] 55 | [ div 56 | [ style "display" "block" 57 | , style "white-space" "pre-wrap" 58 | , style "background-color" "black" 59 | , style "padding" "2em" 60 | ] 61 | (viewErrorHelp error) 62 | ] 63 | 64 | 65 | viewErrorHelp : Error.Error -> List (Html msg) 66 | viewErrorHelp error = 67 | case error of 68 | Error.GeneralProblem { path, title, message } -> 69 | viewHeader title path :: viewMessage message 70 | 71 | Error.ModuleProblems badModules -> 72 | viewBadModules badModules 73 | 74 | 75 | 76 | -- VIEW HEADER 77 | 78 | 79 | viewHeader : String -> Maybe String -> Html msg 80 | viewHeader title maybeFilePath = 81 | let 82 | left = "-- " ++ title ++ " " 83 | right = 84 | case maybeFilePath of 85 | Nothing -> 86 | "" 87 | Just filePath -> 88 | " " ++ filePath 89 | in 90 | span [ style "color" "rgb(51,187,200)" ] [ text (fill left right ++ "\n\n") ] 91 | 92 | 93 | fill : String -> String -> String 94 | fill left right = 95 | left ++ String.repeat (80 - String.length left - String.length right) "-" ++ right 96 | 97 | 98 | 99 | -- VIEW BAD MODULES 100 | 101 | 102 | viewBadModules : List Error.BadModule -> List (Html msg) 103 | viewBadModules badModules = 104 | case badModules of 105 | [] -> 106 | [] 107 | 108 | [badModule] -> 109 | [viewBadModule badModule] 110 | 111 | a :: b :: cs -> 112 | viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs) 113 | 114 | 115 | viewBadModule : Error.BadModule -> Html msg 116 | viewBadModule { path, problems } = 117 | span [] (List.map (viewProblem path) problems) 118 | 119 | 120 | viewProblem : String -> Error.Problem -> Html msg 121 | viewProblem filePath problem = 122 | span [] (viewHeader problem.title (Just filePath) :: viewMessage problem.message) 123 | 124 | 125 | viewSeparator : String -> String -> Html msg 126 | viewSeparator before after = 127 | span [ style "color" "rgb(211,56,211)" ] 128 | [ text <| 129 | String.padLeft 80 ' ' (before ++ " ↑ ") ++ "\n" ++ 130 | "====o======================================================================o====\n" ++ 131 | " ↓ " ++ after ++ "\n\n\n" 132 | ] 133 | 134 | 135 | 136 | -- VIEW MESSAGE 137 | 138 | 139 | viewMessage : List Error.Chunk -> List (Html msg) 140 | viewMessage chunks = 141 | case chunks of 142 | [] -> 143 | [ text "\n\n\n" ] 144 | 145 | chunk :: others -> 146 | let 147 | htmlChunk = 148 | case chunk of 149 | Error.Unstyled string -> 150 | text string 151 | 152 | Error.Styled style string -> 153 | span (styleToAttrs style) [ text string ] 154 | in 155 | htmlChunk :: viewMessage others 156 | 157 | 158 | styleToAttrs : Error.Style -> List (Attribute msg) 159 | styleToAttrs { bold, underline, color } = 160 | addBold bold <| addUnderline underline <| addColor color [] 161 | 162 | 163 | addBold : Bool -> List (Attribute msg) -> List (Attribute msg) 164 | addBold bool attrs = 165 | if bool then 166 | style "font-weight" "bold" :: attrs 167 | else 168 | attrs 169 | 170 | 171 | addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg) 172 | addUnderline bool attrs = 173 | if bool then 174 | style "text-decoration" "underline" :: attrs 175 | else 176 | attrs 177 | 178 | 179 | addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg) 180 | addColor maybeColor attrs = 181 | case maybeColor of 182 | Nothing -> 183 | attrs 184 | 185 | Just color -> 186 | style "color" (colorToCss color) :: attrs 187 | 188 | 189 | colorToCss : Error.Color -> String 190 | colorToCss color = 191 | case color of 192 | Error.Red -> "rgb(194,54,33)" 193 | Error.RED -> "rgb(252,57,31)" 194 | Error.Magenta -> "rgb(211,56,211)" 195 | Error.MAGENTA -> "rgb(249,53,248)" 196 | Error.Yellow -> "rgb(173,173,39)" 197 | Error.YELLOW -> "rgb(234,236,35)" 198 | Error.Green -> "rgb(37,188,36)" 199 | Error.GREEN -> "rgb(49,231,34)" 200 | Error.Cyan -> "rgb(51,187,200)" 201 | Error.CYAN -> "rgb(20,240,240)" 202 | Error.Blue -> "rgb(73,46,225)" 203 | Error.BLUE -> "rgb(88,51,255)" 204 | Error.White -> "rgb(203,204,205)" 205 | Error.WHITE -> "rgb(233,235,235)" 206 | Error.Black -> "rgb(0,0,0)" 207 | Error.BLACK -> "rgb(129,131,131)" 208 | -------------------------------------------------------------------------------- /compiler/src/Elm/Interface.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Interface 3 | ( Interfaces 4 | , Interface(..) 5 | , Union 6 | , Alias 7 | , Binop(..) 8 | , fromModule 9 | , toPublicUnion 10 | , toPublicAlias 11 | , toUnionInternals 12 | , toAliasInternals 13 | ) 14 | where 15 | 16 | 17 | import Control.Monad (liftM4) 18 | import Data.Binary 19 | import Data.Map ((!)) 20 | import qualified Data.Map as Map 21 | import qualified Data.Map.Merge.Strict as Map 22 | 23 | import qualified AST.Canonical as Can 24 | import qualified AST.Module.Name as ModuleName 25 | import qualified AST.Utils.Binop as Binop 26 | import qualified Elm.Name as N 27 | import qualified Reporting.Annotation as A 28 | 29 | 30 | 31 | -- INTERFACES 32 | 33 | 34 | type Interfaces = 35 | Map.Map ModuleName.Canonical Interface 36 | 37 | 38 | 39 | -- INTERFACE 40 | 41 | 42 | data Interface = 43 | Interface 44 | { _types :: Map.Map N.Name Can.Annotation 45 | , _unions :: Map.Map N.Name Union 46 | , _aliases :: Map.Map N.Name Alias 47 | , _binops :: Map.Map N.Name Binop 48 | } 49 | 50 | 51 | data Union 52 | = OpenUnion Can.Union 53 | | ClosedUnion Can.Union 54 | | PrivateUnion Can.Union 55 | 56 | 57 | data Alias 58 | = PublicAlias Can.Alias 59 | | PrivateAlias Can.Alias 60 | 61 | 62 | data Binop = 63 | Binop 64 | { _op_name :: N.Name 65 | , _op_annotation :: Can.Annotation 66 | , _op_associativity :: Binop.Associativity 67 | , _op_precedence :: Binop.Precedence 68 | } 69 | 70 | 71 | 72 | -- FROM MODULE 73 | 74 | 75 | fromModule :: Map.Map N.Name Can.Annotation -> Can.Module -> Interface 76 | fromModule types (Can.Module _ _ exports _ unions aliases binops _) = 77 | Interface 78 | { _types = privatize exports types 79 | , _unions = privatizeUnions exports unions 80 | , _aliases = privatizeAliases exports aliases 81 | , _binops = privatize exports (Map.map (toOp types) binops) 82 | } 83 | 84 | 85 | privatize :: Can.Exports -> Map.Map N.Name a -> Map.Map N.Name a 86 | privatize exports dict = 87 | case exports of 88 | Can.ExportEverything _ -> 89 | dict 90 | 91 | Can.Export explicitExports -> 92 | Map.intersection dict explicitExports 93 | 94 | 95 | toOp :: Map.Map N.Name Can.Annotation -> Can.Binop -> Binop 96 | toOp types (Can.Binop_ associativity precedence name) = 97 | Binop name (types ! name) associativity precedence 98 | 99 | 100 | privatizeUnions :: Can.Exports -> Map.Map N.Name Can.Union -> Map.Map N.Name Union 101 | privatizeUnions exports unions = 102 | case exports of 103 | Can.ExportEverything _ -> 104 | Map.map OpenUnion unions 105 | 106 | Can.Export explicitExports -> 107 | Map.merge onLeft onRight onBoth explicitExports unions 108 | where 109 | onLeft = Map.dropMissing 110 | onRight = Map.mapMissing (\_ u -> PrivateUnion u) 111 | onBoth = Map.zipWithMatched $ \_ e u -> 112 | case A.toValue e of 113 | Can.ExportUnionOpen -> OpenUnion u 114 | Can.ExportUnionClosed -> ClosedUnion u 115 | _ -> error "impossible exports discovered in privatizeUnions" 116 | 117 | 118 | privatizeAliases :: Can.Exports -> Map.Map N.Name Can.Alias -> Map.Map N.Name Alias 119 | privatizeAliases exports aliases = 120 | case exports of 121 | Can.ExportEverything _ -> 122 | Map.map PublicAlias aliases 123 | 124 | Can.Export explicitExports -> 125 | Map.merge onLeft onRight onBoth explicitExports aliases 126 | where 127 | onLeft = Map.dropMissing 128 | onRight = Map.mapMissing (\_ a -> PrivateAlias a) 129 | onBoth = Map.zipWithMatched (\_ _ a -> PublicAlias a) 130 | 131 | 132 | 133 | -- PUBLICIZE 134 | 135 | 136 | toPublicUnion :: Union -> Maybe Can.Union 137 | toPublicUnion iUnion = 138 | case iUnion of 139 | OpenUnion union -> 140 | Just union 141 | 142 | ClosedUnion (Can.Union vars _ _ opts) -> 143 | Just (Can.Union vars [] 0 opts) 144 | 145 | PrivateUnion _ -> 146 | Nothing 147 | 148 | 149 | toPublicAlias :: Alias -> Maybe Can.Alias 150 | toPublicAlias iAlias = 151 | case iAlias of 152 | PublicAlias alias -> 153 | Just alias 154 | 155 | PrivateAlias _ -> 156 | Nothing 157 | 158 | 159 | 160 | -- INTERNALS 161 | 162 | 163 | toUnionInternals :: Union -> Can.Union 164 | toUnionInternals iUnion = 165 | case iUnion of 166 | OpenUnion union -> union 167 | ClosedUnion union -> union 168 | PrivateUnion union -> union 169 | 170 | 171 | toAliasInternals :: Alias -> Can.Alias 172 | toAliasInternals iAlias = 173 | case iAlias of 174 | PublicAlias alias -> alias 175 | PrivateAlias alias -> alias 176 | 177 | 178 | 179 | -- BINARY 180 | 181 | 182 | instance Binary Interface where 183 | get = 184 | liftM4 Interface get get get get 185 | 186 | put (Interface a b c d) = 187 | put a >> put b >> put c >> put d 188 | 189 | 190 | instance Binary Union where 191 | put union = 192 | case union of 193 | OpenUnion u -> putWord8 0 >> put u 194 | ClosedUnion u -> putWord8 1 >> put u 195 | PrivateUnion u -> putWord8 2 >> put u 196 | 197 | get = 198 | do n <- getWord8 199 | case n of 200 | 0 -> OpenUnion <$> get 201 | 1 -> ClosedUnion <$> get 202 | 2 -> PrivateUnion <$> get 203 | _ -> error "binary encoding of Union was corrupted" 204 | 205 | 206 | instance Binary Alias where 207 | put union = 208 | case union of 209 | PublicAlias a -> putWord8 0 >> put a 210 | PrivateAlias a -> putWord8 1 >> put a 211 | 212 | get = 213 | do n <- getWord8 214 | case n of 215 | 0 -> PublicAlias <$> get 216 | 1 -> PrivateAlias <$> get 217 | _ -> error "binary encoding of Alias was corrupted" 218 | 219 | 220 | instance Binary Binop where 221 | get = 222 | liftM4 Binop get get get get 223 | 224 | put (Binop a b c d) = 225 | put a >> put b >> put c >> put d 226 | 227 | -------------------------------------------------------------------------------- /compiler/src/Parse/Declaration.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Parse.Declaration 4 | ( declaration 5 | , infix_ 6 | ) 7 | where 8 | 9 | 10 | import qualified Data.Text.Encoding as Text 11 | 12 | import qualified AST.Source as Src 13 | import qualified AST.Utils.Binop as Binop 14 | import qualified Elm.Name as N 15 | import qualified Parse.Expression as Expr 16 | import qualified Parse.Pattern as Pattern 17 | import Parse.Primitives 18 | import qualified Parse.Primitives.Keyword as Keyword 19 | import qualified Parse.Primitives.Number as Number 20 | import qualified Parse.Primitives.Symbol as Symbol 21 | import qualified Parse.Primitives.Variable as Var 22 | import qualified Parse.Primitives.Whitespace as W 23 | import qualified Parse.Type as Type 24 | import qualified Reporting.Annotation as A 25 | import qualified Reporting.Error.Syntax as E 26 | import qualified Reporting.Region as R 27 | 28 | 29 | 30 | -- DECLARATION 31 | 32 | 33 | declaration :: SParser Src.Decl 34 | declaration = 35 | hint E.Decl $ 36 | do start <- getPosition 37 | oneOf 38 | [ doc_ start 39 | , type_ start 40 | , port_ start 41 | , def_ start 42 | ] 43 | 44 | 45 | 46 | -- DOC COMMENTS 47 | 48 | 49 | {-# INLINE doc_ #-} 50 | doc_ :: R.Position -> SParser Src.Decl 51 | doc_ start = 52 | do doc <- W.docComment 53 | end <- getPosition 54 | pos <- W.whitespace 55 | return ( A.at start end (Src.Docs (Text.decodeUtf8 doc)), end, pos ) 56 | 57 | 58 | 59 | -- DEFINITION and ANNOTATION 60 | 61 | 62 | {-# INLINE def_ #-} 63 | def_ :: R.Position -> SParser Src.Decl 64 | def_ start = 65 | do name <- Var.lower 66 | nameEnd <- getPosition 67 | let locatedName = A.at start nameEnd name 68 | spaces 69 | oneOf 70 | [ do Symbol.hasType 71 | inContext start (E.Annotation name) $ 72 | do spaces 73 | (tipe, end, space) <- Type.expression 74 | return ( A.at start end (Src.Annotation locatedName tipe), end, space ) 75 | , inContext start (E.Definition name) $ 76 | definitionHelp start locatedName [] 77 | ] 78 | 79 | 80 | definitionHelp :: R.Position -> A.Located N.Name -> [Src.Pattern] -> SParser Src.Decl 81 | definitionHelp start name revArgs = 82 | oneOf 83 | [ do arg <- hint E.Arg Pattern.term 84 | spaces 85 | definitionHelp start name (arg : revArgs) 86 | , do Symbol.equals 87 | spaces 88 | (body, end, space) <- Expr.expression 89 | let def = A.at start end (Src.Definition name (reverse revArgs) body) 90 | return ( def, end, space ) 91 | ] 92 | 93 | 94 | 95 | -- TYPE ALIAS and UNION TYPES 96 | 97 | 98 | {-# INLINE type_ #-} 99 | type_ :: R.Position -> SParser Src.Decl 100 | type_ start = 101 | do Keyword.type_ 102 | spaces 103 | oneOf 104 | [ do Keyword.alias_ 105 | inContext start E.TypeAlias $ 106 | do spaces 107 | (name, args) <- nameArgsEquals 108 | (tipe, end, pos) <- Type.expression 109 | return ( A.at start end (Src.Alias name args tipe), end, pos ) 110 | , inContext start E.TypeUnion $ 111 | do (name, args) <- nameArgsEquals 112 | (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor 113 | (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace 114 | return ( A.at start end (Src.Union name args ctors), end, pos ) 115 | ] 116 | 117 | 118 | nameArgsEquals :: Parser (A.Located N.Name, [A.Located N.Name]) 119 | nameArgsEquals = 120 | do name <- addLocation Var.upper 121 | spaces 122 | nameArgsEqualsHelp name [] 123 | 124 | 125 | nameArgsEqualsHelp :: A.Located N.Name -> [A.Located N.Name] -> Parser (A.Located N.Name, [A.Located N.Name]) 126 | nameArgsEqualsHelp name args = 127 | oneOf 128 | [ do arg <- addLocation Var.lower 129 | spaces 130 | nameArgsEqualsHelp name (arg:args) 131 | , do Symbol.equals 132 | spaces 133 | return ( name, reverse args ) 134 | ] 135 | 136 | 137 | chompConstructors :: [(A.Located N.Name, [Src.Type])] -> R.Position -> SPos -> SParser [(A.Located N.Name, [Src.Type])] 138 | chompConstructors ctors end pos = 139 | oneOf 140 | [ do checkSpace pos 141 | Symbol.pipe 142 | spaces 143 | (ctor, newEnd, newSpace) <- Type.unionConstructor 144 | chompConstructors (ctor:ctors) newEnd newSpace 145 | , return ( reverse ctors, end, pos ) 146 | ] 147 | 148 | 149 | 150 | -- PORT 151 | 152 | 153 | {-# INLINE port_ #-} 154 | port_ :: R.Position -> SParser Src.Decl 155 | port_ start = 156 | do Keyword.port_ 157 | inContext start E.Port $ 158 | do spaces 159 | name <- addLocation Var.lower 160 | spaces 161 | Symbol.hasType 162 | spaces 163 | (tipe, end, pos) <- Type.expression 164 | return ( A.at start end (Src.Port name tipe), end, pos ) 165 | 166 | 167 | 168 | -- INFIX 169 | 170 | 171 | -- INVARIANT: always chomps to a freshline 172 | -- 173 | infix_ :: Parser Src.Decl 174 | infix_ = 175 | do start <- getPosition 176 | Keyword.infix_ 177 | inContext start E.Infix $ 178 | do spaces 179 | associativity <- 180 | oneOf 181 | [ Keyword.left_ >> return Binop.Left 182 | , Keyword.right_ >> return Binop.Right 183 | , Keyword.non_ >> return Binop.Non 184 | ] 185 | spaces 186 | precedence <- Number.precedence 187 | spaces 188 | Symbol.leftParen 189 | op <- Symbol.binop 190 | Symbol.rightParen 191 | spaces 192 | Symbol.equals 193 | spaces 194 | name <- Var.lower 195 | end <- getPosition 196 | checkFreshLine =<< W.whitespace 197 | return (A.at start end (Src.Binop op associativity precedence name)) 198 | -------------------------------------------------------------------------------- /compiler/src/Parse/Primitives.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Parse.Primitives 4 | ( I.Parser 5 | , I.oneOf 6 | , run, runAt 7 | , try, deadend, hint, endOfFile 8 | , noFloatsAllowedInPatterns 9 | , getPosition, getCol 10 | , pushContext, popContext 11 | , getIndent, setIndent 12 | , W.SPos 13 | , SParser 14 | , addLocation, inContext 15 | , spaces, noSpace, checkSpace, checkAligned, checkFreshLine 16 | ) 17 | where 18 | 19 | 20 | import Prelude hiding (length) 21 | import qualified Data.ByteString.Internal as B 22 | 23 | import Parse.Primitives.Internals (Parser(..), State(..), expect, noError) 24 | import qualified Parse.Primitives.Internals as I 25 | import qualified Parse.Primitives.Whitespace as W 26 | import qualified Reporting.Annotation as A 27 | import qualified Reporting.Error.Syntax as E 28 | import qualified Reporting.Region as R 29 | 30 | 31 | 32 | -- RUN 33 | 34 | 35 | run :: Parser a -> B.ByteString -> Either E.Error a 36 | run parser bytes = 37 | runAt 1 1 parser bytes 38 | 39 | 40 | runAt :: Int -> Int -> Parser a -> B.ByteString -> Either E.Error a 41 | runAt startRow startColumn (Parser parser) (B.PS fp offset length) = 42 | case parser (State fp offset (offset + length) 0 startRow startColumn []) Ok Err Ok Err of 43 | Ok value _ _ -> 44 | Right value 45 | 46 | Err (E.ParseError row col problem) -> 47 | let 48 | pos = R.Position row col 49 | mkError overallRegion subRegion = 50 | Left (E.Parse overallRegion subRegion problem) 51 | in 52 | case problem of 53 | E.BadChar endCol -> 54 | mkError (R.Region pos (R.Position row endCol)) Nothing 55 | 56 | E.BadEscape width _ -> 57 | mkError (R.Region pos (R.Position row (col + width))) Nothing 58 | 59 | E.BadUnderscore badCol -> 60 | mkError (R.Region pos (R.Position row badCol)) Nothing 61 | 62 | E.BadOp _ ((_, start) : _) -> 63 | mkError (R.Region start pos) (Just (R.Region pos pos)) 64 | 65 | E.Theories ((_, start) : _) _ -> 66 | mkError (R.Region start pos) (Just (R.Region pos pos)) 67 | 68 | _ -> 69 | mkError (R.Region pos pos) Nothing 70 | 71 | 72 | 73 | -- RESULT 74 | 75 | 76 | data Result a 77 | = Ok a State E.ParseError 78 | | Err E.ParseError 79 | 80 | 81 | 82 | -- COMBINATORS 83 | 84 | 85 | try :: Parser a -> Parser a 86 | try (Parser parser) = 87 | Parser $ \state cok _ eok eerr -> 88 | parser state cok eerr eok eerr 89 | 90 | 91 | deadend :: [E.Theory] -> Parser a 92 | deadend thrys = 93 | Parser $ \(State _ _ _ _ row col ctx) _ _ _ eerr -> 94 | eerr (E.ParseError row col (E.Theories ctx thrys)) 95 | 96 | 97 | hint :: E.Next -> Parser a -> Parser a 98 | hint next (Parser parser) = 99 | Parser $ \state@(State _ _ _ _ row col ctx) cok cerr eok eerr -> 100 | let 101 | eok' x s _ = 102 | eok x s (expect row col ctx (E.Expecting next)) 103 | 104 | eerr' _ = 105 | eerr (expect row col ctx (E.Expecting next)) 106 | in 107 | parser state cok cerr eok' eerr' 108 | 109 | 110 | endOfFile :: Parser () 111 | endOfFile = 112 | Parser $ \state@(State _ offset terminal _ _ _ _) _ _ eok eerr -> 113 | if offset < terminal then 114 | eerr noError 115 | else 116 | eok () state noError 117 | 118 | 119 | noFloatsAllowedInPatterns :: Parser a 120 | noFloatsAllowedInPatterns = 121 | Parser $ \(State _ _ _ _ row col _) _ cerr _ _ -> 122 | cerr (E.ParseError row col E.FloatInPattern) 123 | 124 | 125 | 126 | -- STATE 127 | 128 | 129 | {-# INLINE getPosition #-} 130 | getPosition :: Parser R.Position 131 | getPosition = 132 | Parser $ \state@(State _ _ _ _ row col _) _ _ eok _ -> 133 | eok (R.Position row col) state noError 134 | 135 | 136 | getIndent :: Parser Int 137 | getIndent = 138 | Parser $ \state@(State _ _ _ indent _ _ _) _ _ eok _ -> 139 | eok indent state noError 140 | 141 | 142 | getCol :: Parser Int 143 | getCol = 144 | Parser $ \state@(State _ _ _ _ _ col _) _ _ eok _ -> 145 | eok col state noError 146 | 147 | 148 | pushContext :: R.Position -> E.Context -> Parser () 149 | pushContext pos ctx = 150 | Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ -> 151 | eok () (state { _context = (ctx, pos) : context }) noError 152 | 153 | 154 | popContext :: a -> Parser a 155 | popContext value = 156 | Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ -> 157 | eok value (state { _context = tail context }) noError 158 | 159 | 160 | setIndent :: Int -> Parser () 161 | setIndent indent = 162 | Parser $ \state _ _ eok _ -> 163 | eok () (state { _indent = indent }) noError 164 | 165 | 166 | 167 | -- SPACE PARSER 168 | 169 | 170 | type SParser a = 171 | Parser (a, R.Position, W.SPos) 172 | 173 | 174 | 175 | -- LOCATION 176 | 177 | 178 | addLocation :: Parser a -> Parser (A.Located a) 179 | addLocation parser = 180 | do start <- getPosition 181 | value <- parser 182 | end <- getPosition 183 | return (A.at start end value) 184 | 185 | 186 | inContext :: R.Position -> E.Context -> Parser a -> Parser a 187 | inContext pos ctx parser = 188 | do pushContext pos ctx 189 | a <- parser 190 | popContext a 191 | 192 | 193 | -- WHITESPACE VARIATIONS 194 | 195 | 196 | spaces :: Parser () 197 | spaces = 198 | checkSpace =<< W.whitespace 199 | 200 | 201 | noSpace :: R.Position -> W.SPos -> Parser () 202 | noSpace pos (W.SPos spos) = 203 | if pos == spos 204 | then return () 205 | else deadend [] 206 | 207 | 208 | checkSpace :: W.SPos -> Parser () 209 | checkSpace (W.SPos (R.Position _ col)) = 210 | do indent <- getIndent 211 | if col > indent && col > 1 212 | then return () 213 | else deadend [E.BadSpace] 214 | 215 | 216 | checkAligned :: W.SPos -> Parser () 217 | checkAligned (W.SPos (R.Position _ col)) = 218 | do indent <- getIndent 219 | if col == indent 220 | then return () 221 | else deadend [E.BadSpace] 222 | 223 | 224 | checkFreshLine :: W.SPos -> Parser () 225 | checkFreshLine (W.SPos (R.Position _ col)) = 226 | if col == 1 227 | then return () 228 | else deadend [E.BadSpace] 229 | --------------------------------------------------------------------------------