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