4c27440 · elk · git.iko.soy

compiler/Build/File.hs+30−8

compare with master

unifiedsplit

@@ -10,6 +10,7 @@ import System.FilePath

10import System.IO

11

12import qualified Data.Binary as Binary

13+import qualified Data.List as List

13import qualified Data.Maybe as Maybe

14import qualified Data.Maybe as Maybe

14import qualified Data.Map as Map

15import qualified Data.Map as Map

15import qualified Data.ByteString.Lazy as L

16import qualified Data.ByteString.Lazy as L

@@ -34,17 +35,37 @@ type Build a = BuildT IO a

34-- Interfaces, remembering if something was recompiled

35-- Interfaces, remembering if something was recompiled

35type BInterfaces = Map.Map String (Bool, M.ModuleInterface)

36type BInterfaces = Map.Map String (Bool, M.ModuleInterface)

36

37

37−evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)

38+evalBuild :: Flag.Flags -> M.Interfaces -> Build ()

39+ -> IO (Map.Map String M.ModuleInterface, Maybe String)

38−evalBuild flags interfaces b = do

40+evalBuild flags interfaces build =

39− (_, s) <- evalRWST b flags (fmap notUpdated interfaces)

41+ do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)

40− return . getLast $ s

42+ return (fmap snd ifaces, getLast moduleNames)

41 where

43 where

42− notUpdated i = (False, i)

44+ notUpdated iface = (False, iface)

43

45

44-- | Builds a list of files, returning the moduleName of the last one.

46-- | Builds a list of files, returning the moduleName of the last one.

45-- Returns \"\" if the list is empty

47-- Returns \"\" if the list is empty

46build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String

48build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String

49+build flags interfaces files =

47−build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll

50+ do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)

51+ let removeTopName = Maybe.maybe id Map.delete topName

52+ mapM_ (checkPorts topName) (Map.toList $ removeTopName ifaces)

53+ return $ Maybe.fromMaybe "" topName

54+ where

55+ checkPorts topName (name,iface)

56+ | null ports = return ()

57+ | otherwise = Print.failure msg

58+ where

59+ ports = M.iPorts iface

60+ msg = concat

61+ [ "Port Error: ports may only appear in the main module, but\n"

62+ , " sub-module ", name, " declares the following port"

63+ , if length ports == 1 then "" else "s", ": "

64+ , List.intercalate ", " ports

65+ , case topName of

66+ Nothing -> ""

67+ Just tname -> "\n All ports must appear in module " ++ tname

68+ ]

48

69

49buildAll :: [FilePath] -> Build ()

70buildAll :: [FilePath] -> Build ()

50buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)

71buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)

@@ -152,5 +173,6 @@ compile number filePath =

152 L.hPut handle (Binary.encode (name, interfs))

173 L.hPut handle (Binary.encode (name, interfs))

153

174

154update :: String -> M.ModuleInterface -> Bool -> Build ()

175update :: String -> M.ModuleInterface -> Bool -> Build ()

176+update name inter wasUpdated =

155−update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))

177+ do modify (Map.insert name (wasUpdated, inter))

156− >> tell (Last . Just $ name)

178+ tell (Last . Just $ name)

compiler/Build/Interface.hs+3−8

@@ -4,28 +4,23 @@ module Build.Interface (load,isValid) where

4import qualified Data.ByteString.Lazy as L

5import qualified Data.Binary as Binary

6

7+import qualified Build.Print as Print

7import qualified Elm.Internal.Version as Version

8import qualified Elm.Internal.Version as Version

8import System.Directory (doesFileExist)

9import System.Directory (doesFileExist)

9−import System.Exit

10−import System.IO

11−

12import SourceSyntax.Module

10import SourceSyntax.Module

13

11

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

12load :: Binary.Binary a => FilePath -> IO a

15load filePath =

13load filePath =

16 do exists <- doesFileExist filePath

14 do exists <- doesFileExist filePath

17 case exists of

15 case exists of

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

16+ False -> Print.failure $ "Unable to find file " ++ filePath ++ " for deserialization!"

19 True -> do

17 True -> do

20 bytes <- L.readFile filePath

18 bytes <- L.readFile filePath

21 case Binary.decodeOrFail bytes of

19 case Binary.decodeOrFail bytes of

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

20 Right (_, _, binaryInfo) -> return binaryInfo

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

21+ Left (_, offset, err) -> Print.failure $ msg offset err

24

22

25 where

23 where

26− failure err = do hPutStrLn stderr err

27− exitFailure

28−

29 msg offset err = concat

24 msg offset err = concat

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

25 [ "Error reading build artifact: ", filePath, "\n"

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

26 , " '", err, "' at offset ", show offset, "\n"

compiler/Build/Source.hs+5−4

@@ -35,8 +35,8 @@ build noPrelude interfaces source =

35 | null exs =

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

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

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

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

40 | otherwise = exs

41

42 metaModule <- Canonical.metadataModule interfaces $

@@ -48,9 +48,10 @@ build noPrelude interfaces source =

48 -- reorder AST into strongly connected components

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 ]

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

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

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

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

54+ , ports = [ portName port | Port port <- decls ]

54 }

55 }

55

56

56 types <- TI.infer interfaces metaModule

57 types <- TI.infer interfaces metaModule

compiler/Docs.hs+4−8

@@ -134,14 +134,13 @@ collect infixes types aliases adts things =

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

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

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

137− D.TypeAlias name vars tipe derivations ->

137+ D.TypeAlias name vars tipe ->

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

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

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

140− D.Datatype name vars ctors derivations ->

140+ D.Datatype name vars ctors ->

141 let tipe = Data name (map Var vars)

142 fields = ["typeVariables" .= vars

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

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

144− , "deriving" .= derivations ]

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

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

146 where

145 where

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

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

@@ -162,6 +161,3 @@ instance ToJSON Type where

162ctorToJson tipe (ctor, tipes) =

161ctorToJson tipe (ctor, tipes) =

163 object [ "name" .= ctor

162 object [ "name" .= ctor

164 , "type" .= foldr Lambda tipe tipes ]

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

165−

166−instance ToJSON D.Derivation where

167− toJSON = toJSON . show

compiler/Parse/Declaration.hs+3−7

@@ -24,11 +24,7 @@ alias = do

24 args <- spacePrefix lowVar

25 padded equals

26 tipe <- Type.expr

27− json <- option [] $ do

28− try $ padded (reserved "deriving")

29− string "Json"

30− return [D.Json]

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

27+ return (D.TypeAlias name args tipe)

32

28

33datatype :: IParser D.ParseDeclaration

29datatype :: IParser D.ParseDeclaration

34datatype = do

30datatype = do

@@ -38,7 +34,7 @@ datatype = do

38 args <- spacePrefix lowVar

34 args <- spacePrefix lowVar

39 padded equals

35 padded equals

40 tcs <- pipeSep1 Type.constructor

36 tcs <- pipeSep1 Type.constructor

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

37+ return $ D.Datatype name args tcs

42

38

43

39

44infixDecl :: IParser D.ParseDeclaration

40infixDecl :: IParser D.ParseDeclaration

@@ -60,4 +56,4 @@ port =

60 whitespace

56 whitespace

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

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

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

58 D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr

63− , port' equals D.PPDef Expr.expr ]

59+ , port' equals D.PPDef Expr.expr ]

compiler/Paths_Elm.h → compiler/Paths_Elmrenamed

The content is the same.

compiler/SourceSyntax/Declaration.hs+12−35

@@ -9,8 +9,8 @@ import Text.PrettyPrint as P

9

10data Declaration' port def

11 = Definition def

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

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

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

13+ | TypeAlias String [String] T.Type

14 | Port port

15 | Fixity Assoc Int String

16 deriving (Show)

@@ -18,9 +18,6 @@ data Declaration' port def

18data Assoc = L | N | R

19 deriving (Eq)

20

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

22− deriving (Eq, Show)

23−

24data ParsePort

21data ParsePort

25 = PPAnnotation String T.Type

22 = PPAnnotation String T.Type

26 | PPDef String Expr.LParseExpr

23 | PPDef String Expr.LParseExpr

@@ -31,26 +28,15 @@ data Port

31 | In String T.Type

28 | In String T.Type

32 deriving (Show)

29 deriving (Show)

33

30

31+portName :: Port -> String

32+portName port =

33+ case port of

34+ Out name _ _ -> name

35+ In name _ -> name

36+

34type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

37type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

35type Declaration = Declaration' Port Expr.Def

38type Declaration = Declaration' Port Expr.Def

36

39

37−instance Binary Derivation where

38− get = do n <- getWord8

39− return $ case n of

40− 0 -> Json

41− 1 -> JS

42− 2 -> Binary

43− 3 -> New

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

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

46−

47− put derivation =

48− putWord8 $ case derivation of

49− Json -> 0

50− JS -> 1

51− Binary -> 2

52− New -> 3

53−

54instance Show Assoc where

40instance Show Assoc where

55 show assoc =

41 show assoc =

56 case assoc of

42 case assoc of

@@ -73,19 +59,18 @@ instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

73 case decl of

59 case decl of

74 Definition def -> pretty def

60 Definition def -> pretty def

75

61

76− Datatype tipe tvars ctors deriveables ->

62+ Datatype tipe tvars ctors ->

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

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

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

64+ (P.sep $ zipWith join ("=" : repeat "|") ctors)

79 where

65 where

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

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

81 prettyCtor (name, tipes) =

67 prettyCtor (name, tipes) =

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

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

83

69

84− TypeAlias name tvars tipe deriveables ->

70+ TypeAlias name tvars tipe ->

85− alias <+> prettyDeriving deriveables

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

86 where

72 where

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

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

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

89

74

90 Port port -> pretty port

75 Port port -> pretty port

91

76

@@ -112,11 +97,3 @@ instance Pretty Port where

112

97

113prettyPort :: (Pretty a) => String -> String -> a -> Doc

98prettyPort :: (Pretty a) => String -> String -> a -> Doc

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

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

115−

116−prettyDeriving :: [Derivation] -> Doc

117−prettyDeriving deriveables =

118− case deriveables of

119− [] -> P.empty

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

121− ds -> P.text "deriving" <+>

122− P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)

compiler/SourceSyntax/Module.hs+16−11

@@ -47,20 +47,23 @@ data MetadataModule =

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

48 , aliases :: [Alias]

49 , datatypes :: [ADT]

50+ , ports :: [String]

50 } deriving Show

51 } deriving Show

51

52

52type Interfaces = Map.Map String ModuleInterface

53type Interfaces = Map.Map String ModuleInterface

53−type ADT = (String, [String], [(String,[Type])], [Derivation])

54+type ADT = (String, [String], [(String,[Type])])

54−type Alias = (String, [String], Type, [Derivation])

55+type Alias = (String, [String], Type)

55

56

56−data ModuleInterface = ModuleInterface {

57+data ModuleInterface =

58+ ModuleInterface

57− iVersion :: Version.Version,

59+ { iVersion :: Version.Version

58− iTypes :: Map.Map String Type,

60+ , iTypes :: Map.Map String Type

59− iImports :: [(String, ImportMethod)],

61+ , iImports :: [(String, ImportMethod)]

60− iAdts :: [ADT],

62+ , iAdts :: [ADT]

61− iAliases :: [Alias],

63+ , iAliases :: [Alias]

62− iFixities :: [(Assoc, Int, String)]

64+ , iFixities :: [(Assoc, Int, String)]

65+ , iPorts :: [String]

63−} deriving Show

66+ } deriving Show

64

67

65metaToInterface :: MetadataModule -> ModuleInterface

68metaToInterface :: MetadataModule -> ModuleInterface

66metaToInterface metaModule =

69metaToInterface metaModule =

@@ -71,10 +74,11 @@ metaToInterface metaModule =

71 , iAdts = datatypes metaModule

74 , iAdts = datatypes metaModule

72 , iAliases = aliases metaModule

75 , iAliases = aliases metaModule

73 , iFixities = fixities metaModule

76 , iFixities = fixities metaModule

77+ , iPorts = ports metaModule

74 }

78 }

75

79

76instance Binary ModuleInterface where

80instance Binary ModuleInterface where

77− get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get

81+ get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get <*> get

78 put modul = do

82 put modul = do

79 put (iVersion modul)

83 put (iVersion modul)

80 put (iTypes modul)

84 put (iTypes modul)

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

82 put (iAdts modul)

86 put (iAdts modul)

83 put (iAliases modul)

87 put (iAliases modul)

84 put (iFixities modul)

88 put (iFixities modul)

89+ put (iPorts modul)

compiler/Transform/Canonicalize.hs+8−7

@@ -25,13 +25,14 @@ interface moduleName iface =

25 , iAdts = map (both prefix renameCtors) (iAdts iface)

26 , iAliases = map (both prefix renameType') (iAliases iface)

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

28+ , iPorts = iPorts iface

28 }

29 }

29 where

30 where

30− both f g (a,b,c,d) = (f a, b, g c, d)

31+ both f g (a,b,c) = (f a, b, g c)

31 prefix name = moduleName ++ "." ++ name

32 prefix name = moduleName ++ "." ++ name

32

33

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

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

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

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

35 canons = Map.fromList $ concat

36 canons = Map.fromList $ concat

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

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

37

38

@@ -56,24 +57,24 @@ metadataModule ifaces modul =

56 [] -> Right ()

57 [] -> Right ()

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

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

58 program' <- rename initialEnv (program modul)

59 program' <- rename initialEnv (program modul)

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

60+ aliases' <- mapM (three3 renameType') (aliases modul)

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

61+ datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)

61 return $ modul { program = program'

62 return $ modul { program = program'

62 , aliases = aliases'

63 , aliases = aliases'

63 , datatypes = datatypes' }

64 , datatypes = datatypes' }

64 where

65 where

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

66 two2 f (a,b) = (,) a <$> f b

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

67+ three3 f (a,b,c) = (,,) a b <$> f c

67 renameType' =

68 renameType' =

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

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

69

70

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

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

71 canon (name, importMethod) =

72 canon (name, importMethod) =

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

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

73 iface = ifaces Map.! name

74 iface = ifaces Map.! name

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

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

75 , map get1 (iAliases iface)

76 , map get1 (iAliases iface)

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

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

77 in case importMethod of

78 in case importMethod of

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

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

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

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

compiler/Transform/Check.hs+10−32

@@ -21,8 +21,7 @@ mistakes decls =

21 concat [ infiniteTypeAliases decls

22 , illFormedTypes decls

23 , map P.text (duplicateConstructors decls)

24− , map P.text (duplicates decls)

24+ , map P.text (duplicates decls) ]

25− , badDerivations decls ]

26

25

27dups :: Ord a => [a] -> [a]

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

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

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

@@ -67,35 +66,14 @@ duplicateConstructors decls =

67 map (dupErr "definition of type constructor") (dups typeCtors) ++

66 map (dupErr "definition of type constructor") (dups typeCtors) ++

68 map (dupErr "definition of data constructor") (dups dataCtors)

67 map (dupErr "definition of data constructor") (dups dataCtors)

69 where

68 where

70− typeCtors = [ name | D.Datatype name _ _ _ <- decls ]

69+ typeCtors = [ name | D.Datatype name _ _ <- decls ]

71− dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]

70+ dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

72−

73−badDerivations :: [D.Declaration] -> [Doc]

74−badDerivations decls = concatMap badDerivation derivations

75− where

76− derivations =

77− [ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++

78− [ (decl, tvars, derives) | decl@(D.Datatype _ tvars _ derives) <- decls ]

79−

80− badDerivation (decl, tvars, derives) =

81− case (tvars, derives) of

82− (_:_, _)

83− | D.Json `elem` derives -> [report decl D.Json]

84− | D.Binary `elem` derives -> [report decl D.Binary]

85− _ -> []

86−

87− report decl derive =

88− P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."

89− , P.text "Make sure all type variables are replaced with concrete types:"

90− , P.text "\n"

91− , nest 4 (pretty decl)

92− ]

93

71

94illFormedTypes :: [D.Declaration] -> [Doc]

72illFormedTypes :: [D.Declaration] -> [Doc]

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

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

96 where

74 where

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

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

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

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

99

77

100 freeVars tipe =

78 freeVars tipe =

101 case tipe of

79 case tipe of

@@ -138,8 +116,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

138

116

139infiniteTypeAliases :: [D.Declaration] -> [Doc]

117infiniteTypeAliases :: [D.Declaration] -> [Doc]

140infiniteTypeAliases decls =

118infiniteTypeAliases decls =

141− [ report name tvars tipe ds | D.TypeAlias name tvars tipe ds <- decls

119+ [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls

142− , infiniteType name tipe ]

120+ , infiniteType name tipe ]

143 where

121 where

144 infiniteType name tipe =

122 infiniteType name tipe =

145 let infinite = infiniteType name in

123 let infinite = infiniteType name in

@@ -152,11 +130,11 @@ infiniteTypeAliases decls =

152 indented :: D.Declaration -> Doc

130 indented :: D.Declaration -> Doc

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

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

154

132

155− report name args tipe derivations =

133+ report name args tipe =

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

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

157− , indented $ D.TypeAlias name args tipe derivations

135+ , indented $ D.TypeAlias name args tipe

158 , P.text $ eightyCharLines 0 msg2

136 , P.text $ eightyCharLines 0 msg2

159− , indented $ D.Datatype name args [(name,[tipe])] derivations

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

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

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

161 ]

139 ]

162 where

140 where

compiler/Transform/Declaration.hs+4−4

@@ -23,11 +23,11 @@ combineAnnotations = go

23 -- simple cases, pass them through with no changes

24 [] -> return []

25

26− Datatype name tvars ctors ds : rest ->

26+ Datatype name tvars ctors : rest ->

27− (:) (Datatype name tvars ctors ds) <$> go rest

27+ (:) (Datatype name tvars ctors) <$> go rest

28

29− TypeAlias name tvars alias ds : rest ->

29+ TypeAlias name tvars alias : rest ->

30− (:) (TypeAlias name tvars alias ds) <$> go rest

30+ (:) (TypeAlias name tvars alias) <$> go rest

31

32 Fixity assoc prec op : rest ->

33 (:) (Fixity assoc prec op) <$> go rest

compiler/Transform/SafeNames.hs+3−3

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

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

65 , program = expression (program modul)

66 , aliases =

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

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

68 in map makeSafe (aliases modul)

69 , datatypes =

70− let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)

70+ let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)

71 in map makeSafe (datatypes modul)

72− }

72+ }

compiler/Type/Alias.hs+3−3

@@ -21,7 +21,7 @@ collect interfaces moduleAliases =

21 rawAliases =

22 moduleAliases ++ concatMap iAliases (Map.elems interfaces)

23

24− isPrimitive (_,_,tipe,_) =

24+ isPrimitive (_,_,tipe) =

25 case tipe of

26 Data _ [] -> True

27 _ -> False

@@ -68,7 +68,7 @@ canonicalRealias aliases tipe =

68 [] -> if tipe == tipe' then tipe else f tipe'

69 tipes -> f (bestType tipes)

70 where

71− tryRealias (name, args, aliasTipe, _) =

71+ tryRealias (name, args, aliasTipe) =

72 case diff aliasTipe tipe of

73 Nothing -> []

74 Just kvs ->

@@ -136,4 +136,4 @@ collectFields fields =

136 foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields

137

138flattenFields fields =

139− concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)

139+ concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)

compiler/Type/Constrain/Declaration.hs+4−5

@@ -15,7 +15,7 @@ toDefs decl =

15 case decl of

16 Definition def -> [def]

17

18− Datatype name tvars constructors _ -> concatMap toDefs' constructors

18+ Datatype name tvars constructors -> concatMap toDefs' constructors

19 where

20 toDefs' (ctor, tipes) =

21 let vars = take (length tipes) arguments

@@ -23,7 +23,7 @@ toDefs decl =

23 body = L.none . E.Data ctor $ map (L.none . E.Var) vars

24 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

25

26− TypeAlias name _ tipe@(T.Record fields ext) _ ->

26+ TypeAlias name _ tipe@(T.Record fields ext) ->

27 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

28 where

29 args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext

@@ -38,8 +38,7 @@ toDefs decl =

38

39 -- Type aliases must be added to an extended equality dictionary,

40 -- but they do not require any basic constraints.

41− -- TODO: with the ability to derive code, you may need to generate stuff!

42− TypeAlias _ _ _ _ -> []

41+ TypeAlias _ _ _ -> []

43

42

44 Port port ->

43 Port port ->

45 case port of

44 case port of

@@ -60,4 +59,4 @@ buildFunction body@(L.L s _) vars =

60 foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)

59 foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)

61

60

62definition :: String -> E.LExpr -> T.Type -> E.Def

61definition :: String -> E.LExpr -> T.Type -> E.Def

63−definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)

62+definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)

compiler/Type/Environment.hs+4−4

@@ -29,7 +29,7 @@ data Environment = Environment {

29initialEnvironment :: [ADT] -> [Alias] -> IO Environment

30initialEnvironment datatypes aliases = do

31 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases

32+ let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

33 env = Environment {

34 constructor = Map.empty,

35 value = Map.empty,

@@ -42,7 +42,7 @@ makeTypes :: [ADT] -> IO TypeDict

42makeTypes datatypes =

43 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

44 where

45− nameAndKind (name, tvars, _, _) = (name, length tvars)

45+ nameAndKind (name, tvars, _) = (name, length tvars)

46

47 makeCtor (name, _) = do

48 ctor <- VarN <$> namedVar Constant name

@@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins

84

85

86ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors, _) =

87+ctorToType env (name, tvars, ctors) =

88 zip (map fst ctors) (map inst ctors)

89 where

90 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

@@ -167,4 +167,4 @@ instantiator env sourceType = go sourceType

167 ext' <- case ext of

168 Nothing -> return $ TermN EmptyRecord1

169 Just x -> go (Src.Var x)

170− return $ TermN (Record1 fields' ext')

170+ return $ TermN (Record1 fields' ext')

libraries/Native/List.js+3−3

@@ -55,7 +55,7 @@ Elm.Native.List.make = function(elm) {

55 function append(xs,ys) {

56 // append Text

57 if (xs.text || ys.text) {

58− return Utils.txt(Utils.makeText('',xs) + Utils.makeText('',ys));

58+ return Utils.txt(Utils.makeText(xs) + Utils.makeText(ys));

59 }

60

61 // append Strings

@@ -270,10 +270,10 @@ Elm.Native.List.make = function(elm) {

270

271 function join(sep, xss) {

272 if (sep.text) {

273− sep = Utils.makeText('',sep);

273+ sep = Utils.makeText(sep);

274 xss = toArray(xss);

275 for (var i = xss.length; i--; ) {

276− xss[i] = Utils.makeText('',xss[i]);

276+ xss[i] = Utils.makeText(xss[i]);

277 }

278 return Utils.txt(xss.join(sep));

279 }

libraries/Native/Text.js+7−5

@@ -91,10 +91,11 @@ Elm.Native.Text.make = function(elm) {

91 function position(align) {

92 function create(text) {

93 var raw = {

94− ctor:'RawHtml',

94+ ctor :'RawHtml',

95− html: Utils.makeText('text-align:' + align + ';', text),

95+ html : Utils.makeText(text),

96+ align: align,

96− guid: null,

97+ guid : null,

97− args: [],

98+ args : [],

98 };

99 };

99 var pos = A2(Utils.htmlHeight, 0, raw);

100 var pos = A2(Utils.htmlHeight, 0, raw);

100 return A3(Element.newElement, pos._0, pos._1, raw);

101 return A3(Element.newElement, pos._0, pos._1, raw);

@@ -106,6 +107,7 @@ Elm.Native.Text.make = function(elm) {

106 var raw = {

107 var raw = {

107 ctor:'RawHtml',

108 ctor:'RawHtml',

108 html: text,

109 html: text,

110+ align: null,

109 guid: guid,

111 guid: guid,

110 args: [],

112 args: [],

111 };

113 };

@@ -145,4 +147,4 @@ Elm.Native.Text.make = function(elm) {

145

147

146 asText : asText,

148 asText : asText,

147 };

149 };

148−};

150+};

libraries/Native/Utils.js+2−2

@@ -74,8 +74,8 @@ Elm.Native.Utils.make = function(elm) {

74 return t;

75 }

76

77− function makeText(style, text) {

77+ function makeText(text) {

78− var style = style;

78+ var style = '';

79 var line = '';

80 var href = '';

81 while (true) {

libraries/Signal.elm+12−9

@@ -106,13 +106,13 @@ countIf = Native.Signal.countIf

106

107{-| Keep only events that satisfy the given predicate. Elm does not allow

108undefined signals, so a base case must be provided in case the predicate is

109−never satisfied. -}

109+not satisfied initially. -}

110keepIf : (a -> Bool) -> a -> Signal a -> Signal a

111keepIf = Native.Signal.keepIf

112

113{-| Drop events that satisfy the given predicate. Elm does not allow undefined

114−signals, so a base case must be provided in case the predicate is never

114+signals, so a base case must be provided in case the predicate is satisfied

115−satisfied. -}

115+initially. -}

116dropIf : (a -> Bool) -> a -> Signal a -> Signal a

117dropIf = Native.Signal.dropIf

118

@@ -120,21 +120,24 @@ dropIf = Native.Signal.dropIf

120becomes true, the most recent value of the second signal will be propagated.

121Until the first signal becomes false again, all events will be propagated. Elm

122does not allow undefined signals, so a base case must be provided in case the

123−first signal is never true. -}

123+first signal is not true initially. -}

124keepWhen : Signal Bool -> a -> Signal a -> Signal a

125keepWhen = Native.Signal.keepWhen

126

127{-| Drop events when the first signal is true. When the first signal becomes

128false, the most recent value of the second signal will be propagated. Until the

129first signal becomes true again, all events will be propagated. Elm does not

130−allow undefined signals, so a base case must be provided in case the first

130+allow undefined signals, s oa base case must be provided in case the first

131−signal is always true. -}

131+signal is true initially. -}

132dropWhen : Signal Bool -> a -> Signal a -> Signal a

133dropWhen = Native.Signal.dropWhen

134

135−{-| Drop sequential repeated values. For example, if a signal produces the

135+{-| Drop updates that repeat the current value of the signal.

136−sequence `[1,1,2,2,1]`, it becomes `[1,2,1]` by dropping the values that are the

136+

137−same as the previous value. -}

137+Imagine a signal `numbers` has initial value

138+0 and then updates with values 0, 0, 1, 1, and 2. `dropRepeats numbers`

139+is a signal that has initial value 0 and updates as follows: ignore 0,

140+ignore 0, update to 1, ignore 1, update to 2. -}

138dropRepeats : Signal a -> Signal a

141dropRepeats : Signal a -> Signal a

139dropRepeats = Native.Signal.dropRepeats

142dropRepeats = Native.Signal.dropRepeats

140

143

libraries/Time.elm+7−3

@@ -81,9 +81,13 @@ each mouse click and false otherwise.

81since : Time -> Signal a -> Signal Bool

82since = Native.Time.since

83

84−{-| Add a timestamp to any signal. Timestamps increase monotonically. Each

84+{-| Add a timestamp to any signal. Timestamps increase monotonically. When you

85+create `(timestamp Mouse.x)`, an initial timestamp is produced. The timestamp

86+updates whenever `Mouse.x` updates.

87+

88+Timestamp updates are tied to individual events, so

85−timestamp is related to a specfic event, so `Mouse.x` and `Mouse.y` will always

89+`(timestamp Mouse.x)` and `(timestamp Mouse.y)` will always have the same

86−have the same timestamp because they both rely on the same underlying event.

90+timestamp because they rely on the same underlying event (`Mouse.position`).

87-}

91-}

88timestamp : Signal a -> Signal (Time, a)

92timestamp : Signal a -> Signal (Time, a)

89timestamp = Native.Time.timestamp

93timestamp = Native.Time.timestamp

runtime/Init.js+5−4

@@ -220,14 +220,15 @@ function initGraphics(elm, Module) {

220 elm.node.appendChild(Render.render(currentScene));

221

222 // set up updates so that the DOM is adjusted as necessary.

223+ var savedScene = currentScene;

223− function domUpdate(newScene, currentScene) {

224+ function domUpdate(newScene) {

224 ElmRuntime.draw(function(_) {

225 ElmRuntime.draw(function(_) {

225− Render.update(elm.node.firstChild, currentScene, newScene);

226+ Render.update(elm.node.firstChild, savedScene, newScene);

226 if (elm.Native.Window) elm.Native.Window.values.resizeIfNeeded();

227 if (elm.Native.Window) elm.Native.Window.values.resizeIfNeeded();

228+ savedScene = newScene;

227 });

229 });

228− return newScene;

229 }

230 }

230− var renderer = A3(Signal.foldp, F2(domUpdate), currentScene, signalGraph);

231+ var renderer = A2(Signal.lift, domUpdate, signalGraph);

231

232

232 // must check for resize after 'renderer' is created so

233 // must check for resize after 'renderer' is created so

233 // that changes show up.

234 // that changes show up.

runtime/Render/Element.js+2

@@ -158,10 +158,12 @@ function rawHtml(elem) {

158 var html = elem.html;

159 var args = elem.args;

160 var guid = elem.guid;

161+ var align = elem.align;

161

162

162 var div = newElement('div');

163 var div = newElement('div');

163 div.innerHTML = html;

164 div.innerHTML = html;

164 div.style.visibility = "hidden";

165 div.style.visibility = "hidden";

166+ if (align) div.style.textAlign = align;

165 document.body.appendChild(div);

167 document.body.appendChild(div);

166

168

167 for (var i = args.length; i--; ) {

169 for (var i = args.length; i--; ) {