You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
97 lines
2.5 KiB
97 lines
2.5 KiB
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
module Elaboration.Monad where
|
|
|
|
import Control.Monad.Except
|
|
import Control.Monad.Reader
|
|
import Control.Applicative
|
|
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import qualified Data.Sequence as Seq
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.Text (Text)
|
|
|
|
import Syntax
|
|
|
|
import Value
|
|
|
|
|
|
data ElabState =
|
|
ElabState
|
|
{ elabEnv :: {-# UNPACK #-} !Env
|
|
, elabLevel :: {-# UNPACK #-} !Level
|
|
, elabSwitches :: {-# UNPACK #-} !Int
|
|
, elabNames :: HashMap Text (Level, VTy)
|
|
, elabConstrs :: HashMap Text VTy
|
|
, elabBound :: [BoundDef]
|
|
, elabSourcePos :: ((Int, Int), (Int, Int))
|
|
}
|
|
deriving (Eq)
|
|
|
|
emptyElabState :: ElabState
|
|
emptyElabState = ElabState emptyEnv (Lvl 0) 0 mempty mempty [] ((0, 0), (0, 0))
|
|
|
|
getNames :: MonadReader ElabState m => m [Text]
|
|
getNames = asks (map go . elabBound) where
|
|
go (BDBound n) = n
|
|
go (BDDefined n) = n
|
|
|
|
data ElabError
|
|
= NotInScope Text
|
|
| NotFunction [Text] Term
|
|
| NotEqual [Text] Term Term
|
|
| CantSolveMeta [Text] Term Term
|
|
deriving (Show)
|
|
|
|
data ProgError
|
|
= ProgError { peErr :: ElabError
|
|
, peSL :: !Int
|
|
, peSC :: !Int
|
|
, peEL :: !Int
|
|
, peEC :: !Int
|
|
}
|
|
deriving (Show)
|
|
|
|
newtype ElabM a
|
|
= ElabM { runElab :: ElabState -> IO (Either [ProgError] a) }
|
|
deriving
|
|
( Functor
|
|
, Applicative
|
|
, Monad
|
|
|
|
, Alternative
|
|
, MonadPlus
|
|
|
|
, MonadReader ElabState
|
|
, MonadError [ProgError]
|
|
, MonadIO
|
|
)
|
|
via ReaderT ElabState (ExceptT [ProgError] IO)
|
|
|
|
typeError :: ElabError -> ElabM a
|
|
typeError err = do
|
|
(s, e) <- asks elabSourcePos
|
|
throwError [uncurry (uncurry (ProgError err) s) e]
|
|
|
|
assumeLocal :: Text -> VTy -> ElabM a -> ElabM a
|
|
assumeLocal name tipe = local go where
|
|
go r =
|
|
r { elabLevel = succ (elabLevel r)
|
|
, elabNames = HashMap.insert name (elabLevel r, tipe) (elabNames r)
|
|
, elabEnv = (elabEnv r) {
|
|
locals = VGlued (HVar (Bound (unLvl (elabLevel r)))) mempty Nothing
|
|
Seq.<| locals (elabEnv r)
|
|
}
|
|
, elabBound = BDBound name:elabBound r
|
|
}
|
|
|
|
defineLocal :: Text -> VTy -> Value -> ElabM a -> ElabM a
|
|
defineLocal name tipe val = local go where
|
|
go r =
|
|
r { elabLevel = succ (elabLevel r)
|
|
, elabNames = HashMap.insert name (elabLevel r, tipe) (elabNames r)
|
|
, elabEnv = (elabEnv r) {
|
|
locals = val Seq.<| locals (elabEnv r)
|
|
}
|
|
, elabBound = BDDefined name:elabBound r
|
|
}
|