git.iko.soy/rowtype-yoga/purescript-native
on 2ffe085 help sign in
rowtype-yoga/purescript-native/src/PureScript/TypeChecker.hs
88 lines 3.5 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
27import PureScript.TypeChecker.Synonyms
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
43typeCheckAll :: [Declaration] -> Check ()
44typeCheckAll [] = return ()
45typeCheckAll (DataDeclaration name args dctors : rest) = do
46 rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
47 env <- getEnv
48 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
49 ctorKind <- kindsOf (Just name) args (catMaybes $ map snd dctors)
50 putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }
51 flip mapM_ dctors $ \(dctor, maybeTy) ->
52 rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
53 env' <- getEnv
54 guardWith (dctor ++ " is already defined") $ not $ flip M.member (dataConstructors env') dctor
55 let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
56 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
57 let polyType = PolyType args dctorTy
58 putEnv $ env' { dataConstructors = M.insert dctor polyType (dataConstructors env') }
59 typeCheckAll rest
60typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
61 rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do
62 env <- getEnv
63 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
64 kind <- kindsOf (Just name) args [ty]
65 putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env)
66 , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }
67 typeCheckAll rest
68typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
69 typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
70typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
71typeCheckAll (ValueDeclaration name val : rest) = do
72 rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do
73 env <- getEnv
74 case M.lookup name (names env) of
75 Just ty -> throwError $ show name ++ " is already defined"
76 Nothing -> do
77 ty <- typeOf name val
78 putEnv (env { names = M.insert name (ty, Value) (names env) })
79 typeCheckAll rest
80typeCheckAll (ExternDeclaration name ty : rest) = do
81 rethrow (("Error in extern declaration " ++ show name ++ ": ") ++) $ do
82 env <- getEnv
83 kind <- kindOf ty
84 guardWith "Expected kind *" $ kind == Star
85 case M.lookup name (names env) of
86 Just _ -> throwError $ show name ++ " is already defined"
87 Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })
88 typeCheckAll rest