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