3e63279 · elk · git.iko.soy

Elm.cabal+11−6

compare with master

unifiedsplit

@@ -1,5 +1,5 @@

1Name: Elm

2−Version: 0.10.0.2

2+Version: 0.10.1

3Synopsis: The Elm language module.

4Description: Elm aims to make client-side web-development more pleasant.

5 It is a statically/strongly typed, functional reactive

@@ -54,12 +54,13 @@ Library

54 Generate.Markdown,

55 Transform.Canonicalize,

56 Transform.Check,

57+ Transform.Expression,

58+ Transform.Declaration,

59+ Transform.Definition,

57 Transform.SafeNames,

60 Transform.SafeNames,

58 Transform.SortDefinitions,

61 Transform.SortDefinitions,

59 Transform.Substitute,

62 Transform.Substitute,

60− Transform.Optimize,

61 Metadata.Prelude,

63 Metadata.Prelude,

62− InterfaceSerialization,

63 Parse.Binop,

64 Parse.Binop,

64 Parse.Declaration,

65 Parse.Declaration,

65 Parse.Expression,

66 Parse.Expression,

@@ -86,6 +87,7 @@ Library

86 Build.Dependencies,

87 Build.Dependencies,

87 Build.File,

88 Build.File,

88 Build.Flags,

89 Build.Flags,

90+ Build.Interface,

89 Build.Print,

91 Build.Print,

90 Build.Source,

92 Build.Source,

91 Build.Utils,

93 Build.Utils,

@@ -133,12 +135,13 @@ Executable elm

133 Generate.Cases,

135 Generate.Cases,

134 Transform.Canonicalize,

136 Transform.Canonicalize,

135 Transform.Check,

137 Transform.Check,

138+ Transform.Expression,

139+ Transform.Declaration,

140+ Transform.Definition,

136 Transform.SafeNames,

141 Transform.SafeNames,

137 Transform.SortDefinitions,

142 Transform.SortDefinitions,

138 Transform.Substitute,

143 Transform.Substitute,

139− Transform.Optimize,

140 Metadata.Prelude,

144 Metadata.Prelude,

141− InterfaceSerialization,

142 Parse.Binop,

145 Parse.Binop,

143 Parse.Declaration,

146 Parse.Declaration,

144 Parse.Expression,

147 Parse.Expression,

@@ -165,6 +168,7 @@ Executable elm

165 Build.Dependencies,

168 Build.Dependencies,

166 Build.File,

169 Build.File,

167 Build.Flags,

170 Build.Flags,

171+ Build.Interface,

168 Build.Print,

172 Build.Print,

169 Build.Source,

173 Build.Source,

170 Build.Utils,

174 Build.Utils,

@@ -228,7 +232,8 @@ Executable elm-doc

228 pandoc >= 1.10,

232 pandoc >= 1.10,

229 parsec >= 3.1.1,

233 parsec >= 3.1.1,

230 pretty,

234 pretty,

231− text

235+ text,

236+ union-find

232

237

233Test-Suite test-elm

238Test-Suite test-elm

234 Type: exitcode-stdio-1.0

239 Type: exitcode-stdio-1.0

README.md+21−13

@@ -3,11 +3,15 @@ Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/)

3

4## Install

5

6+**Arch Linux** — follow [these directions](https://github.com/evancz/Elm/wiki/Installing-Elm#arch-linux) and then

7+jump to the [My First Project](#my-first-project) section.

8+<br/>

6−**Note for OS X 10.9 Maverics:** you must follow

9+**OS X 10.9** — follow

7[these directions](http://justtesting.org/post/64947952690/the-glasgow-haskell-compiler-ghc-on-os-x-10-9)

10[these directions](http://justtesting.org/post/64947952690/the-glasgow-haskell-compiler-ghc-on-os-x-10-9)

8−before continuing!

11+before continuing with the platform agnostic directions below.

9

12

13+**Platform Agnostic** —

10−Download the [Haskell Platform 2012.2.0.0 or later](http://hackage.haskell.org/platform/).

14+download the [Haskell Platform 2012.2.0.0 or later](http://hackage.haskell.org/platform/).

11Once the Haskell Platform is installed:

15Once the Haskell Platform is installed:

12

16

13 cabal update

17 cabal update

@@ -19,11 +23,8 @@ Once the Haskell Platform is installed:

19To use `elm` and `elm-server` you may need to add a new directory to your PATH.

23To use `elm` and `elm-server` you may need to add a new directory to your PATH.

20

24

21Cabal should tell you where your executables are located upon

25Cabal should tell you where your executables are located upon

22−successful installation.

26+successful installation. It'll be something like `/home/evan/.cabal/bin`

23−

27+which you should append to your PATH variable.

24−For me, the executables were placed in `/home/evan/.cabal/bin` which I

25−appended to the end of my PATH variable in my .bashrc file.

26−

27See this tutorial if you are new to changing your PATH in

28See this tutorial if you are new to changing your PATH in

28[Unix/Linux](http://www.cyberciti.biz/faq/unix-linux-adding-path/).

29[Unix/Linux](http://www.cyberciti.biz/faq/unix-linux-adding-path/).

29

30

@@ -44,8 +45,15 @@ allowing you to navigate to `Main.elm` and see your first program in action.

44

45

45#### Final Notes

46#### Final Notes

46

47

47−The `elm` package provides support for compilation of Elm code directly in Haskell.

48+The `elm` package provides

48−Check it out [on Hackage](http://hackage.haskell.org/package/Elm) if you are interested.

49+[some utility functions](http://hackage.haskell.org/package/Elm) for

49−

50+working with Elm in Haskell. This can be useful for creating tooling

51+for Elm, and has been useful for projects like

52+[the website](http://elm-lang.org/) and

53+[`elm-get`](https://github.com/evancz/elm-get). Email the list if you

54+want to rely on these functions!

55+

56+If you are stuck, email

50−If you are stuck, email [the list](https://groups.google.com/forum/?fromgroups#!forum/elm-discuss)

57+[the list](https://groups.google.com/forum/?fromgroups#!forum/elm-discuss)

58+or ask a question in the

51−or ask a question in the [#Elm IRC channel](http://webchat.freenode.net/?channels=elm).

59+[#Elm IRC channel](http://webchat.freenode.net/?channels=elm).

compiler/Build/Dependencies.hs+1−11

@@ -1,12 +1,11 @@

1+{-# OPTIONS_GHC -W #-}

1module Build.Dependencies (getSortedDependencies) where

2module Build.Dependencies (getSortedDependencies) where

2

3

3−import Data.Data

4import Control.Applicative

5import Control.Monad.Error

6import qualified Control.Monad.State as State

7import qualified Data.Aeson as Json

8import qualified Data.ByteString.Lazy.Char8 as BSC

9−import qualified Data.Char as Char

10import qualified Data.Graph as Graph

9import qualified Data.Graph as Graph

11import qualified Data.List as List

10import qualified Data.List as List

12import qualified Data.Map as Map

11import qualified Data.Map as Map

@@ -16,20 +15,11 @@ import System.Directory

16import System.Exit

15import System.Exit

17import System.FilePath as FP

16import System.FilePath as FP

18import System.IO

17import System.IO

19−import Text.PrettyPrint (Doc)

20

18

21import qualified SourceSyntax.Module as Module

19import qualified SourceSyntax.Module as Module

22−import qualified SourceSyntax.Type as Type

23import qualified Parse.Parse as Parse

20import qualified Parse.Parse as Parse

24−import qualified Metadata.Prelude as Prelude

25−import qualified Transform.Check as Check

26−import qualified Transform.SortDefinitions as SD

27−import qualified Type.Inference as TI

28−import qualified Type.Constrain.Declaration as TcDecl

29−import qualified Transform.Canonicalize as Canonical

30import qualified Elm.Internal.Paths as Path

21import qualified Elm.Internal.Paths as Path

31import qualified Elm.Internal.Name as N

22import qualified Elm.Internal.Name as N

32−import qualified Elm.Internal.Version as V

33import qualified Elm.Internal.Dependencies as Deps

23import qualified Elm.Internal.Dependencies as Deps

34

24

35getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]

25getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]

compiler/Build/File.hs+5−6

@@ -1,8 +1,8 @@

1+{-# OPTIONS_GHC -W #-}

1module Build.File (build) where

2module Build.File (build) where

2

3

3import Control.Monad (when)

4import Control.Monad (when)

4import qualified Data.Binary as Binary

5import qualified Data.Binary as Binary

5−import qualified Data.List as List

6import qualified Data.Map as Map

7import System.Directory

8import System.Exit

@@ -15,10 +15,10 @@ import qualified Data.ByteString.Lazy as L

15

16import qualified Build.Utils as Utils

17import qualified Build.Flags as Flag

18−import qualified Build.Source as Source

18+import qualified Build.Interface as Interface

19import qualified Build.Print as Print

20+import qualified Build.Source as Source

20import qualified Generate.JavaScript as JS

21import qualified Generate.JavaScript as JS

21−import qualified InterfaceSerialization as IS

22import qualified Parse.Module as Parser

23import qualified SourceSyntax.Module as M

24

@@ -57,9 +57,8 @@ alreadyCompiled flags filePath = do

57retrieve :: Flag.Flags -> Map.Map String M.ModuleInterface -> FilePath

58 -> IO (String, M.ModuleInterface)

59retrieve flags interfaces filePath = do

60− bytes <- IS.loadInterface (Utils.elmi flags filePath)

61− let binary = IS.interfaceDecode (Utils.elmi flags filePath) =<< bytes

60+ iface <- Interface.load (Utils.elmi flags filePath)

62− case IS.validVersion filePath =<< binary of

61+ case Interface.isValid filePath iface of

63 Right (name, interface) ->

62 Right (name, interface) ->

64 do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)

63 do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)

65 return (name, interface)

64 return (name, interface)

compiler/Build/Interface.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# OPTIONS_GHC -W #-}

2+module Build.Interface (load,isValid) where

3+

4+import qualified Data.ByteString.Lazy as L

5+import qualified Data.Binary as Binary

6+

7+import qualified Elm.Internal.Version as Version

8+import System.Directory (doesFileExist)

9+import System.Exit

10+import System.IO

11+

12+import SourceSyntax.Module

13+

14+load :: Binary.Binary a => FilePath -> IO a

15+load filePath =

16+ do exists <- doesFileExist filePath

17+ case exists of

18+ False -> failure $ "Unable to find file " ++ filePath ++ " for deserialization!"

19+ True -> do

20+ bytes <- L.readFile filePath

21+ case Binary.decodeOrFail bytes of

22+ Right (_, _, binaryInfo) -> return binaryInfo

23+ Left (_, offset, err) -> failure $ msg offset err

24+

25+ where

26+ failure err = do hPutStrLn stderr err

27+ exitFailure

28+

29+ msg offset err = concat

30+ [ "Error reading build artifact: ", filePath, "\n"

31+ , " '", err, "' at offset ", show offset, "\n"

32+ , " The file was generated by a previous build and may be outdated or corrupt.\n"

33+ , " Please remove the file and try again."

34+ ]

35+

36+isValid :: FilePath -> (String, ModuleInterface) -> Either String (String, ModuleInterface)

37+isValid filePath (name, interface) =

38+ let version = iVersion interface in

39+ if version == Version.elmVersion

40+ then Right (name, interface)

41+ else Left $ concat

42+ [ "Error reading build artifact: ", filePath, "\n"

43+ , " It was generated by version ", show version, " of the compiler,\n"

44+ , " but you are using version ", show Version.elmVersion, "\n"

45+ , " Please remove the file and try again.\n"

46+ ]

compiler/Build/Print.hs+1−1

@@ -7,7 +7,7 @@ import qualified SourceSyntax.PrettyPrint as Pretty

7import qualified Type.Alias as Alias

8import qualified Text.PrettyPrint as P

9

10−metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule () () -> IO ()

10+metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule -> IO ()

11metaTypes interfaces meta =

12 types interfaces (M.types meta) (M.aliases meta) (M.imports meta)

13

compiler/Build/Source.hs+25−32

@@ -1,19 +1,15 @@

1+{-# OPTIONS_GHC -W #-}

1module Build.Source (build) where

2module Build.Source (build) where

2

3

3−import Data.Data

4−import Control.Monad.State

5−import qualified Data.Graph as Graph

6−import qualified Data.List as List

7import qualified Data.Map as Map

4import qualified Data.Map as Map

8import qualified Data.Set as Set

5import qualified Data.Set as Set

9−import System.Directory

10−import System.Exit

11import System.FilePath as FP

6import System.FilePath as FP

12import Text.PrettyPrint (Doc)

7import Text.PrettyPrint (Doc)

13

8

14import SourceSyntax.Declaration

9import SourceSyntax.Declaration

15import SourceSyntax.Module

10import SourceSyntax.Module

16import qualified SourceSyntax.Expression as Expr

11import qualified SourceSyntax.Expression as Expr

12+import qualified SourceSyntax.Pattern as Pattern

17import qualified SourceSyntax.Type as Type

13import qualified SourceSyntax.Type as Type

18import qualified Parse.Parse as Parse

14import qualified Parse.Parse as Parse

19import qualified Metadata.Prelude as Prelude

15import qualified Metadata.Prelude as Prelude

@@ -23,42 +19,39 @@ import qualified Type.Inference as TI

23import qualified Type.Constrain.Declaration as TcDecl

19import qualified Type.Constrain.Declaration as TcDecl

24import qualified Transform.Canonicalize as Canonical

20import qualified Transform.Canonicalize as Canonical

25

21

26−build :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())

22+build :: Bool -> Interfaces -> String -> Either [Doc] MetadataModule

27build noPrelude interfaces source =

23build noPrelude interfaces source =

28− do let add = if noPrelude then id else Prelude.add

24+ do let add = Prelude.add noPrelude

29 infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

25 infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

30 . concatMap iFixities $ Map.elems interfaces

26 . concatMap iFixities $ Map.elems interfaces

31

27

28+ Module names exs ims decls <- do

32− modul@(Module _ _ _ decls') <- add `fmap` Parse.program infixes source

29+ modul@(Module _ _ _ decls) <- add `fmap` Parse.program infixes source

33−

34− -- check for structural errors

35− Module names exs ims decls <-

36− case Check.mistakes decls' of

30+ case Check.mistakes decls of

37− [] -> return modul

31+ [] -> return modul

38− ms -> Left ms

32+ ms -> Left ms

39

33

40 let exports'

34 let exports'

41 | null exs =

35 | null exs =

42− let get = Set.toList . SD.boundVars in

36+ let get = Set.toList . Pattern.boundVars in

43− concat [ get pattern | Definition (Expr.Def pattern _) <- decls ] ++

37+ concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++

44− concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++

38+ concat [ map fst ctors | Datatype _ _ ctors _ <- decls ] ++

45− [ name | TypeAlias name _ (Type.Record _ _) <- decls ]

39+ [ name | TypeAlias name _ (Type.Record _ _) _ <- decls ]

46 | otherwise = exs

40 | otherwise = exs

47

41

48− metaModule <- Canonical.metadataModule interfaces $ MetadataModule {

42+ metaModule <- Canonical.metadataModule interfaces $

43+ MetadataModule

49− names = names,

44+ { names = names

50− path = FP.joinPath names,

45+ , path = FP.joinPath names

51− exports = exports',

46+ , exports = exports'

52− imports = ims,

47+ , imports = ims

53 -- reorder AST into strongly connected components

48 -- reorder AST into strongly connected components

54− program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls,

49+ , program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls

55− types = Map.empty,

50+ , types = Map.empty

56− datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],

51+ , datatypes = [ (name,vars,ctors,ds) | Datatype name vars ctors ds <- decls ]

57− fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],

52+ , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]

58− aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],

53+ , aliases = [ (name,tvs,tipe,ds) | TypeAlias name tvs tipe ds <- decls ]

59− foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],

60− foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]

61− }

54+ }

62

55

63 types <- TI.infer interfaces metaModule

56 types <- TI.infer interfaces metaModule

64

57

compiler/Build/Utils.hs+1

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1module Build.Utils where

2module Build.Utils where

2

3

3import System.FilePath ((</>), replaceExtension)

4import System.FilePath ((</>), replaceExtension)

compiler/Compiler.hs+3−3

@@ -1,7 +1,7 @@

1+{-# OPTIONS_GHC -W #-}

1module Main where

2module Main where

2

3

3import Control.Monad (foldM)

4import Control.Monad (foldM)

4−import qualified Data.Map as Map

5import qualified Data.Maybe as Maybe

6import Text.Blaze.Html.Renderer.String (renderHtml)

7import qualified Data.ByteString.Lazy.Char8 as BS

@@ -31,13 +31,13 @@ compileArgs flags =

31build :: Flag.Flags -> FilePath -> IO ()

32build flags rootFile =

33 do let noPrelude = Flag.no_prelude flags

34− builtIns <- if noPrelude then return Map.empty else Prelude.interfaces

34+ builtIns <- Prelude.interfaces noPrelude

35

36 files <- if Flag.make flags

37 then getSortedDependencies (Flag.src_dir flags) builtIns rootFile

38 else return [rootFile]

39

40− (moduleName, interfaces) <-

40+ (moduleName, _) <-

41 File.build flags (length files) builtIns "" files

42

43 js <- foldM appendToOutput BS.empty files

compiler/Docs.hs+18−13

@@ -17,8 +17,8 @@ import qualified Data.Text as Text

17

18import SourceSyntax.Helpers (isSymbol)

19import SourceSyntax.Type (Type(..))

20−import SourceSyntax.Declaration (Declaration(..), Assoc(..))

20+import qualified SourceSyntax.Expression as E

21−import SourceSyntax.Expression (Def(..))

21+import qualified SourceSyntax.Declaration as D

22

23import Text.Parsec hiding (newline,spaces)

24import Parse.Declaration (alias,datatype,infixDecl)

@@ -77,10 +77,10 @@ moduleDocs = do

77 structure <- docComment

78 return (List.intercalate "." names, exports, structure)

79

80−document :: IParser [(String, Declaration t v, String)]

80+document :: IParser [(String, D.ParseDeclaration, String)]

81document = onFreshLines (\t ts -> ts ++ [t]) [] docThing

82

83−docThing :: IParser (String, Declaration t v, String)

83+docThing :: IParser (String, D.ParseDeclaration, String)

84docThing = uncommentable <|> commented <|> uncommented ""

85 where

86 uncommentable = do

@@ -93,7 +93,7 @@ docThing = uncommentable <|> commented <|> uncommented ""

93 uncommented comment

94

95 uncommented comment = do

96− (src,def) <- withSource $ choice [ alias, datatype, Definition <$> typeAnnotation ]

96+ (src,def) <- withSource $ choice [ alias, datatype, D.Definition <$> typeAnnotation ]

97 return (comment, def, src)

98

99

@@ -121,7 +121,7 @@ collect infixes types aliases adts things =

121 where

122 nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes

123 addDefaultInfix name pairs

124− | all isSymbol name = addInfix (L, 9 :: Int) pairs

124+ | all isSymbol name = addInfix (D.L, 9 :: Int) pairs

125 | otherwise = pairs

126

127 customOps = Map.intersectionWith addInfix infixes types

@@ -130,16 +130,18 @@ collect infixes types aliases adts things =

130

131 (comment, decl, source) : rest ->

132 case decl of

133− Fixity assoc prec name ->

133+ D.Fixity assoc prec name ->

134 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

135− Definition (TypeAnnotation name tipe) ->

135+ D.Definition (E.TypeAnnotation name tipe) ->

136 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

137− TypeAlias name vars tipe ->

137+ D.TypeAlias name vars tipe derivations ->

138− let fields = ["typeVariables" .= vars, "type" .= tipe ]

138+ let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]

139 in collect infixes types (insert name fields aliases) adts rest

140− Datatype name vars ctors ->

140+ D.Datatype name vars ctors derivations ->

141 let tipe = Data name (map Var vars)

142+ fields = ["typeVariables" .= vars

142− fields = ["typeVariables" .= vars, "constructors" .= map (ctorToJson tipe) ctors ]

143+ , "constructors" .= map (ctorToJson tipe) ctors

144+ , "deriving" .= derivations ]

143 in collect infixes types aliases (insert name fields adts) rest

145 in collect infixes types aliases (insert name fields adts) rest

144 where

146 where

145 insert name fields dict = Map.insert name (obj name fields) dict

147 insert name fields dict = Map.insert name (obj name fields) dict

@@ -160,4 +162,7 @@ instance ToJSON Type where

160

162

161ctorToJson tipe (ctor, tipes) =

163ctorToJson tipe (ctor, tipes) =

162 object [ "name" .= ctor

164 object [ "name" .= ctor

163− , "type" .= foldr Lambda tipe tipes ]

165+ , "type" .= foldr Lambda tipe tipes ]

166+

167+instance ToJSON D.Derivation where

168+ toJSON = toJSON . show

compiler/Elm/Internal/Utils.hs+1−1

@@ -21,7 +21,7 @@ compile source =

21

22{-# NOINLINE interfaces #-}

23interfaces :: M.Interfaces

24−interfaces = unsafePerformIO $ Prelude.interfaces

24+interfaces = unsafePerformIO $ Prelude.interfaces False

25

26-- |This function extracts the module name of a given source program.

27moduleName :: String -> Maybe String

compiler/Generate/Cases.hs+21−21

@@ -1,9 +1,9 @@

1module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

2

3−import Control.Applicative ((<$>),(<*>))

3+import Control.Applicative ((<$>))

4−import Control.Arrow (first,second)

4+import Control.Arrow (first)

5import Control.Monad.State

6−import Data.List (groupBy,sortBy,lookup)

6+import Data.List (groupBy,sortBy)

7import Data.Maybe (fromMaybe)

8

9import SourceSyntax.Location

@@ -13,7 +13,7 @@ import SourceSyntax.Expression

13import Transform.Substitute

14

15

16−toMatch :: [(Pattern, LExpr t v)] -> State Int (String, Match t v)

16+toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)

17toMatch patterns = do

18 v <- newVar

19 (,) v <$> match [v] (map (first (:[])) patterns) Fail

@@ -23,19 +23,19 @@ newVar = do n <- get

23 modify (+1)

24 return $ "_v" ++ show n

25

26−data Match t v

26+data Match

27− = Match String [Clause t v] (Match t v)

27+ = Match String [Clause] Match

28 | Break

29 | Fail

30− | Other (LExpr t v)

30+ | Other LExpr

31− | Seq [Match t v]

31+ | Seq [Match]

32 deriving Show

33

34−data Clause t v =

34+data Clause =

35− Clause (Either String Literal) [String] (Match t v)

35+ Clause (Either String Literal) [String] Match

36 deriving Show

37

38−matchSubst :: [(String,String)] -> Match t v -> Match t v

38+matchSubst :: [(String,String)] -> Match -> Match

39matchSubst _ Break = Break

40matchSubst _ Fail = Fail

41matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

@@ -47,7 +47,7 @@ matchSubst pairs (Match n cs m) =

47 clauseSubst (Clause c vs m) =

48 Clause c (map varSubst vs) (matchSubst pairs m)

49

50−isCon (p:ps, e) =

50+isCon (p:_, _) =

51 case p of

52 PData _ _ -> True

53 PLiteral _ -> True

@@ -55,7 +55,7 @@ isCon (p:ps, e) =

55

56isVar p = not (isCon p)

57

58−match :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)

58+match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

59match [] [] def = return def

60match [] [([],e)] Fail = return $ Other e

61match [] [([],e)] Break = return $ Other e

@@ -72,10 +72,10 @@ dealias v c@(p:ps, L s e) =

72 PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)

73 _ -> c

74

75−matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)

75+matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

76matchVar (v:vs) cs def = match vs (map subVar cs) def

77 where

78− subVar (p:ps, ce@(L s e)) = (ps, L s $ subOnePattern p e)

78+ subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)

79 where

80 subOnePattern pattern e =

81 case pattern of

@@ -84,7 +84,7 @@ matchVar (v:vs) cs def = match vs (map subVar cs) def

84 PRecord fs ->

85 foldr (\x -> subst x (Access (L s (Var v)) x)) e fs

86

87−matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)

87+matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

88matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

89 where

90 css = groupBy eq (sortBy cmp cs)

@@ -106,10 +106,10 @@ matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

106

107matchClause :: Either String Literal

108 -> [String]

109− -> [([Pattern],LExpr t v)]

109+ -> [([Pattern],LExpr)]

110− -> Match t v

110+ -> Match

111− -> State Int (Clause t v)

111+ -> State Int Clause

112−matchClause c (v:vs) cs def =

112+matchClause c (_:vs) cs def =

113 do vs' <- getVars

114 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def

115 where

@@ -124,6 +124,6 @@ matchClause c (v:vs) cs def =

124 (PData _ ps : _, _) -> forM ps (const newVar)

125 (PLiteral _ : _, _) -> return []

126

127−matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)

127+matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

128matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

129 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

compiler/Generate/JavaScript.hs+92−114

@@ -1,5 +1,4 @@

1−{-# OPTIONS -Wall #-}

1+{-# OPTIONS_GHC -W #-}

2−

3module Generate.JavaScript (generate) where

2module Generate.JavaScript (generate) where

4

3

5import Control.Arrow (first,(***))

4import Control.Arrow (first,(***))

@@ -13,11 +12,10 @@ import qualified Generate.Cases as Case

13import qualified Generate.Markdown as MD

12import qualified Generate.Markdown as MD

14import qualified SourceSyntax.Helpers as Help

13import qualified SourceSyntax.Helpers as Help

15import SourceSyntax.Literal

14import SourceSyntax.Literal

16−import SourceSyntax.Pattern

15+import SourceSyntax.Pattern as Pattern

17import SourceSyntax.Location

16import SourceSyntax.Location

18import SourceSyntax.Expression

17import SourceSyntax.Expression

19import SourceSyntax.Module

18import SourceSyntax.Module

20−import qualified Transform.SortDefinitions as SD

21import Language.ECMAScript3.Syntax

19import Language.ECMAScript3.Syntax

22import Language.ECMAScript3.PrettyPrint

20import Language.ECMAScript3.PrettyPrint

23import qualified Transform.SafeNames as MakeSafe

21import qualified Transform.SafeNames as MakeSafe

@@ -27,8 +25,8 @@ split = go []

27 where

25 where

28 go vars str =

26 go vars str =

29 case break (=='.') str of

27 case break (=='.') str of

30− (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

28+ (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

31− | otherwise -> go (vars ++ [x]) rest

29+ | otherwise -> go (vars ++ [x]) rest

32 (x,[]) -> vars ++ [x]

30 (x,[]) -> vars ++ [x]

33

31

34var name = Id () name

32var name = Id () name

@@ -40,7 +38,11 @@ function args stmts = FuncExpr () Nothing (map var args) stmts

40call = CallExpr ()

38call = CallExpr ()

41string = StringLit ()

39string = StringLit ()

42

40

41+dotSep vars =

42+ case vars of

43−dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)

43+ x:xs -> foldl (DotRef ()) (ref x) (map var xs)

44+ [] -> error "dotSep must be called on a non-empty list of variables"

45+

44obj = dotSep . split

46obj = dotSep . split

45

47

46varDecl :: String -> Expression () -> VarDecl ()

48varDecl :: String -> Expression () -> VarDecl ()

@@ -52,24 +54,24 @@ include alias moduleName =

52

54

53internalImports name =

55internalImports name =

54 VarDeclStmt ()

56 VarDeclStmt ()

55− [ varDecl "N" (obj "Elm.Native")

57+ [ varDecl "_N" (obj "Elm.Native")

56− , include "_N" "N.Utils"

58+ , include "_U" "_N.Utils"

57− , include "_L" "N.List"

59+ , include "_L" "_N.List"

58− , include "_E" "N.Error"

60+ , include "_E" "_N.Error"

59− , include "_J" "N.JavaScript"

61+ , include "_J" "_N.JavaScript"

60 , varDecl "$moduleName" (string name)

62 , varDecl "$moduleName" (string name)

61 ]

63 ]

62

64

63literal :: Literal -> Expression ()

65literal :: Literal -> Expression ()

64literal lit =

66literal lit =

65 case lit of

67 case lit of

66− Chr c -> obj "_N.chr" <| string [c]

68+ Chr c -> obj "_U.chr" <| string [c]

67 Str s -> string s

69 Str s -> string s

68 IntNum n -> IntLit () n

70 IntNum n -> IntLit () n

69 FloatNum n -> NumLit () n

71 FloatNum n -> NumLit () n

70 Boolean b -> BoolLit () b

72 Boolean b -> BoolLit () b

71

73

72−expression :: LExpr () () -> State Int (Expression ())

74+expression :: LExpr -> State Int (Expression ())

73expression (L span expr) =

75expression (L span expr) =

74 case expr of

76 case expr of

75 Var x -> return $ ref x

77 Var x -> return $ ref x

@@ -86,19 +88,19 @@ expression (L span expr) =

86

88

87 Remove e x ->

89 Remove e x ->

88 do e' <- expression e

90 do e' <- expression e

89− return $ obj "_N.remove" `call` [string x, e']

91+ return $ obj "_U.remove" `call` [string x, e']

90

92

91 Insert e x v ->

93 Insert e x v ->

92 do v' <- expression v

94 do v' <- expression v

93 e' <- expression e

95 e' <- expression e

94− return $ obj "_N.insert" `call` [string x, v', e']

96+ return $ obj "_U.insert" `call` [string x, v', e']

95

97

96 Modify e fs ->

98 Modify e fs ->

97 do e' <- expression e

99 do e' <- expression e

98 fs' <- forM fs $ \(f,v) -> do

100 fs' <- forM fs $ \(f,v) -> do

99 v' <- expression v

101 v' <- expression v

100 return $ ArrayLit () [string f, v']

102 return $ ArrayLit () [string f, v']

101− return $ obj "_N.replace" `call` [ArrayLit () fs', e']

103+ return $ obj "_U.replace" `call` [ArrayLit () fs', e']

102

104

103 Record fields ->

105 Record fields ->

104 do fields' <- forM fields $ \(f,e) -> do

106 do fields' <- forM fields $ \(f,e) -> do

@@ -150,7 +152,7 @@ expression (L span expr) =

150 _ -> (func, args)

152 _ -> (func, args)

151

153

152 Let defs e ->

154 Let defs e ->

153− do let (defs',e') = SD.flattenLets defs e

155+ do let (defs',e') = flattenLets defs e

154 stmts <- concat <$> mapM definition defs'

156 stmts <- concat <$> mapM definition defs'

155 exp <- expression e'

157 exp <- expression e'

156 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []

158 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []

@@ -194,60 +196,62 @@ expression (L span expr) =

194 pad = "<div style=\"height:0;width:0;\"> </div>"

196 pad = "<div style=\"height:0;width:0;\"> </div>"

195 md = pad ++ MD.toHtml doc ++ pad

197 md = pad ++ MD.toHtml doc ++ pad

196

198

197− GLShader uid src ->

199+ GLShader _ src ->

198 return . literal $ Str src

200 return . literal $ Str src

199

201

202+ PortIn name _ _ handler ->

203+ do handler' <- expression handler

204+ return $ obj "Native.Ports.portIn" `call` [ string name, handler' ]

205+

206+ PortOut name _ signal ->

207+ do signal' <- expression signal

208+ return $ obj "Native.Ports.portOut" `call` [ string name, signal' ]

209+

210+definition :: Def -> State Int [Statement ()]

211+definition (Definition pattern expr@(L span _) _) = do

212+ expr' <- expression expr

213+ let assign x = varDecl x expr'

214+ case pattern of

215+ PVar x

216+ | Help.isOp x ->

217+ let op = LBracket () (ref "_op") (string x) in

218+ return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

219+ | otherwise ->

220+ return [ VarDeclStmt () [ assign x ] ]

221+

222+ PRecord fields ->

223+ let setField f = varDecl f (dotSep ["$",f]) in

224+ return [ VarDeclStmt () (assign "$" : map setField fields) ]

225+

226+ PData name patterns | vars /= Nothing ->

227+ return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

228+ where

229+ vars = getVars patterns

230+ getVars patterns =

231+ case patterns of

232+ PVar x : rest -> (x:) `fmap` getVars rest

233+ [] -> Just []

234+ _ -> Nothing

235+

236+ decl x n = varDecl x (dotSep ["$","_" ++ show n])

237+ setup vars

238+ | Help.isTuple name = assign "$" : vars

239+ | otherwise = assign "$raw" : safeAssign : vars

240+

241+ safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)

242+ if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)

243+ exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]

244+

245+ _ ->

246+ do defs' <- concat <$> mapM toDef vars

247+ return (VarDeclStmt () [assign "$"] : defs')

248+ where

249+ vars = Set.toList $ Pattern.boundVars pattern

250+ mkVar = L span . Var

251+ toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]

252+ in definition $ Definition (PVar y) expr Nothing

200

253

201−definition :: Def () () -> State Int [Statement ()]

202−definition def =

203− case def of

204− TypeAnnotation _ _ -> return []

205−

206− Def pattern expr@(L span _) -> do

207− expr' <- expression expr

208− let assign x = varDecl x expr'

209− case pattern of

210− PVar x

211− | Help.isOp x ->

212− let op = LBracket () (ref "_op") (string x) in

213− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

214− | otherwise ->

215− return [ VarDeclStmt () [ assign x ] ]

216−

217− PRecord fields ->

218− let setField f = varDecl f (dotSep ["$",f]) in

219− return [ VarDeclStmt () (assign "$" : map setField fields) ]

220−

221− PData name patterns | vars /= Nothing ->

222− case vars of

223− Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]

224− where

225− vars = getVars patterns

226− getVars patterns =

227− case patterns of

228− PVar x : rest -> (x:) `fmap` getVars rest

229− [] -> Just []

230− _ -> Nothing

231−

232− decl x n = varDecl x (dotSep ["$","_" ++ show n])

233− setup vars

234− | Help.isTuple name = assign "$" : vars

235− | otherwise = assign "$raw" : safeAssign : vars

236−

237− safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)

238− if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)

239− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]

240−

241− _ ->

242− do defs' <- concat <$> mapM toDef vars

243− return (VarDeclStmt () [assign "$"] : defs')

244− where

245− vars = Set.toList $ SD.boundVars pattern

246− mkVar = L span . Var

247− toDef y = definition $

248− Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])

249−

250−match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]

254+match :: (Show a) => a -> Case.Match -> State Int [Statement ()]

251match span mtch =

255match span mtch =

252 case mtch of

256 case mtch of

253 Case.Match name clauses mtch' ->

257 Case.Match name clauses mtch' ->

@@ -292,8 +296,12 @@ clause span variable (Case.Clause value vars mtch) =

292 [] -> name

296 [] -> name

293 is -> drop (last is + 1) name

297 is -> drop (last is + 1) name

294

298

299+flattenLets defs lexpr@(L _ expr) =

300+ case expr of

301+ Let ds body -> flattenLets (defs ++ ds) body

302+ _ -> (defs, lexpr)

295

303

296−generate :: MetadataModule () () -> String

304+generate :: MetadataModule -> String

297generate unsafeModule =

305generate unsafeModule =

298 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

306 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

299 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

307 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

@@ -301,17 +309,16 @@ generate unsafeModule =

301 modul = MakeSafe.metadataModule unsafeModule

309 modul = MakeSafe.metadataModule unsafeModule

302 thisModule = dotSep ("_elm" : names modul ++ ["values"])

310 thisModule = dotSep ("_elm" : names modul ++ ["values"])

303 programStmts =

311 programStmts =

312+ concat

304− concat [ setup (Just "_elm") (names modul ++ ["values"])

313+ [ setup (Just "_elm") (names modul ++ ["values"])

305− , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]

314+ , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]

306− , [ internalImports (List.intercalate "." (names modul)) ]

315+ , [ internalImports (List.intercalate "." (names modul)) ]

307− , concatMap jsImport (imports modul)

316+ , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul

308− , concatMap importEvent (foreignImports modul)

309− , [ assign ["_op"] (ObjectLit () []) ]

317+ , [ assign ["_op"] (ObjectLit () []) ]

310− , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0

318+ , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0

311− , map exportEvent $ foreignExports modul

312− , [ jsExports ]

319+ , [ jsExports ]

313− , [ ReturnStmt () (Just thisModule) ]

320+ , [ ReturnStmt () (Just thisModule) ]

314− ]

321+ ]

315

322

316 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)

323 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)

317 where

324 where

@@ -324,7 +331,7 @@ generate unsafeModule =

324 _ -> ExprStmt () $

331 _ -> ExprStmt () $

325 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

332 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

326

333

327− jsImport (modul,_) = setup Nothing path ++ [ include ]

334+ jsImport modul = setup Nothing path ++ [ include ]

328 where

335 where

329 path = split modul

336 path = split modul

330 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"

337 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"

@@ -336,32 +343,6 @@ generate unsafeModule =

336 Nothing -> tail . init $ List.inits path

343 Nothing -> tail . init $ List.inits path

337 Just nmspc -> drop 2 . init . List.inits $ nmspc : path

344 Just nmspc -> drop 2 . init . List.inits $ nmspc : path

338

345

339− addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")

340−

341− importEvent (js,base,elm,_) =

342− [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]

343− , ExprStmt () $

344− obj "document.addEventListener" `call`

345− [ addId js

346− , function ["_e"]

347− [ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]

348− ]

349− ]

350−

351− exportEvent (js,elm,_) =

352− ExprStmt () $

353− ref "A2" `call`

354− [ obj "Signal.lift"

355− , function ["_v"]

356− [ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]

357− , ExprStmt () $

358− obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]

359− , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")

360− , ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"

361− , ReturnStmt () (Just $ ref "_v")

362− ]

363− , ref elm ]

364−

365binop span op e1 e2 =

346binop span op e1 e2 =

366 case op of

347 case op of

367 "Basics.." ->

348 "Basics.." ->

@@ -388,9 +369,6 @@ binop span op e1 e2 =

388 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

369 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

389 _ -> es ++ [e]

370 _ -> es ++ [e]

390

371

391− js1 = expression e1

392− js2 = expression e2

393−

394 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

372 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

395 | otherwise = dotSep parts

373 | otherwise = dotSep parts

396 where

374 where

@@ -414,8 +392,8 @@ binop span op e1 e2 =

414 specialOps = concat

392 specialOps = concat

415 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

393 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

416 , specialOp "|>" $ flip (<|)

394 , specialOp "|>" $ flip (<|)

417− , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]

395+ , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]

418− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])

396+ , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

419 , specialOp "<" $ cmp OpLT 0

397 , specialOp "<" $ cmp OpLT 0

420 , specialOp ">" $ cmp OpGT 0

398 , specialOp ">" $ cmp OpGT 0

421 , specialOp "<=" $ cmp OpLT 1

399 , specialOp "<=" $ cmp OpLT 1

@@ -423,4 +401,4 @@ binop span op e1 e2 =

423 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

401 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

424 ]

402 ]

425

403

426− cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)

404+ cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)

compiler/Generate/Noscript.hs+8−9

@@ -1,35 +1,34 @@

1module Generate.Noscript (noscript) where

2

3import Data.List (isInfixOf)

4−import SourceSyntax.Declaration (Declaration(..))

4+import qualified SourceSyntax.Declaration as D

5import SourceSyntax.Expression

6import SourceSyntax.Literal

7import SourceSyntax.Location

8import SourceSyntax.Module

9import qualified Generate.Markdown as MD

10

11−noscript :: Module t v -> String

11+noscript :: Extract def => Module def -> String

12noscript modul = concat (extract modul)

13

14class Extract a where

15 extract :: a -> [String]

16

17−instance Extract (Module t v) where

17+instance Extract def => Extract (Module def) where

18 extract (Module _ _ _ stmts) =

19 map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)

20

21−instance Extract (Declaration t v) where

21+instance Extract def => Extract (D.Declaration' port def) where

22− extract (Definition d) = extract d

22+ extract (D.Definition d) = extract d

23 extract _ = []

24

25−instance Extract (Def t v) where

25+instance Extract Def where

26− extract (Def _ e) = extract e

26+ extract (Definition _ e _) = extract e

27− extract _ = []

28

27

29instance Extract e => Extract (Located e) where

28instance Extract e => Extract (Located e) where

30 extract (L _ e) = extract e

29 extract (L _ e) = extract e

31

30

32−instance Extract (Expr t v) where

31+instance Extract def => Extract (Expr' def) where

33 extract expr =

32 extract expr =

34 let f = extract in

33 let f = extract in

35 case expr of

34 case expr of

compiler/InterfaceSerialization.hsdeleted−52

@@ -1,52 +0,0 @@

1−module InterfaceSerialization ( loadInterface

2− , interfaceDecode

3− , validVersion

4− ) where

5−

6−import qualified Data.ByteString.Lazy as L

7−import qualified Data.Binary as Binary

8−

9−import qualified Elm.Internal.Version as Version

10−import System.Directory (doesFileExist)

11−import System.IO (hPutStrLn, stderr)

12−import System.Exit (exitFailure)

13−

14−import SourceSyntax.Module

15−

16−loadInterface :: FilePath -> IO (Either String L.ByteString)

17−loadInterface filePath = do

18− exists <- doesFileExist filePath

19− if exists

20− then do

21− byteString <- L.readFile filePath

22− return $ Right byteString

23−

24− else

25− return $ Left $ "Unable to find file " ++ filePath ++

26− " for deserialization!"

27−

28−interfaceDecode :: Binary.Binary a =>

29− FilePath -> L.ByteString -> Either String a

30−interfaceDecode filePath bytes = do

31− case Binary.decodeOrFail bytes of

32− Right (_, _, binaryInfo) -> Right binaryInfo

33−

34− Left (_, offset, err) ->

35− Left $ concat [ "Error reading build artifact: ", filePath, "\n"

36− , " The exact error was '", err, "' at offset ", show offset, ".\n"

37− , " The file was generated by a previous build and may be outdated or corrupt.\n"

38− , " Please remove the file and try again."

39− ]

40−

41−validVersion :: FilePath -> (String, ModuleInterface) ->

42− Either String (String, ModuleInterface)

43−validVersion filePath (name, interface) =

44− if iVersion interface == Version.elmVersion then

45− Right (name, interface)

46− else

47− Left $ concat

48− [ "Error reading build artifact: ", filePath, "\n"

49− , " It was generated by a different version of the compiler: "

50− , show (iVersion interface), "\n"

51− , " Please remove the file and try again.\n"

52− ]

compiler/Metadata/Prelude.hs+27−38

@@ -1,70 +1,59 @@

1+{-# OPTIONS_GHC -W #-}

1module Metadata.Prelude (interfaces, add) where

2module Metadata.Prelude (interfaces, add) where

2

3

3import qualified Data.Map as Map

4import qualified Data.Map as Map

4import qualified Control.Exception as E

5import qualified Control.Exception as E

5import qualified Paths_Elm as Path

6import qualified Paths_Elm as Path

6−import System.Directory

7import System.Exit

8−import System.FilePath

9import System.IO

8import System.IO

10import SourceSyntax.Module

9import SourceSyntax.Module

11−import qualified Data.Binary as Binary

10+import qualified Build.Interface as Interface

12−import qualified Data.ByteString.Lazy as BS

13

11

14−import qualified InterfaceSerialization as IS

15−

16−add :: Module t v -> Module t v

12+add :: Bool -> Module def -> Module def

17−add (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts

13+add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls

18 where

14 where

19− customIms = concatMap addModule prelude

15+ customIms = if noPrelude then [] else concatMap addModule prelude

20

16

21 addModule (n, method) = case lookup n ims of

17 addModule (n, method) = case lookup n ims of

22 Nothing -> [(n, method)]

18 Nothing -> [(n, method)]

23− Just (As m) -> [(n, method)]

19+ Just (As _) -> [(n, method)]

24 Just _ -> []

20 Just _ -> []

25

21

26prelude :: [(String, ImportMethod)]

22prelude :: [(String, ImportMethod)]

27−prelude = text ++ map (\n -> (n, Hiding [])) modules

23+prelude = string : text ++ map (\n -> (n, Hiding [])) modules

28 where

24 where

29 text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]

25 text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]

26+ string = ("String", As "String")

30 modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"

27 modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"

31− , "Graphics.Element", "Color", "Graphics.Collage" ]

28+ , "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]

32

29

33−interfaces :: IO Interfaces

30+interfaces :: Bool -> IO Interfaces

31+interfaces noPrelude =

32+ if noPrelude

33+ then return $ Map.empty

34−interfaces = safeReadDocs =<< Path.getDataFileName "interfaces.data"

34+ else safeReadDocs =<< Path.getDataFileName "interfaces.data"

35

36safeReadDocs :: FilePath -> IO Interfaces

37safeReadDocs name =

38 E.catch (readDocs name) $ \err -> do

39 let _ = err :: IOError

40+ hPutStrLn stderr $ unlines $

40− putStrLn $ unlines [ "Error reading types for standard library!"

41+ [ "Error reading types for standard library from file " ++ name

41− , " The file should be at " ++ name

42− , " If you are using a stable version of Elm,"

42+ , " If you are using a stable version of Elm, please report an issue at"

43− , " please report an issue at github.com/evancz/Elm"

43+ , " <http://github.com/evancz/Elm/issues> specifying version numbers for"

44− , " and specify your versions of Elm and your OS" ]

44+ , " Elm and your OS." ]

45 exitFailure

46

47−firstModuleInterface :: [(String, ModuleInterface)] ->

48− Either String (String, ModuleInterface)

49−firstModuleInterface interfaces =

50− case interfaces of

51− [] -> Left "No interfaces found in serialized Prelude!"

52− iface:_ -> Right iface

53−

54readDocs :: FilePath -> IO Interfaces

47readDocs :: FilePath -> IO Interfaces

55readDocs filePath = do

48readDocs filePath = do

56− bytes <- IS.loadInterface filePath

49+ interfaces <- Interface.load filePath

57− let interfaces = IS.interfaceDecode filePath =<< bytes

50+ case mapM (Interface.isValid filePath) (interfaces :: [(String, ModuleInterface)]) of

58−

59− -- Although every ModuleInterface that is deserialized in this collection

60− -- contains the compiler version, we only check the first ModuleInterface

61− -- since it doesn't make sense that different modules in Prelude would

62− -- have been compiled by different compiler versions.

63− isValid = IS.validVersion filePath =<< firstModuleInterface =<< interfaces

64−

65− case (interfaces, isValid) of

66− (_, Left err) -> do

51+ Left err -> do

67 hPutStrLn stderr err

52 hPutStrLn stderr err

68 exitFailure

53 exitFailure

69

54

55+ Right [] -> do

56+ hPutStrLn stderr "No interfaces found in serialized Prelude!"

57+ exitFailure

58+

70− (Right ifaces, _) -> return $ Map.fromList ifaces

59+ Right ifaces -> return $ Map.fromList ifaces

compiler/Parse/Binop.hs+15−16

@@ -1,12 +1,11 @@

1module Parse.Binop (binops, OpTable) where

2

3import Control.Applicative ((<$>))

4−import Control.Monad.Error

5import Data.List (intercalate)

4import Data.List (intercalate)

6import qualified Data.Map as Map

5import qualified Data.Map as Map

7

6

8import SourceSyntax.Location (merge)

7import SourceSyntax.Location (merge)

9−import SourceSyntax.Expression (LExpr, Expr(Binop))

8+import qualified SourceSyntax.Expression as E

10import SourceSyntax.Declaration (Assoc(..))

9import SourceSyntax.Declaration (Assoc(..))

11import Text.Parsec

10import Text.Parsec

12import Parse.Helpers

11import Parse.Helpers

@@ -17,13 +16,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table

17opAssoc :: OpTable -> String -> Assoc

16opAssoc :: OpTable -> String -> Assoc

18opAssoc table op = snd $ Map.findWithDefault (9,L) op table

17opAssoc table op = snd $ Map.findWithDefault (9,L) op table

19

18

20−hasLevel :: OpTable -> Int -> (String, LExpr t v) -> Bool

19+hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool

21hasLevel table n (op,_) = opLevel table op == n

20hasLevel table n (op,_) = opLevel table op == n

22

21

23−binops :: IParser (LExpr t v)

22+binops :: IParser E.LParseExpr

24− -> IParser (LExpr t v)

23+ -> IParser E.LParseExpr

25 -> IParser String

24 -> IParser String

26− -> IParser (LExpr t v)

25+ -> IParser E.LParseExpr

27binops term last anyOp =

26binops term last anyOp =

28 do e <- term

27 do e <- term

29 table <- getState

28 table <- getState

@@ -39,9 +38,9 @@ binops term last anyOp =

39

38

40split :: OpTable

39split :: OpTable

41 -> Int

40 -> Int

42− -> LExpr t v

41+ -> E.LParseExpr

43− -> [(String, LExpr t v)]

42+ -> [(String, E.LParseExpr)]

44− -> IParser (LExpr t v)

43+ -> IParser E.LParseExpr

45split _ _ e [] = return e

44split _ _ e [] = return e

46split table n e eops = do

45split table n e eops = do

47 assoc <- getAssoc table n eops

46 assoc <- getAssoc table n eops

@@ -50,26 +49,26 @@ split table n e eops = do

50 case assoc of R -> joinR es ops

49 case assoc of R -> joinR es ops

51 _ -> joinL es ops

50 _ -> joinL es ops

52

51

53−splitLevel :: OpTable -> Int -> LExpr t v -> [(String, LExpr t v)]

52+splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]

54− -> [IParser (LExpr t v)]

53+ -> [IParser E.LParseExpr]

55splitLevel table n e eops =

54splitLevel table n e eops =

56 case break (hasLevel table n) eops of

55 case break (hasLevel table n) eops of

57 (lops, (op,e'):rops) ->

56 (lops, (op,e'):rops) ->

58 split table (n+1) e lops : splitLevel table n e' rops

57 split table (n+1) e lops : splitLevel table n e' rops

59 (lops, []) -> [ split table (n+1) e lops ]

58 (lops, []) -> [ split table (n+1) e lops ]

60

59

61−joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)

60+joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr

62joinL [e] [] = return e

61joinL [e] [] = return e

63−joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops

62+joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops

64joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

63joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

65

64

66−joinR :: [LExpr t v] -> [String] -> IParser (LExpr t v)

65+joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr

67joinR [e] [] = return e

66joinR [e] [] = return e

68joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

67joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

69− return (merge a e (Binop op a e))

68+ return (merge a e (E.Binop op a e))

70joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

69joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

71

70

72−getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc

71+getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc

73getAssoc table n eops

72getAssoc table n eops

74 | all (==L) assocs = return L

73 | all (==L) assocs = return L

75 | all (==R) assocs = return R

74 | all (==R) assocs = return R

compiler/Parse/Declaration.hs+34−88

@@ -1,36 +1,36 @@

1−

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2module Parse.Declaration where

3

4−import Control.Applicative ((<$>), (<*>))

4+import Control.Applicative ((<$>))

5−import qualified Data.List as List

6−import qualified Data.Set as Set

7import Text.Parsec hiding (newline,spaces)

5import Text.Parsec hiding (newline,spaces)

8−import Text.Parsec.Indent

9

6

10import Parse.Helpers

7import Parse.Helpers

11import qualified Parse.Expression as Expr

8import qualified Parse.Expression as Expr

12−import qualified SourceSyntax.Type as T

13import qualified Parse.Type as Type

9import qualified Parse.Type as Type

14−import SourceSyntax.Declaration (Declaration(..), Assoc(..))

10+import qualified SourceSyntax.Declaration as D

15

11

16

12

17−declaration :: IParser (Declaration t v)

13+declaration :: IParser D.ParseDeclaration

18−declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition

14+declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

19

15

20−definition :: IParser (Declaration t v)

16+definition :: IParser D.ParseDeclaration

21−definition = Definition <$> Expr.def

17+definition = D.Definition <$> Expr.def

22

18

23−alias :: IParser (Declaration t v)

19+alias :: IParser D.ParseDeclaration

24alias = do

20alias = do

25 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

21 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

26 forcedWS

22 forcedWS

27− alias <- capVar

23+ name <- capVar

28− args <- spacePrefix lowVar

24+ args <- spacePrefix lowVar

29 padded equals

25 padded equals

30 tipe <- Type.expr

26 tipe <- Type.expr

27+ json <- option [] $ do

28+ try $ padded (reserved "deriving")

29+ string "Json"

30+ return [D.Json]

31− return (TypeAlias alias args tipe)

31+ return (D.TypeAlias name args tipe json)

32

33−datatype :: IParser (Declaration t v)

33+datatype :: IParser D.ParseDeclaration

34datatype = do

35 reserved "data" <?> "datatype definition (data T = A | B | ...)"

36 forcedWS

@@ -38,81 +38,27 @@ datatype = do

38 args <- spacePrefix lowVar

39 padded equals

40 tcs <- pipeSep1 Type.constructor

41− return $ Datatype name args tcs

41+ return $ D.Datatype name args tcs []

42

43

44−infixDecl :: IParser (Declaration t v)

44+infixDecl :: IParser D.ParseDeclaration

45infixDecl = do

46− assoc <- choice [ reserved "infixl" >> return L

46+ assoc <- choice [ reserved "infixl" >> return D.L

47− , reserved "infix" >> return N

47+ , reserved "infix" >> return D.N

48− , reserved "infixr" >> return R ]

48+ , reserved "infixr" >> return D.R ]

49 forcedWS

50 n <- digit

51 forcedWS

52− Fixity assoc (read [n]) <$> anyOp

52+ D.Fixity assoc (read [n]) <$> anyOp

53−

53+

54−

54+

55−foreignDef :: IParser (Declaration t v)

55+port :: IParser D.ParseDeclaration

56−foreignDef = do

56+port =

57− try (reserved "foreign")

57+ do try (reserved "port")

58− whitespace

58+ whitespace

59− importEvent <|> exportEvent

59+ name <- lowVar

60−

60+ whitespace

61−exportEvent :: IParser (Declaration t v)

61+ let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }

62−exportEvent = do

62+ D.Port <$> choice [ port' hasType D.PortAnnotation Type.expr

63− try (reserved "export") >> padded (reserved "jsevent")

63+ , port' (string "<-") D.SendDefinition Expr.expr

64− eventName <- jsVar

64+ , port' (string "->") D.RecvDefinition Expr.expr ]

65− whitespace

66− elmVar <- lowVar

67− padded hasType

68− tipe <- Type.expr

69− case tipe of

70− T.Data "Signal" [t] ->

71− case isExportable t of

72− Nothing -> return (ExportEvent eventName elmVar tipe)

73− Just err -> fail err

74− _ -> fail "When importing foreign events, the imported value must have type Signal."

75−

76−importEvent :: IParser (Declaration t v)

77−importEvent = do

78− try (reserved "import") >> padded (reserved "jsevent")

79− eventName <- jsVar

80− baseValue <- padded Expr.term

81− <?> "Base case for imported signal (signals cannot be undefined)"

82− elmVar <- lowVar <?> "Name of imported signal"

83− padded hasType

84− tipe <- Type.expr

85− case tipe of

86− T.Data "Signal" [t] ->

87− case isExportable t of

88− Nothing -> return (ImportEvent eventName baseValue elmVar tipe)

89− Just err -> fail err

90− _ -> fail "When importing foreign events, the imported value must have type Signal."

91−

92−jsVar :: IParser String

93−jsVar = betwixt '"' '"' $ do

94− v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')

95− if Set.notMember v jsReserveds then return v else

96− fail $ "'" ++ v ++

97− "' is not a good name for a importing or exporting JS values."

98−

99−isExportable tipe =

100− case tipe of

101− T.Lambda _ _ ->

102− Just $ "Elm's JavaScript event interface does not yet handle functions. " ++

103− "Only simple values can be imported and exported in this release."

104−

105− T.Data "JSArray" [t] -> isExportable t

106−

107− T.Data name []

108− | any (`List.isSuffixOf` name) jsTypes -> Nothing

109− | otherwise -> Just $ "'" ++ name ++ "' is not an exportable type." ++ msg

110−

111− T.Data name _ ->

112− Just $ "'" ++ name ++ "' is not an exportable type " ++

113− "constructor. Only 'JSArray' is an exportable container."

114−

115− T.Var _ -> Just $ "Cannot export type variables." ++ msg

116− where

117− msg = " The following types are exportable: " ++ List.intercalate ", " jsTypes

118− jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]

compiler/Parse/Expression.hs+22−23

@@ -1,6 +1,5 @@

1−module Parse.Expression (def,term,typeAnnotation) where

1+module Parse.Expression (def,term,typeAnnotation,expr) where

2

3−import Control.Arrow ((***))

4import Control.Applicative ((<$>), (<*>))

3import Control.Applicative ((<$>), (<*>))

5import Data.List (foldl')

4import Data.List (foldl')

6import Text.Parsec hiding (newline,spaces)

5import Text.Parsec hiding (newline,spaces)

@@ -16,26 +15,25 @@ import SourceSyntax.Location as Location

16import SourceSyntax.Pattern hiding (tuple,list)

15import SourceSyntax.Pattern hiding (tuple,list)

17import qualified SourceSyntax.Literal as Literal

16import qualified SourceSyntax.Literal as Literal

18import SourceSyntax.Expression

17import SourceSyntax.Expression

19−import SourceSyntax.Declaration (Declaration(Definition))

20

18

21

19

22-------- Basic Terms --------

20-------- Basic Terms --------

23

21

24−varTerm :: IParser (Expr t v)

22+varTerm :: IParser ParseExpr

25varTerm = toVar <$> var <?> "variable"

23varTerm = toVar <$> var <?> "variable"

26

24

27−toVar :: String -> Expr t v

25+toVar :: String -> ParseExpr

28toVar v = case v of "True" -> Literal (Literal.Boolean True)

26toVar v = case v of "True" -> Literal (Literal.Boolean True)

29 "False" -> Literal (Literal.Boolean False)

27 "False" -> Literal (Literal.Boolean False)

30 _ -> Var v

28 _ -> Var v

31

29

32−accessor :: IParser (Expr t v)

30+accessor :: IParser ParseExpr

33accessor = do

31accessor = do

34 (start, lbl, end) <- located (try (string "." >> rLabel))

32 (start, lbl, end) <- located (try (string "." >> rLabel))

35 let loc e = Location.at start end e

33 let loc e = Location.at start end e

36 return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))

34 return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))

37

35

38−negative :: IParser (Expr t v)

36+negative :: IParser ParseExpr

39negative = do

37negative = do

40 (start, nTerm, end) <-

38 (start, nTerm, end) <-

41 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

39 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

@@ -45,7 +43,7 @@ negative = do

45

43

46-------- Complex Terms --------

44-------- Complex Terms --------

47

45

48−listTerm :: IParser (Expr t v)

46+listTerm :: IParser ParseExpr

49listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

47listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

50 where

48 where

51 range = do

49 range = do

@@ -74,7 +72,7 @@ listTerm = markdown' <|> glShader' <|> braces (try range <|> ExplicitList <$> co

74 string "}}"

72 string "}}"

75 return (md ++ span uid (length exprs), exprs ++ [e])

73 return (md ++ span uid (length exprs), exprs ++ [e])

76

74

77−parensTerm :: IParser (LExpr t v)

75+parensTerm :: IParser LParseExpr

78parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

76parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

79 where

77 where

80 opFn = do

78 opFn = do

@@ -97,7 +95,7 @@ parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

97 [e] -> e

95 [e] -> e

98 _ -> Location.at start end (tuple es)

96 _ -> Location.at start end (tuple es)

99

97

100−recordTerm :: IParser (LExpr t v)

98+recordTerm :: IParser LParseExpr

101recordTerm = brackets $ choice [ misc, addLocation record ]

99recordTerm = brackets $ choice [ misc, addLocation record ]

102 where field = do

100 where field = do

103 label <- rLabel

101 label <- rLabel

@@ -130,14 +128,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]

130 Nothing -> try (insert record) <|> try (modify record)

128 Nothing -> try (insert record) <|> try (modify record)

131

129

132

130

133−term :: IParser (LExpr t v)

131+term :: IParser LParseExpr

134term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

132term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

135 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

133 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

136 <?> "basic term (4, x, 'c', etc.)"

134 <?> "basic term (4, x, 'c', etc.)"

137

135

138-------- Applications --------

136-------- Applications --------

139

137

140−appExpr :: IParser (LExpr t v)

138+appExpr :: IParser LParseExpr

141appExpr = do

139appExpr = do

142 t <- term

140 t <- term

143 ts <- constrainedSpacePrefix term $ \str ->

141 ts <- constrainedSpacePrefix term $ \str ->

@@ -148,12 +146,12 @@ appExpr = do

148

146

149-------- Normal Expressions --------

147-------- Normal Expressions --------

150

148

151−binaryExpr :: IParser (LExpr t v)

149+binaryExpr :: IParser LParseExpr

152binaryExpr = binops appExpr lastExpr anyOp

150binaryExpr = binops appExpr lastExpr anyOp

153 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

151 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

154 <|> lambdaExpr

152 <|> lambdaExpr

155

153

156−ifExpr :: IParser (Expr t v)

154+ifExpr :: IParser ParseExpr

157ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

155ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

158 where

156 where

159 normal = do

157 normal = do

@@ -169,7 +167,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

169 b <- expr ; padded arrow

167 b <- expr ; padded arrow

170 (,) b <$> expr

168 (,) b <$> expr

171

169

172−lambdaExpr :: IParser (LExpr t v)

170+lambdaExpr :: IParser LParseExpr

173lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

171lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

174 whitespace

172 whitespace

175 args <- spaceSep1 Pattern.term

173 args <- spaceSep1 Pattern.term

@@ -177,17 +175,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

177 body <- expr

175 body <- expr

178 return (makeFunction args body)

176 return (makeFunction args body)

179

177

180−defSet :: IParser [Def t v]

178+defSet :: IParser [ParseDef]

181defSet = block (do d <- def ; whitespace ; return d)

179defSet = block (do d <- def ; whitespace ; return d)

182

180

183−letExpr :: IParser (Expr t v)

181+letExpr :: IParser ParseExpr

184letExpr = do

182letExpr = do

185 reserved "let" ; whitespace

183 reserved "let" ; whitespace

186 defs <- defSet

184 defs <- defSet

187 padded (reserved "in")

185 padded (reserved "in")

188 Let defs <$> expr

186 Let defs <$> expr

189

187

190−caseExpr :: IParser (Expr t v)

188+caseExpr :: IParser ParseExpr

191caseExpr = do

189caseExpr = do

192 reserved "case"; e <- padded expr; reserved "of"; whitespace

190 reserved "case"; e <- padded expr; reserved "of"; whitespace

193 Case e <$> (with <|> without)

191 Case e <$> (with <|> without)

@@ -197,6 +195,7 @@ caseExpr = do

197 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

195 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

198 without = block (do c <- case_ ; whitespace ; return c)

196 without = block (do c <- case_ ; whitespace ; return c)

199

197

198+expr :: IParser LParseExpr

200expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

199expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

201 <|> lambdaExpr

200 <|> lambdaExpr

202 <|> binaryExpr

201 <|> binaryExpr

@@ -212,7 +211,7 @@ defStart =

212 where

211 where

213 func pattern =

212 func pattern =

214 case pattern of

213 case pattern of

215− PVar v -> (pattern:) <$> spacePrefix Pattern.term

214+ PVar _ -> (pattern:) <$> spacePrefix Pattern.term

216 _ -> do try (lookAhead (whitespace >> string "="))

215 _ -> do try (lookAhead (whitespace >> string "="))

217 return [pattern]

216 return [pattern]

218

217

@@ -222,18 +221,18 @@ defStart =

222 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

221 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

223 else [ PVar (o:p), p1, p2 ]

222 else [ PVar (o:p), p1, p2 ]

224

223

225−makeFunction :: [Pattern] -> LExpr t v -> LExpr t v

224+makeFunction :: [Pattern] -> LParseExpr -> LParseExpr

226makeFunction args body@(L s _) =

225makeFunction args body@(L s _) =

227 foldr (\arg body' -> L s $ Lambda arg body') body args

226 foldr (\arg body' -> L s $ Lambda arg body') body args

228

227

229−definition :: IParser (Def t v)

228+definition :: IParser ParseDef

230definition = withPos $ do

229definition = withPos $ do

231 (name:args) <- defStart

230 (name:args) <- defStart

232 padded equals

231 padded equals

233 body <- expr

232 body <- expr

234 return . Def name $ makeFunction args body

233 return . Def name $ makeFunction args body

235

234

236−typeAnnotation :: IParser (Def t v)

235+typeAnnotation :: IParser ParseDef

237typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

236typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

238 where

237 where

239 start = do

238 start = do

@@ -241,5 +240,5 @@ typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

241 padded hasType

240 padded hasType

242 return v

241 return v

243

242

244−def :: IParser (Def t v)

243+def :: IParser ParseDef

245def = typeAnnotation <|> definition

244def = typeAnnotation <|> definition

compiler/Parse/Helpers.hs+2−2

@@ -25,7 +25,7 @@ reserveds = [ "if", "then", "else"

25 , "module", "where"

26 , "import", "as", "hiding", "open"

27 , "export", "foreign"

28− , "deriving" ]

28+ , "deriving", "port" ]

29

30jsReserveds :: Set.Set String

31jsReserveds = Set.fromList

@@ -209,7 +209,7 @@ located p = do

209 end <- getPosition

210 return (start, e, end)

211

212−accessible :: IParser (LExpr t v) -> IParser (LExpr t v)

212+accessible :: IParser LParseExpr -> IParser LParseExpr

213accessible expr = do

214 start <- getPosition

215 ce@(L _ e) <- expr

compiler/Parse/Literal.hs+3−4

@@ -1,13 +1,12 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

1module Parse.Literal (literal) where

2module Parse.Literal (literal) where

2

3

3−import Control.Applicative ((<$>), (<*>))

4+import Control.Applicative ((<$>))

4−import Control.Monad

5import Text.Parsec hiding (newline,spaces)

6−import Text.Parsec.Indent

7−

8import Parse.Helpers

6import Parse.Helpers

9import SourceSyntax.Literal

7import SourceSyntax.Literal

10

8

9+literal :: IParser Literal

11literal = num <|> (Str <$> str) <|> (Chr <$> chr)

10literal = num <|> (Str <$> str) <|> (Chr <$> chr)

12

11

13num :: IParser Literal

12num :: IParser Literal

compiler/Parse/Module.hs+1−2

@@ -1,4 +1,3 @@

1−

2module Parse.Module (moduleDef, getModuleName, imports) where

1module Parse.Module (moduleDef, getModuleName, imports) where

3

2

4import Control.Applicative ((<$>), (<*>))

3import Control.Applicative ((<$>), (<*>))

@@ -6,7 +5,7 @@ import Data.List (intercalate)

6import Text.Parsec hiding (newline,spaces)

5import Text.Parsec hiding (newline,spaces)

7

6

8import Parse.Helpers

7import Parse.Helpers

9−import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)

8+import SourceSyntax.Module (ImportMethod(..), Imports)

10

9

11varList :: IParser [String]

10varList :: IParser [String]

12varList = parens $ commaSep1 (var <|> parens symOp)

11varList = parens $ commaSep1 (var <|> parens symOp)

compiler/Parse/Parse.hs+23−20

@@ -1,22 +1,19 @@

1+{-# OPTIONS_GHC -W #-}

1module Parse.Parse (program, dependencies) where

2module Parse.Parse (program, dependencies) where

2

3

3import Control.Applicative ((<$>), (<*>))

4import Control.Applicative ((<$>), (<*>))

4−import Control.Monad

5+import qualified Data.List as List

5−import Data.Char (isSymbol, isDigit)

6−import Data.List (foldl',intercalate)

7import qualified Data.Map as Map

6import qualified Data.Map as Map

8import Text.Parsec hiding (newline,spaces)

7import Text.Parsec hiding (newline,spaces)

9import qualified Text.PrettyPrint as P

8import qualified Text.PrettyPrint as P

10

9

11−import qualified SourceSyntax.Module as S

10+import qualified SourceSyntax.Declaration as D

12−import SourceSyntax.Declaration (Declaration(Fixity))

11+import qualified SourceSyntax.Module as M

13import Parse.Helpers

12import Parse.Helpers

14−import Parse.Binop (OpTable)

15−import Parse.Expression

16import Parse.Declaration (infixDecl)

13import Parse.Declaration (infixDecl)

17−import Parse.Type

18import Parse.Module

14import Parse.Module

19import qualified Parse.Declaration as Decl

15import qualified Parse.Declaration as Decl

16+import Transform.Declaration (combineAnnotations)

20

17

21freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

18freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

22 freshLine

19 freshLine

@@ -25,19 +22,25 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

25decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

22decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

26 (d:) <$> many freshDef

23 (d:) <$> many freshDef

27

24

28−program :: OpTable -> String -> Either [P.Doc] (S.Module t v)

25+program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)

26+program table src =

29−program table = setupParserWithTable table $ do

27+ do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src

28+ decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

29+ return $ M.Module names exs ims decls

30+

31+programParser :: IParser (M.Module D.ParseDeclaration)

32+programParser =

30− optional freshLine

33+ do optional freshLine

31− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

34+ (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

32− is <- (do try (lookAhead $ reserved "import")

35+ is <- (do try (lookAhead $ reserved "import")

33− imports `followedBy` freshLine) <|> return []

36+ imports `followedBy` freshLine) <|> return []

34− declarations <- decls

37+ declarations <- decls

35− optional freshLine ; optional spaces ; eof

38+ optional freshLine ; optional spaces ; eof

36− return $ S.Module names exports is declarations

39+ return $ M.Module names exports is declarations

37

40

38dependencies :: String -> Either [P.Doc] (String, [String])

41dependencies :: String -> Either [P.Doc] (String, [String])

39dependencies =

42dependencies =

40− let getName = intercalate "." . fst in

43+ let getName = List.intercalate "." . fst in

41 setupParser $ do

44 setupParser $ do

42 optional freshLine

45 optional freshLine

43 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

46 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

@@ -56,12 +59,12 @@ setupParserWithTable table p source =

56 msg overlap =

59 msg overlap =

57 P.vcat [ P.text "Parse error:"

60 P.vcat [ P.text "Parse error:"

58 , P.text $ "Overlapping definitions for infix operators: " ++

61 , P.text $ "Overlapping definitions for infix operators: " ++

59− intercalate " " (Map.keys overlap)

62+ List.intercalate " " (Map.keys overlap)

60 ]

63 ]

61

64

62parseFixities = do

65parseFixities = do

63 decls <- onFreshLines (:) [] infixDecl

66 decls <- onFreshLines (:) [] infixDecl

64− return $ Map.fromList [ (op,(lvl,assoc)) | Fixity assoc lvl op <- decls ]

67+ return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]

65

68

66setupParser :: IParser a -> String -> Either [P.Doc] a

69setupParser :: IParser a -> String -> Either [P.Doc] a

67setupParser p source =

70setupParser p source =

compiler/Parse/Pattern.hs+6−8

@@ -1,13 +1,10 @@

1−

1+{-# OPTIONS_GHC -W #-}

2module Parse.Pattern (term, expr) where

3

4−import Control.Applicative ((<$>),(<*>),pure)

4+import Control.Applicative ((<$>))

5−import Control.Monad

6−import Control.Monad.State

7import Data.Char (isUpper)

5import Data.Char (isUpper)

8import Data.List (intercalate)

6import Data.List (intercalate)

9import Text.Parsec hiding (newline,spaces,State)

7import Text.Parsec hiding (newline,spaces,State)

10−import Text.Parsec.Indent

11

8

12import Parse.Helpers

9import Parse.Helpers

13import Parse.Literal

10import Parse.Literal

@@ -20,9 +17,10 @@ basic = choice

20 [ char '_' >> return PAnything

17 [ char '_' >> return PAnything

21 , do v <- var

18 , do v <- var

22 return $ case v of

19 return $ case v of

23− "True" -> PLiteral (Boolean True)

20+ "True" -> PLiteral (Boolean True)

24− "False" -> PLiteral (Boolean False)

21+ "False" -> PLiteral (Boolean False)

25− c : _ -> if isUpper c then PData v [] else PVar v

22+ c:_ | isUpper c -> PData v []

23+ _ -> PVar v

26 , PLiteral <$> literal

24 , PLiteral <$> literal

27 ]

25 ]

28

26

compiler/Parse/Type.hs+3−4

@@ -1,11 +1,9 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

1module Parse.Type where

2module Parse.Type where

2

3

3import Control.Applicative ((<$>),(<*>))

4import Control.Applicative ((<$>),(<*>))

4−import Control.Monad (liftM,mapM)

5−import Data.Char (isLower)

6−import Data.List (lookup,intercalate)

5+import Data.List (intercalate)

7import Text.Parsec

6import Text.Parsec

8−import Text.Parsec.Indent

9

7

10import SourceSyntax.Type as T

8import SourceSyntax.Type as T

11import Parse.Helpers

9import Parse.Helpers

@@ -42,6 +40,7 @@ record =

42 whitespace >> hasType >> whitespace

40 whitespace >> hasType >> whitespace

43 (,) lbl <$> expr

41 (,) lbl <$> expr

44

42

43+capTypeVar :: IParser String

45capTypeVar = intercalate "." <$> dotSep1 capVar

44capTypeVar = intercalate "." <$> dotSep1 capVar

46

45

47constructor0 :: IParser T.Type

46constructor0 :: IParser T.Type

compiler/SourceSyntax/Declaration.hs+99−20

@@ -1,21 +1,56 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Declaration where

2module SourceSyntax.Declaration where

2

3

4+import Data.Binary

3import qualified SourceSyntax.Expression as Expr

5import qualified SourceSyntax.Expression as Expr

4−import SourceSyntax.Type

6+import qualified SourceSyntax.Type as T

5import SourceSyntax.PrettyPrint

7import SourceSyntax.PrettyPrint

6import Text.PrettyPrint as P

8import Text.PrettyPrint as P

7

9

8−data Declaration tipe var

10+data Declaration' port def

9− = Definition (Expr.Def tipe var)

11+ = Definition def

10− | Datatype String [String] [(String,[Type])]

12+ | Datatype String [String] [(String,[T.Type])] [Derivation]

11− | TypeAlias String [String] Type

13+ | TypeAlias String [String] T.Type [Derivation]

12− | ImportEvent String (Expr.LExpr tipe var) String Type

14+ | Port port

13− | ExportEvent String String Type

14 | Fixity Assoc Int String

15 | Fixity Assoc Int String

15− deriving (Eq, Show)

16+ deriving (Show)

16

17

17data Assoc = L | N | R

18data Assoc = L | N | R

18− deriving (Eq)

19+ deriving (Eq)

20+

21+data Derivation = Json | JS | Binary | New

22+ deriving (Eq, Show)

23+

24+data ParsePort

25+ = PortAnnotation String T.Type

26+ | SendDefinition String Expr.LParseExpr

27+ | RecvDefinition String Expr.LParseExpr

28+ deriving (Show)

29+

30+data Port

31+ = Send String Expr.LExpr T.Type

32+ | Recv String Expr.LExpr T.Type

33+ deriving (Show)

34+

35+type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

36+type Declaration = Declaration' Port Expr.Def

37+

38+instance Binary Derivation where

39+ get = do n <- getWord8

40+ return $ case n of

41+ 0 -> Json

42+ 1 -> JS

43+ 2 -> Binary

44+ 3 -> New

45+ _ -> error "Unable to decode Derivation. You may have corrupted binary files,\n\

46+ \so please report an issue at <https://github.com/evancz/Elm/issues>"

47+

48+ put derivation =

49+ putWord8 $ case derivation of

50+ Json -> 0

51+ JS -> 1

52+ Binary -> 2

53+ New -> 3

19

54

20instance Show Assoc where

55instance Show Assoc where

21 show assoc =

56 show assoc =

@@ -24,24 +59,68 @@ instance Show Assoc where

24 N -> "non"

59 N -> "non"

25 R -> "right"

60 R -> "right"

26

61

62+instance Binary Assoc where

63+ get = do n <- getWord8

64+ return $ case n of

65+ 0 -> L

66+ 1 -> N

67+ 2 -> R

68+ _ -> error "Error reading valid associativity from serialized string"

69+

70+ put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

71+

27−instance Pretty (Declaration t v) where

72+instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

28 pretty decl =

73 pretty decl =

29 case decl of

74 case decl of

30 Definition def -> pretty def

75 Definition def -> pretty def

31

76

32− Datatype tipe tvars ctors ->

77+ Datatype tipe tvars ctors deriveables ->

33 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

78 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

34− (P.sep $ zipWith join ("=" : repeat "|") ctors)

79+ (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables

35 where

80 where

36 join c ctor = P.text c <+> prettyCtor ctor

81 join c ctor = P.text c <+> prettyCtor ctor

37 prettyCtor (name, tipes) =

82 prettyCtor (name, tipes) =

38− P.hang (P.text name) 2 (P.sep (map prettyParens tipes))

83+ P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))

84+

85+ TypeAlias name tvars tipe deriveables ->

86+ alias <+> prettyDeriving deriveables

87+ where

88+ name' = P.text name <+> P.hsep (map P.text tvars)

89+ alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)

90+

91+ Port port -> pretty port

92+

93+ Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op

94+ where

95+ assoc' = case assoc of

96+ L -> P.text "l"

97+ N -> P.empty

98+ R -> P.text "r"

99+

100+instance Pretty ParsePort where

101+ pretty port =

102+ case port of

103+ PortAnnotation name tipe -> prettyPort name ":" tipe

104+ SendDefinition name expr -> prettyPort name "<-" expr

105+ RecvDefinition name expr -> prettyPort name "->" expr

106+

107+instance Pretty Port where

108+ pretty port =

109+ case port of

110+ Send name expr tipe -> mkPort "<-" name expr tipe

111+ Recv name expr tipe -> mkPort "->" name expr tipe

112+ where

113+ mkPort arrow name expr tipe =

114+ P.vcat [ prettyPort name ":" tipe

115+ , prettyPort name arrow expr ]

39

116

40− TypeAlias name tvars tipe ->

117+prettyPort :: (Pretty a) => String -> String -> a -> Doc

41− let alias = P.text name <+> P.hsep (map P.text tvars) in

118+prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e

42− P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe)

43

119

44− -- TODO: Actually write out the contained data in these cases.

120+prettyDeriving :: [Derivation] -> Doc

45− ImportEvent _ _ _ _ -> P.text (show decl)

121+prettyDeriving deriveables =

46− ExportEvent _ _ _ -> P.text (show decl)

122+ case deriveables of

47− Fixity _ _ _ -> P.text (show decl)

123+ [] -> P.empty

124+ [d] -> P.text "deriving" <+> P.text (show d)

125+ ds -> P.text "deriving" <+>

126+ P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)

compiler/SourceSyntax/Expression.hs+93−37

@@ -1,55 +1,93 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Expression where

2module SourceSyntax.Expression where

2

3

3−import Data.List (intercalate)

4import SourceSyntax.PrettyPrint

5import Text.PrettyPrint as P

6import qualified SourceSyntax.Helpers as Help

7import qualified SourceSyntax.Location as Location

8import qualified SourceSyntax.Pattern as Pattern

9−import qualified SourceSyntax.Type as Type

9+import qualified SourceSyntax.Type as SrcType

10import qualified SourceSyntax.Literal as Literal

11+import qualified Type.Type as Type

11

12

13+{-| This is a located expression. -}

12−type LExpr tipe var = Location.Located (Expr tipe var)

14+type LExpr' def = Location.Located (Expr' def)

13−data Expr t v

15+

16+{-| This is a fully general expression. The compilation process will enrich

17+this data structure with additional information after the initial parse.

18+The type holes let us reflect these structural changes in the types.

19+

20+ def: Parsing allows two kinds of definitions (type annotations or definitions),

21+ but later checks will see that they are well formed and combine them.

22+

23+ t: for adding type information, currently unused

24+

25+ v: for enriching variables with information like provenonce, currently unused

26+

27+Please don't get on my case to take the unused ones out. I have considered it.

28+It's a huge pain to add and remove, it will get used eventually, and it's not

29+hurting anything as it is.

30+-}

31+data Expr' def

14 = Literal Literal.Literal

32 = Literal Literal.Literal

15 | Var String

33 | Var String

16− | Range (LExpr t v) (LExpr t v)

34+ | Range (LExpr' def) (LExpr' def)

17− | ExplicitList [LExpr t v]

35+ | ExplicitList [LExpr' def]

18− | Binop String (LExpr t v) (LExpr t v)

36+ | Binop String (LExpr' def) (LExpr' def)

19− | Lambda Pattern.Pattern (LExpr t v)

37+ | Lambda Pattern.Pattern (LExpr' def)

20− | App (LExpr t v) (LExpr t v)

38+ | App (LExpr' def) (LExpr' def)

21− | MultiIf [(LExpr t v,LExpr t v)]

39+ | MultiIf [(LExpr' def,LExpr' def)]

22− | Let [Def t v] (LExpr t v)

40+ | Let [def] (LExpr' def)

23− | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]

41+ | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]

24− | Data String [LExpr t v]

42+ | Data String [LExpr' def]

25− | Access (LExpr t v) String

43+ | Access (LExpr' def) String

26− | Remove (LExpr t v) String

44+ | Remove (LExpr' def) String

27− | Insert (LExpr t v) String (LExpr t v)

45+ | Insert (LExpr' def) String (LExpr' def)

28− | Modify (LExpr t v) [(String, LExpr t v)]

46+ | Modify (LExpr' def) [(String, LExpr' def)]

29− | Record [(String, LExpr t v)]

47+ | Record [(String, LExpr' def)]

30− | Markdown String String [LExpr t v]

48+ | Markdown String String [LExpr' def]

49+ -- for type checking and code gen only

50+ | PortIn String SrcType.Type Type.Variable (LExpr' def)

51+ | PortOut String SrcType.Type (LExpr' def)

31 | GLShader String String

52 | GLShader String String

32− deriving (Eq)

33−

34−data Def tipe var

35− = Def Pattern.Pattern (LExpr tipe var)

36− | TypeAnnotation String Type.Type

37− deriving (Eq, Show)

38

53

54+type ParseExpr = Expr' ParseDef

55+type LParseExpr = LExpr' ParseDef

56+type LExpr = LExpr' Def

57+type Expr = Expr' Def

58+

59+{-| Style of definitions as they are parsed. Users specify them

60+separately, and other checks will make sure they can be combined.

61+-}

62+data ParseDef

63+ = Def Pattern.Pattern LParseExpr

64+ | TypeAnnotation String SrcType.Type

65+ deriving (Show)

66+

67+{-| After checking that type annotations and definitions are all

68+valid, they can be combined.

69+-}

70+data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)

71+ deriving (Show)

72+

73+tuple :: [LExpr' def] -> Expr' def

39tuple es = Data ("_Tuple" ++ show (length es)) es

74tuple es = Data ("_Tuple" ++ show (length es)) es

40

75

76+delist :: LExpr' def -> [LExpr' def]

41delist (Location.L _ (Data "::" [h,t])) = h : delist t

77delist (Location.L _ (Data "::" [h,t])) = h : delist t

42delist _ = []

78delist _ = []

43

79

80+saveEnvName :: String

44saveEnvName = "_save_the_environment!!!"

81saveEnvName = "_save_the_environment!!!"

45

82

83+dummyLet :: Pretty def => [def] -> LExpr' def

46dummyLet defs =

84dummyLet defs =

47 Location.none $ Let defs (Location.none $ Var saveEnvName)

85 Location.none $ Let defs (Location.none $ Var saveEnvName)

48

86

49−instance Show (Expr t v) where

87+instance Pretty def => Show (Expr' def) where

50 show = render . pretty

88 show = render . pretty

51

89

52−instance Pretty (Expr t v) where

90+instance Pretty def => Pretty (Expr' def) where

53 pretty expr =

91 pretty expr =

54 case expr of

92 case expr of

55 Literal lit -> pretty lit

93 Literal lit -> pretty lit

@@ -74,44 +112,61 @@ instance Pretty (Expr t v) where

74 P.hang pexpr 2 (P.vcat (map pretty' pats))

112 P.hang pexpr 2 (P.vcat (map pretty' pats))

75 where

113 where

76 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

114 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

77− pretty' (p,e) = pretty p <+> P.text "->" <+> pretty e

115+ pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

78 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

116 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

79 Data "[]" [] -> P.text "[]"

117 Data "[]" [] -> P.text "[]"

80 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

118 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

81 Access e x -> prettyParens e <> P.text "." <> variable x

119 Access e x -> prettyParens e <> P.text "." <> variable x

82 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)

120 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)

83 Insert (Location.L _ (Remove e y)) x v ->

121 Insert (Location.L _ (Remove e y)) x v ->

84− P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.text "=" <+> pretty v)

122+ P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)

85 Insert e x v ->

123 Insert e x v ->

86− P.braces (pretty e <+> P.text "|" <+> variable x <+> P.text "=" <+> pretty v)

124+ P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)

87

125

88 Modify e fs ->

126 Modify e fs ->

89 P.braces $ P.hang (pretty e <+> P.text "|")

127 P.braces $ P.hang (pretty e <+> P.text "|")

90 4

128 4

91 (commaSep $ map field fs)

129 (commaSep $ map field fs)

92 where

130 where

93− field (x,e) = variable x <+> P.text "<-" <+> pretty e

131+ field (k,v) = variable k <+> P.text "<-" <+> pretty v

94

132

95 Record fs ->

133 Record fs ->

96 P.braces $ P.nest 2 (commaSep $ map field fs)

134 P.braces $ P.nest 2 (commaSep $ map field fs)

97 where

135 where

98− field (x,e) = variable x <+> P.text "=" <+> pretty e

136+ field (x,e) = variable x <+> P.equals <+> pretty e

99

137

100 Markdown _ _ _ -> P.text "[markdown| ... |]"

138 Markdown _ _ _ -> P.text "[markdown| ... |]"

101

139

140+ GLShader _ _ -> P.text "[glShader| ... |]"

141+

142+ PortIn _ _ _ handler -> pretty handler

143+

144+ PortOut _ _ signal -> pretty signal

145+

102−instance Pretty (Def t v) where

146+instance Pretty ParseDef where

103 pretty def =

147 pretty def =

104 case def of

148 case def of

105 TypeAnnotation name tipe ->

149 TypeAnnotation name tipe ->

106− variable name <+> P.text ":" <+> pretty tipe

150+ variable name <+> P.colon <+> pretty tipe

107 Def pattern expr ->

151 Def pattern expr ->

108− pretty pattern <+> P.text "=" <+> pretty expr

152+ pretty pattern <+> P.equals <+> pretty expr

109−

153+

154+instance Pretty Def where

155+ pretty (Definition pattern expr maybeTipe) =

156+ P.vcat [ annotation, definition ]

157+ where

158+ definition = pretty pattern <+> P.equals <+> pretty expr

159+ annotation = case maybeTipe of

160+ Nothing -> P.empty

161+ Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

162+

163+collectApps :: LExpr' def -> [LExpr' def]

110collectApps lexpr@(Location.L _ expr) =

164collectApps lexpr@(Location.L _ expr) =

111 case expr of

165 case expr of

112 App a b -> collectApps a ++ [b]

166 App a b -> collectApps a ++ [b]

113 _ -> [lexpr]

167 _ -> [lexpr]

114

168

169+collectLambdas :: LExpr' def -> ([Doc], LExpr' def)

115collectLambdas lexpr@(Location.L _ expr) =

170collectLambdas lexpr@(Location.L _ expr) =

116 case expr of

171 case expr of

117 Lambda pattern body ->

172 Lambda pattern body ->

@@ -119,6 +174,7 @@ collectLambdas lexpr@(Location.L _ expr) =

119 in (pretty pattern : ps, body')

174 in (pretty pattern : ps, body')

120 _ -> ([], lexpr)

175 _ -> ([], lexpr)

121

176

177+prettyParens :: (Pretty def) => LExpr' def -> Doc

122prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

178prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

123 where

179 where

124 needed =

180 needed =

@@ -129,5 +185,5 @@ prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

129 MultiIf _ -> True

185 MultiIf _ -> True

130 Let _ _ -> True

186 Let _ _ -> True

131 Case _ _ -> True

187 Case _ _ -> True

132− Data name (x:xs) -> name /= "::"

188+ Data name (_:_) -> name /= "::"

133 _ -> False

189 _ -> False

compiler/SourceSyntax/Helpers.hs+1−1

@@ -1,4 +1,4 @@

1−

1+{-# OPTIONS_GHC -Wall #-}

2module SourceSyntax.Helpers where

3

4import qualified Data.Char as Char

compiler/SourceSyntax/Literal.hs+1

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Literal where

2module SourceSyntax.Literal where

2

3

3import SourceSyntax.PrettyPrint

4import SourceSyntax.PrettyPrint

compiler/SourceSyntax/Module.hs+28−43

@@ -1,21 +1,18 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Module where

2module SourceSyntax.Module where

2

3

3import Data.Binary

4import Data.Binary

4−import Data.List (intercalate)

5import qualified Data.Map as Map

6import Control.Applicative ((<$>), (<*>))

7−import Control.Arrow (second)

8

7

9import SourceSyntax.Expression (LExpr)

8import SourceSyntax.Expression (LExpr)

10import SourceSyntax.Declaration

9import SourceSyntax.Declaration

11import SourceSyntax.Type

10import SourceSyntax.Type

12−import System.FilePath (joinPath)

13−import Control.Monad (liftM)

14

11

15import qualified Elm.Internal.Version as Version

12import qualified Elm.Internal.Version as Version

16

13

17−data Module tipe var =

14+data Module def =

18− Module [String] Exports Imports [Declaration tipe var]

15+ Module [String] Exports Imports [def]

19 deriving (Show)

16 deriving (Show)

20

17

21type Exports = [String]

18type Exports = [String]

@@ -25,48 +22,47 @@ data ImportMethod = As String | Importing [String] | Hiding [String]

25 deriving (Eq, Ord, Show)

22 deriving (Eq, Ord, Show)

26

23

27instance Binary ImportMethod where

24instance Binary ImportMethod where

25+ put method =

26+ let put' n info = putWord8 n >> put info in

27+ case method of

28− put (As s) = do put (0 :: Word8)

28+ As s -> put' 0 s

29− put s

30−

31− put (Importing ss) = do put (1 :: Word8)

29+ Importing ss -> put' 1 ss

32− put ss

33−

34− put (Hiding ss) = do put (2 :: Word8)

30+ Hiding ss -> put' 2 ss

35− put ss

36

31

37 get = do tag <- getWord8

32 get = do tag <- getWord8

38 case tag of

33 case tag of

39− 0 -> liftM As get

34+ 0 -> As <$> get

40− 1 -> liftM Importing get

35+ 1 -> Importing <$> get

41− 2 -> liftM Hiding get

36+ 2 -> Hiding <$> get

42 _ -> error "Error reading valid ImportMethod type from serialized string"

37 _ -> error "Error reading valid ImportMethod type from serialized string"

43

38

44−data MetadataModule t v = MetadataModule {

39+data MetadataModule =

40+ MetadataModule

45− names :: [String],

41+ { names :: [String]

46− path :: FilePath,

42+ , path :: FilePath

47− exports :: [String],

43+ , exports :: [String]

48− imports :: [(String, ImportMethod)],

44+ , imports :: [(String, ImportMethod)]

49− program :: LExpr t v,

45+ , program :: LExpr

50− types :: Map.Map String Type,

46+ , types :: Map.Map String Type

51− fixities :: [(Assoc, Int, String)],

47+ , fixities :: [(Assoc, Int, String)]

52− aliases :: [(String, [String], Type)],

48+ , aliases :: [Alias]

53− datatypes :: [ (String, [String], [(String,[Type])]) ],

49+ , datatypes :: [ADT]

54− foreignImports :: [(String, LExpr t v, String, Type)],

55− foreignExports :: [(String, String, Type)]

56−} deriving Show

50+ } deriving Show

57

51

58type Interfaces = Map.Map String ModuleInterface

52type Interfaces = Map.Map String ModuleInterface

59−type ADT = (String, [String], [(String,[Type])])

53+type ADT = (String, [String], [(String,[Type])], [Derivation])

54+type Alias = (String, [String], Type, [Derivation])

60

55

61data ModuleInterface = ModuleInterface {

56data ModuleInterface = ModuleInterface {

62 iVersion :: Version.Version,

57 iVersion :: Version.Version,

63 iTypes :: Map.Map String Type,

58 iTypes :: Map.Map String Type,

64 iImports :: [(String, ImportMethod)],

59 iImports :: [(String, ImportMethod)],

65 iAdts :: [ADT],

60 iAdts :: [ADT],

66− iAliases :: [(String, [String], Type)],

61+ iAliases :: [Alias],

67 iFixities :: [(Assoc, Int, String)]

62 iFixities :: [(Assoc, Int, String)]

68} deriving Show

63} deriving Show

69

64

65+metaToInterface :: MetadataModule -> ModuleInterface

70metaToInterface metaModule =

66metaToInterface metaModule =

71 ModuleInterface

67 ModuleInterface

72 { iVersion = Version.elmVersion

68 { iVersion = Version.elmVersion

@@ -86,14 +82,3 @@ instance Binary ModuleInterface where

86 put (iAdts modul)

82 put (iAdts modul)

87 put (iAliases modul)

83 put (iAliases modul)

88 put (iFixities modul)

84 put (iFixities modul)

89−

90−

91−instance Binary Assoc where

92− get = do n <- getWord8

93− return $ case n of

94− 0 -> L

95− 1 -> N

96− 2 -> R

97− _ -> error "Error reading valid associativity from serialized string"

98−

99− put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

compiler/SourceSyntax/Pattern.hs+21−2

@@ -1,9 +1,10 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Pattern where

2module SourceSyntax.Pattern where

2

3

3−import Data.List (intercalate)

4import SourceSyntax.Helpers as Help

5import SourceSyntax.PrettyPrint

6import Text.PrettyPrint as PP

7+import qualified Data.Set as Set

7import SourceSyntax.Literal as Literal

8import SourceSyntax.Literal as Literal

8

9

9data Pattern = PData String [Pattern]

10data Pattern = PData String [Pattern]

@@ -14,11 +15,28 @@ data Pattern = PData String [Pattern]

14 | PLiteral Literal.Literal

15 | PLiteral Literal.Literal

15 deriving (Eq, Ord, Show)

16 deriving (Eq, Ord, Show)

16

17

18+cons :: Pattern -> Pattern -> Pattern

17cons h t = PData "::" [h,t]

19cons h t = PData "::" [h,t]

20+

21+nil :: Pattern

18−nil = PData "[]" []

22+nil = PData "[]" []

23+

24+list :: [Pattern] -> Pattern

19list = foldr cons nil

25list = foldr cons nil

26+

27+tuple :: [Pattern] -> Pattern

20tuple es = PData ("_Tuple" ++ show (length es)) es

28tuple es = PData ("_Tuple" ++ show (length es)) es

21

29

30+boundVars :: Pattern -> Set.Set String

31+boundVars pattern =

32+ case pattern of

33+ PVar x -> Set.singleton x

34+ PAlias x p -> Set.insert x (boundVars p)

35+ PData _ ps -> Set.unions (map boundVars ps)

36+ PRecord fields -> Set.fromList fields

37+ PAnything -> Set.empty

38+ PLiteral _ -> Set.empty

39+

22

40

23instance Pretty Pattern where

41instance Pretty Pattern where

24 pretty pattern =

42 pretty pattern =

@@ -37,6 +55,7 @@ instance Pretty Pattern where

37 PP.parens . commaCat $ map pretty ps

55 PP.parens . commaCat $ map pretty ps

38 else hsep (PP.text name : map prettyParens ps)

56 else hsep (PP.text name : map prettyParens ps)

39

57

58+prettyParens :: Pattern -> Doc

40prettyParens pattern = parensIf needsThem (pretty pattern)

59prettyParens pattern = parensIf needsThem (pretty pattern)

41 where

60 where

42 needsThem =

61 needsThem =

compiler/SourceSyntax/Type.hs+5−1

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Type where

2module SourceSyntax.Type where

2

3

3import Data.Binary

4import Data.Binary

@@ -31,7 +32,7 @@ tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

31instance Pretty Type where

32instance Pretty Type where

32 pretty tipe =

33 pretty tipe =

33 case tipe of

34 case tipe of

34− Lambda t1 t2 -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

35+ Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

35 where t:ts = collectLambdas tipe

36 where t:ts = collectLambdas tipe

36 Var x -> P.text x

37 Var x -> P.text x

37 Data "_List" [t] -> P.brackets (pretty t)

38 Data "_List" [t] -> P.brackets (pretty t)

@@ -47,12 +48,14 @@ instance Pretty Type where

47 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

48 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

48 prettyFields = commaSep . map prettyField $ fields

49 prettyFields = commaSep . map prettyField $ fields

49

50

51+collectLambdas :: Type -> [Doc]

50collectLambdas tipe =

52collectLambdas tipe =

51 case tipe of

53 case tipe of

52 Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body

54 Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body

53 Lambda arg body -> pretty arg : collectLambdas body

55 Lambda arg body -> pretty arg : collectLambdas body

54 _ -> [pretty tipe]

56 _ -> [pretty tipe]

55

57

58+collectRecords :: Type -> ([(String,Type)], Type)

56collectRecords = go []

59collectRecords = go []

57 where

60 where

58 go fields tipe =

61 go fields tipe =

@@ -60,6 +63,7 @@ collectRecords = go []

60 Record fs ext -> go (fs ++ fields) ext

63 Record fs ext -> go (fs ++ fields) ext

61 _ -> (fields, tipe)

64 _ -> (fields, tipe)

62

65

66+prettyParens :: Type -> Doc

63prettyParens tipe = parensIf needed (pretty tipe)

67prettyParens tipe = parensIf needed (pretty tipe)

64 where

68 where

65 needed =

69 needed =

compiler/SourceSyntax/Variable.hsdeleted−2

@@ -1,2 +0,0 @@

1−module SourceSyntax.Variable where

2−

compiler/Transform/Canonicalize.hs+77−81

@@ -1,9 +1,8 @@

1−

1+{-# OPTIONS_GHC -W #-}

2−{-# OPTIONS -Wall #-}

3−

4module Transform.Canonicalize (interface, metadataModule) where

2module Transform.Canonicalize (interface, metadataModule) where

5

3

6import Control.Arrow ((***))

4import Control.Arrow ((***))

5+import Control.Applicative (Applicative,(<$>),(<*>))

7import Control.Monad.Identity

6import Control.Monad.Identity

8import qualified Data.Map as Map

7import qualified Data.Map as Map

9import qualified Data.Set as Set

8import qualified Data.Set as Set

@@ -12,10 +11,8 @@ import qualified Data.Either as Either

12import SourceSyntax.Module

11import SourceSyntax.Module

13import SourceSyntax.Expression

12import SourceSyntax.Expression

14import SourceSyntax.Location as Loc

13import SourceSyntax.Location as Loc

15−import SourceSyntax.Pattern

14+import qualified SourceSyntax.Pattern as P

16−import SourceSyntax.Helpers (isOp)

17import qualified SourceSyntax.Type as Type

15import qualified SourceSyntax.Type as Type

18−import qualified Transform.SortDefinitions as SD

19import Text.PrettyPrint as P

16import Text.PrettyPrint as P

20

17

21interface :: String -> ModuleInterface -> ModuleInterface

18interface :: String -> ModuleInterface -> ModuleInterface

@@ -29,11 +26,11 @@ interface moduleName iface =

29 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

26 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

30 }

27 }

31 where

28 where

32− both f g (a,b,c) = (f a, b, g c)

29+ both f g (a,b,c,d) = (f a, b, g c, d)

33 prefix name = moduleName ++ "." ++ name

30 prefix name = moduleName ++ "." ++ name

34

31

35 pair name = (name, moduleName ++ "." ++ name)

32 pair name = (name, moduleName ++ "." ++ name)

36− canon (name,_,_) = pair name

33+ canon (name,_,_,_) = pair name

37 canons = Map.fromList $ concat

34 canons = Map.fromList $ concat

38 [ map canon (iAdts iface), map canon (iAliases iface) ]

35 [ map canon (iAdts iface), map canon (iAliases iface) ]

39

36

@@ -42,48 +39,41 @@ interface moduleName iface =

42 renameType' =

39 renameType' =

43 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

40 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

44

41

45−renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type

42+renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

46−renameType rename tipe =

43+renameType renamer tipe =

47− let rnm = renameType rename in

44+ let rnm = renameType renamer in

48 case tipe of

45 case tipe of

49− Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b

46+ Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

50− Type.Var x -> return tipe

47+ Type.Var _ -> return tipe

51− Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts

48+ Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

52 Type.EmptyRecord -> return tipe

49 Type.EmptyRecord -> return tipe

53− Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext

50+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext

54− where rnm' (f,t) = (,) f `liftM` rnm t

51+ where rnm' (f,t) = (,) f <$> rnm t

55

52

56−metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)

53+metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

57metadataModule ifaces modul =

54metadataModule ifaces modul =

58− do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

55+ do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

59− [] -> Right ()

56+ [] -> Right ()

60− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

57+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

61 program' <- rename initialEnv (program modul)

58 program' <- rename initialEnv (program modul)

62− aliases' <- mapM (third renameType') (aliases modul)

59+ aliases' <- mapM (three4 renameType') (aliases modul)

63− datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)

60+ datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)

64− exports' <- mapM (third renameType') (foreignExports modul)

65− imports' <- mapM (twoAndFour (rename initialEnv) renameType') (foreignImports modul)

66 return $ modul { program = program'

61 return $ modul { program = program'

67 , aliases = aliases'

62 , aliases = aliases'

68− , datatypes = datatypes'

63+ , datatypes = datatypes' }

69− , foreignExports = exports'

70− , foreignImports = imports' }

71 where

64 where

72− second f (a,b) = (,) a `fmap` f b

65+ two2 f (a,b) = (,) a <$> f b

73− third f (a,b,c) = (,,) a b `fmap` f c

74− twoAndFour f g (a,b,c,d) = do b' <- f b

75− d' <- g d

76− return (a,b',c,d')

66+ three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d

77 renameType' =

67 renameType' =

78 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

68 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

79

69

80− get1 (a,_,_) = a

70+ get1 (a,_,_,_) = a

81 canon (name, importMethod) =

71 canon (name, importMethod) =

82 let pair pre var = (pre ++ drop (length name + 1) var, var)

72 let pair pre var = (pre ++ drop (length name + 1) var, var)

83 iface = ifaces Map.! name

73 iface = ifaces Map.! name

84 allNames = concat [ Map.keys (iTypes iface)

74 allNames = concat [ Map.keys (iTypes iface)

85 , map get1 (iAliases iface)

75 , map get1 (iAliases iface)

86− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

76+ , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]

87 in case importMethod of

77 in case importMethod of

88 As alias -> map (pair (alias ++ ".")) allNames

78 As alias -> map (pair (alias ++ ".")) allNames

89 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

79 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

@@ -91,18 +81,19 @@ metadataModule ifaces modul =

91 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

81 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

92 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

82 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

93

83

94− pair n = (n,n)

84+ two n = (n,n)

95− localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))

85+ localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))

86+ globalEnv =

96− globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

87+ map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

97− map (\n -> "_Tuple" ++ show n) [0..9]

88+ map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

98 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

89 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

99 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

90 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

100

91

101type Env = Map.Map String String

92type Env = Map.Map String String

102

93

103−extend :: Env -> Pattern -> Env

94+extend :: Env -> P.Pattern -> Env

104extend env pattern = Map.union (Map.fromList (zip xs xs)) env

95extend env pattern = Map.union (Map.fromList (zip xs xs)) env

105− where xs = Set.toList (SD.boundVars pattern)

96+ where xs = Set.toList (P.boundVars pattern)

106

97

107

98

108replace :: String -> Env -> String -> Either String String

99replace :: String -> Env -> String -> Either String String

@@ -116,77 +107,82 @@ replace variable env v =

116 msg = if null matches then "" else

107 msg = if null matches then "" else

117 "\nClose matches include: " ++ List.intercalate ", " matches

108 "\nClose matches include: " ++ List.intercalate ", " matches

118

109

119−rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)

110+rename :: Env -> LExpr -> Either [Doc] LExpr

120−rename env lexpr@(L s expr) =

111+rename env (L s expr) =

121 let rnm = rename env

112 let rnm = rename env

122 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

113 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

123 format = Either.either throw return

114 format = Either.either throw return

115+ renameType' env = renameType (format . replace "variable" env)

124 in

116 in

125− L s `liftM`

117+ L s <$>

126 case expr of

118 case expr of

127− Literal lit -> return expr

119+ Literal _ -> return expr

128

120

129− Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2

121+ Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

130

122

131− Access e x -> Access `liftM` rnm e `ap` return x

123+ Access e x -> Access <$> rnm e <*> return x

132

124

133− Remove e x -> flip Remove x `liftM` rnm e

125+ Remove e x -> flip Remove x <$> rnm e

134

126

135− Insert e x v -> flip Insert x `liftM` rnm e `ap` rnm v

127+ Insert e x v -> flip Insert x <$> rnm e <*> rnm v

136

128

137 Modify e fs ->

129 Modify e fs ->

138− Modify `liftM` rnm e `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs

130+ Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs

139

131

140− Record fs -> Record `liftM` mapM frnm fs

132+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs

141− where

142− frnm (f,e) = (,) f `liftM` rename env e

143

133

144 Binop op e1 e2 ->

134 Binop op e1 e2 ->

145 do op' <- format (replace "variable" env op)

135 do op' <- format (replace "variable" env op)

146− Binop op' `liftM` rnm e1 `ap` rnm e2

136+ Binop op' <$> rnm e1 <*> rnm e2

147

137

148 Lambda pattern e ->

138 Lambda pattern e ->

149 let env' = extend env pattern in

139 let env' = extend env pattern in

150− Lambda `liftM` format (renamePattern env' pattern) `ap` rename env' e

140+ Lambda <$> format (renamePattern env' pattern) <*> rename env' e

151

141

152− App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2

142+ App e1 e2 -> App <$> rnm e1 <*> rnm e2

153

143

154− MultiIf ps -> MultiIf `liftM` mapM grnm ps

144+ MultiIf ps -> MultiIf <$> mapM grnm ps

155− where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e

145+ where grnm (b,e) = (,) <$> rnm b <*> rnm e

156

146

157− Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e

147+ Let defs e -> Let <$> mapM rename' defs <*> rename env' e

158 where

148 where

159− env' = foldl extend env [ pattern | Def pattern _ <- defs ]

149+ env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

160− rename' def =

150+ rename' (Definition p body mtipe) =

151+ Definition <$> format (renamePattern env' p)

152+ <*> rename env' body

161− case def of

153+ <*> case mtipe of

162− Def p exp ->

154+ Nothing -> return Nothing

163− Def `liftM` format (renamePattern env' p) `ap` rename env' exp

164− TypeAnnotation name tipe ->

165− TypeAnnotation name `liftM`

166− renameType (format . replace "variable" env') tipe

155+ Just tipe -> Just <$> renameType' env' tipe

167

156

168− Var x -> Var `liftM` format (replace "variable" env x)

157+ Var x -> Var <$> format (replace "variable" env x)

169

158

170− Data name es -> Data name `liftM` mapM rnm es

159+ Data name es -> Data name <$> mapM rnm es

171

160

172− ExplicitList es -> ExplicitList `liftM` mapM rnm es

161+ ExplicitList es -> ExplicitList <$> mapM rnm es

173

162

174− Case e cases -> Case `liftM` rnm e `ap` mapM branch cases

163+ Case e cases -> Case <$> rnm e <*> mapM branch cases

175 where

164 where

176− branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)

165+ branch (pattern,b) = (,) <$> format (renamePattern env pattern)

177− `ap` rename (extend env pattern) e

166+ <*> rename (extend env pattern) b

167+

168+ Markdown uid md es -> Markdown uid md <$> mapM rnm es

169+

170+ PortIn name st tt handler ->

171+ do st' <- renameType' env st

172+ handler' <- rnm handler

173+ return $ PortIn name st' tt handler'

178

174

179− Markdown uid md es -> Markdown uid md `liftM` mapM rnm es

175+ PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

180

176

181 GLShader _ _ -> return expr

177 GLShader _ _ -> return expr

182

178

183−renamePattern :: Env -> Pattern -> Either String Pattern

179+renamePattern :: Env -> P.Pattern -> Either String P.Pattern

184renamePattern env pattern =

180renamePattern env pattern =

185 case pattern of

181 case pattern of

186− PVar _ -> return pattern

182+ P.PVar _ -> return pattern

187− PLiteral _ -> return pattern

183+ P.PLiteral _ -> return pattern

188− PRecord _ -> return pattern

184+ P.PRecord _ -> return pattern

189− PAnything -> return pattern

185+ P.PAnything -> return pattern

190− PAlias x p -> PAlias x `liftM` renamePattern env p

186+ P.PAlias x p -> P.PAlias x <$> renamePattern env p

191− PData name ps -> PData `liftM` replace "pattern" env name

187+ P.PData name ps -> P.PData <$> replace "pattern" env name

192− `ap` mapM (renamePattern env) ps

188+ <*> mapM (renamePattern env) ps

compiler/Transform/Check.hs+81−86

@@ -1,106 +1,99 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Transform.Check (mistakes) where

2module Transform.Check (mistakes) where

2

3

3−import Transform.SortDefinitions (boundVars)

4−import SourceSyntax.Declaration (Declaration(..))

5−import SourceSyntax.Expression

6−import SourceSyntax.Pattern

7−import SourceSyntax.Location

8−import SourceSyntax.PrettyPrint

9−import qualified SourceSyntax.Type as T

10−import Data.List as List

4+import qualified Data.List as List

11−import qualified Data.Map as Map

12import qualified Data.Maybe as Maybe

5import qualified Data.Maybe as Maybe

13import qualified Data.Set as Set

6import qualified Data.Set as Set

7+

8+import qualified SourceSyntax.Expression as E

9+import qualified SourceSyntax.Declaration as D

10+import qualified SourceSyntax.Pattern as Pattern

11+import qualified SourceSyntax.Type as T

12+import qualified Transform.Expression as Expr

13+

14+import SourceSyntax.PrettyPrint

14import Text.PrettyPrint as P

15import Text.PrettyPrint as P

15

16

17

17−mistakes :: [Declaration t v] -> [Doc]

18+mistakes :: [D.Declaration] -> [Doc]

18mistakes decls =

19mistakes decls =

19 concat [ infiniteTypeAliases decls

20 concat [ infiniteTypeAliases decls

20 , illFormedTypes decls

21 , illFormedTypes decls

21 , map P.text (duplicateConstructors decls)

22 , map P.text (duplicateConstructors decls)

22− , map P.text (concatMap findErrors (getLets decls)) ]

23+ , map P.text (duplicates decls)

23− where

24+ , badDerivations decls ]

24− findErrors defs = duplicates defs ++ badOrder defs

25

26−getLets :: [Declaration t v] -> [[Def t v]]

27−getLets decls = defs : concatMap defLets defs

28− where

29− defs = [ d | Definition d <- decls ]

30−

31− defLets def =

32− case def of

33− TypeAnnotation _ _ -> []

34− Def _ expr -> exprLets expr

35−

36− exprLets (L _ expr) =

37− case expr of

38− Var _ -> []

39− Lambda p e -> exprLets e

40− Binop op e1 e2 -> exprLets e1 ++ exprLets e2

41− Case e cases -> exprLets e ++ concatMap (exprLets . snd) cases

42− Data name es -> concatMap exprLets es

43− Literal _ -> []

44− Range e1 e2 -> exprLets e1 ++ exprLets e2

45− ExplicitList es -> concatMap exprLets es

46− App e1 e2 -> exprLets e1 ++ exprLets e2

47− MultiIf branches -> concatMap (\(b,e) -> exprLets b ++ exprLets e) branches

48− Access e lbl -> exprLets e

49− Remove e lbl -> exprLets e

50− Insert e lbl v -> exprLets e ++ exprLets v

51− Modify e fields -> exprLets e ++ concatMap (exprLets . snd) fields

52− Record fields -> concatMap (exprLets . snd) fields

53− Markdown uid md es -> []

54− Let defs body -> [defs] ++ exprLets body

55−

56−dups :: Eq a => [a] -> [a]

26+dups :: Ord a => [a] -> [a]

57−dups = map head . filter ((>1) . length) . List.group

27+dups = map head . filter ((>1) . length) . List.group . List.sort

58

28

59dupErr :: String -> String -> String

29dupErr :: String -> String -> String

60dupErr err x =

30dupErr err x =

61 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

31 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

62

32

63−duplicates :: [Def t v] -> [String]

33+duplicates :: [D.Declaration] -> [String]

64−duplicates defs =

34+duplicates decls =

65− map defMsg (dups definitions) ++ map annMsg (dups annotations)

35+ map msg (dups (portNames ++ concatMap getNames defPatterns)) ++

66− where

36+ case mapM exprDups (portExprs ++ defExprs) of

67− annotations = List.sort [ name | TypeAnnotation name _ <- defs ]

37+ Left name -> [msg name]

68− definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]

38+ Right _ -> []

69− defMsg = dupErr "definition of"

70− annMsg = dupErr "type annotation for"

71

39

72−duplicateConstructors :: [Declaration t v] -> [String]

73−duplicateConstructors decls =

74− map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

75 where

40 where

76− typeCtors = List.sort [ name | Datatype name _ _ <- decls ]

41+ msg = dupErr "definition of"

77− dataCtors = List.sort . concat $

78− [ map fst patterns | Datatype _ _ patterns <- decls ]

79− dataMsg = dupErr "definition of data constructor"

80− typeMsg = dupErr "definition of type constructor"

81−

82−badOrder :: [Def t v] -> [String]

83−badOrder defs = go defs

84− where

85− msg x = "Syntax Error: The type annotation for '" ++ x ++

86− "' must be directly above its definition."

87

42

88− go defs =

43+ (defPatterns, defExprs) =

89− case defs of

44+ unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

90− TypeAnnotation name _ : Def (PVar name') _ : rest

91− | name == name' -> go rest

92

45

93− TypeAnnotation name _ : rest -> [msg name] ++ go rest

46+ (portNames, portExprs) =

47+ unzip $ flip map [ port | D.Port port <- decls ] $ \port ->

48+ case port of

49+ D.Send name expr _ -> (name,expr)

50+ D.Recv name expr _ -> (name,expr)

94

51

95− _ : rest -> go rest

52+ getNames = Set.toList . Pattern.boundVars

96

53

54+ exprDups :: E.LExpr -> Either String E.LExpr

55+ exprDups expr = Expr.crawlLet defsDups expr

56+

57+ defsDups :: [E.Def] -> Either String [E.Def]

58+ defsDups defs =

59+ case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of

60+ [] -> Right defs

61+ name:_ -> Left name

62+

63+duplicateConstructors :: [D.Declaration] -> [String]

64+duplicateConstructors decls =

65+ map (dupErr "definition of type constructor") (dups typeCtors) ++

66+ map (dupErr "definition of data constructor") (dups dataCtors)

67+ where

68+ typeCtors = [ name | D.Datatype name _ _ _ <- decls ]

69+ dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]

70+

71+badDerivations :: [D.Declaration] -> [Doc]

72+badDerivations decls = concatMap badDerivation derivations

73+ where

74+ derivations =

75+ [ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++

76+ [ (decl, tvars, derives) | decl@(D.Datatype _ tvars _ derives) <- decls ]

77+

78+ badDerivation (decl, tvars, derives) =

79+ case (tvars, derives) of

80+ (_:_, _)

81+ | D.Json `elem` derives -> [report decl D.Json]

82+ | D.Binary `elem` derives -> [report decl D.Binary]

97 _ -> []

83 _ -> []

98

84

85+ report decl derive =

86+ P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."

87+ , P.text "Make sure all type variables are replaced with concrete types:"

88+ , P.text "\n"

89+ , nest 4 (pretty decl)

90+ ]

91+

99−illFormedTypes :: [Declaration t v] -> [Doc]

92+illFormedTypes :: [D.Declaration] -> [Doc]

100illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

93illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

101 where

94 where

102− aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]

95+ aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]

103− adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]

96+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]

104

97

105 freeVars tipe =

98 freeVars tipe =

106 case tipe of

99 case tipe of

@@ -132,7 +125,7 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

132

125

133 addCommas xs

126 addCommas xs

134 | length xs < 3 = concat xs

127 | length xs < 3 = concat xs

135− | otherwise = intercalate "," xs

128+ | otherwise = List.intercalate "," xs

136

129

137 addAnd xs

130 addAnd xs

138 | length xs < 2 = xs

131 | length xs < 2 = xs

@@ -141,12 +134,13 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

141 quote tvar = "'" ++ tvar ++ "'"

134 quote tvar = "'" ++ tvar ++ "'"

142

135

143

136

144−infiniteTypeAliases :: [Declaration t v] -> [Doc]

137+infiniteTypeAliases :: [D.Declaration] -> [Doc]

145infiniteTypeAliases decls =

138infiniteTypeAliases decls =

146− [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]

139+ [ report name tvars tipe ds | D.TypeAlias name tvars tipe ds <- decls

140+ , infiniteType name tipe ]

147 where

141 where

148− isInfinite name tipe =

142+ infiniteType name tipe =

149− let infinite = isInfinite name in

143+ let infinite = infiniteType name in

150 case tipe of

144 case tipe of

151 T.Lambda a b -> infinite a || infinite b

145 T.Lambda a b -> infinite a || infinite b

152 T.Var _ -> False

146 T.Var _ -> False

@@ -154,16 +148,17 @@ infiniteTypeAliases decls =

154 T.EmptyRecord -> False

148 T.EmptyRecord -> False

155 T.Record fields ext -> infinite ext || any (infinite . snd) fields

149 T.Record fields ext -> infinite ext || any (infinite . snd) fields

156

150

151+ indented :: D.Declaration -> Doc

152+ indented decl = P.text "\n " <> pretty decl <> P.text "\n"

153+

157− report decl@(TypeAlias name args tipe) =

154+ report name args tipe derivations =

158 P.vcat [ P.text $ eightyCharLines 0 msg1

155 P.vcat [ P.text $ eightyCharLines 0 msg1

159− , indented decl

156+ , indented $ D.TypeAlias name args tipe derivations

160 , P.text $ eightyCharLines 0 msg2

157 , P.text $ eightyCharLines 0 msg2

161− , indented (Datatype name args [(name,[tipe])])

158+ , indented $ D.Datatype name args [(name,[tipe])] derivations

162 , P.text $ eightyCharLines 0 msg3 ++ "\n"

159 , P.text $ eightyCharLines 0 msg3 ++ "\n"

163 ]

160 ]

164 where

161 where

165− indented decl = P.text "\n " <> pretty decl <> P.text "\n"

166−

167 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++

162 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++

168 "Notice that it appears in its own definition, so when \

163 "Notice that it appears in its own definition, so when \

169 \you expand it, it just keeps getting bigger:"

164 \you expand it, it just keeps getting bigger:"

compiler/Transform/Declaration.hsnew file+67

@@ -0,0 +1,67 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Declaration where

3+

4+import Control.Applicative ((<$>))

5+import qualified SourceSyntax.Pattern as P

6+import SourceSyntax.Expression as E

7+import SourceSyntax.Declaration as D

8+

9+import qualified Transform.Expression as Expr

10+import qualified Transform.Definition as Def

11+

12+

13+combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]

14+combineAnnotations = go

15+ where

16+ msg x = "Syntax Error: The type annotation for '" ++ x ++

17+ "' must be directly above its definition."

18+

19+ exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations

20+

21+ go decls =

22+ case decls of

23+ -- simple cases, pass them through with no changes

24+ [] -> return []

25+

26+ Datatype name tvars ctors ds : rest ->

27+ (:) (Datatype name tvars ctors ds) <$> go rest

28+

29+ TypeAlias name tvars alias ds : rest ->

30+ (:) (TypeAlias name tvars alias ds) <$> go rest

31+

32+ Fixity assoc prec op : rest ->

33+ (:) (Fixity assoc prec op) <$> go rest

34+

35+ -- combine definitions

36+ D.Definition def : defRest ->

37+ case def of

38+ Def pat expr ->

39+ do expr' <- exprCombineAnnotations expr

40+ let def' = E.Definition pat expr' Nothing

41+ (:) (D.Definition def') <$> go defRest

42+

43+ TypeAnnotation name tipe ->

44+ case defRest of

45+ D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->

46+ do expr' <- exprCombineAnnotations expr

47+ let def' = E.Definition pat expr' (Just tipe)

48+ (:) (D.Definition def') <$> go rest

49+

50+ _ -> Left (msg name)

51+

52+ -- combine ports

53+ Port port : portRest ->

54+ case port of

55+ SendDefinition name _ -> Left (msg name)

56+ RecvDefinition name _ -> Left (msg name)

57+ PortAnnotation name tipe ->

58+ case portRest of

59+ Port (SendDefinition name' expr) : rest | name == name' ->

60+ do expr' <- exprCombineAnnotations expr

61+ (:) (Port (Send name expr' tipe)) <$> go rest

62+

63+ Port (RecvDefinition name' expr) : rest | name == name' ->

64+ do expr' <- exprCombineAnnotations expr

65+ (:) (Port (Recv name expr' tipe)) <$> go rest

66+

67+ _ -> Left (msg name)

compiler/Transform/Definition.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Definition where

3+

4+import Control.Applicative ((<$>))

5+import qualified SourceSyntax.Pattern as P

6+import SourceSyntax.Expression

7+import qualified Transform.Expression as Expr

8+

9+combineAnnotations :: [ParseDef] -> Either String [Def]

10+combineAnnotations = go

11+ where

12+ msg x = "Syntax Error: The type annotation for '" ++ x ++

13+ "' must be directly above its definition."

14+

15+ exprCombineAnnotations = Expr.crawlLet combineAnnotations

16+

17+ go defs =

18+ case defs of

19+ TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->

20+ do expr' <- exprCombineAnnotations expr

21+ let def = Definition pat expr' (Just tipe)

22+ (:) def <$> go rest

23+

24+ TypeAnnotation name _ : _ -> Left (msg name)

25+

26+ Def pat expr : rest ->

27+ do expr' <- exprCombineAnnotations expr

28+ let def = Definition pat expr' Nothing

29+ (:) def <$> go rest

30+

31+ [] -> return []

compiler/Transform/Expression.hsnew file+57

@@ -0,0 +1,57 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Expression (crawlLet, checkPorts) where

3+

4+import Control.Applicative ((<$>),(<*>))

5+import SourceSyntax.Expression

6+import SourceSyntax.Location

7+import qualified SourceSyntax.Type as ST

8+import qualified Type.Type as TT

9+

10+crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')

11+crawlLet = crawl (\_ _ _ -> return ()) (\_ _ -> return ())

12+

13+checkPorts :: (String -> ST.Type -> TT.Variable -> Either a ())

14+ -> (String -> ST.Type -> Either a ())

15+ -> LExpr

16+ -> Either a LExpr

17+checkPorts inCheck outCheck expr =

18+ crawl inCheck outCheck (mapM checkDef) expr

19+ where

20+ checkDef def@(Definition _ body _) =

21+ do _ <- checkPorts inCheck outCheck body

22+ return def

23+

24+crawl :: (String -> ST.Type -> TT.Variable -> Either a ())

25+ -> (String -> ST.Type -> Either a ())

26+ -> ([def] -> Either a [def'])

27+ -> LExpr' def

28+ -> Either a (LExpr' def')

29+crawl portInCheck portOutCheck defsTransform = go

30+ where

31+ go (L srcSpan expr) =

32+ L srcSpan <$>

33+ case expr of

34+ Var x -> return (Var x)

35+ Lambda p e -> Lambda p <$> go e

36+ Binop op e1 e2 -> Binop op <$> go e1 <*> go e2

37+ Case e cases -> Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases

38+ Data name es -> Data name <$> mapM go es

39+ Literal lit -> return (Literal lit)

40+ Range e1 e2 -> Range <$> go e1 <*> go e2

41+ ExplicitList es -> ExplicitList <$> mapM go es

42+ App e1 e2 -> App <$> go e1 <*> go e2

43+ MultiIf branches -> MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches

44+ Access e lbl -> Access <$> go e <*> return lbl

45+ Remove e lbl -> Remove <$> go e <*> return lbl

46+ Insert e lbl v -> Insert <$> go e <*> return lbl <*> go v

47+ Modify e fields -> Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields

48+ Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields

49+ Markdown uid md es -> Markdown uid md <$> mapM go es

50+ Let defs body -> Let <$> defsTransform defs <*> go body

51+ GLShader uid src -> return (GLShader uid src)

52+ PortIn name st tt handler ->

53+ do portInCheck name st tt

54+ PortIn name st tt <$> go handler

55+ PortOut name st signal ->

56+ do portOutCheck name st

57+ PortOut name st <$> go signal

compiler/Transform/Optimize.hsdeleted−136

@@ -1,136 +0,0 @@

1−module Transform.Optimize (optimize) where

2−

3−import SourceSyntax.Declaration (Declaration(..))

4−import SourceSyntax.Expression

5−import SourceSyntax.Literal

6−import SourceSyntax.Location

7−import SourceSyntax.Module

8−import Control.Arrow (second, (***))

9−import Data.Char (isAlpha)

10−

11−optimize (Module name ims exs stmts) =

12− Module name ims exs (map optimizeStmt stmts)

13−

14−optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'

15− where stmt' = simp stmt

16−

17−class Simplify a where

18− simp :: a -> a

19−

20−instance Simplify (Declaration t v) where

21− simp (Definition def) = Definition (simp def)

22− simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t

23− simp stmt = stmt

24−

25−instance Simplify (Def t v) where

26− simp (Def name e) = Def name (simp e)

27− simp x = x

28−

29−instance Simplify e => Simplify (Located e) where

30− simp (L s e) = L s (simp e)

31−

32−instance Simplify (Expr t v) where

33− simp expr =

34− let f = simp in

35− case expr of

36− Range e1 e2 -> Range (f e1) (f e2)

37− Binop op e1 e2 -> binop op (f e1) (f e2)

38− Lambda x e -> Lambda x (f e)

39− Record fs -> Record (map (second simp) fs)

40− App e1 e2 -> App (f e1) (f e2)

41− Let defs e -> Let (map simp defs) (f e)

42− Data name es -> Data name (map f es)

43− MultiIf es -> MultiIf . clipBranches $ map (f *** f) es

44− Case e cases -> Case (f e) (map (second f) cases)

45− _ -> expr

46−

47−

48−clipBranches [] = []

49−clipBranches (e:es) =

50− case e of

51− (L _ (Literal (Boolean True)), _) -> [e]

52− _ -> e : clipBranches es

53−

54−

55−isValue e =

56− case e of

57− Literal _ -> True

58− Var _ -> True

59− Data _ _ -> True

60− _ -> False

61−

62−

63−binop op ce1@(L s1 e1) ce2@(L s2 e2) =

64− let c1 = L s1

65− c2 = L s2

66− int = Literal . IntNum

67− str = Literal . Str

68− bool = Literal . Boolean

69− in

70− case (op, e1, e2) of

71− (_, Literal (IntNum n), Literal (IntNum m)) ->

72− case op of

73− { "+" -> int $ (+) n m

74− ; "-" -> int $ (-) n m

75− ; "*" -> int $ (*) n m

76− ; "^" -> int $ n ^ m

77− ; "div" -> int $ div n m

78− ; "mod" -> int $ mod n m

79− ; "rem" -> int $ rem n m

80− ; "<" -> bool $ n < m

81− ; ">" -> bool $ n > m

82− ; "<=" -> bool $ n <= m

83− ; ">=" -> bool $ n >= m

84− ; "==" -> bool $ n == m

85− ; "/=" -> bool $ n /= m

86− ; _ -> Binop op ce1 ce2 }

87− {--

88− -- flip order to move lone integers to the left

89− ("+", _, IntNum n) -> binop "+" ce2 ce1

90− ("*", _, IntNum n) -> binop "*" ce2 ce1

91−

92− ("+", IntNum 0, _) -> e2

93− ("+", IntNum n, Binop "+" (L _ (IntNum m)) ce) ->

94− binop "+" (c1 $ IntNum (n+m)) ce

95− ("+", Binop "+" (L _ (IntNum n)) ce1'

96− , Binop "+" (L _ (IntNum m)) ce2') ->

97− binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')

98−

99− ("*", IntNum 0, _) -> e1

100− ("*", IntNum 1, _) -> e2

101− ("*", IntNum n, Binop "*" (L _ (IntNum m)) ce) ->

102− binop "*" (none $ IntNum (n*m)) ce

103− ("*", Binop "*" (L _ (IntNum n)) ce1'

104− , Binop "*" (L _ (IntNum m)) ce2') ->

105− binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')

106−

107− ("-", _, IntNum 0) -> e1

108− ("/", _, IntNum 1) -> e1

109− ("div", _, IntNum 1) -> e1

110−--}

111− (_, Literal (Boolean n), Literal (Boolean m)) ->

112− case op of

113− "&&" -> bool $ n && m

114− "||" -> bool $ n || m

115− _ -> Binop op ce1 ce2

116−

117− ("&&", Literal (Boolean True), _) -> e2

118− ("&&", Literal (Boolean False), _) -> bool False

119− ("||", Literal (Boolean True), _) -> bool True

120− ("||", Literal (Boolean False), _) -> e2

121−

122− ("::", _, _) -> Data "::" [ce1, ce2]

123−

124− ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2

125− ("++", Literal (Str s1), Binop "++" (L _ (Literal (Str s2))) ce) ->

126− Binop "++" (c1 . str $ s1 ++ s2) ce

127− ("++", Binop "++" e (L _ (Literal (Str s1))), Literal (Str s2)) ->

128− Binop "++" e (c1 . str $ s1 ++ s2)

129−

130− ("++", Data "[]" [], _) -> e2

131− ("++", _, Data "[]" []) -> e1

132− ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]

133−

134− _ | isAlpha (head op) || '_' == head op ->

135− App (none $ App (none $ Var op) ce1) ce2

136− | otherwise -> Binop op ce1 ce2

compiler/Transform/SafeNames.hs+11−16

@@ -27,7 +27,7 @@ pattern pat =

27 PAlias x p -> PAlias (var x) (pattern p)

28 PData name ps -> PData name (map pattern ps)

29

30−expression :: LExpr t v -> LExpr t v

30+expression :: LExpr -> LExpr

31expression (L loc expr) =

32 let f = expression in

33 L loc $

@@ -49,14 +49,15 @@ expression (L loc expr) =

49 Modify r fs -> Modify (f r) (map (var *** f) fs)

50 Record fs -> Record (map (var *** f) fs)

51 Markdown uid md es -> Markdown uid md (map f es)

52+ GLShader _ _ -> expr

53+ PortIn name st tt handler -> PortIn name st tt (f handler)

54+ PortOut name st signal -> PortOut name st (f signal)

52

55

53−definition :: Def t v -> Def t v

56+definition :: Def -> Def

54−definition def =

57+definition (Definition p e t) =

55− case def of

56− Def p e -> Def (pattern p) (expression e)

58+ Definition (pattern p) (expression e) t

57− TypeAnnotation name t -> TypeAnnotation (var name) t

58

59

59−metadataModule :: MetadataModule t v -> MetadataModule t v

60+metadataModule :: MetadataModule -> MetadataModule

60metadataModule modul =

61metadataModule modul =

61 modul

62 modul

62 { names = map var (names modul)

63 { names = map var (names modul)

@@ -64,15 +65,9 @@ metadataModule modul =

64 , imports = map (first var) (imports modul)

65 , imports = map (first var) (imports modul)

65 , program = expression (program modul)

66 , program = expression (program modul)

66 , aliases =

67 , aliases =

67− let makeSafe (name, tvars, tipe) = (var name, tvars, tipe)

68+ let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)

68 in map makeSafe (aliases modul)

69 in map makeSafe (aliases modul)

69 , datatypes =

70 , datatypes =

70− let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)

71+ let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)

71 in map makeSafe (datatypes modul)

72 in map makeSafe (datatypes modul)

72− , foreignImports =

73− let makeSafe (js,expr,elm,tipe) = (js, expression expr, var elm, tipe)

74− in map makeSafe (foreignImports modul)

75− , foreignExports =

76− let makeSafe (js,elm,tipe) = (js, var elm, tipe)

77− in map makeSafe (foreignExports modul)

78− }

73+ }

compiler/Transform/SortDefinitions.hs+50−104

@@ -1,39 +1,25 @@

1−

1+{-# OPTIONS_GHC -Wall #-}

2−{-# OPTIONS -Wall #-}

3−

4−module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where

2+module Transform.SortDefinitions (sortDefs) where

5

3

6import Control.Monad.State

4import Control.Monad.State

7−import Control.Applicative ((<$>))

5+import Control.Applicative ((<$>),(<*>))

8−import qualified Data.Set as Set

9import qualified Data.Map as Map

6import qualified Data.Map as Map

10−import qualified SourceSyntax.Type as ST

11import SourceSyntax.Expression

7import SourceSyntax.Expression

12import SourceSyntax.Location

8import SourceSyntax.Location

13−import SourceSyntax.Pattern

9+import qualified SourceSyntax.Pattern as P

14import qualified Data.Graph as Graph

10import qualified Data.Graph as Graph

15−import qualified Data.Map as Map

11+import qualified Data.Set as Set

16import qualified Data.Maybe as Maybe

12import qualified Data.Maybe as Maybe

17

13

18−boundVars :: Pattern -> Set.Set String

19−boundVars pattern =

20− case pattern of

21− PVar x -> Set.singleton x

22− PAlias x p -> Set.insert x (boundVars p)

23− PData _ ps -> Set.unions (map boundVars ps)

24− PRecord fields -> Set.fromList fields

25− PAnything -> Set.empty

26− PLiteral _ -> Set.empty

27−

28−ctors :: Pattern -> [String]

14+ctors :: P.Pattern -> [String]

29ctors pattern =

15ctors pattern =

30 case pattern of

16 case pattern of

31− PVar x -> []

17+ P.PVar _ -> []

32− PAlias x p -> ctors p

18+ P.PAlias _ p -> ctors p

33− PData ctor ps -> ctor : concatMap ctors ps

19+ P.PData ctor ps -> ctor : concatMap ctors ps

34− PRecord fields -> []

20+ P.PRecord _ -> []

35− PAnything -> []

21+ P.PAnything -> []

36− PLiteral _ -> []

22+ P.PLiteral _ -> []

37

23

38free :: String -> State (Set.Set String) ()

24free :: String -> State (Set.Set String) ()

39free x = modify (Set.insert x)

25free x = modify (Set.insert x)

@@ -41,70 +27,68 @@ free x = modify (Set.insert x)

41bound :: Set.Set String -> State (Set.Set String) ()

27bound :: Set.Set String -> State (Set.Set String) ()

42bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

28bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

43

29

44−sortDefs :: LExpr t v -> LExpr t v

30+sortDefs :: LExpr -> LExpr

45sortDefs expr = evalState (reorder expr) Set.empty

31sortDefs expr = evalState (reorder expr) Set.empty

46

32

47−flattenLets defs lexpr@(L _ expr) =

48− case expr of

49− Let ds body -> flattenLets (defs ++ ds) body

50− _ -> (defs, lexpr)

51−

52−

53−reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)

33+reorder :: LExpr -> State (Set.Set String) LExpr

54−reorder lexpr@(L s expr) =

34+reorder (L s expr) =

55− L s `liftM`

35+ L s <$>

56 case expr of

36 case expr of

57 -- Be careful adding and restricting freeVars

37 -- Be careful adding and restricting freeVars

58 Var x -> free x >> return expr

38 Var x -> free x >> return expr

59

39

60 Lambda p e ->

40 Lambda p e ->

61− uncurry Lambda `liftM` bindingReorder (p,e)

41+ uncurry Lambda <$> bindingReorder (p,e)

62

42

63 Binop op e1 e2 ->

43 Binop op e1 e2 ->

64 do free op

44 do free op

65− Binop op `liftM` reorder e1 `ap` reorder e2

45+ Binop op <$> reorder e1 <*> reorder e2

66

46

67 Case e cases ->

47 Case e cases ->

68− Case `liftM` reorder e `ap` mapM bindingReorder cases

48+ Case <$> reorder e <*> mapM bindingReorder cases

69

49

70 Data name es ->

50 Data name es ->

71 do free name

51 do free name

72− Data name `liftM` mapM reorder es

52+ Data name <$> mapM reorder es

73

53

74 -- Just pipe the reorder though

54 -- Just pipe the reorder though

75 Literal _ -> return expr

55 Literal _ -> return expr

76

56

77 Range e1 e2 ->

57 Range e1 e2 ->

78− Range `liftM` reorder e1 `ap` reorder e2

58+ Range <$> reorder e1 <*> reorder e2

79

59

80 ExplicitList es ->

60 ExplicitList es ->

81− ExplicitList `liftM` mapM reorder es

61+ ExplicitList <$> mapM reorder es

82

62

83 App e1 e2 ->

63 App e1 e2 ->

84− App `liftM` reorder e1 `ap` reorder e2

64+ App <$> reorder e1 <*> reorder e2

85

65

86 MultiIf branches ->

66 MultiIf branches ->

87− MultiIf `liftM` mapM reorderPair branches

67+ MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches

88

68

89 Access e lbl ->

69 Access e lbl ->

90− Access `liftM` reorder e `ap` return lbl

70+ Access <$> reorder e <*> return lbl

91

71

92 Remove e lbl ->

72 Remove e lbl ->

93− Remove `liftM` reorder e `ap` return lbl

73+ Remove <$> reorder e <*> return lbl

94

74

95 Insert e lbl v ->

75 Insert e lbl v ->

96− Insert `liftM` reorder e `ap` return lbl `ap` reorder v

76+ Insert <$> reorder e <*> return lbl <*> reorder v

97

77

98 Modify e fields ->

78 Modify e fields ->

99− Modify `liftM` reorder e `ap` mapM reorderField fields

79+ Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields

100

80

101 Record fields ->

81 Record fields ->

102− Record `liftM` mapM reorderField fields

82+ Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields

103

83

104 Markdown uid md es -> Markdown uid md <$> mapM reorder es

84 Markdown uid md es -> Markdown uid md <$> mapM reorder es

105

85

106 GLShader _ _ -> return expr

86 GLShader _ _ -> return expr

107

87

88+ PortOut name st signal -> PortOut name st <$> reorder signal

89+

90+ PortIn name st tt handler -> PortIn name st tt <$> reorder handler

91+

108 -- Actually do some reordering

92 -- Actually do some reordering

109 Let defs body ->

93 Let defs body ->

110 do body' <- reorder body

94 do body' <- reorder body

@@ -117,48 +101,24 @@ reorder lexpr@(L s expr) =

117 let defss = map Graph.flattenSCC sccs

101 let defss = map Graph.flattenSCC sccs

118

102

119 -- remove let-bound variables from the context

103 -- remove let-bound variables from the context

120− let getPatterns def =

121− case def of

122− Def pattern _ -> pattern

123− TypeAnnotation name _ -> PVar name

124− forM (map getPatterns defs) $ \pattern -> do

104+ forM_ defs $ \(Definition pattern _ _) -> do

125− bound (boundVars pattern)

105+ bound (P.boundVars pattern)

126 mapM free (ctors pattern)

106 mapM free (ctors pattern)

127

107

128− let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)

129− L _ let' = foldr addDefs body' defss

108+ let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss

130

109

131 return let'

110 return let'

132

111

133− where

134− toDefs def =

135− case def of

136− (pattern, expr, Nothing) -> [ Def pattern expr ]

137− (PVar name, expr, Just tipe) ->

138− [ TypeAnnotation name tipe, Def (PVar name) expr ]

139− _ -> error $ unlines

140− [ "The impossible occurred."

141− , "Please report an issue at <https://github.com/evancz/Elm/issues>."

142− , "Be very descriptive because something quite weird probably happened." ]

143−

144−reorderField (label, expr) =

145− (,) label `liftM` reorder expr

146−

147−reorderPair (e1,e2) =

148− (,) `liftM` reorder e1 `ap` reorder e2

149−

150−bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)

112+bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)

151bindingReorder (pattern,expr) =

113bindingReorder (pattern,expr) =

152 do expr' <- reorder expr

114 do expr' <- reorder expr

153− bound (boundVars pattern)

115+ bound (P.boundVars pattern)

154− mapM free (ctors pattern)

116+ mapM_ free (ctors pattern)

155 return (pattern, expr')

117 return (pattern, expr')

156

118

157

119

158−type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)

159−

160−reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])

120+reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])

161−reorderAndGetDependencies (pattern, expr, mType) =

121+reorderAndGetDependencies (Definition pattern expr mType) =

162 do globalFrees <- get

122 do globalFrees <- get

163 -- work in a fresh environment

123 -- work in a fresh environment

164 put Set.empty

124 put Set.empty

@@ -166,44 +126,30 @@ reorderAndGetDependencies (pattern, expr, mType) =

166 localFrees <- get

126 localFrees <- get

167 -- merge with global frees

127 -- merge with global frees

168 modify (Set.union globalFrees)

128 modify (Set.union globalFrees)

169− return ((pattern, expr', mType), Set.toList localFrees)

129+ return (Definition pattern expr' mType, Set.toList localFrees)

170

130

171

131

172-- This also reorders the all of the sub-expressions in the Def list.

132-- This also reorders the all of the sub-expressions in the Def list.

173−buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]

133+buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]

174buildDefDict defs =

134buildDefDict defs =

175− do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)

135+ do pdefsDeps <- mapM reorderAndGetDependencies defs

176 return $ realDeps (addKey pdefsDeps)

136 return $ realDeps (addKey pdefsDeps)

177

137

178 where

138 where

179− getPDefs :: [Def t v] -> [PDef t v]

180− getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $

181− Map.toList $ go defs Map.empty Map.empty

182− where

183− go [] ds ts =

184− Map.unions [ Map.difference ds ts

185− , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]

186−

187− go (def:defs) ds ts =

188− case def of

189− Def p e -> go defs (Map.insert p (e, Nothing) ds) ts

190− TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)

191−

192− addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]

139+ addKey :: [(Def, [String])] -> [(Def, Int, [String])]

193 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

140 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

194

141

195− variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]

142+ variableToKey :: (Def, Int, [String]) -> [(String, Int)]

196− variableToKey ((pattern, _, _), key, _) =

143+ variableToKey (Definition pattern _ _, key, _) =

197− [ (var, key) | var <- Set.toList (boundVars pattern) ]

144+ [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

198

145

199− variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int

146+ variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int

200 variableToKeyMap pdefsDeps =

147 variableToKeyMap pdefsDeps =

201 Map.fromList (concatMap variableToKey pdefsDeps)

148 Map.fromList (concatMap variableToKey pdefsDeps)

202

149

203− realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]

150+ realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]

204 realDeps pdefsDeps = map convert pdefsDeps

151 realDeps pdefsDeps = map convert pdefsDeps

205 where

152 where

206 varDict = variableToKeyMap pdefsDeps

153 varDict = variableToKeyMap pdefsDeps

207 convert (pdef, key, deps) =

154 convert (pdef, key, deps) =

208 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

155 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

209−

compiler/Transform/Substitute.hs+9−9

@@ -4,10 +4,10 @@ module Transform.Substitute (subst) where

4import Control.Arrow (second, (***))

5import SourceSyntax.Expression

6import SourceSyntax.Location

7+import qualified SourceSyntax.Pattern as Pattern

7import qualified Data.Set as Set

8import qualified Data.Set as Set

8−import qualified Transform.SortDefinitions as SD

9

10−subst :: String -> Expr t v -> Expr t v -> Expr t v

10+subst :: String -> Expr -> Expr -> Expr

11subst old new expr =

12 let f (L s e) = L s (subst old new e) in

13 case expr of

@@ -15,7 +15,7 @@ subst old new expr =

15 ExplicitList es -> ExplicitList (map f es)

16 Binop op e1 e2 -> Binop op (f e1) (f e2)

17 Lambda p e

18− | Set.member old (SD.boundVars p) -> expr

18+ | Set.member old (Pattern.boundVars p) -> expr

19 | otherwise -> Lambda p (f e)

20 App e1 e2 -> App (f e1) (f e2)

21 MultiIf ps -> MultiIf (map (f *** f) ps)

@@ -24,12 +24,9 @@ subst old new expr =

24 | anyShadow -> expr

25 | otherwise -> Let (map substDef defs) (f body)

26 where

27+ substDef (Definition p e t) = Definition p (f e) t

27 anyShadow =

28 anyShadow =

28− any (Set.member old . SD.boundVars) [ p | Def p _ <- defs ]

29+ any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]

29− substDef def =

30− case def of

31− TypeAnnotation _ _ -> def

32− Def p e -> Def p (f e)

33

30

34 Var x -> if x == old then new else expr

31 Var x -> if x == old then new else expr

35 Case e cases -> Case (f e) $ map (second f) cases

32 Case e cases -> Case (f e) $ map (second f) cases

@@ -40,4 +37,7 @@ subst old new expr =

40 Modify r fs -> Modify (f r) (map (second f) fs)

37 Modify r fs -> Modify (f r) (map (second f) fs)

41 Record fs -> Record (map (second f) fs)

38 Record fs -> Record (map (second f) fs)

42 Literal _ -> expr

39 Literal _ -> expr

43− Markdown uid md es -> Markdown uid md (map f es)

40+ Markdown uid md es -> Markdown uid md (map f es)

41+ GLShader _ _ -> expr

42+ PortIn name st tt handler -> PortIn name st tt (f handler)

43+ PortOut name st signal -> PortOut name st (f signal)

compiler/Type/Alias.hs+4−4

@@ -9,7 +9,7 @@ import qualified Data.List as List

9import SourceSyntax.Type

10import SourceSyntax.Module

11

12−type Rules = ([(String,[String],Type)], Type -> Type)

12+type Rules = ([Alias], Type -> Type)

13

14rules interfaces moduleAliases moduleImports =

15 (collect interfaces moduleAliases, localizer moduleImports)

@@ -20,7 +20,7 @@ collect interfaces moduleAliases =

20 rawAliases =

21 moduleAliases ++ concatMap iAliases (Map.elems interfaces)

22

23− isPrimitive (_,_,tipe) =

23+ isPrimitive (_,_,tipe,_) =

24 case tipe of

25 Data _ [] -> True

26 _ -> False

@@ -62,13 +62,13 @@ realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

62

63-- Realias using canonical aliases, so results will have aliases

64-- that are fully qualified and possible to compare.

65−canonicalRealias :: [(String,[String],Type)] -> Type -> Type

65+canonicalRealias :: [Alias] -> Type -> Type

66canonicalRealias aliases tipe =

67 case concatMap tryRealias aliases of

68 [] -> if tipe == tipe' then tipe else f tipe'

69 tipes -> f (bestType tipes)

70 where

71− tryRealias (name, args, aliasTipe) =

71+ tryRealias (name, args, aliasTipe, _) =

72 case diff aliasTipe tipe of

73 Nothing -> []

74 Just kvs ->

compiler/Type/Constrain/Declaration.hs+35−36

@@ -1,70 +1,69 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Type.Constrain.Declaration where

2module Type.Constrain.Declaration where

2

3

3−import Control.Monad

4−import Control.Applicative ((<$>))

5−

6−import qualified Data.Map as Map

7−

8−import qualified Type.Constrain.Expression as TcExpr

9−import qualified Type.Environment as Env

10−

11import SourceSyntax.Declaration

4import SourceSyntax.Declaration

12−import qualified SourceSyntax.Expression as Src

5+import qualified SourceSyntax.Expression as E

13import qualified SourceSyntax.Location as L

6import qualified SourceSyntax.Location as L

14import qualified SourceSyntax.Pattern as P

7import qualified SourceSyntax.Pattern as P

15−import qualified SourceSyntax.Type as Type

8+import qualified SourceSyntax.Type as T

9+import qualified Type.Type as Type

10+import System.IO.Unsafe

16

11

17−toExpr :: [Declaration t v] -> [Src.Def t v]

12+toExpr :: [Declaration] -> [E.Def]

18toExpr = concatMap toDefs

13toExpr = concatMap toDefs

19

14

20−toDefs :: Declaration t v -> [Src.Def t v]

15+toDefs :: Declaration -> [E.Def]

21toDefs decl =

16toDefs decl =

22 case decl of

17 case decl of

23 Definition def -> [def]

18 Definition def -> [def]

24

19

25− Datatype name tvars constructors -> concatMap toDefs constructors

20+ Datatype name tvars constructors _ -> concatMap toDefs' constructors

26 where

21 where

27− toDefs (ctor, tipes) =

22+ toDefs' (ctor, tipes) =

28 let vars = take (length tipes) arguments

23 let vars = take (length tipes) arguments

29− tbody = Type.Data name $ map Type.Var tvars

24+ tbody = T.Data name $ map T.Var tvars

30− body = L.none . Src.Data ctor $ map (L.none . Src.Var) vars

25+ body = L.none . E.Data ctor $ map (L.none . E.Var) vars

31− in [ Src.TypeAnnotation ctor $ foldr Type.Lambda tbody tipes

26+ in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

32− , Src.Def (P.PVar ctor) $ buildFunction body vars

33− ]

34

27

35− TypeAlias name tvars tipe@(Type.Record fields ext) ->

28+ TypeAlias name _ tipe@(T.Record fields ext) _ ->

36− [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args

37− , Src.Def (P.PVar name) $ buildFunction record vars ]

29+ [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

38 where

30 where

39 args = case ext of

31 args = case ext of

40− Type.EmptyRecord -> map snd fields

32+ T.EmptyRecord -> map snd fields

41 _ -> map snd fields ++ [ext]

33 _ -> map snd fields ++ [ext]

42

34

43− var = L.none . Src.Var

35+ var = L.none . E.Var

44 vars = take (length args) arguments

36 vars = take (length args) arguments

45

37

46 efields = zip (map fst fields) (map var vars)

38 efields = zip (map fst fields) (map var vars)

47 record = case ext of

39 record = case ext of

48− Type.EmptyRecord -> L.none $ Src.Record efields

40+ T.EmptyRecord -> L.none $ E.Record efields

49− _ -> foldl (\r (f,v) -> L.none $ Src.Insert r f v) (var $ last vars) efields

41+ _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

50

42

51 -- Type aliases must be added to an extended equality dictionary,

43 -- Type aliases must be added to an extended equality dictionary,

52 -- but they do not require any basic constraints.

44 -- but they do not require any basic constraints.

53− TypeAlias _ _ _ -> []

45+ -- TODO: with the ability to derive code, you may need to generate stuff!

54−

46+ TypeAlias _ _ _ _ -> []

55− ImportEvent _ expr@(L.L s _) name tipe ->

47+

56− [ Src.TypeAnnotation name tipe

48+ Port port ->

57− , Src.Def (P.PVar name) (L.L s $ Src.App (L.L s $ Src.Var "constant") expr) ]

49+ case port of

58−

50+ Send name expr@(L.L s _) tipe ->

59− ExportEvent _ name tipe ->

51+ [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

60− [ Src.TypeAnnotation name tipe ]

52+ Recv name expr@(L.L s _) tipe ->

53+ unsafePerformIO $ do

54+ tvar <- Type.var Type.Flexible

55+ return $ [ definition name (L.L s $ E.PortIn name tipe tvar expr) tipe ]

61

56

62 -- no constraints are needed for fixity declarations

57 -- no constraints are needed for fixity declarations

63 Fixity _ _ _ -> []

58 Fixity _ _ _ -> []

64

59

65

60

66arguments :: [String]

61arguments :: [String]

67−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]

62+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

68

63

64+buildFunction :: E.LExpr -> [String] -> E.LExpr

69buildFunction body@(L.L s _) vars =

65buildFunction body@(L.L s _) vars =

70− foldr (\p e -> L.L s (Src.Lambda p e)) body (map P.PVar vars)

66+ foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)

67+

68+definition :: String -> E.LExpr -> T.Type -> E.Def

69+definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)

compiler/Type/Constrain/Expression.hs+20−37

@@ -1,21 +1,16 @@

1−

1+{-# OPTIONS_GHC -W #-}

2−{-# OPTIONS -Wall #-}

3−

4module Type.Constrain.Expression where

2module Type.Constrain.Expression where

5

3

6import qualified Data.List as List

4import qualified Data.List as List

7import qualified Data.Map as Map

5import qualified Data.Map as Map

8import qualified Data.Set as Set

6import qualified Data.Set as Set

9−import Control.Arrow (second)

7+import Control.Applicative ((<$>))

10−import Control.Applicative ((<$>),(<*>))

11import qualified Control.Monad as Monad

8import qualified Control.Monad as Monad

12import Control.Monad.Error

9import Control.Monad.Error

13−import Control.Monad.State

14−import Data.Traversable (traverse)

15import qualified Text.PrettyPrint as PP

10import qualified Text.PrettyPrint as PP

16import qualified Parse.Helpers as PH

11import qualified Parse.Helpers as PH

17import SourceSyntax.Location as Loc

12import SourceSyntax.Location as Loc

18−import SourceSyntax.Pattern (Pattern(PVar))

13+import SourceSyntax.Pattern (Pattern(PVar), boundVars)

19import SourceSyntax.Expression

14import SourceSyntax.Expression

20import qualified SourceSyntax.Type as SrcT

15import qualified SourceSyntax.Type as SrcT

21import Type.Type hiding (Descriptor(..))

16import Type.Type hiding (Descriptor(..))

@@ -23,10 +18,8 @@ import Type.Fragment

23import qualified Type.Environment as Env

18import qualified Type.Environment as Env

24import qualified Type.Constrain.Literal as Literal

19import qualified Type.Constrain.Literal as Literal

25import qualified Type.Constrain.Pattern as Pattern

20import qualified Type.Constrain.Pattern as Pattern

26−import qualified Transform.SortDefinitions as SD

27−

28

21

29−constrain :: Env.Environment -> LExpr a b -> Type -> ErrorT [PP.Doc] IO TypeConstraint

22+constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

30constrain env (L span expr) tipe =

23constrain env (L span expr) tipe =

31 let list t = Env.get env Env.types "_List" <| t

24 let list t = Env.get env Env.types "_List" <| t

32 and = L span . CAnd

25 and = L span . CAnd

@@ -159,13 +152,18 @@ constrain env (L span expr) tipe =

159 (schemes, rqs, fqs, header, c2, c1) <-

152 (schemes, rqs, fqs, header, c2, c1) <-

160 Monad.foldM (constrainDef env)

153 Monad.foldM (constrainDef env)

161 ([], [], [], Map.empty, true, true)

154 ([], [], [], Map.empty, true, true)

162− (collapseDefs defs)

155+ (concatMap expandPattern defs)

163 return $ clet schemes

156 return $ clet schemes

164 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

157 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

165 (c1 /\ c))

158 (c1 /\ c))

166

159

160+ PortIn _ _ tt handler ->

161+ constrain env handler (VarN tt)

167

162

163+ PortOut _ _ signal ->

164+ constrain env signal tipe

165+

168−constrainDef env info (pattern, expr, maybeTipe) =

166+constrainDef env info (Definition pattern expr maybeTipe) =

169 let qs = [] -- should come from the def, but I'm not sure what would live there...

167 let qs = [] -- should come from the def, but I'm not sure what would live there...

170 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

168 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

171 in

169 in

@@ -202,33 +200,18 @@ constrainDef env info (pattern, expr, maybeTipe) =

202 , c /\ c2

200 , c /\ c2

203 , c1 )

201 , c1 )

204

202

203+ _ -> error (show pattern)

204+

205−expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)

205+expandPattern :: Def -> [Def]

206− -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

207−expandPattern triple@(pattern, lexpr@(L s _), maybeType) =

206+expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =

208 case pattern of

207 case pattern of

209− PVar _ -> [triple]

208+ PVar _ -> [def]

210− _ -> (PVar x, lexpr, maybeType) : map toDef vars

209+ _ -> Definition (PVar x) lexpr maybeType : map toDef vars

211 where

210 where

212− vars = Set.toList $ SD.boundVars pattern

211+ vars = Set.toList $ boundVars pattern

213 x = "$" ++ concat vars

212 x = "$" ++ concat vars

214− var = L s . Var

213+ mkVar = L s . Var

215− toDef y = (PVar y, L s $ Case (var x) [(pattern, var y)], Nothing)

214+ toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

216−

217−collapseDefs :: [Def t v] -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

218−collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty

219− where

220− go output defs typs [] =

221− output ++ concatMap Map.elems [

222− Map.intersectionWithKey (\k v t -> (PVar k, v, Just t)) defs typs,

223− Map.mapWithKey (\k v -> (PVar k, v, Nothing)) (Map.difference defs typs) ]

224− go output defs typs (d:ds) =

225− case d of

226− Def (PVar name) body ->

227− go output (Map.insert name body defs) typs ds

228− Def pattern body ->

229− go ((pattern, body, Nothing) : output) defs typs ds

230− TypeAnnotation name typ ->

231− go output defs (Map.insert name typ typs) ds

232

215

233try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

216try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

234try span computation = do

217try span computation = do

compiler/Type/Constrain/Pattern.hs−2

@@ -5,8 +5,6 @@ import Control.Arrow (second)

5import Control.Applicative ((<$>))

6import qualified Control.Monad as Monad

7import Control.Monad.Error

8−import qualified Data.List as List

9−import qualified Data.Maybe as Maybe

10import qualified Data.Map as Map

8import qualified Data.Map as Map

11import qualified Text.PrettyPrint as PP

9import qualified Text.PrettyPrint as PP

12

10

compiler/Type/Environment.hs+8−8

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.Environment where

2module Type.Environment where

2

3

3import Control.Applicative ((<$>), (<*>))

4import Control.Applicative ((<$>), (<*>))

@@ -9,11 +10,10 @@ import qualified Control.Monad.State as State

9import qualified Data.Traversable as Traverse

10import qualified Data.Traversable as Traverse

10import qualified Data.Map as Map

11import qualified Data.Map as Map

11import Data.List (isPrefixOf)

12import Data.List (isPrefixOf)

12−import qualified Data.UnionFind.IO as UF

13import qualified Text.PrettyPrint as PP

14

15import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT)

16+import SourceSyntax.Module (ADT, Alias)

17import Type.Type

18

19type TypeDict = Map.Map String Type

@@ -26,10 +26,10 @@ data Environment = Environment {

26 value :: TypeDict

27}

28

29−initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment

29+initialEnvironment :: [ADT] -> [Alias] -> IO Environment

30initialEnvironment datatypes aliases = do

31 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

32+ let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases

33 env = Environment {

34 constructor = Map.empty,

35 value = Map.empty,

@@ -42,9 +42,9 @@ makeTypes :: [ADT] -> IO TypeDict

42makeTypes datatypes =

43 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

44 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

45+ nameAndKind (name, tvars, _, _) = (name, length tvars)

46

47− makeCtor (name, kind) = do

47+ makeCtor (name, _) = do

48 ctor <- VarN <$> namedVar Constant name

49 return (name, ctor)

50

@@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins

84

85

86ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

87+ctorToType env (name, tvars, ctors, _) =

88 zip (map fst ctors) (map inst ctors)

89 where

90 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

@@ -94,7 +94,7 @@ ctorToType env (name, tvars, ctors) =

94

95

96 go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

97− go (ctor, args) = do

97+ go (_, args) = do

98 types <- mapM (instantiator env) args

99 returnType <- instantiator env (Src.Data name (map Src.Var tvars))

100 return (types, returnType)

compiler/Type/ExtraChecks.hs+98−26

@@ -1,10 +1,12 @@

1+{-# OPTIONS_GHC -W #-}

2+module Type.ExtraChecks (mainType, occurs, portTypes) where

1-- This module contains checks to be run *after* type inference has

3-- This module contains checks to be run *after* type inference has

2-- completed successfully. At that point we still need to do occurs

4-- completed successfully. At that point we still need to do occurs

3-- checks and ensure that `main` has an acceptable type.

5-- checks and ensure that `main` has an acceptable type.

4−module Type.ExtraChecks (extraChecks, occursCheck) where

5

6

6import Control.Applicative ((<$>),(<*>))

7import Control.Applicative ((<$>),(<*>))

7import Control.Monad.State

8import Control.Monad.State

9+import qualified Data.List as List

8import qualified Data.Map as Map

10import qualified Data.Map as Map

9import qualified Data.UnionFind.IO as UF

11import qualified Data.UnionFind.IO as UF

10import Type.Type ( Variable, structure, Term1(..), toSrcType )

12import Type.Type ( Variable, structure, Term1(..), toSrcType )

@@ -12,33 +14,103 @@ import qualified Type.State as TS

12import qualified Type.Alias as Alias

14import qualified Type.Alias as Alias

13import Text.PrettyPrint as P

15import Text.PrettyPrint as P

14import SourceSyntax.PrettyPrint (pretty)

16import SourceSyntax.PrettyPrint (pretty)

15−import SourceSyntax.Type (Type)

17+import qualified SourceSyntax.Type as T

18+import qualified SourceSyntax.Expression as E

16−import qualified SourceSyntax.Location as Location

19+import qualified SourceSyntax.Location as L

17−import qualified SourceSyntax.Expression as Expr

20+import qualified Transform.Expression as Expr

18import qualified Data.Traversable as Traverse

21import qualified Data.Traversable as Traverse

22+import System.IO.Unsafe

19

23

20−extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))

24+throw err = Left [ P.vcat err ]

21−extraChecks rules env =

22− mainCheck rules <$> Traverse.traverse toSrcType env

23

25

24−mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)

26+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))

25−mainCheck rules env =

27+mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

26− let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in

28+ where

29+ mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)

30+ mainCheck rules env =

27− case Map.lookup "main" env of

31+ case Map.lookup "main" env of

28− Nothing -> Right env

32+ Nothing -> Right env

29− Just tipe

33+ Just mainType

34+ | tipe `elem` acceptable -> Right env

35+ | otherwise -> throw err

36+ where

37+ acceptable = [ "Graphics.Element.Element"

38+ , "Signal.Signal Graphics.Element.Element" ]

39+

30− | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->

40+ tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType

31− Right env

32− | otherwise ->

33− Left [ P.vcat [ P.text "Type Error:"

34− , P.text "Bad type for 'main'. It must have type Element or a (Signal Element)"

41+ err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

35− , P.text "Instead 'main' has type:\n"

42+ , P.text "Instead 'main' has type:\n"

36− , P.nest 4 . pretty $ Alias.realias rules tipe

43+ , P.nest 4 . pretty $ Alias.realias rules mainType

37− , P.text " " ]

44+ , P.text " " ]

45+

46+portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

47+portTypes rules expr =

48+ const () <$> Expr.checkPorts checkIn checkOut expr

49+ where

50+ showType tipe = (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"

51+

52+ checkIn name st tt =

53+ do t <- getSignal name st

54+ case unsafePerformIO (toSrcType tt) of

55+ T.Lambda a b ->

56+ do isJsType "coming in" name a

57+ if b `elem` okayTypes then return () else throw msg

58+ where

59+ okayTypes = [ t

60+ , T.Data "Maybe.Maybe" [t]

61+ , T.Data "Either.Either" [T.Data "String.String" [], t]

62+ ]

63+ msg = [ P.text $ "Type Error: the handler for port '" ++ name ++

64+ "' returns values of type:\n"

65+ , showType b

66+ , P.text $ "but the port's type annotation requires that the handler returns values"

67+ , P.text $ "with one of the following types:\n"

68+ ] ++ map showType okayTypes ++

69+ [ P.text "If the handler returns a Maybe or Either, invalid values will cause an"

70+ , P.text "error to be thrown to the JS error handler associated with this port." ]

71+

72+ tipe ->

73+ throw [ P.text $ "Type Error: the handler for port '" ++ name ++

74+ "' must be a function!"

75+ , P.text "Instead it was given a value of type:\n"

76+ , showType tipe

77+ ]

78+

79+ checkOut name st =

80+ do t <- getSignal name st

81+ isJsType "sent out" name t

82+

83+ getSignal name tipe =

84+ case tipe of

85+ T.Data "Signal.Signal" [t] -> return t

86+ _ -> throw [ P.text $ "Type Error: port '" ++ name ++ "' must be a Signal,"

87+ , P.text $ "but the type annotation says it has non-Signal type:\n"

88+ , showType tipe

89+ , P.text $ "Maybe instead you want the following type?\n"

90+ , showType (T.Data "Signal.Signal" [tipe])

91+ ]

92+

93+ isJsType msg name tipe =

94+ case tipe of

95+ T.Data ctor ts | okay ctor -> mapM_ (isJsType msg name) ts

96+ | otherwise -> throw $ err msg "Elm values"

97+ T.Var _ -> throw $ err msg "type variables"

98+ T.Lambda _ _ -> throw $ err msg "Elm functions"

99+ T.EmptyRecord -> throw $ err msg "Elm records"

100+ T.Record _ _ -> throw $ err msg "Elm records"

101+ where

102+ okay ctor = and [ List.isPrefixOf "JavaScript." ctor

103+ , 1 == length (filter (=='.') ctor) ]

104+

105+ err msg kind =

106+ [ P.text $ "Type Error: the values " ++ msg ++ " through port '" ++ name ++

107+ "' must be JavaScript values."

108+ , P.text $ "The values sent through this port contain " ++ kind ++ " with type:\n"

109+ , showType tipe

38− ]

110+ ]

39

111

40−occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()

112+occurs :: (String, Variable) -> StateT TS.SolverState IO ()

41−occursCheck (name, variable) =

113+occurs (name, variable) =

42 do vars <- liftIO $ infiniteVars [] variable

114 do vars <- liftIO $ infiniteVars [] variable

43 case vars of

115 case vars of

44 [] -> return ()

116 [] -> return ()

@@ -47,10 +119,10 @@ occursCheck (name, variable) =

47 case structure desc of

119 case structure desc of

48 Nothing ->

120 Nothing ->

49 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

121 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

50− Just struct ->

122+ Just _ ->

51 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

123 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

52 var' <- liftIO $ UF.fresh desc

124 var' <- liftIO $ UF.fresh desc

53− TS.addError (Location.NoSpan name) (Just msg) var var'

125+ TS.addError (L.NoSpan name) (Just msg) var var'

54 where

126 where

55 msg = "Infinite types are not allowed"

127 msg = "Infinite types are not allowed"

56 fallback _ = return $ P.text msg

128 fallback _ = return $ P.text msg

compiler/Type/Inference.hs+7−8

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.Inference where

2module Type.Inference where

2

3

3import qualified Data.Map as Map

4import qualified Data.Map as Map

@@ -5,27 +6,23 @@ import qualified Data.Map as Map

5import qualified Type.Type as T

6import qualified Type.Type as T

6import qualified Type.Environment as Env

7import qualified Type.Environment as Env

7import qualified Type.Constrain.Expression as TcExpr

8import qualified Type.Constrain.Expression as TcExpr

8−import qualified Type.Constrain.Declaration as TcDecl

9import qualified Type.Solve as Solve

10

11import SourceSyntax.Module as Module

12−import qualified SourceSyntax.Expression as Expr

13−import SourceSyntax.Location (Located, noneNoDocs)

12+import SourceSyntax.Location (noneNoDocs)

14−import SourceSyntax.PrettyPrint

15import SourceSyntax.Type (Type)

13import SourceSyntax.Type (Type)

16import Text.PrettyPrint

14import Text.PrettyPrint

17import qualified Type.State as TS

15import qualified Type.State as TS

18−import Type.ExtraChecks (extraChecks)

16+import qualified Type.ExtraChecks as Check

19import Control.Monad.State (execStateT, forM)

17import Control.Monad.State (execStateT, forM)

20import Control.Monad.Error (runErrorT, liftIO)

18import Control.Monad.Error (runErrorT, liftIO)

21−import Control.Arrow (second)

22import qualified Type.Alias as Alias

19import qualified Type.Alias as Alias

23

20

24import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

21import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

25 -- the IO monad. I don't think that'd be worthwhile.

22 -- the IO monad. I don't think that'd be worthwhile.

26

23

27

24

28−infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String Type)

25+infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)

29infer interfaces modul = unsafePerformIO $ do

26infer interfaces modul = unsafePerformIO $ do

30 env <- Env.initialEnvironment

27 env <- Env.initialEnvironment

31 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

28 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

@@ -55,4 +52,6 @@ infer interfaces modul = unsafePerformIO $ do

55 let rules = Alias.rules interfaces (aliases modul) (imports modul)

52 let rules = Alias.rules interfaces (aliases modul) (imports modul)

56 case TS.sErrors state of

53 case TS.sErrors state of

57 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

54 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

55+ [] -> case Check.portTypes rules (program modul) of

58− [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)

56+ Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)

57+ Left err -> return (Left err)

compiler/Type/Solve.hs+3−5

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.Solve (solve) where

2module Type.Solve (solve) where

2

3

3import Control.Monad

4import Control.Monad

@@ -5,14 +6,11 @@ import Control.Monad.State

5import qualified Data.UnionFind.IO as UF

6import qualified Data.UnionFind.IO as UF

6import qualified Data.Map as Map

7import qualified Data.Map as Map

7import qualified Data.Traversable as Traversable

8import qualified Data.Traversable as Traversable

8−import qualified Data.Maybe as Maybe

9import qualified Data.List as List

10import Type.Type

11import Type.Unify

12−import qualified Type.ExtraChecks as EC

12+import qualified Type.ExtraChecks as Check

13−import qualified Type.Environment as Env

14import qualified Type.State as TS

13import qualified Type.State as TS

15−import qualified Text.PrettyPrint as P

16import SourceSyntax.Location (Located(L), SrcSpan)

14import SourceSyntax.Location (Located(L), SrcSpan)

17

15

18

16

@@ -122,7 +120,7 @@ solve (L span constraint) =

122 headers <- Map.unions `fmap` mapM (solveScheme span) schemes

120 headers <- Map.unions `fmap` mapM (solveScheme span) schemes

123 TS.modifyEnv $ \env -> Map.union headers env

121 TS.modifyEnv $ \env -> Map.union headers env

124 solve constraint'

122 solve constraint'

125− mapM EC.occursCheck $ Map.toList headers

123+ mapM Check.occurs $ Map.toList headers

126 TS.modifyEnv (\_ -> oldEnv)

124 TS.modifyEnv (\_ -> oldEnv)

127

125

128 CInstance name term -> do

126 CInstance name term -> do

compiler/Type/State.hs+3−5

@@ -1,9 +1,8 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.State where

2module Type.State where

2

3

3import Type.Type

4import Type.Type

4import qualified Data.Map as Map

5import qualified Data.Map as Map

5−import qualified Data.List as List

6−import qualified Type.Environment as Env

7import qualified Data.UnionFind.IO as UF

6import qualified Data.UnionFind.IO as UF

8import Control.Monad.State

7import Control.Monad.State

9import Control.Applicative ((<$>),(<*>), Applicative)

8import Control.Applicative ((<$>),(<*>), Applicative)

@@ -11,7 +10,6 @@ import qualified Data.Traversable as Traversable

11import Text.PrettyPrint as P

10import Text.PrettyPrint as P

12import SourceSyntax.PrettyPrint

11import SourceSyntax.PrettyPrint

13import SourceSyntax.Location

12import SourceSyntax.Location

14−import qualified SourceSyntax.Type as Src

15import qualified Type.Alias as Alias

13import qualified Type.Alias as Alias

16

14

17-- Pool

15-- Pool

@@ -64,8 +62,8 @@ addError span hint t1 t2 =

64 ]

62 ]

65

63

66 location = case span of

64 location = case span of

67− NoSpan msg -> ""

65+ NoSpan _ -> ""

68− Span p1 p2 msg ->

66+ Span p1 p2 _ ->

69 if line p1 == line p2 then " on line " ++ show (line p1)

67 if line p1 == line p2 then " on line " ++ show (line p1)

70 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

68 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

71

69

compiler/Type/Type.hs+11−8

@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

62infixl 8 /\

63

64(/\) :: Constraint a b -> Constraint a b -> Constraint a b

65−a@(L s1 c1) /\ b@(L s2 c2) =

65+a@(L _ c1) /\ b@(L _ c2) =

66 case (c1, c2) of

67 (CTrue, _) -> b

68 (_, CTrue) -> a

@@ -95,6 +95,7 @@ data Flex = Rigid | Flexible | Constant | Is SuperType

95data SuperType = Number | Comparable | Appendable

96 deriving (Show, Eq)

97

98+namedVar :: Flex -> String -> IO Variable

98namedVar flex name = UF.fresh $ Descriptor {

99namedVar flex name = UF.fresh $ Descriptor {

99 structure = Nothing,

100 structure = Nothing,

100 rank = noRank,

101 rank = noRank,

@@ -104,6 +105,7 @@ namedVar flex name = UF.fresh $ Descriptor {

104 mark = noMark

105 mark = noMark

105 }

106 }

106

107

108+var :: Flex -> IO Variable

107var flex = UF.fresh $ Descriptor {

109var flex = UF.fresh $ Descriptor {

108 structure = Nothing,

110 structure = Nothing,

109 rank = noRank,

111 rank = noRank,

@@ -113,6 +115,7 @@ var flex = UF.fresh $ Descriptor {

113 mark = noMark

115 mark = noMark

114 }

116 }

115

117

118+structuredVar :: Term1 Variable -> IO Variable

116structuredVar structure = UF.fresh $ Descriptor {

119structuredVar structure = UF.fresh $ Descriptor {

117 structure = Just structure,

120 structure = Just structure,

118 rank = noRank,

121 rank = noRank,

@@ -368,8 +371,8 @@ toSrcType variable = do

368 Src.Record fs'' <$> toSrcType ext

371 Src.Record fs'' <$> toSrcType ext

369 Nothing ->

372 Nothing ->

370 case name desc of

373 case name desc of

371− Just x@(c:cs) | Char.isLower c -> return (Src.Var x)

374+ Just x@(c:_) | Char.isLower c -> return (Src.Var x)

372− | otherwise -> return (Src.Data x [])

375+ | otherwise -> return (Src.Data x [])

373 _ -> error $ concat

376 _ -> error $ concat

374 [ "Problem converting the following type "

377 [ "Problem converting the following type "

375 , "from a type-checker type to a source-syntax type:"

378 , "from a type-checker type to a source-syntax type:"

@@ -383,12 +386,12 @@ collectApps variable = go [] variable

383 go vars variable = do

386 go vars variable = do

384 desc <- UF.descriptor variable

387 desc <- UF.descriptor variable

385 case (structure desc, vars) of

388 case (structure desc, vars) of

386− (Nothing, [v] ) -> case name desc of

389+ (Nothing, [v]) -> case name desc of

387 Just "_List" -> return (List v)

390 Just "_List" -> return (List v)

388 _ -> return Other

391 _ -> return Other

389− (Nothing, vs ) -> case name desc of

392+ (Nothing, vs) -> case name desc of

390 Just ctor | isTuple ctor -> return (Tuple vs)

393 Just ctor | isTuple ctor -> return (Tuple vs)

391 _ -> return Other

394 _ -> return Other

392− (Just term, vs) -> case term of

395+ (Just term, _) -> case term of

393− App1 a b -> go (vars ++ [b]) a

396+ App1 a b -> go (vars ++ [b]) a

394− _ -> return Other

397+ _ -> return Other

compiler/Type/Unify.hs+3−3

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.Unify (unify) where

2module Type.Unify (unify) where

2

3

3import Type.Type

4import Type.Type

@@ -5,7 +6,6 @@ import qualified Data.UnionFind.IO as UF

5import qualified Data.Map as Map

6import qualified Data.Map as Map

6import qualified Data.Maybe as Maybe

7import qualified Data.Maybe as Maybe

7import qualified Type.State as TS

8import qualified Type.State as TS

8−import Control.Arrow (first,second)

9import Control.Monad.State

10import SourceSyntax.Location

11import Type.PrettyPrint

@@ -193,8 +193,8 @@ actuallyUnify span variable1 variable2 = do

193

194 unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a

195

196− eat (x:xs) (y:ys) = eat xs ys

196+ eat (_:xs) (_:ys) = eat xs ys

197− eat xs ys = xs

197+ eat xs _ = xs

198

199 _ -> TS.addError span Nothing variable1 variable2

200

libraries/Native/Ports.jsnew file+68

@@ -0,0 +1,68 @@

1+Elm.Native.Ports = {};

2+Elm.Native.Ports.make = function(elm) {

3+ elm.Native = elm.Native || {};

4+ elm.Native.Ports = elm.Native.Ports || {};

5+ if (elm.Native.Ports.values) return elm.Native.Ports.values;

6+

7+ var Signal = Elm.Signal.make(elm);

8+

9+ // On failure, return message. On success, return the value in an array.

10+ // Wrapping in an array allows the programmer to pass in a null value.

11+ function processInput(converter, v) {

12+ try { var elmValue = converter(v); }

13+ catch(e) { return "The given value caused a runtime error!\n" + e.toString(); }

14+

15+ var ctor = elmValue.ctor;

16+ if (ctor === 'Nothing' || ctor === 'Left') {

17+ return "The port's conversion function failed.";

18+ } else if (ctor === 'Just' || ctor === 'Right') {

19+ return [elmValue._0];

20+ }

21+ return [elmValue];

22+ }

23+ function portIn(name, converter) {

24+ var port = elm.ports.incoming[name];

25+ if (!port) {

26+ throw new Error("Initialization Error: port '" + name +

27+ "' was not given an input!");

28+ }

29+ elm.ports.uses[name] += 1;

30+ var result = processInput(converter, port.internal.defaultValue);

31+ if (typeof result === 'string') {

32+ throw new Error("Initialization Error: The default value for port '" +

33+ name + "' is invalid.\n" + result);

34+ }

35+ var signal = Signal.constant(result[0]);

36+ port.internal.subscribe(function(v) {

37+ var result = processInput(converter, v);

38+ if (typeof result === 'string') {

39+ port.internal.errorHandler(v)

40+ } else {

41+ elm.notify(signal.id, result[0]);

42+ }

43+ });

44+ return signal;

45+ }

46+ function portOut(name, signal) {

47+ var subscribers = []

48+ function subscribe(handler) {

49+ subscribers.push(handler);

50+ }

51+ function unsubscribe(handler) {

52+ subscribers.pop(subscribers.indexOf(handler));

53+ }

54+ A2( Signal.lift, function(value) {

55+ var len = subscribers.length;

56+ for (var i = 0; i < len; ++i) {

57+ subscribers[i](value);

58+ }

59+ }, signal);

60+ elm.ports.outgoing[name] = { subscribe:subscribe, unsubscribe:unsubscribe };

61+ return signal;

62+ }

63+

64+ return elm.Native.Ports.values = {

65+ portOut: portOut,

66+ portIn: portIn

67+ };

68+};

libraries/elm_dependencies.json+4−4

@@ -1,9 +1,9 @@

1−{ "version": "0.10.0.2"

1+{ "version": "0.10.1"

2, "summary": "Elm's standard libraries"

3−, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.11, you should be using version 0.11 of the standard libraries."

3+, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.10.1, you should be using version 0.10.1 of the standard libraries."

4, "license": "BSD3"

5, "repository": "http://github.com/evancz/Elm.git"

6−, "elm-version": "0.10.0.2"

6+, "elm-version": "0.10.1"

7, "dependencies": {}

8, "exposed-modules":

9 [ "Basics"

@@ -36,4 +36,4 @@

36 , "WebSocket"

37 , "Window"

38 ]

39−}

39+}

runtime/Init.js+82−30

@@ -2,7 +2,7 @@

2(function() {

3'use strict';

4

5−Elm.fullscreen = function(module) {

5+Elm.fullscreen = function(module, ports) {

6 var style = document.createElement('style');

7 style.type = 'text/css';

8 style.innerHTML = "html,head,body { padding:0; margin:0; }" +

@@ -10,24 +10,47 @@ Elm.fullscreen = function(module) {

10 document.head.appendChild(style);

11 var container = document.createElement('div');

12 document.body.appendChild(container);

13− return init(ElmRuntime.Display.FULLSCREEN, container, module);

13+ return init(ElmRuntime.Display.FULLSCREEN, container, module, ports || {});

14};

15

16−Elm.embed = function(module, container) {

16+Elm.embed = function(module, container, ports) {

17 var tag = container.tagName;

18 if (tag !== 'DIV') {

19 throw new Error('Elm.node must be given a DIV, not a ' + tag + '.');

20 } else if (container.hasChildNodes()) {

21 throw new Error('Elm.node must be given an empty DIV. No children allowed!');

22 }

23− return init(ElmRuntime.Display.COMPONENT, container, module);

23+ return init(ElmRuntime.Display.COMPONENT, container, module, ports || {});

24};

25

26−Elm.worker = function(module) {

26+Elm.worker = function(module, ports) {

27− return init(ElmRuntime.Display.NONE, {}, module);

27+ return init(ElmRuntime.Display.NONE, {}, module, ports || {});

28};

29

30+Elm.input = function(defaultValue, errorHandler) {

31+ var subscribers = []

32+ function subscribe(handler) {

33+ subscribers.push(handler);

34+ }

35+ function unsubscribe(handler) {

36+ subscribers.pop(subscribers.indexOf(handler));

37+ }

38+ function send(value) {

39+ var len = subscribers.length;

40+ for (var i = 0; i < len; ++i) {

41+ subscribers[i](value);

42+ }

43+ }

44+ return {

45+ send:send,

46+ internal: { defaultValue:defaultValue,

47+ errorHandler:errorHandler,

48+ subscribe: subscribe,

49+ unsubscribe: unsubscribe }

50+ };

51+}

52+

30−function init(display, container, module, moduleToReplace) {

53+function init(display, container, module, ports, moduleToReplace) {

31 // defining state needed for an instance of the Elm RTS

54 // defining state needed for an instance of the Elm RTS

32 var inputs = [];

55 var inputs = [];

33

56

@@ -59,6 +82,10 @@ function init(display, container, module, moduleToReplace) {

59 listeners.push(listener);

82 listeners.push(listener);

60 }

83 }

61

84

85+ var portUses = {}

86+ for (var key in ports) {

87+ portUses[key] = 0;

88+ }

62 // create the actual RTS. Any impure modules will attach themselves to this

89 // create the actual RTS. Any impure modules will attach themselves to this

63 // object. This permits many Elm programs to be embedded per document.

90 // object. This permits many Elm programs to be embedded per document.

64 var elm = {

91 var elm = {

@@ -67,34 +94,15 @@ function init(display, container, module, moduleToReplace) {

67 display:display,

94 display:display,

68 id:ElmRuntime.guid(),

95 id:ElmRuntime.guid(),

69 addListener:addListener,

96 addListener:addListener,

70− inputs:inputs

97+ inputs:inputs,

98+ ports: { incoming:ports, outgoing:{}, uses:portUses }

71 };

99 };

72

100

73− // Set up methods to communicate with Elm program from JS.

74− function send(name, value) {

75− if (typeof value === 'undefined') return function(v) { return send(name,v); };

76− var e = document.createEvent('Event');

77− e.initEvent(name + '_' + elm.id, true, true);

78− e.value = value;

79− document.dispatchEvent(e);

80− }

81− function recv(name, handler) {

82− document.addEventListener(name + '_' + elm.id, handler);

83− }

84−

85− recv('log', function(e) {console.log(e.value)});

86− recv('title', function(e) {document.title = e.value});

87− recv('redirect', function(e) {

88− if (e.value.length > 0) { window.location = e.value; }

89− });

90−

91 function swap(newModule) {

101 function swap(newModule) {

92 removeListeners(listeners);

102 removeListeners(listeners);

93 var div = document.createElement('div');

103 var div = document.createElement('div');

94− var newElm = init(display, div, newModule, elm);

104+ var newElm = init(display, div, newModule, ports, elm);

95 inputs = [];

105 inputs = [];

96− // elm.send = newElm.send;

97− // elm.recv = newElm.recv;

98 // elm.swap = newElm.swap;

106 // elm.swap = newElm.swap;

99 return newElm;

107 return newElm;

100 }

108 }

@@ -103,6 +111,7 @@ function init(display, container, module, moduleToReplace) {

103 var reportAnyErrors = function() {};

111 var reportAnyErrors = function() {};

104 try {

112 try {

105 Module = module.make(elm);

113 Module = module.make(elm);

114+ checkPorts(elm);

106 } catch(e) {

115 } catch(e) {

107 var directions = "<br/>    Open the developer console for more details."

116 var directions = "<br/>    Open the developer console for more details."

108 Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');

117 Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');

@@ -110,6 +119,7 @@ function init(display, container, module, moduleToReplace) {

110 }

119 }

111 inputs = ElmRuntime.filterDeadInputs(inputs);

120 inputs = ElmRuntime.filterDeadInputs(inputs);

112 filterListeners(inputs, listeners);

121 filterListeners(inputs, listeners);

122+ addReceivers(elm.ports.outgoing);

113 if (display !== ElmRuntime.Display.NONE) {

123 if (display !== ElmRuntime.Display.NONE) {

114 var graphicsNode = initGraphics(elm, Module);

124 var graphicsNode = initGraphics(elm, Module);

115 }

125 }

@@ -123,9 +133,26 @@ function init(display, container, module, moduleToReplace) {

123 }

133 }

124

134

125 reportAnyErrors();

135 reportAnyErrors();

126− return { send:send, recv:recv, swap:swap };

136+ return { swap:swap, output:elm.ports.outgoing };

127};

137};

128

138

139+function checkPorts(elm) {

140+ var portUses = elm.ports.uses;

141+ for (var key in portUses) {

142+ var uses = portUses[key]

143+ if (uses === 0) {

144+ throw new Error(

145+ "Initialization Error: there is no port named '" + key + "'.\n" +

146+ "You should probably remove that input from your initialization code.");

147+ } else if (uses > 1) {

148+ throw new Error(

149+ "Initialization Error: port '" + key +

150+ "' has been declared multiple times in the Elm code.\n" +

151+ "Remove declarations until there is exactly one.");

152+ }

153+ }

154+}

155+

129function filterListeners(inputs, listeners) {

156function filterListeners(inputs, listeners) {

130 loop:

157 loop:

131 for (var i = listeners.length; i--; ) {

158 for (var i = listeners.length; i--; ) {

@@ -146,6 +173,31 @@ function removeListeners(listeners) {

146 }

173 }

147}

174}

148

175

176+// add receivers for built-in ports if they are defined

177+function addReceivers(ports) {

178+ if ('log' in ports) {

179+ ports.log.subscribe(function(v) { console.log(v) });

180+ }

181+ if ('stdout' in ports) {

182+ var handler = process ? function(v) { process.stdout.write(v); }

183+ : function(v) { console.log(v); };

184+ ports.stdout.subscribe(handler);

185+ }

186+ if ('stderr' in ports) {

187+ var handler = process ? function(v) { process.stderr.write(v); }

188+ : function(v) { console.log('Error:' + v); };

189+ ports.stderr.subscribe(handler);

190+ }

191+ if ('title' in ports) {

192+ ports.title.subscribe(function(v) { document.title = v; });

193+ }

194+ if ('redirect' in ports) {

195+ ports.redirect.subscribe(function(v) {

196+ if (v.length > 0) window.location = v;

197+ });

198+ }

199+}

200+

149function initGraphics(elm, Module) {

201function initGraphics(elm, Module) {

150 if (!('main' in Module))

202 if (!('main' in Module))

151 throw new Error("'main' is missing! What do I display?!");

203 throw new Error("'main' is missing! What do I display?!");

server/Server.hs+4−4

@@ -12,7 +12,7 @@ import System.Exit

12import System.FilePath

13import System.Process

14import GHC.IO.Handle

15−import qualified Language.Elm as Elm

15+import qualified Elm.Internal.Paths as ElmPaths

16import Paths_elm_server

17

18runtime = "/elm-runtime.js"

@@ -74,7 +74,7 @@ parse ("--help":_) = putStrLn usage

74parse ("--version":_) = putStrLn ("The Elm Server " ++ showVersion version)

75parse args =

76 if null remainingArgs then

77− serve portNumber =<< elmRuntime

77+ serve portNumber elmRuntime

78 else

79 putStrLn usageMini

80

@@ -86,9 +86,9 @@ parse args =

86 argValue arg = tail $ dropWhile (/= '=') (head arg)

87 portNumber = if null portArg then 8000 else read (argValue portArg) :: Int

88 elmRuntime = if null runtimeArg then

89− Elm.runtime

89+ ElmPaths.runtime

90 else

91− return $ argValue runtimeArg

91+ argValue runtimeArg

92

93usageMini :: String

94usageMini =

server/elm-server.cabal+2−2

@@ -1,5 +1,5 @@

1Name: elm-server

2−Version: 0.10

2+Version: 0.10.1

3Synopsis: The Elm language server.

4Description: This package provides a standalone, Happstack-based Elm server.

5

@@ -36,5 +36,5 @@ Executable elm-server

36 happstack-server,

37 deepseq,

38 filepath,

39− Elm >= 0.10,

39+ Elm >= 0.10.1,

40 process