git.iko.soy/rowtype-yoga/purescript-native
on adc70ed help sign in
rowtype-yoga/purescript-native/src/PureScript/TypeChecker.hs
69 lines 2.3 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.Maybe
31import Data.Function
33import PureScript.Values
34import PureScript.Types
35import PureScript.Kinds
36import PureScript.Declarations
38import Control.Monad.State
39import Control.Monad.Error
41import qualified Data.Map as M
43typeCheck :: Declaration -> Check ()
44typeCheck (DataDeclaration dcs@(DataConstructors
45 { typeConstructorName = name
46 , typeArguments = args
47 , dataConstructors = ctors
48 })) = rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
49 env <- getEnv
50 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
51 ctorKind <- kindsOf name args (catMaybes $ map snd ctors)
52 putEnv $ env { types = M.insert name ctorKind (types env) }
53 flip mapM_ ctors $ \(dctor, maybeTy) ->
54 rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
55 env' <- getEnv
56 guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor
57 let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
58 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
59 putEnv $ env' { names = M.insert dctor dctorTy (names env') }
60typeCheck (ValueDeclaration name val) = rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do
61 env <- getEnv
62 case M.lookup name (names env) of
63 Just ty -> throwError $ name ++ " is already defined"
64 Nothing -> do
65 ty <- typeOf name val
66 putEnv (env { names = M.insert name ty (names env) })
68typeCheckAll :: [Declaration] -> Check ()
69typeCheckAll = mapM_ typeCheck