3e63279 · elk · git.iko.soy

Elm.cabal+11−6

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

11Name: Elm

2−Version: 0.10.0.2

2+Version: 0.10.1

33Synopsis: The Elm language module.

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

55 It is a statically/strongly typed, functional reactive

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

5454 Generate.Markdown,

5555 Transform.Canonicalize,

5656 Transform.Check,

57+ Transform.Expression,

58+ Transform.Declaration,

59+ Transform.Definition,

5760 Transform.SafeNames,

5861 Transform.SortDefinitions,

5962 Transform.Substitute,

60− Transform.Optimize,

6163 Metadata.Prelude,

62− InterfaceSerialization,

6364 Parse.Binop,

6465 Parse.Declaration,

6566 Parse.Expression,

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

8687 Build.Dependencies,

8788 Build.File,

8889 Build.Flags,

90+ Build.Interface,

8991 Build.Print,

9092 Build.Source,

9193 Build.Utils,

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

133135 Generate.Cases,

134136 Transform.Canonicalize,

135137 Transform.Check,

138+ Transform.Expression,

139+ Transform.Declaration,

140+ Transform.Definition,

136141 Transform.SafeNames,

137142 Transform.SortDefinitions,

138143 Transform.Substitute,

139− Transform.Optimize,

140144 Metadata.Prelude,

141− InterfaceSerialization,

142145 Parse.Binop,

143146 Parse.Declaration,

144147 Parse.Expression,

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

165168 Build.Dependencies,

166169 Build.File,

167170 Build.Flags,

171+ Build.Interface,

168172 Build.Print,

169173 Build.Source,

170174 Build.Utils,

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

228232 pandoc >= 1.10,

229233 parsec >= 3.1.1,

230234 pretty,

231− text

235+ text,

236+ union-find

232237

233238Test-Suite test-elm

234239 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/)

33

44## Install

55

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

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/>

9+**OS X 10.9** — follow

710[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.

912

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

13+**Platform Agnostic** —

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

1115Once the Haskell Platform is installed:

1216

1317 cabal update

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

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

2024

2125Cabal should tell you where your executables are located upon

22−successful installation.

23−

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−

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

27+which you should append to your PATH variable.

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

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

2930

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

4445

4546#### Final Notes

4647

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

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

49−

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

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

48+The `elm` package provides

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

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

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

58+or ask a question in the

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

compiler/Build/Dependencies.hs+1−11

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

1+{-# OPTIONS_GHC -W #-}

12module Build.Dependencies (getSortedDependencies) where

23

3−import Data.Data

44import Control.Applicative

55import Control.Monad.Error

66import qualified Control.Monad.State as State

77import qualified Data.Aeson as Json

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

9−import qualified Data.Char as Char

109import qualified Data.Graph as Graph

1110import qualified Data.List as List

1211import qualified Data.Map as Map

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

1615import System.Exit

1716import System.FilePath as FP

1817import System.IO

19−import Text.PrettyPrint (Doc)

2018

2119import qualified SourceSyntax.Module as Module

22−import qualified SourceSyntax.Type as Type

2320import 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

3021import qualified Elm.Internal.Paths as Path

3122import qualified Elm.Internal.Name as N

32−import qualified Elm.Internal.Version as V

3323import qualified Elm.Internal.Dependencies as Deps

3424

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

compiler/Build/File.hs+5−6

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

1+{-# OPTIONS_GHC -W #-}

12module Build.File (build) where

23

34import Control.Monad (when)

45import qualified Data.Binary as Binary

5−import qualified Data.List as List

66import qualified Data.Map as Map

77import System.Directory

88import System.Exit

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

1515

1616import qualified Build.Utils as Utils

1717import qualified Build.Flags as Flag

18−import qualified Build.Source as Source

18+import qualified Build.Interface as Interface

1919import qualified Build.Print as Print

20+import qualified Build.Source as Source

2021import qualified Generate.JavaScript as JS

21−import qualified InterfaceSerialization as IS

2222import qualified Parse.Module as Parser

2323import qualified SourceSyntax.Module as M

2424

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

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

5858 -> IO (String, M.ModuleInterface)

5959retrieve flags interfaces filePath = do

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

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

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

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

61+ case Interface.isValid filePath iface of

6362 Right (name, interface) ->

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

6564 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

77import qualified Type.Alias as Alias

88import qualified Text.PrettyPrint as P

99

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

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

1111metaTypes interfaces meta =

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

1313

compiler/Build/Source.hs+25−32

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

1+{-# OPTIONS_GHC -W #-}

12module Build.Source (build) where

23

3−import Data.Data

4−import Control.Monad.State

5−import qualified Data.Graph as Graph

6−import qualified Data.List as List

74import qualified Data.Map as Map

85import qualified Data.Set as Set

9−import System.Directory

10−import System.Exit

116import System.FilePath as FP

127import Text.PrettyPrint (Doc)

138

149import SourceSyntax.Declaration

1510import SourceSyntax.Module

1611import qualified SourceSyntax.Expression as Expr

12+import qualified SourceSyntax.Pattern as Pattern

1713import qualified SourceSyntax.Type as Type

1814import qualified Parse.Parse as Parse

1915import qualified Metadata.Prelude as Prelude

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

2319import qualified Type.Constrain.Declaration as TcDecl

2420import qualified Transform.Canonicalize as Canonical

2521

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

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

2723build noPrelude interfaces source =

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

24+ do let add = Prelude.add noPrelude

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

3026 . concatMap iFixities $ Map.elems interfaces

3127

32− 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

37− [] -> return modul

38− ms -> Left ms

28+ Module names exs ims decls <- do

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

30+ case Check.mistakes decls of

31+ [] -> return modul

32+ ms -> Left ms

3933

4034 let exports'

4135 | null exs =

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

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

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

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

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

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

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

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

4640 | otherwise = exs

4741

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

49− names = names,

50− path = FP.joinPath names,

51− exports = exports',

52− imports = ims,

42+ metaModule <- Canonical.metadataModule interfaces $

43+ MetadataModule

44+ { names = names

45+ , path = FP.joinPath names

46+ , exports = exports'

47+ , imports = ims

5348 -- reorder AST into strongly connected components

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

55− types = Map.empty,

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

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

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

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

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

61− }

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

50+ , types = Map.empty

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

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

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

54+ }

6255

6356 types <- TI.infer interfaces metaModule

6457

compiler/Build/Utils.hs+1

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

1+{-# OPTIONS_GHC -W #-}

12module Build.Utils where

23

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

compiler/Compiler.hs+3−3

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

1+{-# OPTIONS_GHC -W #-}

12module Main where

23

34import Control.Monad (foldM)

4−import qualified Data.Map as Map

55import qualified Data.Maybe as Maybe

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

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

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

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

3232build flags rootFile =

3333 do let noPrelude = Flag.no_prelude flags

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

34+ builtIns <- Prelude.interfaces noPrelude

3535

3636 files <- if Flag.make flags

3737 then getSortedDependencies (Flag.src_dir flags) builtIns rootFile

3838 else return [rootFile]

3939

40− (moduleName, interfaces) <-

40+ (moduleName, _) <-

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

4242

4343 js <- foldM appendToOutput BS.empty files

compiler/Docs.hs+18−13

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

1717

1818import SourceSyntax.Helpers (isSymbol)

1919import SourceSyntax.Type (Type(..))

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

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

20+import qualified SourceSyntax.Expression as E

21+import qualified SourceSyntax.Declaration as D

2222

2323import Text.Parsec hiding (newline,spaces)

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

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

7777 structure <- docComment

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

7979

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

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

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

8282

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

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

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

8585 where

8686 uncommentable = do

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

9393 uncommented comment

9494

9595 uncommented comment = do

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

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

9797 return (comment, def, src)

9898

9999

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

121121 where

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

123123 addDefaultInfix name pairs

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

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

125125 | otherwise = pairs

126126

127127 customOps = Map.intersectionWith addInfix infixes types

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

130130

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

132132 case decl of

133− Fixity assoc prec name ->

133+ D.Fixity assoc prec name ->

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

135− Definition (TypeAnnotation name tipe) ->

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

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

137− TypeAlias name vars tipe ->

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

137+ D.TypeAlias name vars tipe derivations ->

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

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

140− Datatype name vars ctors ->

140+ D.Datatype name vars ctors derivations ->

141141 let tipe = Data name (map Var vars)

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

142+ fields = ["typeVariables" .= vars

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

144+ , "deriving" .= derivations ]

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

144146 where

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

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

160162

161163ctorToJson tipe (ctor, tipes) =

162164 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 =

2121

2222{-# NOINLINE interfaces #-}

2323interfaces :: M.Interfaces

24−interfaces = unsafePerformIO $ Prelude.interfaces

24+interfaces = unsafePerformIO $ Prelude.interfaces False

2525

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

2727moduleName :: String -> Maybe String

compiler/Generate/Cases.hs+21−21

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

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

22

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

4−import Control.Arrow (first,second)

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

4+import Control.Arrow (first)

55import Control.Monad.State

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

6+import Data.List (groupBy,sortBy)

77import Data.Maybe (fromMaybe)

88

99import SourceSyntax.Location

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

1313import Transform.Substitute

1414

1515

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

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

1717toMatch patterns = do

1818 v <- newVar

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

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

2323 modify (+1)

2424 return $ "_v" ++ show n

2525

26−data Match t v

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

26+data Match

27+ = Match String [Clause] Match

2828 | Break

2929 | Fail

30− | Other (LExpr t v)

31− | Seq [Match t v]

30+ | Other LExpr

31+ | Seq [Match]

3232 deriving Show

3333

34−data Clause t v =

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

34+data Clause =

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

3636 deriving Show

3737

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

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

3939matchSubst _ Break = Break

4040matchSubst _ Fail = Fail

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

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

4747 clauseSubst (Clause c vs m) =

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

4949

50−isCon (p:ps, e) =

50+isCon (p:_, _) =

5151 case p of

5252 PData _ _ -> True

5353 PLiteral _ -> True

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

5555

5656isVar p = not (isCon p)

5757

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

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

5959match [] [] def = return def

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

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

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

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

7373 _ -> c

7474

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

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

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

7777 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)

7979 where

8080 subOnePattern pattern e =

8181 case pattern of

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

8484 PRecord fs ->

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

8686

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

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

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

8989 where

9090 css = groupBy eq (sortBy cmp cs)

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

106106

107107matchClause :: Either String Literal

108108 -> [String]

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

110− -> Match t v

111− -> State Int (Clause t v)

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

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

110+ -> Match

111+ -> State Int Clause

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

113113 do vs' <- getVars

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

115115 where

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

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

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

126126

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

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

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

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

compiler/Generate/JavaScript.hs+92−114

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

1−{-# OPTIONS -Wall #-}

2−

1+{-# OPTIONS_GHC -W #-}

32module Generate.JavaScript (generate) where

43

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

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

1312import qualified Generate.Markdown as MD

1413import qualified SourceSyntax.Helpers as Help

1514import SourceSyntax.Literal

16−import SourceSyntax.Pattern

15+import SourceSyntax.Pattern as Pattern

1716import SourceSyntax.Location

1817import SourceSyntax.Expression

1918import SourceSyntax.Module

20−import qualified Transform.SortDefinitions as SD

2119import Language.ECMAScript3.Syntax

2220import Language.ECMAScript3.PrettyPrint

2321import qualified Transform.SafeNames as MakeSafe

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

2725 where

2826 go vars str =

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

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

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

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

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

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

3331

3432var name = Id () name

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

4038call = CallExpr ()

4139string = StringLit ()

4240

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

41+dotSep vars =

42+ case vars of

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

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

45+

4446obj = dotSep . split

4547

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

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

5254

5355internalImports name =

5456 VarDeclStmt ()

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

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

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

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

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

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

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

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

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

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

6062 , varDecl "$moduleName" (string name)

6163 ]

6264

6365literal :: Literal -> Expression ()

6466literal lit =

6567 case lit of

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

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

6769 Str s -> string s

6870 IntNum n -> IntLit () n

6971 FloatNum n -> NumLit () n

7072 Boolean b -> BoolLit () b

7173

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

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

7375expression (L span expr) =

7476 case expr of

7577 Var x -> return $ ref x

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

8688

8789 Remove e x ->

8890 do e' <- expression e

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

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

9092

9193 Insert e x v ->

9294 do v' <- expression v

9395 e' <- expression e

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

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

9597

9698 Modify e fs ->

9799 do e' <- expression e

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

99101 v' <- expression v

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

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

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

102104

103105 Record fields ->

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

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

150152 _ -> (func, args)

151153

152154 Let defs e ->

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

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

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

155157 exp <- expression e'

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

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

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

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

196198

197− GLShader uid src ->

199+ GLShader _ src ->

198200 return . literal $ Str src

199201

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

200253

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 ()]

251255match span mtch =

252256 case mtch of

253257 Case.Match name clauses mtch' ->

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

292296 [] -> name

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

294298

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

300+ case expr of

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

302+ _ -> (defs, lexpr)

295303

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

304+generate :: MetadataModule -> String

297305generate unsafeModule =

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

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

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

301309 modul = MakeSafe.metadataModule unsafeModule

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

303311 programStmts =

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

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

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

307− , concatMap jsImport (imports modul)

308− , concatMap importEvent (foreignImports modul)

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

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

311− , map exportEvent $ foreignExports modul

312− , [ jsExports ]

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

314− ]

312+ concat

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

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

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

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

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

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

319+ , [ jsExports ]

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

321+ ]

315322

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

317324 where

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

324331 _ -> ExprStmt () $

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

326333

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

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

328335 where

329336 path = split modul

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

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

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

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

338345

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−

365346binop span op e1 e2 =

366347 case op of

367348 "Basics.." ->

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

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

389370 _ -> es ++ [e]

390371

391− js1 = expression e1

392− js2 = expression e2

393−

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

395373 | otherwise = dotSep parts

396374 where

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

414392 specialOps = concat

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

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

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

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

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

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

419397 , specialOp "<" $ cmp OpLT 0

420398 , specialOp ">" $ cmp OpGT 0

421399 , specialOp "<=" $ cmp OpLT 1

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

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

424402 ]

425403

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 @@

11module Generate.Noscript (noscript) where

22

33import Data.List (isInfixOf)

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

4+import qualified SourceSyntax.Declaration as D

55import SourceSyntax.Expression

66import SourceSyntax.Literal

77import SourceSyntax.Location

88import SourceSyntax.Module

99import qualified Generate.Markdown as MD

1010

11−noscript :: Module t v -> String

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

1212noscript modul = concat (extract modul)

1313

1414class Extract a where

1515 extract :: a -> [String]

1616

17−instance Extract (Module t v) where

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

1818 extract (Module _ _ _ stmts) =

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

2020

21−instance Extract (Declaration t v) where

22− extract (Definition d) = extract d

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

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

2323 extract _ = []

2424

25−instance Extract (Def t v) where

26− extract (Def _ e) = extract e

27− extract _ = []

25+instance Extract Def where

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

2827

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

3029 extract (L _ e) = extract e

3130

32−instance Extract (Expr t v) where

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

3332 extract expr =

3433 let f = extract in

3534 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 #-}

12module Metadata.Prelude (interfaces, add) where

23

34import qualified Data.Map as Map

45import qualified Control.Exception as E

56import qualified Paths_Elm as Path

6−import System.Directory

77import System.Exit

8−import System.FilePath

98import System.IO

109import SourceSyntax.Module

11−import qualified Data.Binary as Binary

12−import qualified Data.ByteString.Lazy as BS

10+import qualified Build.Interface as Interface

1311

14−import qualified InterfaceSerialization as IS

15−

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

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

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

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

1814 where

19− customIms = concatMap addModule prelude

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

2016

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

2218 Nothing -> [(n, method)]

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

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

2420 Just _ -> []

2521

2622prelude :: [(String, ImportMethod)]

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

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

2824 where

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

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

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

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

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

3229

33−interfaces :: IO Interfaces

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

30+interfaces :: Bool -> IO Interfaces

31+interfaces noPrelude =

32+ if noPrelude

33+ then return $ Map.empty

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

3535

3636safeReadDocs :: FilePath -> IO Interfaces

3737safeReadDocs name =

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

3939 let _ = err :: IOError

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

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

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

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

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

40+ hPutStrLn stderr $ unlines $

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

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

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

44+ , " Elm and your OS." ]

4545 exitFailure

4646

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−

5447readDocs :: FilePath -> IO Interfaces

5548readDocs filePath = do

56− bytes <- IS.loadInterface filePath

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

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

49+ interfaces <- Interface.load filePath

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

51+ Left err -> do

6752 hPutStrLn stderr err

6853 exitFailure

6954

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

55+ Right [] -> do

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

57+ exitFailure

58+

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

compiler/Parse/Binop.hs+15−16

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

11module Parse.Binop (binops, OpTable) where

22

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

4−import Control.Monad.Error

54import Data.List (intercalate)

65import qualified Data.Map as Map

76

87import SourceSyntax.Location (merge)

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

8+import qualified SourceSyntax.Expression as E

109import SourceSyntax.Declaration (Assoc(..))

1110import Text.Parsec

1211import Parse.Helpers

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

1716opAssoc :: OpTable -> String -> Assoc

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

1918

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

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

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

2221

23−binops :: IParser (LExpr t v)

24− -> IParser (LExpr t v)

22+binops :: IParser E.LParseExpr

23+ -> IParser E.LParseExpr

2524 -> IParser String

26− -> IParser (LExpr t v)

25+ -> IParser E.LParseExpr

2726binops term last anyOp =

2827 do e <- term

2928 table <- getState

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

3938

4039split :: OpTable

4140 -> Int

42− -> LExpr t v

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

44− -> IParser (LExpr t v)

41+ -> E.LParseExpr

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

43+ -> IParser E.LParseExpr

4544split _ _ e [] = return e

4645split table n e eops = do

4746 assoc <- getAssoc table n eops

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

5049 case assoc of R -> joinR es ops

5150 _ -> joinL es ops

5251

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

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

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

53+ -> [IParser E.LParseExpr]

5554splitLevel table n e eops =

5655 case break (hasLevel table n) eops of

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

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

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

6059

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

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

6261joinL [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

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

6564

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

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

6766joinR [e] [] = return e

6867joinR (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))

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

7170

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

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

7372getAssoc table n eops

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

7574 | 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 #-}

22module Parse.Declaration where

33

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

5−import qualified Data.List as List

6−import qualified Data.Set as Set

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

75import Text.Parsec hiding (newline,spaces)

8−import Text.Parsec.Indent

96

107import Parse.Helpers

118import qualified Parse.Expression as Expr

12−import qualified SourceSyntax.Type as T

139import qualified Parse.Type as Type

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

10+import qualified SourceSyntax.Declaration as D

1511

1612

17−declaration :: IParser (Declaration t v)

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

13+declaration :: IParser D.ParseDeclaration

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

1915

20−definition :: IParser (Declaration t v)

21−definition = Definition <$> Expr.def

16+definition :: IParser D.ParseDeclaration

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

2218

23−alias :: IParser (Declaration t v)

19+alias :: IParser D.ParseDeclaration

2420alias = do

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

2622 forcedWS

27− alias <- capVar

28− args <- spacePrefix lowVar

23+ name <- capVar

24+ args <- spacePrefix lowVar

2925 padded equals

3026 tipe <- Type.expr

31− return (TypeAlias alias args tipe)

27+ json <- option [] $ do

28+ try $ padded (reserved "deriving")

29+ string "Json"

30+ return [D.Json]

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

3232

33−datatype :: IParser (Declaration t v)

33+datatype :: IParser D.ParseDeclaration

3434datatype = do

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

3636 forcedWS

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

3838 args <- spacePrefix lowVar

3939 padded equals

4040 tcs <- pipeSep1 Type.constructor

41− return $ Datatype name args tcs

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

4242

4343

44−infixDecl :: IParser (Declaration t v)

44+infixDecl :: IParser D.ParseDeclaration

4545infixDecl = do

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

47− , reserved "infix" >> return N

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

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

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

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

4949 forcedWS

5050 n <- digit

5151 forcedWS

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

53−

54−

55−foreignDef :: IParser (Declaration t v)

56−foreignDef = do

57− try (reserved "foreign")

58− whitespace

59− importEvent <|> exportEvent

60−

61−exportEvent :: IParser (Declaration t v)

62−exportEvent = do

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

64− eventName <- jsVar

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"]

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

53+

54+

55+port :: IParser D.ParseDeclaration

56+port =

57+ do try (reserved "port")

58+ whitespace

59+ name <- lowVar

60+ whitespace

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

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

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

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

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

22

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

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

54import Data.List (foldl')

65import Text.Parsec hiding (newline,spaces)

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

1615import SourceSyntax.Pattern hiding (tuple,list)

1716import qualified SourceSyntax.Literal as Literal

1817import SourceSyntax.Expression

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

2018

2119

2220-------- Basic Terms --------

2321

24−varTerm :: IParser (Expr t v)

22+varTerm :: IParser ParseExpr

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

2624

27−toVar :: String -> Expr t v

25+toVar :: String -> ParseExpr

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

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

3028 _ -> Var v

3129

32−accessor :: IParser (Expr t v)

30+accessor :: IParser ParseExpr

3331accessor = do

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

3533 let loc e = Location.at start end e

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

3735

38−negative :: IParser (Expr t v)

36+negative :: IParser ParseExpr

3937negative = do

4038 (start, nTerm, end) <-

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

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

4543

4644-------- Complex Terms --------

4745

48−listTerm :: IParser (Expr t v)

46+listTerm :: IParser ParseExpr

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

5048 where

5149 range = do

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

7472 string "}}"

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

7674

77−parensTerm :: IParser (LExpr t v)

75+parensTerm :: IParser LParseExpr

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

7977 where

8078 opFn = do

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

9795 [e] -> e

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

9997

100−recordTerm :: IParser (LExpr t v)

98+recordTerm :: IParser LParseExpr

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

102100 where field = do

103101 label <- rLabel

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

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

131129

132130

133−term :: IParser (LExpr t v)

131+term :: IParser LParseExpr

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

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

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

137135

138136-------- Applications --------

139137

140−appExpr :: IParser (LExpr t v)

138+appExpr :: IParser LParseExpr

141139appExpr = do

142140 t <- term

143141 ts <- constrainedSpacePrefix term $ \str ->

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

148146

149147-------- Normal Expressions --------

150148

151−binaryExpr :: IParser (LExpr t v)

149+binaryExpr :: IParser LParseExpr

152150binaryExpr = binops appExpr lastExpr anyOp

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

154152 <|> lambdaExpr

155153

156−ifExpr :: IParser (Expr t v)

154+ifExpr :: IParser ParseExpr

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

158156 where

159157 normal = do

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

169167 b <- expr ; padded arrow

170168 (,) b <$> expr

171169

172−lambdaExpr :: IParser (LExpr t v)

170+lambdaExpr :: IParser LParseExpr

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

174172 whitespace

175173 args <- spaceSep1 Pattern.term

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

177175 body <- expr

178176 return (makeFunction args body)

179177

180−defSet :: IParser [Def t v]

178+defSet :: IParser [ParseDef]

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

182180

183−letExpr :: IParser (Expr t v)

181+letExpr :: IParser ParseExpr

184182letExpr = do

185183 reserved "let" ; whitespace

186184 defs <- defSet

187185 padded (reserved "in")

188186 Let defs <$> expr

189187

190−caseExpr :: IParser (Expr t v)

188+caseExpr :: IParser ParseExpr

191189caseExpr = do

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

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

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

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

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

199197

198+expr :: IParser LParseExpr

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

201200 <|> lambdaExpr

202201 <|> binaryExpr

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

212211 where

213212 func pattern =

214213 case pattern of

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

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

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

217216 return [pattern]

218217

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

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

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

224223

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

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

226225makeFunction args body@(L s _) =

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

228227

229−definition :: IParser (Def t v)

228+definition :: IParser ParseDef

230229definition = withPos $ do

231230 (name:args) <- defStart

232231 padded equals

233232 body <- expr

234233 return . Def name $ makeFunction args body

235234

236−typeAnnotation :: IParser (Def t v)

235+typeAnnotation :: IParser ParseDef

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

238237 where

239238 start = do

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

241240 padded hasType

242241 return v

243242

244−def :: IParser (Def t v)

243+def :: IParser ParseDef

245244def = typeAnnotation <|> definition

compiler/Parse/Helpers.hs+2−2

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

2525 , "module", "where"

2626 , "import", "as", "hiding", "open"

2727 , "export", "foreign"

28− , "deriving" ]

28+ , "deriving", "port" ]

2929

3030jsReserveds :: Set.Set String

3131jsReserveds = Set.fromList

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

209209 end <- getPosition

210210 return (start, e, end)

211211

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

212+accessible :: IParser LParseExpr -> IParser LParseExpr

213213accessible expr = do

214214 start <- getPosition

215215 ce@(L _ e) <- expr

compiler/Parse/Literal.hs+3−4

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

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

12module Parse.Literal (literal) where

23

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

4−import Control.Monad

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

55import Text.Parsec hiding (newline,spaces)

6−import Text.Parsec.Indent

7−

86import Parse.Helpers

97import SourceSyntax.Literal

108

9+literal :: IParser Literal

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

1211

1312num :: IParser Literal

compiler/Parse/Module.hs+1−2

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

1−

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

32

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

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

65import Text.Parsec hiding (newline,spaces)

76

87import Parse.Helpers

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

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

109

1110varList :: IParser [String]

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

compiler/Parse/Parse.hs+23−20

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

1+{-# OPTIONS_GHC -W #-}

12module Parse.Parse (program, dependencies) where

23

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

4−import Control.Monad

5−import Data.Char (isSymbol, isDigit)

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

5+import qualified Data.List as List

76import qualified Data.Map as Map

87import Text.Parsec hiding (newline,spaces)

98import qualified Text.PrettyPrint as P

109

11−import qualified SourceSyntax.Module as S

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

10+import qualified SourceSyntax.Declaration as D

11+import qualified SourceSyntax.Module as M

1312import Parse.Helpers

14−import Parse.Binop (OpTable)

15−import Parse.Expression

1613import Parse.Declaration (infixDecl)

17−import Parse.Type

1814import Parse.Module

1915import qualified Parse.Declaration as Decl

16+import Transform.Declaration (combineAnnotations)

2017

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

2219 freshLine

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

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

2623 (d:) <$> many freshDef

2724

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

29−program table = setupParserWithTable table $ do

30− optional freshLine

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

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

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

34− declarations <- decls

35− optional freshLine ; optional spaces ; eof

36− return $ S.Module names exports is declarations

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

26+program table src =

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 =

33+ do optional freshLine

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

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

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

37+ declarations <- decls

38+ optional freshLine ; optional spaces ; eof

39+ return $ M.Module names exports is declarations

3740

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

3942dependencies =

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

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

4144 setupParser $ do

4245 optional freshLine

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

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

5659 msg overlap =

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

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

59− intercalate " " (Map.keys overlap)

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

6063 ]

6164

6265parseFixities = do

6366 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 ]

6568

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

6770setupParser p source =

compiler/Parse/Pattern.hs+6−8

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

1−

1+{-# OPTIONS_GHC -W #-}

22module Parse.Pattern (term, expr) where

33

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

5−import Control.Monad

6−import Control.Monad.State

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

75import Data.Char (isUpper)

86import Data.List (intercalate)

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

10−import Text.Parsec.Indent

118

129import Parse.Helpers

1310import Parse.Literal

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

2017 [ char '_' >> return PAnything

2118 , do v <- var

2219 return $ case v of

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

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

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

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

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

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

23+ _ -> PVar v

2624 , PLiteral <$> literal

2725 ]

2826

compiler/Parse/Type.hs+3−4

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

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

12module Parse.Type where

23

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

4−import Control.Monad (liftM,mapM)

5−import Data.Char (isLower)

6−import Data.List (lookup,intercalate)

5+import Data.List (intercalate)

76import Text.Parsec

8−import Text.Parsec.Indent

97

108import SourceSyntax.Type as T

119import Parse.Helpers

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

4240 whitespace >> hasType >> whitespace

4341 (,) lbl <$> expr

4442

43+capTypeVar :: IParser String

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

4645

4746constructor0 :: IParser T.Type

compiler/SourceSyntax/Declaration.hs+99−20

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

1+{-# OPTIONS_GHC -Wall #-}

12module SourceSyntax.Declaration where

23

4+import Data.Binary

35import qualified SourceSyntax.Expression as Expr

4−import SourceSyntax.Type

6+import qualified SourceSyntax.Type as T

57import SourceSyntax.PrettyPrint

68import Text.PrettyPrint as P

79

8−data Declaration tipe var

9− = Definition (Expr.Def tipe var)

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

11− | TypeAlias String [String] Type

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

13− | ExportEvent String String Type

10+data Declaration' port def

11+ = Definition def

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

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

14+ | Port port

1415 | Fixity Assoc Int String

15− deriving (Eq, Show)

16+ deriving (Show)

1617

1718data 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

1954

2055instance Show Assoc where

2156 show assoc =

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

2459 N -> "non"

2560 R -> "right"

2661

27−instance Pretty (Declaration t v) where

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+

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

2873 pretty decl =

2974 case decl of

3075 Definition def -> pretty def

3176

32− Datatype tipe tvars ctors ->

77+ Datatype tipe tvars ctors deriveables ->

3378 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

3580 where

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

3782 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 ]

39116

40− TypeAlias name tvars tipe ->

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

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

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

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

43119

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

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

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

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

120+prettyDeriving :: [Derivation] -> Doc

121+prettyDeriving deriveables =

122+ case deriveables of

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 #-}

12module SourceSyntax.Expression where

23

3−import Data.List (intercalate)

44import SourceSyntax.PrettyPrint

55import Text.PrettyPrint as P

66import qualified SourceSyntax.Helpers as Help

77import qualified SourceSyntax.Location as Location

88import qualified SourceSyntax.Pattern as Pattern

9−import qualified SourceSyntax.Type as Type

9+import qualified SourceSyntax.Type as SrcType

1010import qualified SourceSyntax.Literal as Literal

11+import qualified Type.Type as Type

1112

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

13−data Expr t v

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

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

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

1432 = Literal Literal.Literal

1533 | Var String

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

17− | ExplicitList [LExpr t v]

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

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

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

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

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

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

24− | Data String [LExpr t v]

25− | Access (LExpr t v) String

26− | Remove (LExpr t v) String

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

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

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

30− | Markdown String String [LExpr t v]

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

35+ | ExplicitList [LExpr' def]

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

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

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

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

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

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

42+ | Data String [LExpr' def]

43+ | Access (LExpr' def) String

44+ | Remove (LExpr' def) String

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

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

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

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)

3152 | 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)

3853

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

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

4075

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

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

4278delist _ = []

4379

80+saveEnvName :: String

4481saveEnvName = "_save_the_environment!!!"

4582

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

4684dummyLet defs =

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

4886

49−instance Show (Expr t v) where

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

5088 show = render . pretty

5189

52−instance Pretty (Expr t v) where

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

5391 pretty expr =

5492 case expr of

5593 Literal lit -> pretty lit

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

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

75113 where

76114 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

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

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

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

81119 Access e x -> prettyParens e <> P.text "." <> variable x

82120 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)

83121 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)

85123 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)

87125

88126 Modify e fs ->

89127 P.braces $ P.hang (pretty e <+> P.text "|")

90128 4

91129 (commaSep $ map field fs)

92130 where

93− field (x,e) = variable x <+> P.text "<-" <+> pretty e

131+ field (k,v) = variable k <+> P.text "<-" <+> pretty v

94132

95133 Record fs ->

96134 P.braces $ P.nest 2 (commaSep $ map field fs)

97135 where

98− field (x,e) = variable x <+> P.text "=" <+> pretty e

136+ field (x,e) = variable x <+> P.equals <+> pretty e

99137

100138 Markdown _ _ _ -> P.text "[markdown| ... |]"

101139

102−instance Pretty (Def t v) where

140+ GLShader _ _ -> P.text "[glShader| ... |]"

141+

142+ PortIn _ _ _ handler -> pretty handler

143+

144+ PortOut _ _ signal -> pretty signal

145+

146+instance Pretty ParseDef where

103147 pretty def =

104148 case def of

105149 TypeAnnotation name tipe ->

106− variable name <+> P.text ":" <+> pretty tipe

150+ variable name <+> P.colon <+> pretty tipe

107151 Def pattern expr ->

108− pretty pattern <+> P.text "=" <+> pretty expr

109−

152+ pretty pattern <+> P.equals <+> pretty expr

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]

110164collectApps lexpr@(Location.L _ expr) =

111165 case expr of

112166 App a b -> collectApps a ++ [b]

113167 _ -> [lexpr]

114168

169+collectLambdas :: LExpr' def -> ([Doc], LExpr' def)

115170collectLambdas lexpr@(Location.L _ expr) =

116171 case expr of

117172 Lambda pattern body ->

@@ -119,6 +174,7 @@ collectLambdas lexpr@(Location.L _ expr) =

119174 in (pretty pattern : ps, body')

120175 _ -> ([], lexpr)

121176

177+prettyParens :: (Pretty def) => LExpr' def -> Doc

122178prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

123179 where

124180 needed =

@@ -129,5 +185,5 @@ prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

129185 MultiIf _ -> True

130186 Let _ _ -> True

131187 Case _ _ -> True

132− Data name (x:xs) -> name /= "::"

188+ Data name (_:_) -> name /= "::"

133189 _ -> False

compiler/SourceSyntax/Helpers.hs+1−1

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

1−

1+{-# OPTIONS_GHC -Wall #-}

22module SourceSyntax.Helpers where

33

44import qualified Data.Char as Char

compiler/SourceSyntax/Literal.hs+1

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

1+{-# OPTIONS_GHC -Wall #-}

12module SourceSyntax.Literal where

23

34import SourceSyntax.PrettyPrint

compiler/SourceSyntax/Module.hs+28−43

@@ -1,21 +1,18 @@

1+{-# OPTIONS_GHC -Wall #-}

12module SourceSyntax.Module where

23

34import Data.Binary

4−import Data.List (intercalate)

55import qualified Data.Map as Map

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

7−import Control.Arrow (second)

87

98import SourceSyntax.Expression (LExpr)

109import SourceSyntax.Declaration

1110import SourceSyntax.Type

12−import System.FilePath (joinPath)

13−import Control.Monad (liftM)

1411

1512import qualified Elm.Internal.Version as Version

1613

17−data Module tipe var =

18− Module [String] Exports Imports [Declaration tipe var]

14+data Module def =

15+ Module [String] Exports Imports [def]

1916 deriving (Show)

2017

2118type Exports = [String]

@@ -25,48 +22,47 @@ data ImportMethod = As String | Importing [String] | Hiding [String]

2522 deriving (Eq, Ord, Show)

2623

2724instance Binary ImportMethod where

28− put (As s) = do put (0 :: Word8)

29− put s

30−

31− put (Importing ss) = do put (1 :: Word8)

32− put ss

33−

34− put (Hiding ss) = do put (2 :: Word8)

35− put ss

25+ put method =

26+ let put' n info = putWord8 n >> put info in

27+ case method of

28+ As s -> put' 0 s

29+ Importing ss -> put' 1 ss

30+ Hiding ss -> put' 2 ss

3631

3732 get = do tag <- getWord8

3833 case tag of

39− 0 -> liftM As get

40− 1 -> liftM Importing get

41− 2 -> liftM Hiding get

34+ 0 -> As <$> get

35+ 1 -> Importing <$> get

36+ 2 -> Hiding <$> get

4237 _ -> error "Error reading valid ImportMethod type from serialized string"

4338

44−data MetadataModule t v = MetadataModule {

45− names :: [String],

46− path :: FilePath,

47− exports :: [String],

48− imports :: [(String, ImportMethod)],

49− program :: LExpr t v,

50− types :: Map.Map String Type,

51− fixities :: [(Assoc, Int, String)],

52− aliases :: [(String, [String], Type)],

53− datatypes :: [ (String, [String], [(String,[Type])]) ],

54− foreignImports :: [(String, LExpr t v, String, Type)],

55− foreignExports :: [(String, String, Type)]

56−} deriving Show

39+data MetadataModule =

40+ MetadataModule

41+ { names :: [String]

42+ , path :: FilePath

43+ , exports :: [String]

44+ , imports :: [(String, ImportMethod)]

45+ , program :: LExpr

46+ , types :: Map.Map String Type

47+ , fixities :: [(Assoc, Int, String)]

48+ , aliases :: [Alias]

49+ , datatypes :: [ADT]

50+ } deriving Show

5751

5852type 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])

6055

6156data ModuleInterface = ModuleInterface {

6257 iVersion :: Version.Version,

6358 iTypes :: Map.Map String Type,

6459 iImports :: [(String, ImportMethod)],

6560 iAdts :: [ADT],

66− iAliases :: [(String, [String], Type)],

61+ iAliases :: [Alias],

6762 iFixities :: [(Assoc, Int, String)]

6863} deriving Show

6964

65+metaToInterface :: MetadataModule -> ModuleInterface

7066metaToInterface metaModule =

7167 ModuleInterface

7268 { iVersion = Version.elmVersion

@@ -86,14 +82,3 @@ instance Binary ModuleInterface where

8682 put (iAdts modul)

8783 put (iAliases modul)

8884 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 #-}

12module SourceSyntax.Pattern where

23

3−import Data.List (intercalate)

44import SourceSyntax.Helpers as Help

55import SourceSyntax.PrettyPrint

66import Text.PrettyPrint as PP

7+import qualified Data.Set as Set

78import SourceSyntax.Literal as Literal

89

910data Pattern = PData String [Pattern]

@@ -14,11 +15,28 @@ data Pattern = PData String [Pattern]

1415 | PLiteral Literal.Literal

1516 deriving (Eq, Ord, Show)

1617

18+cons :: Pattern -> Pattern -> Pattern

1719cons h t = PData "::" [h,t]

18−nil = PData "[]" []

20+

21+nil :: Pattern

22+nil = PData "[]" []

23+

24+list :: [Pattern] -> Pattern

1925list = foldr cons nil

26+

27+tuple :: [Pattern] -> Pattern

2028tuple es = PData ("_Tuple" ++ show (length es)) es

2129

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+

2240

2341instance Pretty Pattern where

2442 pretty pattern =

@@ -37,6 +55,7 @@ instance Pretty Pattern where

3755 PP.parens . commaCat $ map pretty ps

3856 else hsep (PP.text name : map prettyParens ps)

3957

58+prettyParens :: Pattern -> Doc

4059prettyParens pattern = parensIf needsThem (pretty pattern)

4160 where

4261 needsThem =

compiler/SourceSyntax/Type.hs+5−1

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

1+{-# OPTIONS_GHC -Wall #-}

12module SourceSyntax.Type where

23

34import Data.Binary

@@ -31,7 +32,7 @@ tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

3132instance Pretty Type where

3233 pretty tipe =

3334 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) ]

3536 where t:ts = collectLambdas tipe

3637 Var x -> P.text x

3738 Data "_List" [t] -> P.brackets (pretty t)

@@ -47,12 +48,14 @@ instance Pretty Type where

4748 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

4849 prettyFields = commaSep . map prettyField $ fields

4950

51+collectLambdas :: Type -> [Doc]

5052collectLambdas tipe =

5153 case tipe of

5254 Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body

5355 Lambda arg body -> pretty arg : collectLambdas body

5456 _ -> [pretty tipe]

5557

58+collectRecords :: Type -> ([(String,Type)], Type)

5659collectRecords = go []

5760 where

5861 go fields tipe =

@@ -60,6 +63,7 @@ collectRecords = go []

6063 Record fs ext -> go (fs ++ fields) ext

6164 _ -> (fields, tipe)

6265

66+prettyParens :: Type -> Doc

6367prettyParens tipe = parensIf needed (pretty tipe)

6468 where

6569 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−

2−{-# OPTIONS -Wall #-}

3−

1+{-# OPTIONS_GHC -W #-}

42module Transform.Canonicalize (interface, metadataModule) where

53

64import Control.Arrow ((***))

5+import Control.Applicative (Applicative,(<$>),(<*>))

76import Control.Monad.Identity

87import qualified Data.Map as Map

98import qualified Data.Set as Set

@@ -12,10 +11,8 @@ import qualified Data.Either as Either

1211import SourceSyntax.Module

1312import SourceSyntax.Expression

1413import SourceSyntax.Location as Loc

15−import SourceSyntax.Pattern

16−import SourceSyntax.Helpers (isOp)

14+import qualified SourceSyntax.Pattern as P

1715import qualified SourceSyntax.Type as Type

18−import qualified Transform.SortDefinitions as SD

1916import Text.PrettyPrint as P

2017

2118interface :: String -> ModuleInterface -> ModuleInterface

@@ -29,11 +26,11 @@ interface moduleName iface =

2926 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

3027 }

3128 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)

3330 prefix name = moduleName ++ "." ++ name

3431

3532 pair name = (name, moduleName ++ "." ++ name)

36− canon (name,_,_) = pair name

33+ canon (name,_,_,_) = pair name

3734 canons = Map.fromList $ concat

3835 [ map canon (iAdts iface), map canon (iAliases iface) ]

3936

@@ -42,48 +39,41 @@ interface moduleName iface =

4239 renameType' =

4340 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

4441

45−renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type

46−renameType rename tipe =

47− let rnm = renameType rename in

42+renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

43+renameType renamer tipe =

44+ let rnm = renameType renamer in

4845 case tipe of

49− Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b

50− Type.Var x -> return tipe

51− Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts

46+ Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

47+ Type.Var _ -> return tipe

48+ Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

5249 Type.EmptyRecord -> return tipe

53− Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext

54− where rnm' (f,t) = (,) f `liftM` rnm t

50+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext

51+ where rnm' (f,t) = (,) f <$> rnm t

5552

56−metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)

53+metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

5754metadataModule ifaces modul =

58− do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

59− [] -> Right ()

60− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

55+ do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

56+ [] -> Right ()

57+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

6158 program' <- rename initialEnv (program modul)

62− aliases' <- mapM (third renameType') (aliases modul)

63− datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)

64− exports' <- mapM (third renameType') (foreignExports modul)

65− imports' <- mapM (twoAndFour (rename initialEnv) renameType') (foreignImports modul)

59+ aliases' <- mapM (three4 renameType') (aliases modul)

60+ datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)

6661 return $ modul { program = program'

6762 , aliases = aliases'

68− , datatypes = datatypes'

69− , foreignExports = exports'

70− , foreignImports = imports' }

63+ , datatypes = datatypes' }

7164 where

72− second f (a,b) = (,) a `fmap` 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')

65+ two2 f (a,b) = (,) a <$> f b

66+ three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d

7767 renameType' =

7868 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

7969

80− get1 (a,_,_) = a

70+ get1 (a,_,_,_) = a

8171 canon (name, importMethod) =

8272 let pair pre var = (pre ++ drop (length name + 1) var, var)

8373 iface = ifaces Map.! name

8474 allNames = concat [ Map.keys (iTypes iface)

8575 , map get1 (iAliases iface)

86− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

76+ , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]

8777 in case importMethod of

8878 As alias -> map (pair (alias ++ ".")) allNames

8979 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

@@ -91,18 +81,19 @@ metadataModule ifaces modul =

9181 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

9282 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

9383

94− pair n = (n,n)

95− localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))

96− globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

97− map (\n -> "_Tuple" ++ show n) [0..9]

84+ two n = (n,n)

85+ localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))

86+ globalEnv =

87+ map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

88+ map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

9889 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

9990 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

10091

10192type Env = Map.Map String String

10293

103−extend :: Env -> Pattern -> Env

94+extend :: Env -> P.Pattern -> Env

10495extend 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)

10697

10798

10899replace :: String -> Env -> String -> Either String String

@@ -116,77 +107,82 @@ replace variable env v =

116107 msg = if null matches then "" else

117108 "\nClose matches include: " ++ List.intercalate ", " matches

118109

119−rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)

120−rename env lexpr@(L s expr) =

110+rename :: Env -> LExpr -> Either [Doc] LExpr

111+rename env (L s expr) =

121112 let rnm = rename env

122113 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

123114 format = Either.either throw return

115+ renameType' env = renameType (format . replace "variable" env)

124116 in

125− L s `liftM`

117+ L s <$>

126118 case expr of

127− Literal lit -> return expr

119+ Literal _ -> return expr

128120

129− Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2

121+ Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

130122

131− Access e x -> Access `liftM` rnm e `ap` return x

123+ Access e x -> Access <$> rnm e <*> return x

132124

133− Remove e x -> flip Remove x `liftM` rnm e

125+ Remove e x -> flip Remove x <$> rnm e

134126

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

136128

137129 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

139131

140− Record fs -> Record `liftM` mapM frnm fs

141− where

142− frnm (f,e) = (,) f `liftM` rename env e

132+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs

143133

144134 Binop op e1 e2 ->

145135 do op' <- format (replace "variable" env op)

146− Binop op' `liftM` rnm e1 `ap` rnm e2

136+ Binop op' <$> rnm e1 <*> rnm e2

147137

148138 Lambda pattern e ->

149139 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

151141

152− App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2

142+ App e1 e2 -> App <$> rnm e1 <*> rnm e2

153143

154− MultiIf ps -> MultiIf `liftM` mapM grnm ps

155− where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e

144+ MultiIf ps -> MultiIf <$> mapM grnm ps

145+ where grnm (b,e) = (,) <$> rnm b <*> rnm e

156146

157− Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e

147+ Let defs e -> Let <$> mapM rename' defs <*> rename env' e

158148 where

159− env' = foldl extend env [ pattern | Def pattern _ <- defs ]

160− rename' def =

161− case def of

162− Def p exp ->

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

149+ env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

150+ rename' (Definition p body mtipe) =

151+ Definition <$> format (renamePattern env' p)

152+ <*> rename env' body

153+ <*> case mtipe of

154+ Nothing -> return Nothing

155+ Just tipe -> Just <$> renameType' env' tipe

167156

168− Var x -> Var `liftM` format (replace "variable" env x)

157+ Var x -> Var <$> format (replace "variable" env x)

169158

170− Data name es -> Data name `liftM` mapM rnm es

159+ Data name es -> Data name <$> mapM rnm es

171160

172− ExplicitList es -> ExplicitList `liftM` mapM rnm es

161+ ExplicitList es -> ExplicitList <$> mapM rnm es

173162

174− Case e cases -> Case `liftM` rnm e `ap` mapM branch cases

163+ Case e cases -> Case <$> rnm e <*> mapM branch cases

175164 where

176− branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)

177− `ap` rename (extend env pattern) e

165+ branch (pattern,b) = (,) <$> format (renamePattern env pattern)

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'

178174

179− Markdown uid md es -> Markdown uid md `liftM` mapM rnm es

175+ PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

180176

181177 GLShader _ _ -> return expr

182178

183−renamePattern :: Env -> Pattern -> Either String Pattern

179+renamePattern :: Env -> P.Pattern -> Either String P.Pattern

184180renamePattern env pattern =

185181 case pattern of

186− PVar _ -> return pattern

187− PLiteral _ -> return pattern

188− PRecord _ -> return pattern

189− PAnything -> return pattern

190− PAlias x p -> PAlias x `liftM` renamePattern env p

191− PData name ps -> PData `liftM` replace "pattern" env name

192− `ap` mapM (renamePattern env) ps

182+ P.PVar _ -> return pattern

183+ P.PLiteral _ -> return pattern

184+ P.PRecord _ -> return pattern

185+ P.PAnything -> return pattern

186+ P.PAlias x p -> P.PAlias x <$> renamePattern env p

187+ P.PData name ps -> P.PData <$> replace "pattern" env name

188+ <*> mapM (renamePattern env) ps

compiler/Transform/Check.hs+81−86

@@ -1,106 +1,99 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Transform.Check (mistakes) where

23

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

11−import qualified Data.Map as Map

4+import qualified Data.List as List

125import qualified Data.Maybe as Maybe

136import 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

1415import Text.PrettyPrint as P

1516

1617

17−mistakes :: [Declaration t v] -> [Doc]

18+mistakes :: [D.Declaration] -> [Doc]

1819mistakes decls =

1920 concat [ infiniteTypeAliases decls

2021 , illFormedTypes decls

2122 , map P.text (duplicateConstructors decls)

22− , map P.text (concatMap findErrors (getLets decls)) ]

23− where

24− findErrors defs = duplicates defs ++ badOrder defs

23+ , map P.text (duplicates decls)

24+ , badDerivations decls ]

2525

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]

57−dups = map head . filter ((>1) . length) . List.group

26+dups :: Ord a => [a] -> [a]

27+dups = map head . filter ((>1) . length) . List.group . List.sort

5828

5929dupErr :: String -> String -> String

6030dupErr err x =

6131 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

6232

63−duplicates :: [Def t v] -> [String]

64−duplicates defs =

65− map defMsg (dups definitions) ++ map annMsg (dups annotations)

66− where

67− annotations = List.sort [ name | TypeAnnotation name _ <- defs ]

68− definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]

69− defMsg = dupErr "definition of"

70− annMsg = dupErr "type annotation for"

33+duplicates :: [D.Declaration] -> [String]

34+duplicates decls =

35+ map msg (dups (portNames ++ concatMap getNames defPatterns)) ++

36+ case mapM exprDups (portExprs ++ defExprs) of

37+ Left name -> [msg name]

38+ Right _ -> []

7139

72−duplicateConstructors :: [Declaration t v] -> [String]

73−duplicateConstructors decls =

74− map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

7540 where

76− typeCtors = List.sort [ name | Datatype name _ _ <- decls ]

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."

41+ msg = dupErr "definition of"

8742

88− go defs =

89− case defs of

90− TypeAnnotation name _ : Def (PVar name') _ : rest

91− | name == name' -> go rest

43+ (defPatterns, defExprs) =

44+ unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

9245

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)

9451

95− _ : rest -> go rest

52+ getNames = Set.toList . Pattern.boundVars

9653

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]

9783 _ -> []

9884

99−illFormedTypes :: [Declaration t v] -> [Doc]

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+

92+illFormedTypes :: [D.Declaration] -> [Doc]

10093illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

10194 where

102− aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]

103− adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]

95+ aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]

96+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]

10497

10598 freeVars tipe =

10699 case tipe of

@@ -132,7 +125,7 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

132125

133126 addCommas xs

134127 | length xs < 3 = concat xs

135− | otherwise = intercalate "," xs

128+ | otherwise = List.intercalate "," xs

136129

137130 addAnd xs

138131 | length xs < 2 = xs

@@ -141,12 +134,13 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

141134 quote tvar = "'" ++ tvar ++ "'"

142135

143136

144−infiniteTypeAliases :: [Declaration t v] -> [Doc]

137+infiniteTypeAliases :: [D.Declaration] -> [Doc]

145138infiniteTypeAliases 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 ]

147141 where

148− isInfinite name tipe =

149− let infinite = isInfinite name in

142+ infiniteType name tipe =

143+ let infinite = infiniteType name in

150144 case tipe of

151145 T.Lambda a b -> infinite a || infinite b

152146 T.Var _ -> False

@@ -154,16 +148,17 @@ infiniteTypeAliases decls =

154148 T.EmptyRecord -> False

155149 T.Record fields ext -> infinite ext || any (infinite . snd) fields

156150

157− report decl@(TypeAlias name args tipe) =

151+ indented :: D.Declaration -> Doc

152+ indented decl = P.text "\n " <> pretty decl <> P.text "\n"

153+

154+ report name args tipe derivations =

158155 P.vcat [ P.text $ eightyCharLines 0 msg1

159− , indented decl

156+ , indented $ D.TypeAlias name args tipe derivations

160157 , P.text $ eightyCharLines 0 msg2

161− , indented (Datatype name args [(name,[tipe])])

158+ , indented $ D.Datatype name args [(name,[tipe])] derivations

162159 , P.text $ eightyCharLines 0 msg3 ++ "\n"

163160 ]

164161 where

165− indented decl = P.text "\n " <> pretty decl <> P.text "\n"

166−

167162 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++

168163 "Notice that it appears in its own definition, so when \

169164 \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 =

2727 PAlias x p -> PAlias (var x) (pattern p)

2828 PData name ps -> PData name (map pattern ps)

2929

30−expression :: LExpr t v -> LExpr t v

30+expression :: LExpr -> LExpr

3131expression (L loc expr) =

3232 let f = expression in

3333 L loc $

@@ -49,14 +49,15 @@ expression (L loc expr) =

4949 Modify r fs -> Modify (f r) (map (var *** f) fs)

5050 Record fs -> Record (map (var *** f) fs)

5151 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)

5255

53−definition :: Def t v -> Def t v

54−definition def =

55− case def of

56− Def p e -> Def (pattern p) (expression e)

57− TypeAnnotation name t -> TypeAnnotation (var name) t

56+definition :: Def -> Def

57+definition (Definition p e t) =

58+ Definition (pattern p) (expression e) t

5859

59−metadataModule :: MetadataModule t v -> MetadataModule t v

60+metadataModule :: MetadataModule -> MetadataModule

6061metadataModule modul =

6162 modul

6263 { names = map var (names modul)

@@ -64,15 +65,9 @@ metadataModule modul =

6465 , imports = map (first var) (imports modul)

6566 , program = expression (program modul)

6667 , aliases =

67− let makeSafe (name, tvars, tipe) = (var name, tvars, tipe)

68+ let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)

6869 in map makeSafe (aliases modul)

6970 , 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)

7172 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−

2−{-# OPTIONS -Wall #-}

3−

4−module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.SortDefinitions (sortDefs) where

53

64import Control.Monad.State

7−import Control.Applicative ((<$>))

8−import qualified Data.Set as Set

5+import Control.Applicative ((<$>),(<*>))

96import qualified Data.Map as Map

10−import qualified SourceSyntax.Type as ST

117import SourceSyntax.Expression

128import SourceSyntax.Location

13−import SourceSyntax.Pattern

9+import qualified SourceSyntax.Pattern as P

1410import qualified Data.Graph as Graph

15−import qualified Data.Map as Map

11+import qualified Data.Set as Set

1612import qualified Data.Maybe as Maybe

1713

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]

2915ctors pattern =

3016 case pattern of

31− PVar x -> []

32− PAlias x p -> ctors p

33− PData ctor ps -> ctor : concatMap ctors ps

34− PRecord fields -> []

35− PAnything -> []

36− PLiteral _ -> []

17+ P.PVar _ -> []

18+ P.PAlias _ p -> ctors p

19+ P.PData ctor ps -> ctor : concatMap ctors ps

20+ P.PRecord _ -> []

21+ P.PAnything -> []

22+ P.PLiteral _ -> []

3723

3824free :: String -> State (Set.Set String) ()

3925free x = modify (Set.insert x)

@@ -41,70 +27,68 @@ free x = modify (Set.insert x)

4127bound :: Set.Set String -> State (Set.Set String) ()

4228bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

4329

44−sortDefs :: LExpr t v -> LExpr t v

30+sortDefs :: LExpr -> LExpr

4531sortDefs expr = evalState (reorder expr) Set.empty

4632

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)

54−reorder lexpr@(L s expr) =

55− L s `liftM`

33+reorder :: LExpr -> State (Set.Set String) LExpr

34+reorder (L s expr) =

35+ L s <$>

5636 case expr of

5737 -- Be careful adding and restricting freeVars

5838 Var x -> free x >> return expr

5939

6040 Lambda p e ->

61− uncurry Lambda `liftM` bindingReorder (p,e)

41+ uncurry Lambda <$> bindingReorder (p,e)

6242

6343 Binop op e1 e2 ->

6444 do free op

65− Binop op `liftM` reorder e1 `ap` reorder e2

45+ Binop op <$> reorder e1 <*> reorder e2

6646

6747 Case e cases ->

68− Case `liftM` reorder e `ap` mapM bindingReorder cases

48+ Case <$> reorder e <*> mapM bindingReorder cases

6949

7050 Data name es ->

7151 do free name

72− Data name `liftM` mapM reorder es

52+ Data name <$> mapM reorder es

7353

7454 -- Just pipe the reorder though

7555 Literal _ -> return expr

7656

7757 Range e1 e2 ->

78− Range `liftM` reorder e1 `ap` reorder e2

58+ Range <$> reorder e1 <*> reorder e2

7959

8060 ExplicitList es ->

81− ExplicitList `liftM` mapM reorder es

61+ ExplicitList <$> mapM reorder es

8262

8363 App e1 e2 ->

84− App `liftM` reorder e1 `ap` reorder e2

64+ App <$> reorder e1 <*> reorder e2

8565

8666 MultiIf branches ->

87− MultiIf `liftM` mapM reorderPair branches

67+ MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches

8868

8969 Access e lbl ->

90− Access `liftM` reorder e `ap` return lbl

70+ Access <$> reorder e <*> return lbl

9171

9272 Remove e lbl ->

93− Remove `liftM` reorder e `ap` return lbl

73+ Remove <$> reorder e <*> return lbl

9474

9575 Insert e lbl v ->

96− Insert `liftM` reorder e `ap` return lbl `ap` reorder v

76+ Insert <$> reorder e <*> return lbl <*> reorder v

9777

9878 Modify e fields ->

99− Modify `liftM` reorder e `ap` mapM reorderField fields

79+ Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields

10080

10181 Record fields ->

102− Record `liftM` mapM reorderField fields

82+ Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields

10383

10484 Markdown uid md es -> Markdown uid md <$> mapM reorder es

10585

10686 GLShader _ _ -> return expr

10787

88+ PortOut name st signal -> PortOut name st <$> reorder signal

89+

90+ PortIn name st tt handler -> PortIn name st tt <$> reorder handler

91+

10892 -- Actually do some reordering

10993 Let defs body ->

11094 do body' <- reorder body

@@ -117,48 +101,24 @@ reorder lexpr@(L s expr) =

117101 let defss = map Graph.flattenSCC sccs

118102

119103 -- 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

125− bound (boundVars pattern)

104+ forM_ defs $ \(Definition pattern _ _) -> do

105+ bound (P.boundVars pattern)

126106 mapM free (ctors pattern)

127107

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

130109

131110 return let'

132111

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)

151113bindingReorder (pattern,expr) =

152114 do expr' <- reorder expr

153− bound (boundVars pattern)

154− mapM free (ctors pattern)

115+ bound (P.boundVars pattern)

116+ mapM_ free (ctors pattern)

155117 return (pattern, expr')

156118

157119

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])

161−reorderAndGetDependencies (pattern, expr, mType) =

120+reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])

121+reorderAndGetDependencies (Definition pattern expr mType) =

162122 do globalFrees <- get

163123 -- work in a fresh environment

164124 put Set.empty

@@ -166,44 +126,30 @@ reorderAndGetDependencies (pattern, expr, mType) =

166126 localFrees <- get

167127 -- merge with global frees

168128 modify (Set.union globalFrees)

169− return ((pattern, expr', mType), Set.toList localFrees)

129+ return (Definition pattern expr' mType, Set.toList localFrees)

170130

171131

172132-- 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])]

174134buildDefDict defs =

175− do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)

135+ do pdefsDeps <- mapM reorderAndGetDependencies defs

176136 return $ realDeps (addKey pdefsDeps)

177137

178138 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])]

193140 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

194141

195− variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]

196− variableToKey ((pattern, _, _), key, _) =

197− [ (var, key) | var <- Set.toList (boundVars pattern) ]

142+ variableToKey :: (Def, Int, [String]) -> [(String, Int)]

143+ variableToKey (Definition pattern _ _, key, _) =

144+ [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

198145

199− variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int

146+ variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int

200147 variableToKeyMap pdefsDeps =

201148 Map.fromList (concatMap variableToKey pdefsDeps)

202149

203− realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]

150+ realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]

204151 realDeps pdefsDeps = map convert pdefsDeps

205152 where

206153 varDict = variableToKeyMap pdefsDeps

207154 convert (pdef, key, deps) =

208155 (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

44import Control.Arrow (second, (***))

55import SourceSyntax.Expression

66import SourceSyntax.Location

7+import qualified SourceSyntax.Pattern as Pattern

78import qualified Data.Set as Set

8−import qualified Transform.SortDefinitions as SD

99

10−subst :: String -> Expr t v -> Expr t v -> Expr t v

10+subst :: String -> Expr -> Expr -> Expr

1111subst old new expr =

1212 let f (L s e) = L s (subst old new e) in

1313 case expr of

@@ -15,7 +15,7 @@ subst old new expr =

1515 ExplicitList es -> ExplicitList (map f es)

1616 Binop op e1 e2 -> Binop op (f e1) (f e2)

1717 Lambda p e

18− | Set.member old (SD.boundVars p) -> expr

18+ | Set.member old (Pattern.boundVars p) -> expr

1919 | otherwise -> Lambda p (f e)

2020 App e1 e2 -> App (f e1) (f e2)

2121 MultiIf ps -> MultiIf (map (f *** f) ps)

@@ -24,12 +24,9 @@ subst old new expr =

2424 | anyShadow -> expr

2525 | otherwise -> Let (map substDef defs) (f body)

2626 where

27+ substDef (Definition p e t) = Definition p (f e) t

2728 anyShadow =

28− any (Set.member old . SD.boundVars) [ p | Def p _ <- defs ]

29− substDef def =

30− case def of

31− TypeAnnotation _ _ -> def

32− Def p e -> Def p (f e)

29+ any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]

3330

3431 Var x -> if x == old then new else expr

3532 Case e cases -> Case (f e) $ map (second f) cases

@@ -40,4 +37,7 @@ subst old new expr =

4037 Modify r fs -> Modify (f r) (map (second f) fs)

4138 Record fs -> Record (map (second f) fs)

4239 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

99import SourceSyntax.Type

1010import SourceSyntax.Module

1111

12−type Rules = ([(String,[String],Type)], Type -> Type)

12+type Rules = ([Alias], Type -> Type)

1313

1414rules interfaces moduleAliases moduleImports =

1515 (collect interfaces moduleAliases, localizer moduleImports)

@@ -20,7 +20,7 @@ collect interfaces moduleAliases =

2020 rawAliases =

2121 moduleAliases ++ concatMap iAliases (Map.elems interfaces)

2222

23− isPrimitive (_,_,tipe) =

23+ isPrimitive (_,_,tipe,_) =

2424 case tipe of

2525 Data _ [] -> True

2626 _ -> False

@@ -62,13 +62,13 @@ realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

6262

6363-- Realias using canonical aliases, so results will have aliases

6464-- that are fully qualified and possible to compare.

65−canonicalRealias :: [(String,[String],Type)] -> Type -> Type

65+canonicalRealias :: [Alias] -> Type -> Type

6666canonicalRealias aliases tipe =

6767 case concatMap tryRealias aliases of

6868 [] -> if tipe == tipe' then tipe else f tipe'

6969 tipes -> f (bestType tipes)

7070 where

71− tryRealias (name, args, aliasTipe) =

71+ tryRealias (name, args, aliasTipe, _) =

7272 case diff aliasTipe tipe of

7373 Nothing -> []

7474 Just kvs ->

compiler/Type/Constrain/Declaration.hs+35−36

@@ -1,70 +1,69 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Type.Constrain.Declaration where

23

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−

114import SourceSyntax.Declaration

12−import qualified SourceSyntax.Expression as Src

5+import qualified SourceSyntax.Expression as E

136import qualified SourceSyntax.Location as L

147import 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

1611

17−toExpr :: [Declaration t v] -> [Src.Def t v]

12+toExpr :: [Declaration] -> [E.Def]

1813toExpr = concatMap toDefs

1914

20−toDefs :: Declaration t v -> [Src.Def t v]

15+toDefs :: Declaration -> [E.Def]

2116toDefs decl =

2217 case decl of

2318 Definition def -> [def]

2419

25− Datatype name tvars constructors -> concatMap toDefs constructors

20+ Datatype name tvars constructors _ -> concatMap toDefs' constructors

2621 where

27− toDefs (ctor, tipes) =

22+ toDefs' (ctor, tipes) =

2823 let vars = take (length tipes) arguments

29− tbody = Type.Data name $ map Type.Var tvars

30− body = L.none . Src.Data ctor $ map (L.none . Src.Var) vars

31− in [ Src.TypeAnnotation ctor $ foldr Type.Lambda tbody tipes

32− , Src.Def (P.PVar ctor) $ buildFunction body vars

33− ]

24+ tbody = T.Data name $ map T.Var tvars

25+ body = L.none . E.Data ctor $ map (L.none . E.Var) vars

26+ in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

3427

35− TypeAlias name tvars tipe@(Type.Record fields ext) ->

36− [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args

37− , Src.Def (P.PVar name) $ buildFunction record vars ]

28+ TypeAlias name _ tipe@(T.Record fields ext) _ ->

29+ [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

3830 where

3931 args = case ext of

40− Type.EmptyRecord -> map snd fields

32+ T.EmptyRecord -> map snd fields

4133 _ -> map snd fields ++ [ext]

4234

43− var = L.none . Src.Var

35+ var = L.none . E.Var

4436 vars = take (length args) arguments

4537

4638 efields = zip (map fst fields) (map var vars)

4739 record = case ext of

48− Type.EmptyRecord -> L.none $ Src.Record efields

49− _ -> foldl (\r (f,v) -> L.none $ Src.Insert r f v) (var $ last vars) efields

40+ T.EmptyRecord -> L.none $ E.Record efields

41+ _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

5042

5143 -- Type aliases must be added to an extended equality dictionary,

5244 -- but they do not require any basic constraints.

53− TypeAlias _ _ _ -> []

54−

55− ImportEvent _ expr@(L.L s _) name tipe ->

56− [ Src.TypeAnnotation name tipe

57− , Src.Def (P.PVar name) (L.L s $ Src.App (L.L s $ Src.Var "constant") expr) ]

58−

59− ExportEvent _ name tipe ->

60− [ Src.TypeAnnotation name tipe ]

45+ -- TODO: with the ability to derive code, you may need to generate stuff!

46+ TypeAlias _ _ _ _ -> []

47+

48+ Port port ->

49+ case port of

50+ Send name expr@(L.L s _) tipe ->

51+ [ definition name (L.L s $ E.PortOut name tipe expr) 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 ]

6156

6257 -- no constraints are needed for fixity declarations

6358 Fixity _ _ _ -> []

6459

6560

6661arguments :: [String]

67−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]

62+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

6863

64+buildFunction :: E.LExpr -> [String] -> E.LExpr

6965buildFunction 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−

2−{-# OPTIONS -Wall #-}

3−

1+{-# OPTIONS_GHC -W #-}

42module Type.Constrain.Expression where

53

64import qualified Data.List as List

75import qualified Data.Map as Map

86import qualified Data.Set as Set

9−import Control.Arrow (second)

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

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

118import qualified Control.Monad as Monad

129import Control.Monad.Error

13−import Control.Monad.State

14−import Data.Traversable (traverse)

1510import qualified Text.PrettyPrint as PP

1611import qualified Parse.Helpers as PH

1712import SourceSyntax.Location as Loc

18−import SourceSyntax.Pattern (Pattern(PVar))

13+import SourceSyntax.Pattern (Pattern(PVar), boundVars)

1914import SourceSyntax.Expression

2015import qualified SourceSyntax.Type as SrcT

2116import Type.Type hiding (Descriptor(..))

@@ -23,10 +18,8 @@ import Type.Fragment

2318import qualified Type.Environment as Env

2419import qualified Type.Constrain.Literal as Literal

2520import qualified Type.Constrain.Pattern as Pattern

26−import qualified Transform.SortDefinitions as SD

27−

2821

29−constrain :: Env.Environment -> LExpr a b -> Type -> ErrorT [PP.Doc] IO TypeConstraint

22+constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

3023constrain env (L span expr) tipe =

3124 let list t = Env.get env Env.types "_List" <| t

3225 and = L span . CAnd

@@ -159,13 +152,18 @@ constrain env (L span expr) tipe =

159152 (schemes, rqs, fqs, header, c2, c1) <-

160153 Monad.foldM (constrainDef env)

161154 ([], [], [], Map.empty, true, true)

162− (collapseDefs defs)

155+ (concatMap expandPattern defs)

163156 return $ clet schemes

164157 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

165158 (c1 /\ c))

166159

160+ PortIn _ _ tt handler ->

161+ constrain env handler (VarN tt)

167162

168−constrainDef env info (pattern, expr, maybeTipe) =

163+ PortOut _ _ signal ->

164+ constrain env signal tipe

165+

166+constrainDef env info (Definition pattern expr maybeTipe) =

169167 let qs = [] -- should come from the def, but I'm not sure what would live there...

170168 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

171169 in

@@ -202,33 +200,18 @@ constrainDef env info (pattern, expr, maybeTipe) =

202200 , c /\ c2

203201 , c1 )

204202

205−expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)

206− -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

207−expandPattern triple@(pattern, lexpr@(L s _), maybeType) =

203+ _ -> error (show pattern)

204+

205+expandPattern :: Def -> [Def]

206+expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =

208207 case pattern of

209− PVar _ -> [triple]

210− _ -> (PVar x, lexpr, maybeType) : map toDef vars

208+ PVar _ -> [def]

209+ _ -> Definition (PVar x) lexpr maybeType : map toDef vars

211210 where

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

211+ vars = Set.toList $ boundVars pattern

213212 x = "$" ++ concat vars

214− var = L s . Var

215− toDef y = (PVar y, L s $ Case (var x) [(pattern, var 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

213+ mkVar = L s . Var

214+ toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

232215

233216try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

234217try span computation = do

compiler/Type/Constrain/Pattern.hs−2

@@ -5,8 +5,6 @@ import Control.Arrow (second)

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

66import qualified Control.Monad as Monad

77import Control.Monad.Error

8−import qualified Data.List as List

9−import qualified Data.Maybe as Maybe

108import qualified Data.Map as Map

119import qualified Text.PrettyPrint as PP

1210

compiler/Type/Environment.hs+8−8

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

1+{-# OPTIONS_GHC -W #-}

12module Type.Environment where

23

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

@@ -9,11 +10,10 @@ import qualified Control.Monad.State as State

910import qualified Data.Traversable as Traverse

1011import qualified Data.Map as Map

1112import Data.List (isPrefixOf)

12−import qualified Data.UnionFind.IO as UF

1313import qualified Text.PrettyPrint as PP

1414

1515import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT)

16+import SourceSyntax.Module (ADT, Alias)

1717import Type.Type

1818

1919type TypeDict = Map.Map String Type

@@ -26,10 +26,10 @@ data Environment = Environment {

2626 value :: TypeDict

2727}

2828

29−initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment

29+initialEnvironment :: [ADT] -> [Alias] -> IO Environment

3030initialEnvironment datatypes aliases = do

3131 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

3333 env = Environment {

3434 constructor = Map.empty,

3535 value = Map.empty,

@@ -42,9 +42,9 @@ makeTypes :: [ADT] -> IO TypeDict

4242makeTypes datatypes =

4343 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

4444 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

45+ nameAndKind (name, tvars, _, _) = (name, length tvars)

4646

47− makeCtor (name, kind) = do

47+ makeCtor (name, _) = do

4848 ctor <- VarN <$> namedVar Constant name

4949 return (name, ctor)

5050

@@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins

8484

8585

8686ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

87+ctorToType env (name, tvars, ctors, _) =

8888 zip (map fst ctors) (map inst ctors)

8989 where

9090 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

@@ -94,7 +94,7 @@ ctorToType env (name, tvars, ctors) =

9494

9595

9696 go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

97− go (ctor, args) = do

97+ go (_, args) = do

9898 types <- mapM (instantiator env) args

9999 returnType <- instantiator env (Src.Data name (map Src.Var tvars))

100100 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

13-- This module contains checks to be run *after* type inference has

24-- completed successfully. At that point we still need to do occurs

35-- checks and ensure that `main` has an acceptable type.

4−module Type.ExtraChecks (extraChecks, occursCheck) where

56

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

78import Control.Monad.State

9+import qualified Data.List as List

810import qualified Data.Map as Map

911import qualified Data.UnionFind.IO as UF

1012import Type.Type ( Variable, structure, Term1(..), toSrcType )

@@ -12,33 +14,103 @@ import qualified Type.State as TS

1214import qualified Type.Alias as Alias

1315import Text.PrettyPrint as P

1416import SourceSyntax.PrettyPrint (pretty)

15−import SourceSyntax.Type (Type)

16−import qualified SourceSyntax.Location as Location

17−import qualified SourceSyntax.Expression as Expr

17+import qualified SourceSyntax.Type as T

18+import qualified SourceSyntax.Expression as E

19+import qualified SourceSyntax.Location as L

20+import qualified Transform.Expression as Expr

1821import qualified Data.Traversable as Traverse

22+import System.IO.Unsafe

1923

20−extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))

21−extraChecks rules env =

22− mainCheck rules <$> Traverse.traverse toSrcType env

24+throw err = Left [ P.vcat err ]

2325

24−mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)

25−mainCheck rules env =

26− let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in

27− case Map.lookup "main" env of

28− Nothing -> Right env

29− Just tipe

30− | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->

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)"

35− , P.text "Instead 'main' has type:\n"

36− , P.nest 4 . pretty $ Alias.realias rules tipe

37− , P.text " " ]

38− ]

26+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))

27+mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

28+ where

29+ mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)

30+ mainCheck rules env =

31+ case Map.lookup "main" env of

32+ Nothing -> Right env

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+

40+ tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType

41+ err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

42+ , P.text "Instead 'main' has type:\n"

43+ , P.nest 4 . pretty $ Alias.realias rules mainType

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

110+ ]

39111

40−occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()

41−occursCheck (name, variable) =

112+occurs :: (String, Variable) -> StateT TS.SolverState IO ()

113+occurs (name, variable) =

42114 do vars <- liftIO $ infiniteVars [] variable

43115 case vars of

44116 [] -> return ()

@@ -47,10 +119,10 @@ occursCheck (name, variable) =

47119 case structure desc of

48120 Nothing ->

49121 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

50− Just struct ->

122+ Just _ ->

51123 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

52124 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'

54126 where

55127 msg = "Infinite types are not allowed"

56128 fallback _ = return $ P.text msg

compiler/Type/Inference.hs+7−8

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

1+{-# OPTIONS_GHC -W #-}

12module Type.Inference where

23

34import qualified Data.Map as Map

@@ -5,27 +6,23 @@ import qualified Data.Map as Map

56import qualified Type.Type as T

67import qualified Type.Environment as Env

78import qualified Type.Constrain.Expression as TcExpr

8−import qualified Type.Constrain.Declaration as TcDecl

99import qualified Type.Solve as Solve

1010

1111import SourceSyntax.Module as Module

12−import qualified SourceSyntax.Expression as Expr

13−import SourceSyntax.Location (Located, noneNoDocs)

14−import SourceSyntax.PrettyPrint

12+import SourceSyntax.Location (noneNoDocs)

1513import SourceSyntax.Type (Type)

1614import Text.PrettyPrint

1715import qualified Type.State as TS

18−import Type.ExtraChecks (extraChecks)

16+import qualified Type.ExtraChecks as Check

1917import Control.Monad.State (execStateT, forM)

2018import Control.Monad.Error (runErrorT, liftIO)

21−import Control.Arrow (second)

2219import qualified Type.Alias as Alias

2320

2421import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

2522 -- the IO monad. I don't think that'd be worthwhile.

2623

2724

28−infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String Type)

25+infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)

2926infer interfaces modul = unsafePerformIO $ do

3027 env <- Env.initialEnvironment

3128 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

@@ -55,4 +52,6 @@ infer interfaces modul = unsafePerformIO $ do

5552 let rules = Alias.rules interfaces (aliases modul) (imports modul)

5653 case TS.sErrors state of

5754 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

58− [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)

55+ [] -> case Check.portTypes rules (program modul) of

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 #-}

12module Type.Solve (solve) where

23

34import Control.Monad

@@ -5,14 +6,11 @@ import Control.Monad.State

56import qualified Data.UnionFind.IO as UF

67import qualified Data.Map as Map

78import qualified Data.Traversable as Traversable

8−import qualified Data.Maybe as Maybe

99import qualified Data.List as List

1010import Type.Type

1111import Type.Unify

12−import qualified Type.ExtraChecks as EC

13−import qualified Type.Environment as Env

12+import qualified Type.ExtraChecks as Check

1413import qualified Type.State as TS

15−import qualified Text.PrettyPrint as P

1614import SourceSyntax.Location (Located(L), SrcSpan)

1715

1816

@@ -122,7 +120,7 @@ solve (L span constraint) =

122120 headers <- Map.unions `fmap` mapM (solveScheme span) schemes

123121 TS.modifyEnv $ \env -> Map.union headers env

124122 solve constraint'

125− mapM EC.occursCheck $ Map.toList headers

123+ mapM Check.occurs $ Map.toList headers

126124 TS.modifyEnv (\_ -> oldEnv)

127125

128126 CInstance name term -> do

compiler/Type/State.hs+3−5

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

1+{-# OPTIONS_GHC -W #-}

12module Type.State where

23

34import Type.Type

45import qualified Data.Map as Map

5−import qualified Data.List as List

6−import qualified Type.Environment as Env

76import qualified Data.UnionFind.IO as UF

87import Control.Monad.State

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

@@ -11,7 +10,6 @@ import qualified Data.Traversable as Traversable

1110import Text.PrettyPrint as P

1211import SourceSyntax.PrettyPrint

1312import SourceSyntax.Location

14−import qualified SourceSyntax.Type as Src

1513import qualified Type.Alias as Alias

1614

1715-- Pool

@@ -64,8 +62,8 @@ addError span hint t1 t2 =

6462 ]

6563

6664 location = case span of

67− NoSpan msg -> ""

68− Span p1 p2 msg ->

65+ NoSpan _ -> ""

66+ Span p1 p2 _ ->

6967 if line p1 == line p2 then " on line " ++ show (line p1)

7068 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

7169

compiler/Type/Type.hs+11−8

@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

6262infixl 8 /\

6363

6464(/\) :: 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) =

6666 case (c1, c2) of

6767 (CTrue, _) -> b

6868 (_, CTrue) -> a

@@ -95,6 +95,7 @@ data Flex = Rigid | Flexible | Constant | Is SuperType

9595data SuperType = Number | Comparable | Appendable

9696 deriving (Show, Eq)

9797

98+namedVar :: Flex -> String -> IO Variable

9899namedVar flex name = UF.fresh $ Descriptor {

99100 structure = Nothing,

100101 rank = noRank,

@@ -104,6 +105,7 @@ namedVar flex name = UF.fresh $ Descriptor {

104105 mark = noMark

105106 }

106107

108+var :: Flex -> IO Variable

107109var flex = UF.fresh $ Descriptor {

108110 structure = Nothing,

109111 rank = noRank,

@@ -113,6 +115,7 @@ var flex = UF.fresh $ Descriptor {

113115 mark = noMark

114116 }

115117

118+structuredVar :: Term1 Variable -> IO Variable

116119structuredVar structure = UF.fresh $ Descriptor {

117120 structure = Just structure,

118121 rank = noRank,

@@ -368,8 +371,8 @@ toSrcType variable = do

368371 Src.Record fs'' <$> toSrcType ext

369372 Nothing ->

370373 case name desc of

371− Just x@(c:cs) | Char.isLower c -> return (Src.Var x)

372− | otherwise -> return (Src.Data x [])

374+ Just x@(c:_) | Char.isLower c -> return (Src.Var x)

375+ | otherwise -> return (Src.Data x [])

373376 _ -> error $ concat

374377 [ "Problem converting the following type "

375378 , "from a type-checker type to a source-syntax type:"

@@ -383,12 +386,12 @@ collectApps variable = go [] variable

383386 go vars variable = do

384387 desc <- UF.descriptor variable

385388 case (structure desc, vars) of

386− (Nothing, [v] ) -> case name desc of

389+ (Nothing, [v]) -> case name desc of

387390 Just "_List" -> return (List v)

388391 _ -> return Other

389− (Nothing, vs ) -> case name desc of

392+ (Nothing, vs) -> case name desc of

390393 Just ctor | isTuple ctor -> return (Tuple vs)

391394 _ -> return Other

392− (Just term, vs) -> case term of

393− App1 a b -> go (vars ++ [b]) a

394− _ -> return Other

395+ (Just term, _) -> case term of

396+ App1 a b -> go (vars ++ [b]) a

397+ _ -> return Other

compiler/Type/Unify.hs+3−3

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

1+{-# OPTIONS_GHC -W #-}

12module Type.Unify (unify) where

23

34import Type.Type

@@ -5,7 +6,6 @@ import qualified Data.UnionFind.IO as UF

56import qualified Data.Map as Map

67import qualified Data.Maybe as Maybe

78import qualified Type.State as TS

8−import Control.Arrow (first,second)

99import Control.Monad.State

1010import SourceSyntax.Location

1111import Type.PrettyPrint

@@ -193,8 +193,8 @@ actuallyUnify span variable1 variable2 = do

193193

194194 unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a

195195

196− eat (x:xs) (y:ys) = eat xs ys

197− eat xs ys = xs

196+ eat (_:xs) (_:ys) = eat xs ys

197+ eat xs _ = xs

198198

199199 _ -> TS.addError span Nothing variable1 variable2

200200

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"

22, "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."

44, "license": "BSD3"

55, "repository": "http://github.com/evancz/Elm.git"

6−, "elm-version": "0.10.0.2"

6+, "elm-version": "0.10.1"

77, "dependencies": {}

88, "exposed-modules":

99 [ "Basics"

@@ -36,4 +36,4 @@

3636 , "WebSocket"

3737 , "Window"

3838 ]

39−}

39+}

runtime/Init.js+82−30

@@ -2,7 +2,7 @@

22(function() {

33'use strict';

44

5−Elm.fullscreen = function(module) {

5+Elm.fullscreen = function(module, ports) {

66 var style = document.createElement('style');

77 style.type = 'text/css';

88 style.innerHTML = "html,head,body { padding:0; margin:0; }" +

@@ -10,24 +10,47 @@ Elm.fullscreen = function(module) {

1010 document.head.appendChild(style);

1111 var container = document.createElement('div');

1212 document.body.appendChild(container);

13− return init(ElmRuntime.Display.FULLSCREEN, container, module);

13+ return init(ElmRuntime.Display.FULLSCREEN, container, module, ports || {});

1414};

1515

16−Elm.embed = function(module, container) {

16+Elm.embed = function(module, container, ports) {

1717 var tag = container.tagName;

1818 if (tag !== 'DIV') {

1919 throw new Error('Elm.node must be given a DIV, not a ' + tag + '.');

2020 } else if (container.hasChildNodes()) {

2121 throw new Error('Elm.node must be given an empty DIV. No children allowed!');

2222 }

23− return init(ElmRuntime.Display.COMPONENT, container, module);

23+ return init(ElmRuntime.Display.COMPONENT, container, module, ports || {});

2424};

2525

26−Elm.worker = function(module) {

27− return init(ElmRuntime.Display.NONE, {}, module);

26+Elm.worker = function(module, ports) {

27+ return init(ElmRuntime.Display.NONE, {}, module, ports || {});

2828};

2929

30−function init(display, container, module, moduleToReplace) {

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+

53+function init(display, container, module, ports, moduleToReplace) {

3154 // defining state needed for an instance of the Elm RTS

3255 var inputs = [];

3356

@@ -59,6 +82,10 @@ function init(display, container, module, moduleToReplace) {

5982 listeners.push(listener);

6083 }

6184

85+ var portUses = {}

86+ for (var key in ports) {

87+ portUses[key] = 0;

88+ }

6289 // create the actual RTS. Any impure modules will attach themselves to this

6390 // object. This permits many Elm programs to be embedded per document.

6491 var elm = {

@@ -67,34 +94,15 @@ function init(display, container, module, moduleToReplace) {

6794 display:display,

6895 id:ElmRuntime.guid(),

6996 addListener:addListener,

70− inputs:inputs

97+ inputs:inputs,

98+ ports: { incoming:ports, outgoing:{}, uses:portUses }

7199 };

72100

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−

91101 function swap(newModule) {

92102 removeListeners(listeners);

93103 var div = document.createElement('div');

94− var newElm = init(display, div, newModule, elm);

104+ var newElm = init(display, div, newModule, ports, elm);

95105 inputs = [];

96− // elm.send = newElm.send;

97− // elm.recv = newElm.recv;

98106 // elm.swap = newElm.swap;

99107 return newElm;

100108 }

@@ -103,6 +111,7 @@ function init(display, container, module, moduleToReplace) {

103111 var reportAnyErrors = function() {};

104112 try {

105113 Module = module.make(elm);

114+ checkPorts(elm);

106115 } catch(e) {

107116 var directions = "<br/>    Open the developer console for more details."

108117 Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');

@@ -110,6 +119,7 @@ function init(display, container, module, moduleToReplace) {

110119 }

111120 inputs = ElmRuntime.filterDeadInputs(inputs);

112121 filterListeners(inputs, listeners);

122+ addReceivers(elm.ports.outgoing);

113123 if (display !== ElmRuntime.Display.NONE) {

114124 var graphicsNode = initGraphics(elm, Module);

115125 }

@@ -123,9 +133,26 @@ function init(display, container, module, moduleToReplace) {

123133 }

124134

125135 reportAnyErrors();

126− return { send:send, recv:recv, swap:swap };

136+ return { swap:swap, output:elm.ports.outgoing };

127137};

128138

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+

129156function filterListeners(inputs, listeners) {

130157 loop:

131158 for (var i = listeners.length; i--; ) {

@@ -146,6 +173,31 @@ function removeListeners(listeners) {

146173 }

147174}

148175

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+

149201function initGraphics(elm, Module) {

150202 if (!('main' in Module))

151203 throw new Error("'main' is missing! What do I display?!");

server/Server.hs+4−4

@@ -12,7 +12,7 @@ import System.Exit

1212import System.FilePath

1313import System.Process

1414import GHC.IO.Handle

15−import qualified Language.Elm as Elm

15+import qualified Elm.Internal.Paths as ElmPaths

1616import Paths_elm_server

1717

1818runtime = "/elm-runtime.js"

@@ -74,7 +74,7 @@ parse ("--help":_) = putStrLn usage

7474parse ("--version":_) = putStrLn ("The Elm Server " ++ showVersion version)

7575parse args =

7676 if null remainingArgs then

77− serve portNumber =<< elmRuntime

77+ serve portNumber elmRuntime

7878 else

7979 putStrLn usageMini

8080

@@ -86,9 +86,9 @@ parse args =

8686 argValue arg = tail $ dropWhile (/= '=') (head arg)

8787 portNumber = if null portArg then 8000 else read (argValue portArg) :: Int

8888 elmRuntime = if null runtimeArg then

89− Elm.runtime

89+ ElmPaths.runtime

9090 else

91− return $ argValue runtimeArg

91+ argValue runtimeArg

9292

9393usageMini :: String

9494usageMini =

server/elm-server.cabal+2−2

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

11Name: elm-server

2−Version: 0.10

2+Version: 0.10.1

33Synopsis: The Elm language server.

44Description: This package provides a standalone, Happstack-based Elm server.

55

@@ -36,5 +36,5 @@ Executable elm-server

3636 happstack-server,

3737 deepseq,

3838 filepath,

39− Elm >= 0.10,

39+ Elm >= 0.10.1,

4040 process