git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Transform/Check.hs
170 lines 6.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Check (mistakes) where
4import qualified Control.Arrow as Arrow
5import qualified Data.List as List
6import qualified Data.Maybe as Maybe
7import qualified Data.Set as Set
9import qualified SourceSyntax.Expression as E
10import qualified SourceSyntax.Declaration as D
11import qualified SourceSyntax.Pattern as Pattern
12import qualified SourceSyntax.Type as T
13import qualified Transform.Expression as Expr
15import SourceSyntax.PrettyPrint
16import Text.PrettyPrint as P
19mistakes :: [D.Declaration] -> [Doc]
20mistakes decls =
21 concat [ infiniteTypeAliases decls
22 , illFormedTypes decls
23 , map P.text (duplicateConstructors decls)
24 , map P.text (duplicates decls)
25 , badDerivations decls ]
27dups :: Ord a => [a] -> [a]
28dups = map head . filter ((>1) . length) . List.group . List.sort
30dupErr :: String -> String -> String
31dupErr err x =
32 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
34duplicates :: [D.Declaration] -> [String]
35duplicates decls =
36 map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
37 case mapM exprDups (portExprs ++ defExprs) of
38 Left name -> [msg name]
39 Right _ -> []
41 where
42 msg = dupErr "definition of"
44 (defPatterns, defExprs) =
45 unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
47 (portNames, portExprs) =
48 Arrow.second concat $ unzip $
49 flip map [ port | D.Port port <- decls ] $ \port ->
50 case port of
51 D.Out name expr _ -> (name, [expr])
52 D.In name _ -> (name, [])
54 getNames = Set.toList . Pattern.boundVars
56 exprDups :: E.LExpr -> Either String E.LExpr
57 exprDups expr = Expr.crawlLet defsDups expr
59 defsDups :: [E.Def] -> Either String [E.Def]
60 defsDups defs =
61 case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
62 [] -> Right defs
63 name:_ -> Left name
65duplicateConstructors :: [D.Declaration] -> [String]
66duplicateConstructors decls =
67 map (dupErr "definition of type constructor") (dups typeCtors) ++
68 map (dupErr "definition of data constructor") (dups dataCtors)
69 where
70 typeCtors = [ name | D.Datatype name _ _ _ <- decls ]
71 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]
73badDerivations :: [D.Declaration] -> [Doc]
74badDerivations decls = concatMap badDerivation derivations
75 where
76 derivations =
77 [ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++
78 [ (decl, tvars, derives) | decl@(D.Datatype _ tvars _ derives) <- decls ]
80 badDerivation (decl, tvars, derives) =
81 case (tvars, derives) of
82 (_:_, _)
83 | D.Json `elem` derives -> [report decl D.Json]
84 | D.Binary `elem` derives -> [report decl D.Binary]
85 _ -> []
87 report decl derive =
88 P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."
89 , P.text "Make sure all type variables are replaced with concrete types:"
90 , P.text "\n"
91 , nest 4 (pretty decl)
92 ]
94illFormedTypes :: [D.Declaration] -> [Doc]
95illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
96 where
97 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
98 adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]
100 freeVars tipe =
101 case tipe of
102 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
103 T.Var x -> Set.singleton x
104 T.Data _ ts -> Set.unions (map freeVars ts)
105 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
106 where ext' = maybe Set.empty Set.singleton ext
108 undeclared tvars tipes = Set.difference used declared
109 where
110 used = Set.unions (map freeVars tipes)
111 declared = Set.fromList tvars
113 isIllFormed (decl, tvars, tipes) =
114 let unbound = undeclared tvars tipes in
115 if Set.null unbound then Nothing
116 else Just (decl, Set.toList unbound)
118 report (decl, tvars) =
119 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
120 , P.text "\n"
121 , nest 4 (pretty decl) ]
122 where
123 listing =
124 case tvars of
125 [tvar] -> " " ++ quote tvar ++ " is"
126 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
128 addCommas xs
129 | length xs < 3 = concat xs
130 | otherwise = List.intercalate "," xs
132 addAnd xs
133 | length xs < 2 = xs
134 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
136 quote tvar = "'" ++ tvar ++ "'"
139infiniteTypeAliases :: [D.Declaration] -> [Doc]
140infiniteTypeAliases decls =
141 [ report name tvars tipe ds | D.TypeAlias name tvars tipe ds <- decls
142 , infiniteType name tipe ]
143 where
144 infiniteType name tipe =
145 let infinite = infiniteType name in
146 case tipe of
147 T.Lambda a b -> infinite a || infinite b
148 T.Var _ -> False
149 T.Data name' ts -> name == name' || any infinite ts
150 T.Record fields _ -> any (infinite . snd) fields
152 indented :: D.Declaration -> Doc
153 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
155 report name args tipe derivations =
156 P.vcat [ P.text $ eightyCharLines 0 msg1
157 , indented $ D.TypeAlias name args tipe derivations
158 , P.text $ eightyCharLines 0 msg2
159 , indented $ D.Datatype name args [(name,[tipe])] derivations
160 , P.text $ eightyCharLines 0 msg3 ++ "\n"
161 ]
162 where
163 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
164 "Notice that it appears in its own definition, so when \
165 \you expand it, it just keeps getting bigger:"
166 msg2 = "Try this instead:"
167 msg3 = "It looks very similar, but an algebraic data type (ADT) \
168 \actually creates a new type. Unlike with a type alias, this \
169 \freshly created type is meaningful on its own, so an ADT \
170 \does not need to be expanded."