git.iko.soy/elk
on 71bb1c8 help sign in
elk/compiler/Transform/Check.hs
196 lines 7.6 kB history raw
1module Transform.Check (mistakes) where
3import Transform.SortDefinitions (boundVars)
4import qualified SourceSyntax.Declaration as D
5import SourceSyntax.Expression
6import SourceSyntax.Pattern
7import SourceSyntax.Location
8import SourceSyntax.PrettyPrint
9import qualified SourceSyntax.Type as T
10import Data.List as List
11import qualified Data.Map as Map
12import qualified Data.Maybe as Maybe
13import qualified Data.Set as Set
14import Text.PrettyPrint as P
17mistakes :: [D.Declaration t v] -> [Doc]
18mistakes decls =
19 concat [ infiniteTypeAliases decls
20 , illFormedTypes decls
21 , map P.text (duplicateConstructors decls)
22 , map P.text (concatMap findErrors (getLets decls))
23 , badDerivations decls ]
24 where
25 findErrors defs = duplicates defs ++ badOrder defs
27getLets :: [D.Declaration t v] -> [[Def t v]]
28getLets decls = defs : concatMap defLets defs
29 where
30 defs = [ d | D.Definition d <- decls ]
32 defLets def =
33 case def of
34 TypeAnnotation _ _ -> []
35 Def _ expr -> exprLets expr
37 exprLets (L _ expr) =
38 case expr of
39 Var _ -> []
40 Lambda p e -> exprLets e
41 Binop op e1 e2 -> exprLets e1 ++ exprLets e2
42 Case e cases -> exprLets e ++ concatMap (exprLets . snd) cases
43 Data name es -> concatMap exprLets es
44 Literal _ -> []
45 Range e1 e2 -> exprLets e1 ++ exprLets e2
46 ExplicitList es -> concatMap exprLets es
47 App e1 e2 -> exprLets e1 ++ exprLets e2
48 MultiIf branches -> concatMap (\(b,e) -> exprLets b ++ exprLets e) branches
49 Access e lbl -> exprLets e
50 Remove e lbl -> exprLets e
51 Insert e lbl v -> exprLets e ++ exprLets v
52 Modify e fields -> exprLets e ++ concatMap (exprLets . snd) fields
53 Record fields -> concatMap (exprLets . snd) fields
54 Markdown uid md es -> []
55 Let defs body -> [defs] ++ exprLets body
57dups :: Eq a => [a] -> [a]
58dups = map head . filter ((>1) . length) . List.group
60dupErr :: String -> String -> String
61dupErr err x =
62 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
64duplicates :: [Def t v] -> [String]
65duplicates defs =
66 map defMsg (dups definitions) ++ map annMsg (dups annotations)
67 where
68 annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
69 definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
70 defMsg = dupErr "definition of"
71 annMsg = dupErr "type annotation for"
73duplicateConstructors :: [D.Declaration t v] -> [String]
74duplicateConstructors decls =
75 map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
76 where
77 typeCtors = List.sort [ name | D.Datatype name _ _ _ <- decls ]
78 dataCtors = List.sort . concat $
79 [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]
80 dataMsg = dupErr "definition of data constructor"
81 typeMsg = dupErr "definition of type constructor"
83badOrder :: [Def t v] -> [String]
84badOrder defs = go defs
85 where
86 msg x = "Syntax Error: The type annotation for '" ++ x ++
87 "' must be directly above its definition."
89 go defs =
90 case defs of
91 TypeAnnotation name _ : Def (PVar name') _ : rest
92 | name == name' -> go rest
94 TypeAnnotation name _ : rest -> [msg name] ++ go rest
96 _ : rest -> go rest
98 _ -> []
100badDerivations :: [D.Declaration t v] -> [Doc]
101badDerivations decls = concatMap badDerivation derivations
102 where
103 derivations =
104 [ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ] ++
105 [ (decl, tvars, derives) | decl@(D.Datatype name tvars _ derives) <- decls ]
107 badDerivation (decl, tvars, derives) =
108 case (tvars, derives) of
109 (_:_, _)
110 | D.Json `elem` derives -> [report decl D.Json]
111 | D.Binary `elem` derives -> [report decl D.Binary]
112 _ -> []
114 report decl derive =
115 P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."
116 , P.text "Make sure all type variables are replaced with concrete types:"
117 , P.text "\n"
118 , nest 4 (pretty decl)
119 ]
121illFormedTypes :: [D.Declaration t v] -> [Doc]
122illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
123 where
124 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
125 adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]
127 freeVars tipe =
128 case tipe of
129 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
130 T.Var x -> Set.singleton x
131 T.Data _ ts -> Set.unions (map freeVars ts)
132 T.EmptyRecord -> Set.empty
133 T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)
135 undeclared tvars tipes = Set.difference used declared
136 where
137 used = Set.unions (map freeVars tipes)
138 declared = Set.fromList tvars
140 isIllFormed (decl, tvars, tipes) =
141 let unbound = undeclared tvars tipes in
142 if Set.null unbound then Nothing
143 else Just (decl, Set.toList unbound)
145 report (decl, tvars) =
146 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
147 , P.text "\n"
148 , nest 4 (pretty decl) ]
149 where
150 listing =
151 case tvars of
152 [tvar] -> " " ++ quote tvar ++ " is"
153 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
155 addCommas xs
156 | length xs < 3 = concat xs
157 | otherwise = intercalate "," xs
159 addAnd xs
160 | length xs < 2 = xs
161 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
163 quote tvar = "'" ++ tvar ++ "'"
166infiniteTypeAliases :: [D.Declaration t v] -> [Doc]
167infiniteTypeAliases decls =
168 [ report decl | decl@(D.TypeAlias name _ tipe _) <- decls, isInfinite name tipe ]
169 where
170 isInfinite name tipe =
171 let infinite = isInfinite name in
172 case tipe of
173 T.Lambda a b -> infinite a || infinite b
174 T.Var _ -> False
175 T.Data name' ts -> name == name' || any infinite ts
176 T.EmptyRecord -> False
177 T.Record fields ext -> infinite ext || any (infinite . snd) fields
179 report decl@(D.TypeAlias name args tipe derivations) =
180 P.vcat [ P.text $ eightyCharLines 0 msg1
181 , indented decl
182 , P.text $ eightyCharLines 0 msg2
183 , indented (D.Datatype name args [(name,[tipe])] derivations)
184 , P.text $ eightyCharLines 0 msg3 ++ "\n"
185 ]
186 where
187 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
189 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
190 "Notice that it appears in its own definition, so when \
191 \you expand it, it just keeps getting bigger:"
192 msg2 = "Try this instead:"
193 msg3 = "It looks very similar, but an algebraic data type (ADT) \
194 \actually creates a new type. Unlike with a type alias, this \
195 \freshly created type is meaningful on its own, so an ADT \
196 \does not need to be expanded."