git.iko.soy/elk
on dbff625 help sign in
elk/compiler/Transform/Check.hs
147 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 Pattern.boundVarList 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 exprDups :: E.Expr -> Either String E.Expr
54 exprDups expr = Expr.crawlLet defsDups expr
56 defsDups :: [E.Def] -> Either String [E.Def]
57 defsDups defs =
58 let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in
59 case dups $ concatMap varsIn 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 ]
71illFormedTypes :: [D.Declaration] -> [Doc]
72illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
73 where
74 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]
75 adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
77 freeVars tipe =
78 case tipe of
79 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
80 T.Var x -> Set.singleton x
81 T.Data _ ts -> Set.unions (map freeVars ts)
82 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
83 where ext' = maybe Set.empty Set.singleton ext
85 undeclared tvars tipes = Set.difference used declared
86 where
87 used = Set.unions (map freeVars tipes)
88 declared = Set.fromList tvars
90 isIllFormed (decl, tvars, tipes) =
91 let unbound = undeclared tvars tipes in
92 if Set.null unbound then Nothing
93 else Just (decl, Set.toList unbound)
95 report (decl, tvars) =
96 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
97 , P.text "\n"
98 , nest 4 (pretty decl) ]
99 where
100 listing =
101 case tvars of
102 [tvar] -> " " ++ quote tvar ++ " is"
103 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
105 addCommas xs
106 | length xs < 3 = concat xs
107 | otherwise = List.intercalate "," xs
109 addAnd xs
110 | length xs < 2 = xs
111 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
113 quote tvar = "'" ++ tvar ++ "'"
116infiniteTypeAliases :: [D.Declaration] -> [Doc]
117infiniteTypeAliases decls =
118 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
119 , infiniteType name tipe ]
120 where
121 infiniteType name tipe =
122 let infinite = infiniteType name in
123 case tipe of
124 T.Lambda a b -> infinite a || infinite b
125 T.Var _ -> False
126 T.Data name' ts -> name == name' || any infinite ts
127 T.Record fields _ -> any (infinite . snd) fields
129 indented :: D.Declaration -> Doc
130 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
132 report name args tipe =
133 P.vcat [ P.text $ eightyCharLines 0 msg1
134 , indented $ D.TypeAlias name args tipe
135 , P.text $ eightyCharLines 0 msg2
136 , indented $ D.Datatype name args [(name,[tipe])]
137 , P.text $ eightyCharLines 0 msg3 ++ "\n"
138 ]
139 where
140 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
141 "Notice that it appears in its own definition, so when \
142 \you expand it, it just keeps getting bigger:"
143 msg2 = "Try this instead:"
144 msg3 = "It looks very similar, but an algebraic data type (ADT) \
145 \actually creates a new type. Unlike with a type alias, this \
146 \freshly created type is meaningful on its own, so an ADT \
147 \does not need to be expanded."