@@ -9,6 +9,7 @@ import qualified Data.Set as Set
99import Types.Substitutions (subst)
1010import Types.Types
1111import Data.Data
12+import Data.Generics.Uniplate.Data
1213
1314builtins :: [(String,([X],Type))]
1415builtins =
@@ -28,13 +29,16 @@ builtins =
2829 ("LineStyle", ([], makeRecord line))
2930 ]
3031
31−get :: [Declaration t v] -> Map.Map String ([X],Type)
32−get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
33− where getAlias stmt = case stmt of
34− TypeAlias alias xs t -> [(alias, (xs,t))]
35− _ -> []
32+type AliasDict = Map.Map String ([X],Type)
3633
37−dealias :: Map.Map String ([X],Type) -> Type -> Type
34+get :: [Declaration t v] -> AliasDict
35+get decl = Map.fromList (builtins ++ concatMap getAlias decl)
36+ where
37+ getAlias decl = case decl of
38+ TypeAlias alias xs t -> [(alias, (xs,t))]
39+ _ -> []
40+
41+dealias :: AliasDict -> Type -> Type
3842dealias aliases t =
3943 let f = dealias aliases in
4044 case t of
@@ -45,38 +49,54 @@ dealias aliases t =
4549 RecordT r t -> RecordT (Map.map (map f) r) (f t)
4650 _ -> t
4751
48−mistakes :: [Declaration t v] -> [String]
49−mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
52+--mistakes :: [Def t v] -> [String]
53+mistakes defs = badKinds defs -- ++ dups defs ++ badOrder defs
54+
55+extractDefs :: [Declaration t v] -> [Def t v]
56+extractDefs = concatMap keepDef
57+ where
58+ keepDef decl = case decl of
59+ Definition def -> [def]
60+ _ -> []
5061
51−badKinds :: [Declaration t v] -> [String]
52−badKinds stmts = map msg (concatMap badS stmts)
62+badKinds :: (Data t, Data v) => [Declaration t v] -> [String]
63+badKinds decls = map msg (concatMap bad decls)
5364 where
5465 msg x = "Type Error: Type alias '" ++ x ++
5566 "' was given the wrong number of arguments."
5667
57− badT :: Type -> [String]
58− badT t =
59− case t of
60− ADT name ts ->
61− case Map.lookup name (get stmts) of
62− Just (xs,t) | length xs == length ts -> []
63− | otherwise -> [name]
64− Nothing -> concatMap badT ts
65− LambdaT t u -> badT t ++ badT u
66− RecordT r t -> badT t ++ concatMap badT (concat (Map.elems r))
67− _ -> []
68−
69− badS :: Declaration t v -> [String]
70− badS s =
68+ aliases :: AliasDict
69+ aliases = Map.empty
70+
71+ badType :: Type -> [String]
72+ badType t =
73+ case t of
74+ ADT name ts ->
75+ case Map.lookup name aliases of
76+ Just (xs,t) | length xs == length ts -> []
77+ | otherwise -> [name]
78+ Nothing -> concatMap badType ts
79+ LambdaT t u -> badType t ++ badType u
80+ RecordT r t -> badType t ++ concatMap badType (concat (Map.elems r))
81+ _ -> []
82+
83+ --badDef :: AliasDict -> Def t v -> [String]
84+ badDef def =
85+ case def of
86+ TypeAnnotation _ tipe -> badType tipe
87+ FnDef _ _ expr ->
88+ concatMap badDef $ concat [defList | Let defList _ <- universeBi expr]
89+ OpDef _ _ _ expr ->
90+ concatMap badDef $ concat [defList | Let defList _ <- universeBi expr]
91+
92+ --bad :: Declaration t v -> [String]
93+ bad s =
7194 case s of
72− Datatype _ _ tcs -> concatMap badT (concatMap snd tcs)
73− ExportEvent _ _ tipe -> badT tipe
74− ImportEvent _ _ _ tipe -> badT tipe
75− TypeAlias _ _ tipe -> badT tipe
76− Definition d ->
77− case d of
78− TypeAnnotation _ tipe -> badT tipe
79− _ -> []
95+ Datatype _ _ tcs -> concatMap badType (concatMap snd tcs)
96+ ExportEvent _ _ tipe -> badType tipe
97+ ImportEvent _ _ _ tipe -> badType tipe
98+ TypeAlias _ _ tipe -> badType tipe
99+ Definition d -> badDef d
80100
81101annotation :: Declaration t v -> [String]
82102annotation s =
@@ -97,22 +117,22 @@ defName d =
97117 OpDef n _ _ _ -> n
98118
99119dups :: [Declaration t v] -> [String]
100−dups stmts = map defMsg (dup definition) ++ map annMsg (dup annotation)
120+dups defs = map defMsg (dup definition) ++ map annMsg (dup annotation)
101121 where
102122 --dup :: (Declaration t v -> [String]) -> [String]
103− dup f = map head . filter ((>1) . length) . group . sort $ concatMap f stmts
123+ dup f = map head . filter ((>1) . length) . group . sort $ concatMap f defs
104124
105125 msg = "Syntax Error: There can only be one "
106126 defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."
107127 annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
108128
109−badOrder :: [Declaration t v] -> [String]
110−badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs stmts)
129+--badOrder :: [Def t v] -> [String]
130+badOrder defs = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)
111131 where
112132 msg x = "Syntax Error: The type annotation for '" ++ x ++
113133 "' must be directly above its definition."
114− as = sort $ concatMap annotation stmts
115− ds = sort $ concatMap definition stmts
134+ as = sort $ concatMap annotation defs
135+ ds = sort $ concatMap definition defs
116136
117137 expectedPairs :: [String] -> [String] -> [String]
118138 expectedPairs as ds =
@@ -123,9 +143,9 @@ badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualP
123143 GT -> expectedPairs (x:xs) ys
124144 ( _ , _ ) -> []
125145
126− --actualPairs :: [Declaration t v] -> [String]
127− actualPairs stmts =
128− case stmts of
146+ --actualPairs :: [Def t v] -> [String]
147+ actualPairs defs =
148+ case defs of
129149 Definition (TypeAnnotation n _) : Definition d : rest ->
130150 (if n == defName d then [n] else []) ++ actualPairs rest
131151 t:s:rest -> actualPairs (s:rest)