git.iko.soy/elk
on 104faf1 help sign in
elk/compiler/Types/Alias.hs
125 lines 4.2 kB history raw
2module Types.Alias (dealias, get, 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", ([], listOf char))
14 , ("Time", ([], float)) ]
16get :: [Statement] -> Map.Map String ([X],Type)
17get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
18 where getAlias stmt = case stmt of
19 TypeAlias alias xs t -> [(alias, (xs,t))]
20 _ -> []
22dealias :: Map.Map String ([X],Type) -> Type -> Type
23dealias aliases t =
24 let f = dealias aliases in
25 case t of
26 ADT name ts -> case Map.lookup name aliases of
27 Just (xs,t) -> f (subst (zip xs ts) t)
28 Nothing -> ADT name (map f ts)
29 LambdaT t u -> LambdaT (f t) (f u)
30 RecordT r t -> RecordT (Map.map (map f) r) (f t)
31 _ -> t
33mistakes :: [Statement] -> [String]
34mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
36badKinds :: [Statement] -> [String]
37badKinds stmts = map msg (concatMap badS stmts)
38 where
39 msg x = "Type Error: Type alias '" ++ x ++
40 "' was given the wrong number of arguments."
42 badT :: Type -> [String]
43 badT t =
44 case t of
45 ADT name ts ->
46 case Map.lookup name (get stmts) of
47 Just (xs,t) | length xs == length ts -> []
48 | otherwise -> [name]
49 Nothing -> concatMap badT ts
50 LambdaT t u -> badT t ++ badT u
51 RecordT r t -> badT t ++ concatMap badT (concat (Map.elems r))
52 _ -> []
54 badS :: Statement -> [String]
55 badS s =
56 case s of
57 Datatype _ _ tcs -> concatMap badT (concatMap snd tcs)
58 ExportEvent _ _ tipe -> badT tipe
59 ImportEvent _ _ _ tipe -> badT tipe
60 TypeAnnotation _ tipe -> badT tipe
61 TypeAlias _ _ tipe -> badT tipe
62 Definition _ -> []
64annotation :: Statement -> [String]
65annotation s =
66 case s of
67 TypeAnnotation name _ -> [name]
68 _ -> []
70definition :: Statement -> [String]
71definition s =
72 case s of
73 Definition d -> [defName d]
74 _ -> []
76defName :: Def -> String
77defName d =
78 case d of
79 FnDef n _ _ -> n
80 OpDef n _ _ _ -> n
82dups :: [Statement] -> [String]
83dups stmts = map defMsg (dup definition) ++ map annMsg (dup annotation)
84 where
85 dup :: (Statement -> [String]) -> [String]
86 dup f = map head . filter ((>1) . length) . group . sort $ concatMap f stmts
88 msg = "Syntax Error: There can only be one "
89 defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."
90 annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
92badOrder :: [Statement] -> [String]
93badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs stmts)
94 where
95 msg x = "Syntax Error: The type annotation for '" ++ x ++
96 "' must be directly above its definition."
97 as = sort $ concatMap annotation stmts
98 ds = sort $ concatMap definition stmts
100 expectedPairs :: [String] -> [String] -> [String]
101 expectedPairs as ds =
102 case (as,ds) of
103 (x:xs, y:ys) -> case compare x y of
104 LT -> expectedPairs xs (y:ys)
105 EQ -> x : expectedPairs xs ys
106 GT -> expectedPairs (x:xs) ys
107 ( _ , _ ) -> []
109 actualPairs :: [Statement] -> [String]
110 actualPairs stmts =
111 case stmts of
112 TypeAnnotation n _ : Definition d : rest ->
113 (if n == defName d then [n] else []) ++ actualPairs rest
114 t:s:rest -> actualPairs (s:rest)
115 _ -> []
117 missings :: [String] -> [String] -> [String]
118 missings expected actual =
119 case (expected, actual) of
120 (e:es, a:as) -> case compare e a of
121 LT -> e : missings es (a:as)
122 EQ -> missings es as
123 GT -> a : missings (e:es) as
124 ( [] , _ ) -> actual
125 ( _ , [] ) -> expected