git.iko.soy/rowtype-yoga/purescript-native
on ea83764 help sign in
rowtype-yoga/purescript-native/src/PureScript/TypeChecker/Monad.hs
67 lines 1.9 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.TypeChecker.Monad
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.Monad where
19import PureScript.Types
20import PureScript.Kinds
21import PureScript.Names
23import Control.Applicative
24import Control.Monad.State
25import Control.Monad.Error
27import Control.Arrow ((***), first, second)
29import qualified Data.Map as M
31data NameKind = Value | Extern deriving Show
33data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
35data Environment = Environment
36 { names :: M.Map Ident (PolyType, NameKind)
37 , types :: M.Map String (Kind, TypeDeclarationKind)
38 , dataConstructors :: M.Map String PolyType
39 , typeSynonyms :: M.Map String ([String], Type)
40 }
42emptyEnvironment :: Environment
43emptyEnvironment = Environment M.empty M.empty M.empty M.empty
45newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String)
47getEnv :: Check Environment
48getEnv = fmap fst get
50putEnv :: Environment -> Check ()
51putEnv env = fmap (first (const env)) get >>= put
53fresh :: Check Int
54fresh = do
55 (env, n) <- get
56 put (env, n + 1)
57 return n
59check :: Check a -> Either String (a, Environment)
60check = fmap (second fst) . flip runStateT (emptyEnvironment, 0) . unCheck
62guardWith :: (MonadError e m) => e -> Bool -> m ()
63guardWith _ True = return ()
64guardWith e False = throwError e
66rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
67rethrow f = flip catchError $ \e -> throwError (f e)