git.iko.soy/elk
on f57ffdf help sign in
elk/compiler/Transform/Check.hs
153 lines 5.8 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 Data.Data
12import Data.Generics.Uniplate.Data
13import Text.PrettyPrint as P
16mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]
17mistakes decls =
18 concat [ infiniteTypeAliases decls
19 , illFormedTypes decls
20 , map P.text (duplicateConstructors decls)
21 , map P.text (concatMap findErrors (getLets decls)) ]
22 where
23 findErrors defs = duplicates defs ++ badOrder defs
25getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]
26getLets decls = defs : concatMap getSubLets defs
27 where
28 defs = concatMap (\d -> case d of Definition d -> [d] ; _ -> []) decls
30 getSubLets def =
31 case def of
32 Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]
33 TypeAnnotation _ _ -> []
35dups :: Eq a => [a] -> [a]
36dups = map head . filter ((>1) . length) . List.group
38dupErr :: String -> String -> String
39dupErr err x =
40 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
42duplicates :: [Def t v] -> [String]
43duplicates defs =
44 map defMsg (dups definitions) ++ map annMsg (dups annotations)
45 where
46 annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
47 definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
48 defMsg = dupErr "definition of"
49 annMsg = dupErr "type annotation for"
51duplicateConstructors :: [Declaration t v] -> [String]
52duplicateConstructors decls =
53 map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
54 where
55 typeCtors = List.sort [ name | Datatype name _ _ <- decls ]
56 dataCtors = List.sort . concat $
57 [ map fst patterns | Datatype _ _ patterns <- decls ]
58 dataMsg = dupErr "definition of data constructor"
59 typeMsg = dupErr "definition of type constructor"
61badOrder :: [Def t v] -> [String]
62badOrder defs = go defs
63 where
64 msg x = "Syntax Error: The type annotation for '" ++ x ++
65 "' must be directly above its definition."
67 go defs =
68 case defs of
69 TypeAnnotation name _ : Def (PVar name') _ : rest
70 | name == name' -> go rest
72 TypeAnnotation name _ : rest -> [msg name] ++ go rest
74 _ : rest -> go rest
76 _ -> []
78illFormedTypes :: [Declaration t v] -> [Doc]
79illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
80 where
81 aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]
82 adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]
84 freeVars tipe =
85 case tipe of
86 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
87 T.Var x -> Set.singleton x
88 T.Data _ ts -> Set.unions (map freeVars ts)
89 T.EmptyRecord -> Set.empty
90 T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)
92 undeclared tvars tipes = Set.difference used declared
93 where
94 used = Set.unions (map freeVars tipes)
95 declared = Set.fromList tvars
97 isIllFormed (decl, tvars, tipes) =
98 let unbound = undeclared tvars tipes in
99 if Set.null unbound then Nothing
100 else Just (decl, Set.toList unbound)
102 report (decl, tvars) =
103 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
104 , P.text "\n"
105 , nest 4 (pretty decl) ]
106 where
107 listing =
108 case tvars of
109 [tvar] -> " " ++ quote tvar ++ " is"
110 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
112 addCommas xs
113 | length xs < 3 = concat xs
114 | otherwise = intercalate "," xs
116 addAnd xs
117 | length xs < 2 = xs
118 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
120 quote tvar = "'" ++ tvar ++ "'"
123infiniteTypeAliases :: [Declaration t v] -> [Doc]
124infiniteTypeAliases decls =
125 [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]
126 where
127 isInfinite name tipe =
128 let infinite = isInfinite name in
129 case tipe of
130 T.Lambda a b -> infinite a || infinite b
131 T.Var _ -> False
132 T.Data name' ts -> name == name' || any infinite ts
133 T.EmptyRecord -> False
134 T.Record fields ext -> infinite ext || any (infinite . snd) fields
136 report decl@(TypeAlias name args tipe) =
137 P.vcat [ P.text $ eightyCharLines 0 msg1
138 , indented decl
139 , P.text $ eightyCharLines 0 msg2
140 , indented (Datatype name args [(name,[tipe])])
141 , P.text $ eightyCharLines 0 msg3 ++ "\n"
142 ]
143 where
144 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
146 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
147 "Notice that it appears in its own definition, so when \
148 \you expand it, it just keeps getting bigger:"
149 msg2 = "Try this instead:"
150 msg3 = "It looks very similar, but an algebraic data type (ADT) \
151 \actually creates a new type. Unlike with a type alias, this \
152 \freshly created type is meaningful on its own, so an ADT \
153 \does not need to be expanded."