git.iko.soy/elk
on 46f3fa1 help sign in
elk/compiler/Transform/Check.hs
142 lines 5.2 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 (concatMap findErrors (getLets decls)) ]
21 where
22 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 _ _ -> []
36duplicates :: [Def t v] -> [String]
37duplicates defs =
38 map defMsg (dups definitions) ++ map annMsg (dups annotations)
39 where
40 annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
41 definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
43 dups = map head . filter ((>1) . length) . List.group
45 msg = "Syntax Error: There can only be one "
46 defMsg x = msg ++ "definition of '" ++ x ++ "'."
47 annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
50badOrder :: [Def t v] -> [String]
51badOrder defs = go defs
52 where
53 msg x = "Syntax Error: The type annotation for '" ++ x ++
54 "' must be directly above its definition."
56 go defs =
57 case defs of
58 TypeAnnotation name _ : Def (PVar name') _ : rest
59 | name == name' -> go rest
61 TypeAnnotation name _ : rest -> [msg name] ++ go rest
63 _ : rest -> go rest
65 _ -> []
67illFormedTypes :: [Declaration t v] -> [Doc]
68illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
69 where
70 aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]
71 adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]
73 freeVars tipe =
74 case tipe of
75 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
76 T.Var x -> Set.singleton x
77 T.Data _ ts -> Set.unions (map freeVars ts)
78 T.EmptyRecord -> Set.empty
79 T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)
81 undeclared tvars tipes = Set.difference used declared
82 where
83 used = Set.unions (map freeVars tipes)
84 declared = Set.fromList tvars
86 isIllFormed (decl, tvars, tipes) =
87 let unbound = undeclared tvars tipes in
88 if Set.null unbound then Nothing
89 else Just (decl, Set.toList unbound)
91 report (decl, tvars) =
92 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
93 , P.text "\n"
94 , nest 4 (pretty decl) ]
95 where
96 listing =
97 case tvars of
98 [tvar] -> " " ++ quote tvar ++ " is"
99 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
101 addCommas xs
102 | length xs < 3 = concat xs
103 | otherwise = intercalate "," xs
105 addAnd xs
106 | length xs < 2 = xs
107 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
109 quote tvar = "'" ++ tvar ++ "'"
112infiniteTypeAliases :: [Declaration t v] -> [Doc]
113infiniteTypeAliases decls =
114 [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]
115 where
116 isInfinite name tipe =
117 let infinite = isInfinite name in
118 case tipe of
119 T.Lambda a b -> infinite a || infinite b
120 T.Var _ -> False
121 T.Data name' ts -> name == name' || any infinite ts
122 T.EmptyRecord -> False
123 T.Record fields ext -> infinite ext || any (infinite . snd) fields
125 report decl@(TypeAlias name args tipe) =
126 P.vcat [ P.text $ eightyCharLines 0 msg1
127 , indented decl
128 , P.text $ eightyCharLines 0 msg2
129 , indented (Datatype name args [(name,[tipe])])
130 , P.text $ eightyCharLines 0 msg3 ++ "\n"
131 ]
132 where
133 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
135 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
136 "Notice that it appears in its own definition, so when \
137 \you expand it, it just keeps getting bigger:"
138 msg2 = "Try this instead:"
139 msg3 = "It looks very similar, but an algebraic data type (ADT) \
140 \actually creates a new type. Unlike with a type alias, this \
141 \freshly created type is meaningful on its own, so an ADT \
142 \does not need to be expanded."