git.iko.soy/rowtype-yoga/purescript-native
on 667eeef help sign in
rowtype-yoga/purescript-native/src/PureScript/TypeChecker.hs
80 lines 2.9 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 typeCheckAll,
22) where
24import PureScript.TypeChecker.Monad
25import PureScript.TypeChecker.Kinds
26import PureScript.TypeChecker.Types
28import Data.List
29import Data.Maybe
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
42typeCheckAll :: [Declaration] -> Check ()
43typeCheckAll [] = return ()
44typeCheckAll (DataDeclaration dcs@(DataConstructors
45 { typeConstructorName = name
46 , typeArguments = args
47 , dataConstructors = ctors
48 }) : rest) = do
49 rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
50 env <- getEnv
51 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
52 ctorKind <- kindsOf name args (catMaybes $ map snd ctors)
53 putEnv $ env { types = M.insert name ctorKind (types env) }
54 flip mapM_ ctors $ \(dctor, maybeTy) ->
55 rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
56 env' <- getEnv
57 guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor
58 let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
59 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
60 putEnv $ env' { names = M.insert dctor dctorTy (names env') }
61 typeCheckAll rest
62typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
63 typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
64typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ name
65typeCheckAll (ValueDeclaration name val : rest) = do
66 rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do
67 env <- getEnv
68 case M.lookup name (names env) of
69 Just ty -> throwError $ name ++ " is already defined"
70 Nothing -> do
71 ty <- typeOf name val
72 putEnv (env { names = M.insert name ty (names env) })
73 typeCheckAll rest
74typeCheckAll (ExternDeclaration name ty : rest) = do
75 rethrow (("Error in extern declaration " ++ name ++ ": ") ++) $ do
76 env <- getEnv
77 case M.lookup name (names env) of
78 Just _ -> throwError $ name ++ " is already defined"
79 Nothing -> putEnv (env { names = M.insert name ty (names env) })
80 typeCheckAll rest