git.iko.soy/elk
on 294fdfd help sign in
elk/compiler/Types/Alias.hs
137 lines 4.8 kB history raw
2module Types.Alias (dealias, mistakes) where
4import Ast
5import Control.Arrow (second)
6import Data.List (group,sort)
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import Types.Substitutions (subst)
10import Types.Types
12builtins :: [(String,([X],Type))]
13builtins = [ ("String", ([], string)) ]
15getAliases :: [Statement] -> Map.Map String ([X],Type)
16getAliases stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
17 where getAlias stmt = case stmt of
18 TypeAlias alias xs t -> [(alias, (xs,t))]
19 _ -> []
22dealias :: [Statement] -> [Statement]
23dealias 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
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
45mistakes :: [Statement] -> [String]
46mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
48badKinds :: [Statement] -> [String]
49badKinds stmts = map msg (concatMap badS stmts)
50 where
51 msg x = "Type Error: Type alias '" ++ x ++
52 "' was given the wrong number of arguments."
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 _ -> []
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 _ -> []
76annotation :: Statement -> [String]
77annotation s =
78 case s of
79 TypeAnnotation name _ -> [name]
80 _ -> []
82definition :: Statement -> [String]
83definition s =
84 case s of
85 Definition d -> [defName d]
86 _ -> []
88defName :: Def -> String
89defName d =
90 case d of
91 FnDef n _ _ -> n
92 OpDef n _ _ _ -> n
94dups :: [Statement] -> [String]
95dups 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
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 ++ "'."
104badOrder :: [Statement] -> [String]
105badOrder 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
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 ( _ , _ ) -> []
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 _ -> []
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