git.iko.soy/elk
on 007ea71 help sign in
elk/compiler/Transform/Check.hs
148 lines 5.6 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) ]
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 Arrow.second concat $ unzip $
48 flip map [ port | D.Port port <- decls ] $ \port ->
49 case port of
50 D.Out name expr _ -> (name, [expr])
51 D.In name _ -> (name, [])
53 getNames = Set.toList . Pattern.boundVars
55 exprDups :: E.LExpr -> Either String E.LExpr
56 exprDups expr = Expr.crawlLet defsDups expr
58 defsDups :: [E.Def] -> Either String [E.Def]
59 defsDups defs =
60 case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
61 [] -> Right defs
62 name:_ -> Left name
64duplicateConstructors :: [D.Declaration] -> [String]
65duplicateConstructors decls =
66 map (dupErr "definition of type constructor") (dups typeCtors) ++
67 map (dupErr "definition of data constructor") (dups dataCtors)
68 where
69 typeCtors = [ name | D.Datatype name _ _ <- decls ]
70 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
72illFormedTypes :: [D.Declaration] -> [Doc]
73illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
74 where
75 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
76 adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
78 freeVars tipe =
79 case tipe of
80 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
81 T.Var x -> Set.singleton x
82 T.Data _ ts -> Set.unions (map freeVars ts)
83 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
84 where ext' = maybe Set.empty Set.singleton ext
86 undeclared tvars tipes = Set.difference used declared
87 where
88 used = Set.unions (map freeVars tipes)
89 declared = Set.fromList tvars
91 isIllFormed (decl, tvars, tipes) =
92 let unbound = undeclared tvars tipes in
93 if Set.null unbound then Nothing
94 else Just (decl, Set.toList unbound)
96 report (decl, tvars) =
97 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
98 , P.text "\n"
99 , nest 4 (pretty decl) ]
100 where
101 listing =
102 case tvars of
103 [tvar] -> " " ++ quote tvar ++ " is"
104 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
106 addCommas xs
107 | length xs < 3 = concat xs
108 | otherwise = List.intercalate "," xs
110 addAnd xs
111 | length xs < 2 = xs
112 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
114 quote tvar = "'" ++ tvar ++ "'"
117infiniteTypeAliases :: [D.Declaration] -> [Doc]
118infiniteTypeAliases decls =
119 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
120 , infiniteType name tipe ]
121 where
122 infiniteType name tipe =
123 let infinite = infiniteType name in
124 case tipe of
125 T.Lambda a b -> infinite a || infinite b
126 T.Var _ -> False
127 T.Data name' ts -> name == name' || any infinite ts
128 T.Record fields _ -> any (infinite . snd) fields
130 indented :: D.Declaration -> Doc
131 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
133 report name args tipe =
134 P.vcat [ P.text $ eightyCharLines 0 msg1
135 , indented $ D.TypeAlias name args tipe
136 , P.text $ eightyCharLines 0 msg2
137 , indented $ D.Datatype name args [(name,[tipe])]
138 , P.text $ eightyCharLines 0 msg3 ++ "\n"
139 ]
140 where
141 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
142 "Notice that it appears in its own definition, so when \
143 \you expand it, it just keeps getting bigger:"
144 msg2 = "Try this instead:"
145 msg3 = "It looks very similar, but an algebraic data type (ADT) \
146 \actually creates a new type. Unlike with a type alias, this \
147 \freshly created type is meaningful on its own, so an ADT \
148 \does not need to be expanded."