blob: 52e26b79aca3a2de0034fab53f14e45e7d005e23 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
module Haskell.TypeCheck (typeCheck) where
import qualified Data.Map.Strict as Map
import Haskell.AST
typeCheck :: (Eq a, TypeCheck a) => a -> Either String a
typeCheck initVal = go initVal Map.empty
where
go value mapping = do
value2 <- annotate mapping value
if value2 == value then return value else go value2 mapping
class TypeCheck a where
annotate :: Map.Map String Type -> a -> Either String a
instance TypeCheck AST where
annotate mapping (AST tops) = AST <$> mapM (annotate mapping) tops
instance TypeCheck Toplevel where
annotate mapping (TopDef x) = TopDef <$> annotate mapping x
annotate _ (TopDecl x) = return $ TopDecl x
annotate _ (TopData x) = return $ TopData x
annotate _ (TopClass x) = return $ TopClass x
annotate mapping (TopInst x) = TopInst <$> annotate mapping x
instance TypeCheck Def where
annotate mapping (Def name expr) = Def name <$> annotate mapping expr
instance TypeCheck Inst where
annotate mapping (Inst name ty defs) = Inst name ty <$> mapM (annotate mapping) defs
-- TODO: Just passing mappings around is not sufficient; the typechecking
-- needs to be done on the whole environment at once, and dynamically
-- updating the mapping as it goes. In fact, I'd probably do better just
-- looking up how the simplest possible implementation of Hindley-Miller
-- goes, stripping away most classes, and then implementing that.
instance TypeCheck Expr where
annotate mapping (App func' [] _) = annotate mapping func'
annotate mapping (App func' [arg'] _) = do
func <- annotate mapping func'
arg <- annotate mapping arg'
case typeApply (typeOf func) (typeOf arg) of
Just ty -> return $ App func [arg] (Just ty)
Nothing -> Left $ "Cannot apply argument of type " ++ show (typeOf arg) ++
" to function of type " ++ show (typeOf func)
annotate mapping (App func' (arg':args') _) =
combineApps <$> annotate mapping (App (App func' [arg'] Nothing) args' Nothing)
-- annotate mapping (Ref )
combineApps :: Expr -> Expr
combineApps (App (App f as1 _) as2 ty) = combineApps (App f (as1 ++ as2) ty)
combineApps e = recurse id combineApps e
|
