git.iko.soy/elk
on a3801ac help sign in
elk/compiler/Types/Alias.hs
138 lines 4.9 kB history raw
1{-# LANGUAGE PatternGuards #-}
2module Types.Alias (dealias, get, mistakes) where
4import Ast
5import Located
6import Control.Arrow (second)
7import Data.List (group,sort)
8import Data.Maybe (mapMaybe)
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import Types.Substitutions (subst)
12import Types.Types
13import Data.Generics.Uniplate.Data
15builtins :: [(String,([X],Type))]
16builtins =
17 let touch = ("t0", time) : map (flip (,) int) ["x","y","x0","y0","id"]
18 state = [("string", string), ("selectionStart", int), ("selectionEnd", int)]
19 line = [("color", tipe "Color"), ("width", float),
20 ("cap", tipe "LineCap"), ("join", tipe "LineJoin"),
21 ("miterLimit", float), ("dashing", listOf int),
22 ("dashOffset", int)]
23 makeRecord fields =
24 RecordT (Map.fromList $ map (second (:[])) fields) EmptyRecord
25 in [ ("String", ([], listOf char)),
26 ("Time", ([], float)),
27 ("KeyCode", ([], int)),
28 ("Touch", ([], makeRecord touch)),
29 ("FieldState", ([], makeRecord state)),
30 ("LineStyle", ([], makeRecord line))
31 ]
33get :: [Statement] -> Map.Map String ([X],Type)
34get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
35 where getAlias stmt = case stmt of
36 TypeAlias alias xs t -> [(alias, (xs,t))]
37 _ -> []
39dealias :: Map.Map String ([X],Type) -> Type -> Type
40dealias aliases t =
41 let f = dealias aliases in
42 case t of
43 ADT name ts -> case Map.lookup name aliases of
44 Just (xs,t) -> f (subst (zip xs ts) t)
45 Nothing -> ADT name (map f ts)
46 LambdaT t u -> LambdaT (f t) (f u)
47 RecordT r t -> RecordT (Map.map (map f) r) (f t)
48 _ -> t
50mistakes :: [Statement] -> [String]
51mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
53badKinds :: [Statement] -> [String]
54badKinds stmts = [msg tname | t <- universeBi stmts, tname <- badT t]
55 where
56 msg x = "Type Error: Type alias '" ++ x ++
57 "' was given the wrong number of arguments."
59 badT :: Type -> [String]
60 badT (ADT name ts)
61 | Just (xs, _) <- Map.lookup name (get stmts),
62 length xs /= length ts = [name]
63 badT _ = []
65annotation :: Def -> Maybe String
66annotation s =
67 case s of
68 TypeAnnotation name _ -> Just name
69 _ -> Nothing
71definition :: Def -> Maybe String
72definition s =
73 case s of
74 FnDef name _ _ -> Just name
75 OpDef name _ _ _ -> Just name
76 _ -> Nothing
78checkTopLevelAndLets :: [Statement] -> (String -> [Def] -> [a]) -> [a]
79checkTopLevelAndLets stmts fcheck =
80 fcheck "at top-level" topLevelDefs ++
81 concatMap (fcheck "in let binding") allLetDefs
82 where
83 topLevelDefs = mapMaybe maybeDef stmts
84 maybeDef (Definition d) = Just d
85 maybeDef _ = Nothing
86 allLetDefs = [defList | Let defList _ <- universeBi stmts]
88dups :: [Statement] -> [String]
89dups stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
90 let
91 dup :: (Def -> Maybe String) -> [String]
92 dup f = map head . filter ((>1) . length) . group . sort $ mapMaybe f defs
94 msg = "Syntax Error: There can only be one "
95 defMsg x = msg ++ "definition of '" ++ x ++ "' " ++ ctxt ++ "."
96 annMsg x = msg ++ "type annotation for '" ++ x ++ "'" ++ ctxt ++ "."
97 in
98 map defMsg (dup definition) ++ map annMsg (dup annotation)
100badOrder :: [Statement] -> [String]
101badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
102 let
103 msg x = "Syntax Error: The type annotation for '" ++ x ++
104 "' must be directly above its definition in " ++ ctxt ++ "."
105 as = sort $ mapMaybe annotation defs
106 ds = sort $ mapMaybe definition defs
108 expectedPairs :: [String] -> [String] -> [String]
109 expectedPairs as ds =
110 case (as,ds) of
111 (x:xs, y:ys) -> case compare x y of
112 LT -> expectedPairs xs (y:ys)
113 EQ -> x : expectedPairs xs ys
114 GT -> expectedPairs (x:xs) ys
115 ( _ , _ ) -> []
117 actualPairs :: [Def] -> [String]
118 actualPairs stmts =
119 case stmts of
120 TypeAnnotation n _ : rest@(d : _) ->
121 (if Just n == definition d
122 then [n]
123 else []
124 ) ++ actualPairs rest
125 t:s:rest -> actualPairs (s:rest)
126 _ -> []
128 missings :: [String] -> [String] -> [String]
129 missings expected actual =
130 case (expected, actual) of
131 (e:es, a:as) -> case compare e a of
132 LT -> e : missings es (a:as)
133 EQ -> missings es as
134 GT -> a : missings (e:es) as
135 ( [] , _ ) -> actual
136 ( _ , [] ) -> expected
137 in
138 map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)