git.iko.soy/elk
on master help sign in
Split the alias code into its own file. Add checks for duplicate definitions, bad order of definitions, and type aliases without enough arguments
ecc49caevancz
elm/Elm.cabal+2
compare with master
unifiedsplit
@@ -52,6 +52,7 @@ Library
52 Parse.Parser,
52 Parse.Parser,
53 Parse.Patterns,
53 Parse.Patterns,
54 Parse.Types,
54 Parse.Types,
55+ Types.Alias,
55 Types.Types,
56 Types.Types,
56 Types.Constrain,
57 Types.Constrain,
57 Types.Hints,
58 Types.Hints,
@@ -99,6 +100,7 @@ Executable elm
99 Parse.Parser,
100 Parse.Parser,
100 Parse.Patterns,
101 Parse.Patterns,
101 Parse.Types,
102 Parse.Types,
103+ Types.Alias,
102 Types.Types,
104 Types.Types,
103 Types.Constrain,
105 Types.Constrain,
104 Types.Hints,
106 Types.Hints,
elm/src/Initialize.hs+13−11
@@ -10,16 +10,18 @@ import Rename
10import Types.Types ((-:))
10import Types.Types ((-:))
11import Types.Hints (hints)
11import Types.Hints (hints)
12import Types.Unify
12import Types.Unify
13−import Types.Substitutions (dealias)
13+import Types.Alias
14import Optimize
14import Optimize
15
15
16−
16+initialize :: String -> Either String ([String], Module)
17−initialize str =
17+initialize str = do
18− do Module name ex im stmts <- parseProgram str
18+ Module name ex im stmts <- parseProgram str
19+ case mistakes stmts of
20+ m:ms -> Left (unlines (m:ms))
19− let stmts' = dealias stmts
21+ [] -> let stmts' = dealias stmts
20− modul = Module name ex im stmts'
22+ modul = Module name ex im stmts'
21− (escapees, subs) <- unify hints modul
23+ in do (escapees, subs) <- unify hints modul
22− let modul' = optimize . renameModule $ Module name ex im' stmts'
23− where im' | any ((=="Prelude") . fst) im = im
24+ let im' | any ((=="Prelude") . fst) im = im
24− | otherwise = ("Prelude", Hiding []) : im
25+ | otherwise = ("Prelude", Hiding []) : im
26+ modul' = optimize . renameModule $ Module name ex im' stmts'
25− subs `seq` return (escapees, modul')
27+ subs `seq` return (escapees, modul')
elm/src/Types/Alias.hsnew file+137
@@ -0,0 +1,137 @@
1+
2+module Types.Alias (dealias, mistakes) where
3+
4+import Ast
5+import Control.Arrow (second)
6+import Data.List (group,sort)
7+import qualified Data.Map as Map
8+import qualified Data.Set as Set
9+import Types.Substitutions (subst)
10+import Types.Types
11+
12+builtins :: [(String,([X],Type))]
13+builtins = [ ("String", ([], string)) ]
14+
15+getAliases :: [Statement] -> Map.Map String ([X],Type)
16+getAliases stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
17+ where getAlias stmt = case stmt of
18+ TypeAlias alias xs t -> [(alias, (xs,t))]
19+ _ -> []
20+
21+
22+dealias :: [Statement] -> [Statement]
23+dealias stmts = map dealiasS stmts
24+ where
25+ dealiasT :: Type -> Type
26+ dealiasT t =
27+ case t of
28+ ADT name ts -> case Map.lookup name (getAliases stmts) of
29+ Just (xs,t) -> dealiasT (subst (zip xs ts) t)
30+ Nothing -> ADT name (map dealiasT ts)
31+ LambdaT t u -> LambdaT (dealiasT t) (dealiasT u)
32+ RecordT r t -> RecordT (Map.map (map dealiasT) r) (dealiasT t)
33+ _ -> t
34+
35+ dealiasS :: Statement -> Statement
36+ dealiasS s =
37+ case s of
38+ Datatype n xs tcs -> Datatype n xs (map (second (map dealiasT)) tcs)
39+ ExportEvent js elm tipe -> ExportEvent js elm (dealiasT tipe)
40+ ImportEvent js e elm tipe -> ImportEvent js e elm (dealiasT tipe)
41+ TypeAnnotation name tipe -> TypeAnnotation name (dealiasT tipe)
42+ TypeAlias alias xs tipe -> TypeAlias alias xs (dealiasT tipe)
43+ Definition _ -> s
44+
45+mistakes :: [Statement] -> [String]
46+mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
47+
48+badKinds :: [Statement] -> [String]
49+badKinds stmts = map msg (concatMap badS stmts)
50+ where
51+ msg x = "Type Error: Type alias '" ++ x ++
52+ "' was given the wrong number of arguments."
53+
54+ badT :: Type -> [String]
55+ badT t =
56+ case t of
57+ ADT name ts ->
58+ case Map.lookup name (getAliases stmts) of
59+ Just (xs,t) | length xs == length ts -> []
60+ | otherwise -> [name]
61+ Nothing -> concatMap badT ts
62+ LambdaT t u -> badT t ++ badT u
63+ RecordT r t -> badT t ++ concatMap badT (concat (Map.elems r))
64+ _ -> []
65+
66+ badS :: Statement -> [String]
67+ badS s =
68+ case s of
69+ Datatype _ _ tcs -> concatMap badT (concatMap snd tcs)
70+ ExportEvent _ _ tipe -> badT tipe
71+ ImportEvent _ _ _ tipe -> badT tipe
72+ TypeAnnotation _ tipe -> badT tipe
73+ TypeAlias _ _ tipe -> badT tipe
74+ Definition _ -> []
75+
76+annotation :: Statement -> [String]
77+annotation s =
78+ case s of
79+ TypeAnnotation name _ -> [name]
80+ _ -> []
81+
82+definition :: Statement -> [String]
83+definition s =
84+ case s of
85+ Definition d -> [defName d]
86+ _ -> []
87+
88+defName :: Def -> String
89+defName d =
90+ case d of
91+ FnDef n _ _ -> n
92+ OpDef n _ _ _ -> n
93+
94+dups :: [Statement] -> [String]
95+dups stmts = map defMsg (dup definition) ++ map annMsg (dup annotation)
96+ where
97+ dup :: (Statement -> [String]) -> [String]
98+ dup f = map head . filter ((>1) . length) . group . sort $ concatMap f stmts
99+
100+ msg = "Syntax Error: There can only be one "
101+ defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."
102+ annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
103+
104+badOrder :: [Statement] -> [String]
105+badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs stmts)
106+ where
107+ msg x = "Syntax Error: The type annotation for '" ++ x ++
108+ "' must be directly above its definition."
109+ as = sort $ concatMap annotation stmts
110+ ds = sort $ concatMap definition stmts
111+
112+ expectedPairs :: [String] -> [String] -> [String]
113+ expectedPairs as ds =
114+ case (as,ds) of
115+ (x:xs, y:ys) -> case compare x y of
116+ LT -> expectedPairs xs (y:ys)
117+ EQ -> x : expectedPairs xs ys
118+ GT -> expectedPairs (x:xs) ys
119+ ( _ , _ ) -> []
120+
121+ actualPairs :: [Statement] -> [String]
122+ actualPairs stmts =
123+ case stmts of
124+ TypeAnnotation n _ : Definition d : rest ->
125+ if n == defName d then [n] else [] ++ actualPairs rest
126+ t:s:rest -> actualPairs (s:rest)
127+ _ -> []
128+
129+ missings :: [String] -> [String] -> [String]
130+ missings expected actual =
131+ case (expected, actual) of
132+ (e:es, a:as) -> case compare e a of
133+ LT -> e : missings es (a:as)
134+ EQ -> missings es as
135+ GT -> a : missings (e:es) as
136+ ( [] , _ ) -> actual
137+ ( _ , [] ) -> expected
elm/src/Types/Substitutions.hs+1−35
@@ -4,13 +4,11 @@ module Types.Substitutions (subst,
4 freeVars,
4 freeVars,
5 concretize,
5 concretize,
6 rescheme,
6 rescheme,
7− generalize,
7+ generalize) where
8− dealias) where
9
8
10import Ast
9import Ast
11import Context
10import Context
12import Control.DeepSeq (NFData (..), deepseq)
11import Control.DeepSeq (NFData (..), deepseq)
13−import Control.Arrow (second)
14import Control.Monad (liftM)
12import Control.Monad (liftM)
15import Data.List (foldl')
13import Data.List (foldl')
16import qualified Data.Set as Set
14import qualified Data.Set as Set
@@ -90,35 +88,3 @@ generalize :: [X] -> Scheme -> GuidCounter Scheme
90generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
88generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
91 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
89 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
92 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
90 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
93−
94−dealias :: [Statement] -> [Statement]
95−dealias stmts = map dealiasS stmts
96− where
97− builtins :: [(String,([X],Type))]
98− builtins = [ ("String", ([], string)) ]
99−
100− getAliases :: [Statement] -> Map.Map String ([X],Type)
101− getAliases stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
102− where getAlias stmt = case stmt of
103− TypeAlias alias xs t -> [(alias, (xs,t))]
104− _ -> []
105−
106− dealiasT :: Type -> Type
107− dealiasT t =
108− case t of
109− ADT name ts -> case Map.lookup name (getAliases stmts) of
110− Just (xs,t) -> dealiasT (subst (zip xs ts) t)
111− Nothing -> ADT name (map dealiasT ts)
112− LambdaT t u -> LambdaT (dealiasT t) (dealiasT u)
113− RecordT r t -> RecordT (Map.map (map dealiasT) r) (dealiasT t)
114− _ -> t
115−
116− dealiasS :: Statement -> Statement
117− dealiasS s =
118− case s of
119− Datatype n xs tcs -> Datatype n xs (map (second (map dealiasT)) tcs)
120− ExportEvent js elm tipe -> ExportEvent js elm (dealiasT tipe)
121− ImportEvent js e elm tipe -> ImportEvent js e elm (dealiasT tipe)
122− TypeAnnotation name tipe -> TypeAnnotation name (dealiasT tipe)
123− Definition _ -> s
124− TypeAlias _ _ _ -> s