git.iko.soy/elk
on f20fa4e help sign in
elk/compiler/Transform/Check.hs
107 lines 3.7 kB history raw
1module Transform.Check (mistakes) where
3import Transform.SortDefinitions (boundVars)
4import SourceSyntax.Everything
5import SourceSyntax.PrettyPrint
6import qualified SourceSyntax.Type as T
7import Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Maybe as Maybe
10import qualified Data.Set as Set
11import Data.Data
12import Data.Generics.Uniplate.Data
13import Text.PrettyPrint as P
16mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]
17mistakes decls =
18 illFormedTypes decls ++ map P.text (concatMap findErrors (getLets decls))
19 where
20 findErrors defs = duplicates defs ++ badOrder defs
23getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]
24getLets decls = defs : concatMap getSubLets defs
25 where
26 defs = concatMap (\d -> case d of Definition d -> [d] ; _ -> []) decls
28 getSubLets def =
29 case def of
30 Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]
31 TypeAnnotation _ _ -> []
34duplicates :: [Def t v] -> [String]
35duplicates defs =
36 map defMsg (dups definitions) ++ map annMsg (dups annotations)
37 where
38 annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
39 definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
41 dups = map head . filter ((>1) . length) . List.group
43 msg = "Syntax Error: There can only be one "
44 defMsg x = msg ++ "definition of '" ++ x ++ "'."
45 annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
48badOrder :: [Def t v] -> [String]
49badOrder defs = go defs
50 where
51 msg x = "Syntax Error: The type annotation for '" ++ x ++
52 "' must be directly above its definition."
54 go defs =
55 case defs of
56 TypeAnnotation name _ : Def (PVar name') _ : rest
57 | name == name' -> go rest
59 TypeAnnotation name _ : rest -> [msg name] ++ go rest
61 _ : rest -> go rest
63 _ -> []
65illFormedTypes :: [Declaration t v] -> [Doc]
66illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
67 where
68 aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]
69 adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]
71 freeVars tipe =
72 case tipe of
73 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
74 T.Var x -> Set.singleton x
75 T.Data _ ts -> Set.unions (map freeVars ts)
76 T.EmptyRecord -> Set.empty
77 T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)
79 undeclared tvars tipes = Set.difference used declared
80 where
81 used = Set.unions (map freeVars tipes)
82 declared = Set.fromList tvars
84 isIllFormed (decl, tvars, tipes) =
85 let unbound = undeclared tvars tipes in
86 if Set.null unbound then Nothing
87 else Just (decl, Set.toList unbound)
89 report (decl, tvars) =
90 P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
91 , P.text "\n"
92 , nest 4 (pretty decl) ]
93 where
94 listing =
95 case tvars of
96 [tvar] -> " " ++ quote tvar ++ " is"
97 _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
99 addCommas xs
100 | length xs < 3 = concat xs
101 | otherwise = intercalate "," xs
103 addAnd xs
104 | length xs < 2 = xs
105 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
107 quote tvar = "'" ++ tvar ++ "'"