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