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