6ba394c · elk · git.iko.soy

compiler/Build/Source.hs+4−4

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

3535 | null exs =

3636 let get = Set.toList . Pattern.boundVars in

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

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

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

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

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

4040 | otherwise = exs

4141

4242 metaModule <- Canonical.metadataModule interfaces $

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

4848 -- reorder AST into strongly connected components

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

5050 , 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 ]

5252 , 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 ]

5454 }

5555

5656 types <- TI.infer interfaces metaModule

compiler/Docs.hs+4−8

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

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

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

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

137− D.TypeAlias name vars tipe derivations ->

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

137+ D.TypeAlias name vars tipe ->

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

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

140− D.Datatype name vars ctors derivations ->

140+ D.Datatype name vars ctors ->

141141 let tipe = Data name (map Var vars)

142142 fields = ["typeVariables" .= vars

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

144− , "deriving" .= derivations ]

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

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

146145 where

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

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

162161ctorToJson tipe (ctor, tipes) =

163162 object [ "name" .= ctor

164163 , "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

2424 args <- spacePrefix lowVar

2525 padded equals

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

3228

3329datatype :: IParser D.ParseDeclaration

3430datatype = do

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

3834 args <- spacePrefix lowVar

3935 padded equals

4036 tcs <- pipeSep1 Type.constructor

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

37+ return $ D.Datatype name args tcs

4238

4339

4440infixDecl :: IParser D.ParseDeclaration

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

6056 whitespace

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

6258 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

99

1010data Declaration' port def

1111 = Definition def

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

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

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

13+ | TypeAlias String [String] T.Type

1414 | Port port

1515 | Fixity Assoc Int String

1616 deriving (Show)

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

1818data Assoc = L | N | R

1919 deriving (Eq)

2020

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

22− deriving (Eq, Show)

23−

2421data ParsePort

2522 = PPAnnotation String T.Type

2623 | PPDef String Expr.LParseExpr

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

3431type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

3532type Declaration = Declaration' Port Expr.Def

3633

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−

5434instance Show Assoc where

5535 show assoc =

5636 case assoc of

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

7353 case decl of

7454 Definition def -> pretty def

7555

76− Datatype tipe tvars ctors deriveables ->

56+ Datatype tipe tvars ctors ->

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

7959 where

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

8161 prettyCtor (name, tipes) =

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

8363

84− TypeAlias name tvars tipe deriveables ->

85− alias <+> prettyDeriving deriveables

64+ TypeAlias name tvars tipe ->

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

8666 where

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

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

8968

9069 Port port -> pretty port

9170

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

11291

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

11493prettyPort 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 =

5050 } deriving Show

5151

5252type Interfaces = Map.Map String ModuleInterface

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

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

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

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

5555

5656data ModuleInterface = ModuleInterface {

5757 iVersion :: Version.Version,

compiler/Transform/Canonicalize.hs+7−7

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

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

2828 }

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

3131 prefix name = moduleName ++ "." ++ name

3232

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

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

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

3535 canons = Map.fromList $ concat

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

3737

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

5656 [] -> Right ()

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

5858 program' <- rename initialEnv (program modul)

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

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

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

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

6161 return $ modul { program = program'

6262 , aliases = aliases'

6363 , datatypes = datatypes' }

6464 where

6565 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

6767 renameType' =

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

6969

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

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

7171 canon (name, importMethod) =

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

7373 iface = ifaces Map.! name

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

7575 , map get1 (iAliases iface)

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

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

7777 in case importMethod of

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

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

compiler/Transform/Check.hs+10−32

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

2121 concat [ infiniteTypeAliases decls

2222 , illFormedTypes decls

2323 , map P.text (duplicateConstructors decls)

24− , map P.text (duplicates decls)

25− , badDerivations decls ]

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

2625

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

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

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

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

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

6968 where

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

71− 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− ]

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

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

9371

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

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

9674 where

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

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

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

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

9977

10078 freeVars tipe =

10179 case tipe of

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

138116

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

140118infiniteTypeAliases decls =

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

142− , infiniteType name tipe ]

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

120+ , infiniteType name tipe ]

143121 where

144122 infiniteType name tipe =

145123 let infinite = infiniteType name in

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

152130 indented :: D.Declaration -> Doc

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

154132

155− report name args tipe derivations =

133+ report name args tipe =

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

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

135+ , indented $ D.TypeAlias name args tipe

158136 , P.text $ eightyCharLines 0 msg2

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

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

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

161139 ]

162140 where

compiler/Transform/Declaration.hs+4−4

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

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

2424 [] -> return []

2525

26− Datatype name tvars ctors ds : rest ->

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

26+ Datatype name tvars ctors : rest ->

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

2828

29− TypeAlias name tvars alias ds : rest ->

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

29+ TypeAlias name tvars alias : rest ->

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

3131

3232 Fixity assoc prec op : rest ->

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

compiler/Transform/SafeNames.hs+3−3

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

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

6565 , program = expression (program modul)

6666 , aliases =

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

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

6868 in map makeSafe (aliases modul)

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

7171 in map makeSafe (datatypes modul)

72− }

72+ }

compiler/Type/Alias.hs+3−3

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

2121 rawAliases =

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

2323

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

24+ isPrimitive (_,_,tipe) =

2525 case tipe of

2626 Data _ [] -> True

2727 _ -> False

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

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

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

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

137137

138138flattenFields 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 =

1515 case decl of

1616 Definition def -> [def]

1717

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

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

1919 where

2020 toDefs' (ctor, tipes) =

2121 let vars = take (length tipes) arguments

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

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

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

2525

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

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

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

2828 where

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

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

3838

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

4040 -- 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 _ _ _ -> []

4342

4443 Port port ->

4544 case port of

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

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

6160

6261definition :: 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 {

2929initialEnvironment :: [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,7 +42,7 @@ 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

4747 makeCtor (name, _) = do

4848 ctor <- VarN <$> namedVar Constant name

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

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

167167 ext' <- case ext of

168168 Nothing -> return $ TermN EmptyRecord1

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

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

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