git.iko.soy/rowtype-yoga/purescript-native
on 100d787 help sign in
rowtype-yoga/purescript-native/src/PureScript/TypeChecker.hs
67 lines 2.2 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.TypeChecker
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
17module PureScript.TypeChecker (
18 module PureScript.TypeChecker.Monad,
19 module PureScript.TypeChecker.Kinds,
20 module PureScript.TypeChecker.Types,
21 typeCheck,
22 typeCheckAll,
23) where
25import PureScript.TypeChecker.Monad
26import PureScript.TypeChecker.Kinds
27import PureScript.TypeChecker.Types
29import Data.List
30import Data.Function
32import PureScript.Values
33import PureScript.Types
34import PureScript.Kinds
35import PureScript.Declarations
37import Control.Monad.State
38import Control.Monad.Error
40import qualified Data.Map as M
42typeCheck :: Declaration -> Check ()
43typeCheck (DataDeclaration dcs@(DataConstructors
44 { typeConstructorName = name
45 , typeArguments = args
46 , dataConstructors = ctors
47 })) = rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
48 env <- get
49 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
50 kinds <- kindsOf args (map snd ctors)
51 let ctorKind = foldl FunKind Star kinds
52 put $ env { types = M.insert name ctorKind (types env) }
53 flip mapM_ ctors $ \(dctor, ty) -> rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
54 env' <- get
55 guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor
56 let ctorType = Function [ty] $ foldl TypeApp (TypeConstructor name) (map TypeVar args)
57 put $ env' { names = M.insert dctor ctorType (names env) }
58typeCheck (ValueDeclaration name val) = rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do
59 env <- get
60 case M.lookup name (names env) of
61 Just ty -> throwError $ name ++ " is already defined"
62 Nothing -> do
63 ty <- typeOf val
64 put (env { names = M.insert name ty (names env) })
66typeCheckAll :: [Declaration] -> Check ()
67typeCheckAll = mapM_ typeCheck