git.iko.soy/elk
on 2a930fd help sign in
elk/src/Transform/Check.hs
153 lines 5.8 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 AST.Expression.Valid as Valid
10import qualified AST.Declaration as D
11import qualified AST.Pattern as Pattern
12import qualified AST.Type as T
13import qualified AST.Variable as Var
14import qualified Transform.Expression as Expr
16import AST.PrettyPrint
17import Text.PrettyPrint as P
20mistakes :: [D.ValidDecl] -> [Doc]
21mistakes decls =
22 concat [ infiniteTypeAliases decls
23 , illFormedTypes decls
24 , map P.text (duplicateConstructors decls)
25 , map P.text (duplicates 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.ValidDecl] -> [String]
35duplicates decls =
36 map msg (dups (portNames ++ concatMap Pattern.boundVarList 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 (Valid.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 exprDups :: Valid.Expr -> Either String Valid.Expr
55 exprDups expr = Expr.crawlLet defsDups expr
57 defsDups :: [Valid.Def] -> Either String [Valid.Def]
58 defsDups defs =
59 let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in
60 case dups $ concatMap varsIn defs of
61 [] -> Right defs
62 name:_ -> Left name
64duplicateConstructors :: [D.ValidDecl] -> [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.ValidDecl] -> [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.Type _ -> Set.empty
83 T.App t ts -> Set.unions (map freeVars (t:ts))
84 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
85 where ext' = maybe Set.empty freeVars ext
86 T.Aliased _ t -> freeVars t
88 undeclared tvars tipes = Set.difference used declared
89 where
90 used = Set.unions (map freeVars tipes)
91 declared = Set.fromList tvars
93 isIllFormed (decl, tvars, tipes) =
94 let unbound = undeclared tvars tipes in
95 if Set.null unbound then Nothing
96 else Just (decl, Set.toList unbound)
98 report (decl, tvars) =
99 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
100 , P.text "\n"
101 , nest 4 (pretty decl) ]
102 where
103 listing =
104 case tvars of
105 [tvar] -> " " ++ quote tvar ++ " is"
106 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
108 addCommas xs
109 | length xs < 3 = concat xs
110 | otherwise = List.intercalate "," xs
112 addAnd xs
113 | length xs < 2 = xs
114 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
116 quote tvar = "'" ++ tvar ++ "'"
119infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
120infiniteTypeAliases decls =
121 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
122 , infiniteType name tipe ]
123 where
124 infiniteType :: String -> T.Type Var.Raw -> Bool
125 infiniteType name tipe =
126 let infinite = infiniteType name in
127 case tipe of
128 T.Lambda a b -> infinite a || infinite b
129 T.Var _ -> False
130 T.Type (Var.Raw name') -> name == name'
131 T.App t ts -> any infinite (t:ts)
132 T.Record fields _ -> any (infinite . snd) fields
133 T.Aliased _ t -> infinite t
135 indented :: D.ValidDecl -> Doc
136 indented decl = P.text "\n " <> pretty decl <> P.text "\n"
138 report name args tipe =
139 P.vcat [ P.text $ eightyCharLines 0 msg1
140 , indented $ D.TypeAlias name args tipe
141 , P.text $ eightyCharLines 0 msg2
142 , indented $ D.Datatype name args [(name,[tipe])]
143 , P.text $ eightyCharLines 0 msg3 ++ "\n"
144 ]
145 where
146 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
147 "Notice that it appears in its own definition, so when \
148 \you expand it, it just keeps getting bigger:"
149 msg2 = "Try this instead:"
150 msg3 = "It looks very similar, but an algebraic data type (ADT) \
151 \actually creates a new type. Unlike with a type alias, this \
152 \freshly created type is meaningful on its own, so an ADT \
153 \does not need to be expanded."