6ba394c · elk · git.iko.soy

compiler/Build/Source.hs+4−4

compare with master

unifiedsplit

@@ -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,9 @@ 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 }

55

56 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/SourceSyntax/Declaration.hs+6−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

@@ -34,23 +31,6 @@ data Port

34type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

31type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

35type Declaration = Declaration' Port Expr.Def

32type Declaration = Declaration' Port Expr.Def

36

33

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

34instance Show Assoc where

55 show assoc =

35 show assoc =

56 case assoc of

36 case assoc of

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

73 case decl of

53 case decl of

74 Definition def -> pretty def

54 Definition def -> pretty def

75

55

76− Datatype tipe tvars ctors deriveables ->

56+ Datatype tipe tvars ctors ->

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

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

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

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

79 where

59 where

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

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

81 prettyCtor (name, tipes) =

61 prettyCtor (name, tipes) =

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

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

83

63

84− TypeAlias name tvars tipe deriveables ->

64+ TypeAlias name tvars tipe ->

85− alias <+> prettyDeriving deriveables

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

86 where

66 where

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

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

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

89

68

90 Port port -> pretty port

69 Port port -> pretty port

91

70

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

112

91

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

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

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

93prettyPort 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+2−2

@@ -50,8 +50,8 @@ data MetadataModule =

50 } deriving Show

51

52type Interfaces = Map.Map String ModuleInterface

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

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

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

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

55

56data ModuleInterface = ModuleInterface {

57 iVersion :: Version.Version,

compiler/Transform/Canonicalize.hs+7−7

@@ -27,11 +27,11 @@ interface moduleName iface =

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

28 }

29 where

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

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

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

32

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

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

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

35 canons = Map.fromList $ concat

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

37

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

56 [] -> Right ()

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

58 program' <- rename initialEnv (program modul)

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

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

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

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

61 return $ modul { program = program'

62 , aliases = aliases'

63 , datatypes = datatypes' }

64 where

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

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

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

67 renameType' =

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

69

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

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

71 canon (name, importMethod) =

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

73 iface = ifaces Map.! name

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

75 , map get1 (iAliases iface)

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

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

77 in case importMethod of

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

79 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')