{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE RecordWildCards #-}

module Data.LLVM.BitCode.Parse where

import           Text.LLVM.AST
import           Text.LLVM.PP

import           Control.Applicative (Alternative(..))
import           Control.Monad (MonadPlus(..), unless)
#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail -- makes fail visible for instance
#endif
import           Control.Monad.Fix (MonadFix)
import           Control.Monad.Except (MonadError(..), Except, runExcept)
import           Control.Monad.Reader (MonadReader(..), ReaderT(..))
import           Control.Monad.State.Strict (MonadState(..), StateT(..))
import           Data.Maybe (fromMaybe)
import           Data.Semigroup
import           Data.Typeable (Typeable)
import           Data.Word ( Word32 )

import qualified Codec.Binary.UTF8.String as UTF8 (decode)
import qualified Control.Exception as X
import qualified Data.ByteString as BS
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import           GHC.Stack (HasCallStack, CallStack, callStack, prettyCallStack)

import           Prelude


-- Error Collection Parser -----------------------------------------------------

data Error = Error
  { Error -> [String]
errContext :: [String]
  , Error -> String
errMessage :: String
  } deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show, Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq, Eq Error
Eq Error =>
(Error -> Error -> Ordering)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Error)
-> (Error -> Error -> Error)
-> Ord Error
Error -> Error -> Bool
Error -> Error -> Ordering
Error -> Error -> Error
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Error -> Error -> Ordering
compare :: Error -> Error -> Ordering
$c< :: Error -> Error -> Bool
< :: Error -> Error -> Bool
$c<= :: Error -> Error -> Bool
<= :: Error -> Error -> Bool
$c> :: Error -> Error -> Bool
> :: Error -> Error -> Bool
$c>= :: Error -> Error -> Bool
>= :: Error -> Error -> Bool
$cmax :: Error -> Error -> Error
max :: Error -> Error -> Error
$cmin :: Error -> Error -> Error
min :: Error -> Error -> Error
Ord)

formatError :: Error -> String
formatError :: Error -> String
formatError Error
err
  | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Error -> [String]
errContext Error
err) = Error -> String
errMessage Error
err
  | Bool
otherwise             = [String] -> String
unlines
                          ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Error -> String
errMessage Error
err
                          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"from:"
                          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'\t' Char -> ShowS
forall a. a -> [a] -> [a]
:) (Error -> [String]
errContext Error
err)

newtype Parse a = Parse
  { forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse :: ReaderT Env (StateT ParseState (Except Error)) a
  } deriving ((forall a b. (a -> b) -> Parse a -> Parse b)
-> (forall a b. a -> Parse b -> Parse a) -> Functor Parse
forall a b. a -> Parse b -> Parse a
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Parse a -> Parse b
fmap :: forall a b. (a -> b) -> Parse a -> Parse b
$c<$ :: forall a b. a -> Parse b -> Parse a
<$ :: forall a b. a -> Parse b -> Parse a
Functor, Functor Parse
Functor Parse =>
(forall a. a -> Parse a)
-> (forall a b. Parse (a -> b) -> Parse a -> Parse b)
-> (forall a b c. (a -> b -> c) -> Parse a -> Parse b -> Parse c)
-> (forall a b. Parse a -> Parse b -> Parse b)
-> (forall a b. Parse a -> Parse b -> Parse a)
-> Applicative Parse
forall a. a -> Parse a
forall a b. Parse a -> Parse b -> Parse a
forall a b. Parse a -> Parse b -> Parse b
forall a b. Parse (a -> b) -> Parse a -> Parse b
forall a b c. (a -> b -> c) -> Parse a -> Parse b -> Parse c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Parse a
pure :: forall a. a -> Parse a
$c<*> :: forall a b. Parse (a -> b) -> Parse a -> Parse b
<*> :: forall a b. Parse (a -> b) -> Parse a -> Parse b
$cliftA2 :: forall a b c. (a -> b -> c) -> Parse a -> Parse b -> Parse c
liftA2 :: forall a b c. (a -> b -> c) -> Parse a -> Parse b -> Parse c
$c*> :: forall a b. Parse a -> Parse b -> Parse b
*> :: forall a b. Parse a -> Parse b -> Parse b
$c<* :: forall a b. Parse a -> Parse b -> Parse a
<* :: forall a b. Parse a -> Parse b -> Parse a
Applicative, Monad Parse
Monad Parse =>
(forall a. (a -> Parse a) -> Parse a) -> MonadFix Parse
forall a. (a -> Parse a) -> Parse a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall a. (a -> Parse a) -> Parse a
mfix :: forall a. (a -> Parse a) -> Parse a
MonadFix)

instance Monad Parse where
#if !MIN_VERSION_base(4,11,0)
  {-# INLINE return #-}
  return = pure
#endif

  {-# INLINE (>>=) #-}
  Parse ReaderT Env (StateT ParseState (Except Error)) a
m >>= :: forall a b. Parse a -> (a -> Parse b) -> Parse b
>>= a -> Parse b
f = ReaderT Env (StateT ParseState (Except Error)) b -> Parse b
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a
m ReaderT Env (StateT ParseState (Except Error)) a
-> (a -> ReaderT Env (StateT ParseState (Except Error)) b)
-> ReaderT Env (StateT ParseState (Except Error)) b
forall a b.
ReaderT Env (StateT ParseState (Except Error)) a
-> (a -> ReaderT Env (StateT ParseState (Except Error)) b)
-> ReaderT Env (StateT ParseState (Except Error)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parse b -> ReaderT Env (StateT ParseState (Except Error)) b
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse (Parse b -> ReaderT Env (StateT ParseState (Except Error)) b)
-> (a -> Parse b)
-> a
-> ReaderT Env (StateT ParseState (Except Error)) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Parse b
f)

#if !MIN_VERSION_base(4,13,0)
  {-# INLINE fail #-}
  fail = failWithContext
#endif

instance MonadFail Parse where
  {-# INLINE fail #-}
  fail :: forall a. String -> Parse a
fail = String -> Parse a
forall a. String -> Parse a
failWithContext

instance Alternative Parse where
  {-# INLINE empty #-}
  empty :: forall a. Parse a
empty = String -> Parse a
forall a. String -> Parse a
failWithContext String
"empty"

  {-# INLINE (<|>) #-}
  Parse a
a <|> :: forall a. Parse a -> Parse a -> Parse a
<|> Parse a
b = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ ReaderT Env (StateT ParseState (Except Error)) a
-> (Error -> ReaderT Env (StateT ParseState (Except Error)) a)
-> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a
-> (Error -> ReaderT Env (StateT ParseState (Except Error)) a)
-> ReaderT Env (StateT ParseState (Except Error)) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
a) (ReaderT Env (StateT ParseState (Except Error)) a
-> Error -> ReaderT Env (StateT ParseState (Except Error)) a
forall a b. a -> b -> a
const (Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
b))

instance MonadPlus Parse where
  {-# INLINE mzero #-}
  mzero :: forall a. Parse a
mzero = String -> Parse a
forall a. String -> Parse a
failWithContext String
"mzero"

  {-# INLINE mplus #-}
  mplus :: forall a. Parse a -> Parse a -> Parse a
mplus = Parse a -> Parse a -> Parse a
forall a. Parse a -> Parse a -> Parse a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

runParse :: Parse a -> Either Error a
runParse :: forall a. Parse a -> Either Error a
runParse (Parse ReaderT Env (StateT ParseState (Except Error)) a
m) =
  case Except Error (a, ParseState) -> Either Error (a, ParseState)
forall e a. Except e a -> Either e a
runExcept (StateT ParseState (Except Error) a
-> ParseState -> Except Error (a, ParseState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT Env (StateT ParseState (Except Error)) a
-> Env -> StateT ParseState (Except Error) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env (StateT ParseState (Except Error)) a
m Env
emptyEnv) ParseState
emptyParseState) of
    Left Error
err     -> Error -> Either Error a
forall a b. a -> Either a b
Left Error
err
    Right (a
a, ParseState
_) -> a -> Either Error a
forall a b. b -> Either a b
Right a
a

notImplemented :: Parse a
notImplemented :: forall a. Parse a
notImplemented  = String -> Parse a
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not implemented"

-- Parse State -----------------------------------------------------------------

data ParseState = ParseState
  { ParseState -> TypeTable
psTypeTable     :: TypeTable
  , ParseState -> Int
psTypeTableSize :: !Int
  , ParseState -> ValueTable
psValueTable    :: ValueTable
  , ParseState -> Maybe StringTable
psStringTable   :: Maybe StringTable
  , ParseState -> ValueTable
psMdTable       :: ValueTable
  , ParseState -> MdRefTable
psMdRefs        :: MdRefTable
  , ParseState -> Seq FunProto
psFunProtos     :: Seq.Seq FunProto
  , ParseState -> Int
psNextResultId  :: !Int
  , ParseState -> Maybe String
psTypeName      :: Maybe String
  , ParseState -> Int
psNextTypeId    :: !Int
  , ParseState -> Maybe PDebugLoc
psLastLoc       :: Maybe PDebugLoc
  , ParseState -> KindTable
psKinds         :: !KindTable
  , ParseState -> Int
psModVersion    :: !Int
  } deriving (Int -> ParseState -> ShowS
[ParseState] -> ShowS
ParseState -> String
(Int -> ParseState -> ShowS)
-> (ParseState -> String)
-> ([ParseState] -> ShowS)
-> Show ParseState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseState -> ShowS
showsPrec :: Int -> ParseState -> ShowS
$cshow :: ParseState -> String
show :: ParseState -> String
$cshowList :: [ParseState] -> ShowS
showList :: [ParseState] -> ShowS
Show)

-- | The initial parsing state.
emptyParseState :: ParseState
emptyParseState :: ParseState
emptyParseState  = ParseState
  { psTypeTable :: TypeTable
psTypeTable     = TypeTable
forall a. IntMap a
IntMap.empty
  , psTypeTableSize :: Int
psTypeTableSize = Int
0
  , psValueTable :: ValueTable
psValueTable    = Bool -> ValueTable
emptyValueTable Bool
False
  , psStringTable :: Maybe StringTable
psStringTable   = Maybe StringTable
forall a. Maybe a
Nothing
  , psMdTable :: ValueTable
psMdTable       = Bool -> ValueTable
emptyValueTable Bool
False
  , psMdRefs :: MdRefTable
psMdRefs        = MdRefTable
forall a. IntMap a
IntMap.empty
  , psFunProtos :: Seq FunProto
psFunProtos     = Seq FunProto
forall a. Seq a
Seq.empty
  , psNextResultId :: Int
psNextResultId  = Int
0
  , psTypeName :: Maybe String
psTypeName      = Maybe String
forall a. Maybe a
Nothing
  , psNextTypeId :: Int
psNextTypeId    = Int
0
  , psLastLoc :: Maybe PDebugLoc
psLastLoc       = Maybe PDebugLoc
forall a. Maybe a
Nothing
  , psKinds :: KindTable
psKinds         = KindTable
emptyKindTable
  , psModVersion :: Int
psModVersion    = Int
0
  }

-- | The next implicit result id.
nextResultId :: Parse Int
nextResultId :: Parse Int
nextResultId  = ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int)
-> ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psNextResultId = psNextResultId ps + 1 }
  Int -> ReaderT Env (StateT ParseState (Except Error)) Int
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseState -> Int
psNextResultId ParseState
ps)

type PDebugLoc = DebugLoc' Int

setLastLoc :: PDebugLoc -> Parse ()
setLastLoc :: PDebugLoc -> Parse ()
setLastLoc PDebugLoc
loc = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psLastLoc = Just loc }

setRelIds :: Bool -> Parse ()
setRelIds :: Bool -> Parse ()
setRelIds Bool
b = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psValueTable = (psValueTable ps) { valueRelIds = b }}

getRelIds :: Parse Bool
getRelIds :: Parse Bool
getRelIds  = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  Bool -> Parse Bool
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValueTable -> Bool
valueRelIds (ParseState -> ValueTable
psValueTable ParseState
ps))

getLastLoc :: Parse PDebugLoc
getLastLoc :: Parse PDebugLoc
getLastLoc  = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  case ParseState -> Maybe PDebugLoc
psLastLoc ParseState
ps of
    Just PDebugLoc
loc -> PDebugLoc -> Parse PDebugLoc
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PDebugLoc
loc
    Maybe PDebugLoc
Nothing  -> String -> Parse PDebugLoc
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No last location available"

setModVersion :: Int -> Parse ()
setModVersion :: Int -> Parse ()
setModVersion Int
v = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psModVersion = v }

getModVersion :: Parse Int
getModVersion :: Parse Int
getModVersion = ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> Int
psModVersion (ParseState -> Int)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

-- | Sort of a hack to preserve state between function body parses.  It would
-- really be nice to separate this into a different monad, that could just run
-- under the Parse monad, but sort of unnecessary in the long run.
enterFunctionDef :: Parse a -> Parse a
enterFunctionDef :: forall a. Parse a -> Parse a
enterFunctionDef Parse a
m = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps  <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps
    { psNextResultId = 0
    }
  a
res <- Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
m
  ParseState
ps' <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps'
    { psValueTable = psValueTable ps
    , psMdTable    = psMdTable ps
    , psMdRefs     = psMdRefs ps
    , psLastLoc    = Nothing
    }
  a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res


-- Type Table ------------------------------------------------------------------

type TypeTable = IntMap.IntMap Type

-- | Generate a type table, and a type symbol table.
mkTypeTable :: [Type] -> TypeTable
mkTypeTable :: [Type' Ident] -> TypeTable
mkTypeTable  = [(Int, Type' Ident)] -> TypeTable
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, Type' Ident)] -> TypeTable)
-> ([Type' Ident] -> [(Int, Type' Ident)])
-> [Type' Ident]
-> TypeTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Type' Ident] -> [(Int, Type' Ident)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..]

-- | Exceptions contain a callstack, parsing context, explanation, and index
data BadForwardRef
  = BadTypeRef  CallStack [String] String Int
  | BadValueRef CallStack [String] String Int
    deriving (Int -> BadForwardRef -> ShowS
[BadForwardRef] -> ShowS
BadForwardRef -> String
(Int -> BadForwardRef -> ShowS)
-> (BadForwardRef -> String)
-> ([BadForwardRef] -> ShowS)
-> Show BadForwardRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BadForwardRef -> ShowS
showsPrec :: Int -> BadForwardRef -> ShowS
$cshow :: BadForwardRef -> String
show :: BadForwardRef -> String
$cshowList :: [BadForwardRef] -> ShowS
showList :: [BadForwardRef] -> ShowS
Show,Typeable)

instance X.Exception BadForwardRef

badRefError :: BadForwardRef -> Error
badRefError :: BadForwardRef -> Error
badRefError BadForwardRef
ref =
  let (CallStack
stk, [String]
cxt, String
explanation, Int
i, String
thing) =
        case BadForwardRef
ref of
          BadTypeRef  CallStack
stk' [String]
cxt' String
explanation' Int
i' -> (CallStack
stk', [String]
cxt', String
explanation', Int
i', String
"type")
          BadValueRef CallStack
stk' [String]
cxt' String
explanation' Int
i' -> (CallStack
stk', [String]
cxt', String
explanation', Int
i', String
"value")
  in [String] -> String -> Error
Error [String]
cxt (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"bad forward reference to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
thing String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
                         , String
"additional details: "
                         , String
explanation
                         , String
"with call stack: "
                         , CallStack -> String
prettyCallStack CallStack
stk
                         ]

-- | As type tables are always pre-allocated, looking things up should never
-- fail.  As a result, the worst thing that could happen is that the type entry
-- causes a runtime error.  This is pretty bad, but it's an acceptable trade-off
-- for the complexity of the forward references in the type table.
lookupTypeRef :: HasCallStack
              => [String] -> Int -> TypeTable -> Type
lookupTypeRef :: HasCallStack => [String] -> Int -> TypeTable -> Type' Ident
lookupTypeRef [String]
cxt Int
n =
  let explanation :: String
explanation = String
"Bad reference into type table"
  in Type' Ident -> Maybe (Type' Ident) -> Type' Ident
forall a. a -> Maybe a -> a
fromMaybe (BadForwardRef -> Type' Ident
forall a e. Exception e => e -> a
X.throw (CallStack -> [String] -> String -> Int -> BadForwardRef
BadTypeRef CallStack
HasCallStack => CallStack
callStack [String]
cxt String
explanation Int
n)) (Maybe (Type' Ident) -> Type' Ident)
-> (TypeTable -> Maybe (Type' Ident)) -> TypeTable -> Type' Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TypeTable -> Maybe (Type' Ident)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n

setTypeTable :: TypeTable -> Parse ()
setTypeTable :: TypeTable -> Parse ()
setTypeTable TypeTable
table = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeTable = table }

getTypeTable :: Parse TypeTable
getTypeTable :: Parse TypeTable
getTypeTable  = ReaderT Env (StateT ParseState (Except Error)) TypeTable
-> Parse TypeTable
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> TypeTable
psTypeTable (ParseState -> TypeTable)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) TypeTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

setTypeTableSize :: Int -> Parse ()
setTypeTableSize :: Int -> Parse ()
setTypeTableSize Int
n = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeTableSize = n }

-- | Retrieve the current type name, failing if it hasn't been set.
getTypeName :: Parse Ident
getTypeName :: Parse Ident
getTypeName  = ReaderT Env (StateT ParseState (Except Error)) Ident -> Parse Ident
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) Ident
 -> Parse Ident)
-> ReaderT Env (StateT ParseState (Except Error)) Ident
-> Parse Ident
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps  <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  String
str <- case ParseState -> Maybe String
psTypeName ParseState
ps of
    Just String
tn -> do
      ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeName = Nothing }
      String -> ReaderT Env (StateT ParseState (Except Error)) String
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
tn
    Maybe String
Nothing -> do
      ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psNextTypeId = psNextTypeId ps + 1 }
      String -> ReaderT Env (StateT ParseState (Except Error)) String
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String
forall a. Show a => a -> String
show (ParseState -> Int
psNextTypeId ParseState
ps))
  Ident -> ReaderT Env (StateT ParseState (Except Error)) Ident
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Ident
Ident String
str)

setTypeName :: String -> Parse ()
setTypeName :: String -> Parse ()
setTypeName String
name = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeName = Just name }

-- | Lookup the value of a type; don't attempt to resolve to an alias.
getType' :: Int -> Parse Type
getType' :: Int -> Parse (Type' Ident)
getType' Int
ref = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
ref Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ParseState -> Int
psTypeTableSize ParseState
ps)
    (String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"type reference " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ref String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is too large"))
  [String]
cxt <- Parse [String]
getContext
  Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => [String] -> Int -> TypeTable -> Type' Ident
[String] -> Int -> TypeTable -> Type' Ident
lookupTypeRef [String]
cxt Int
ref (ParseState -> TypeTable
psTypeTable ParseState
ps))

-- | Test to see if the type table has been added to already.
isTypeTableEmpty :: Parse Bool
isTypeTableEmpty :: Parse Bool
isTypeTableEmpty  = ReaderT Env (StateT ParseState (Except Error)) Bool -> Parse Bool
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (TypeTable -> Bool
forall a. IntMap a -> Bool
IntMap.null (TypeTable -> Bool)
-> (ParseState -> TypeTable) -> ParseState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState -> TypeTable
psTypeTable (ParseState -> Bool)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

setStringTable :: StringTable -> Parse ()
setStringTable :: StringTable -> Parse ()
setStringTable StringTable
st = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psStringTable = Just st }

getStringTable :: Parse (Maybe StringTable)
getStringTable :: Parse (Maybe StringTable)
getStringTable = ReaderT Env (StateT ParseState (Except Error)) (Maybe StringTable)
-> Parse (Maybe StringTable)
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> Maybe StringTable
psStringTable (ParseState -> Maybe StringTable)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT
     Env (StateT ParseState (Except Error)) (Maybe StringTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

-- Value Tables ----------------------------------------------------------------

-- | Values that have an identifier instead of a string label
type PValue = Value' Int

type PInstr = Instr' Int

data ValueTable = ValueTable
  { ValueTable -> Int
valueNextId  :: !Int
  , ValueTable -> IntMap (Typed PValue)
valueEntries :: IntMap.IntMap (Typed PValue)
  , ValueTable -> IntMap (Int, Int)
strtabEntries :: IntMap.IntMap (Int, Int)
  , ValueTable -> Bool
valueRelIds  :: Bool
  } deriving (Int -> ValueTable -> ShowS
[ValueTable] -> ShowS
ValueTable -> String
(Int -> ValueTable -> ShowS)
-> (ValueTable -> String)
-> ([ValueTable] -> ShowS)
-> Show ValueTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueTable -> ShowS
showsPrec :: Int -> ValueTable -> ShowS
$cshow :: ValueTable -> String
show :: ValueTable -> String
$cshowList :: [ValueTable] -> ShowS
showList :: [ValueTable] -> ShowS
Show)

emptyValueTable :: Bool -> ValueTable
emptyValueTable :: Bool -> ValueTable
emptyValueTable Bool
rel = ValueTable
  { valueNextId :: Int
valueNextId  = Int
0
  , valueEntries :: IntMap (Typed PValue)
valueEntries = IntMap (Typed PValue)
forall a. IntMap a
IntMap.empty
  , strtabEntries :: IntMap (Int, Int)
strtabEntries = IntMap (Int, Int)
forall a. IntMap a
IntMap.empty
  , valueRelIds :: Bool
valueRelIds  = Bool
rel
  }

addValue :: Typed PValue -> ValueTable -> ValueTable
addValue :: Typed PValue -> ValueTable -> ValueTable
addValue Typed PValue
tv ValueTable
vs = (Int, ValueTable) -> ValueTable
forall a b. (a, b) -> b
snd (Typed PValue -> ValueTable -> (Int, ValueTable)
addValue' Typed PValue
tv ValueTable
vs)

addValue' :: Typed PValue -> ValueTable -> (Int,ValueTable)
addValue' :: Typed PValue -> ValueTable -> (Int, ValueTable)
addValue' Typed PValue
tv ValueTable
vs = (ValueTable -> Int
valueNextId ValueTable
vs,ValueTable
vs')
  where
  vs' :: ValueTable
vs' = ValueTable
vs
    { valueNextId  = valueNextId vs + 1
    , valueEntries = IntMap.insert (valueNextId vs) tv (valueEntries vs)
    }

-- | Push a value into the value table, and return its index.
pushValue :: Typed PValue -> Parse Int
pushValue :: Typed PValue -> Parse Int
pushValue Typed PValue
tv = ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int)
-> ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  let vt :: ValueTable
vt = ParseState -> ValueTable
psValueTable ParseState
ps
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psValueTable = addValue tv vt }
  Int -> ReaderT Env (StateT ParseState (Except Error)) Int
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValueTable -> Int
valueNextId ValueTable
vt)

-- | Get the index for the next value.
nextValueId :: Parse Int
nextValueId :: Parse Int
nextValueId  = ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ValueTable -> Int
valueNextId (ValueTable -> Int)
-> (ParseState -> ValueTable) -> ParseState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState -> ValueTable
psValueTable (ParseState -> Int)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

-- | Depending on whether or not relative ids are in use, adjust the id.
adjustId :: Int -> Parse Int
adjustId :: Int -> Parse Int
adjustId Int
n = do
  ValueTable
vt <- Parse ValueTable
getValueTable
  Int -> Parse Int
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValueTable -> Int -> Int
translateValueId ValueTable
vt Int
n)

-- | Translate an id, relative to the value table it references.
-- NOTE: The relative conversion has to be done on a Word32 to handle overflow
-- when n is large the same way BitcodeReaderMDValueList::getValue does.
translateValueId :: ValueTable -> Int -> Int
translateValueId :: ValueTable -> Int -> Int
translateValueId ValueTable
vt Int
n | ValueTable -> Bool
valueRelIds ValueTable
vt = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
adjusted
                      | Bool
otherwise      = Int
n
  where
  adjusted :: Word32
  adjusted :: Word32
adjusted  = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ValueTable -> Int
valueNextId ValueTable
vt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)

-- | Lookup an absolute address in the value table.
lookupValueTableAbs :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
n ValueTable
values = Int -> IntMap (Typed PValue) -> Maybe (Typed PValue)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueTable -> IntMap (Typed PValue)
valueEntries ValueTable
values)

-- | When you know you have an absolute index.
lookupValueAbs :: Int -> Parse (Maybe (Typed PValue))
lookupValueAbs :: Int -> Parse (Maybe (Typed PValue))
lookupValueAbs Int
n = Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
n (ValueTable -> Maybe (Typed PValue))
-> Parse ValueTable -> Parse (Maybe (Typed PValue))
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parse ValueTable
getValueTable

-- | Lookup either a relative id, or an absolute id.
lookupValueTable :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTable :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTable Int
n ValueTable
values =
  Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs (ValueTable -> Int -> Int
translateValueId ValueTable
values Int
n) ValueTable
values

-- | Lookup a value in the value table.
lookupValue :: Int -> Parse (Maybe (Typed PValue))
lookupValue :: Int -> Parse (Maybe (Typed PValue))
lookupValue Int
n = Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTable Int
n (ValueTable -> Maybe (Typed PValue))
-> Parse ValueTable -> Parse (Maybe (Typed PValue))
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parse ValueTable
getValueTable

-- | Lookup lazily, hiding an error in the result if the entry doesn't exist by
-- the time it's needed.  NOTE: This always looks up an absolute index, never a
-- relative one.
forwardRef :: HasCallStack
           => [String] -> Int -> ValueTable -> Typed PValue
forwardRef :: HasCallStack => [String] -> Int -> ValueTable -> Typed PValue
forwardRef [String]
cxt Int
n ValueTable
vt =
  let explanation :: String
explanation = String
"Bad reference into a value table"
  in Typed PValue -> Maybe (Typed PValue) -> Typed PValue
forall a. a -> Maybe a -> a
fromMaybe (BadForwardRef -> Typed PValue
forall a e. Exception e => e -> a
X.throw (CallStack -> [String] -> String -> Int -> BadForwardRef
BadValueRef CallStack
HasCallStack => CallStack
callStack [String]
cxt String
explanation Int
n)) (Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
n ValueTable
vt)

-- | Require that a value be present.
requireValue :: Int -> Parse (Typed PValue)
requireValue :: Int -> Parse (Typed PValue)
requireValue Int
n = do
  Maybe (Typed PValue)
mb <- Int -> Parse (Maybe (Typed PValue))
lookupValue Int
n
  case Maybe (Typed PValue)
mb of
    Just Typed PValue
tv -> Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Typed PValue
tv
    Maybe (Typed PValue)
Nothing -> String -> Parse (Typed PValue)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not defined")

-- | Get the current value table.
getValueTable :: Parse ValueTable
getValueTable :: Parse ValueTable
getValueTable  = ReaderT Env (StateT ParseState (Except Error)) ValueTable
-> Parse ValueTable
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> ValueTable
psValueTable (ParseState -> ValueTable)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) ValueTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

-- | Retrieve the name for the next value.  Note that this doesn't assume that
-- the name gets used, and doesn't update the next id in the value table.
getNextId :: Parse Int
getNextId :: Parse Int
getNextId  = ValueTable -> Int
valueNextId (ValueTable -> Int) -> Parse ValueTable -> Parse Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse ValueTable
getValueTable

-- | Set the current value table.
setValueTable :: ValueTable -> Parse ()
setValueTable :: ValueTable -> Parse ()
setValueTable ValueTable
vt = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psValueTable = vt }

-- | Update the value table, giving a lazy reference to the final table.
fixValueTable :: (ValueTable -> Parse (a,[Typed PValue])) -> Parse a
fixValueTable :: forall a. (ValueTable -> Parse (a, [Typed PValue])) -> Parse a
fixValueTable ValueTable -> Parse (a, [Typed PValue])
k = do
  ValueTable
vt <- Parse ValueTable
getValueTable
  rec let vt' :: ValueTable
vt' = (Typed PValue -> ValueTable -> ValueTable)
-> ValueTable -> [Typed PValue] -> ValueTable
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Typed PValue -> ValueTable -> ValueTable
addValue ValueTable
vt [Typed PValue]
vs
      (a
a,[Typed PValue]
vs) <- ValueTable -> Parse (a, [Typed PValue])
k ValueTable
vt'
  ValueTable -> Parse ()
setValueTable ValueTable
vt'
  a -> Parse a
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

fixValueTable_ :: (ValueTable -> Parse [Typed PValue]) -> Parse ()
fixValueTable_ :: (ValueTable -> Parse [Typed PValue]) -> Parse ()
fixValueTable_ ValueTable -> Parse [Typed PValue]
k = (ValueTable -> Parse ((), [Typed PValue])) -> Parse ()
forall a. (ValueTable -> Parse (a, [Typed PValue])) -> Parse a
fixValueTable ((ValueTable -> Parse ((), [Typed PValue])) -> Parse ())
-> (ValueTable -> Parse ((), [Typed PValue])) -> Parse ()
forall a b. (a -> b) -> a -> b
$ \ ValueTable
vt -> do
  [Typed PValue]
vs <- ValueTable -> Parse [Typed PValue]
k ValueTable
vt
  ((), [Typed PValue]) -> Parse ((), [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ((),[Typed PValue]
vs)


type PValMd = ValMd' Int

type MdTable = ValueTable

getMdTable :: Parse MdTable
getMdTable :: Parse ValueTable
getMdTable  = ReaderT Env (StateT ParseState (Except Error)) ValueTable
-> Parse ValueTable
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> ValueTable
psMdTable (ParseState -> ValueTable)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) ValueTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

setMdTable :: MdTable -> Parse ()
setMdTable :: ValueTable -> Parse ()
setMdTable ValueTable
md = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psMdTable = md }

getMetadata :: Int -> Parse (Typed PValMd)
getMetadata :: Int -> Parse (Typed PValMd)
getMetadata Int
ix = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  case Int -> ParseState -> Maybe (Typed PValue)
resolveMd Int
ix ParseState
ps of
    Just Typed PValue
tv -> case Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
tv of
      ValMd PValMd
val -> Typed PValMd -> Parse (Typed PValMd)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Typed PValue
tv { typedValue = val }
      PValue
_         -> String -> Parse (Typed PValMd)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected non-metadata value in metadata table"
    Maybe (Typed PValue)
Nothing -> String -> Parse (Typed PValMd)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"metadata index " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not defined")

resolveMd :: Int -> ParseState -> Maybe (Typed PValue)
resolveMd :: Int -> ParseState -> Maybe (Typed PValue)
resolveMd Int
ix ParseState
ps = Maybe (Typed PValue)
forall {lab}. Maybe (Typed (Value' lab))
nodeRef Maybe (Typed PValue)
-> Maybe (Typed PValue) -> Maybe (Typed PValue)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe (Typed PValue)
mdValue
  where
  reference :: Int -> Typed (Value' lab)
reference = Type' Ident -> Value' lab -> Typed (Value' lab)
forall a. Type' Ident -> a -> Typed a
Typed (PrimType -> Type' Ident
forall ident. PrimType -> Type' ident
PrimType PrimType
Metadata) (Value' lab -> Typed (Value' lab))
-> (Int -> Value' lab) -> Int -> Typed (Value' lab)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValMd' lab -> Value' lab
forall lab. ValMd' lab -> Value' lab
ValMd (ValMd' lab -> Value' lab)
-> (Int -> ValMd' lab) -> Int -> Value' lab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ValMd' lab
forall lab. Int -> ValMd' lab
ValMdRef
  nodeRef :: Maybe (Typed (Value' lab))
nodeRef   = Int -> Typed (Value' lab)
forall {lab}. Int -> Typed (Value' lab)
reference (Int -> Typed (Value' lab))
-> Maybe Int -> Maybe (Typed (Value' lab))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> MdRefTable -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ix (ParseState -> MdRefTable
psMdRefs ParseState
ps)
  mdValue :: Maybe (Typed PValue)
mdValue   = Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
ix (ParseState -> ValueTable
psMdTable ParseState
ps)


type MdRefTable = IntMap.IntMap Int

setMdRefs :: MdRefTable -> Parse ()
setMdRefs :: MdRefTable -> Parse ()
setMdRefs MdRefTable
refs = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psMdRefs = refs `IntMap.union` psMdRefs ps }


-- Function Prototypes ---------------------------------------------------------

data FunProto = FunProto
  { FunProto -> Type' Ident
protoType       :: Type
  , FunProto -> Maybe Linkage
protoLinkage    :: Maybe Linkage
  , FunProto -> Maybe Visibility
protoVisibility :: Maybe Visibility
  , FunProto -> Maybe GC
protoGC         :: Maybe GC
  , FunProto -> Symbol
protoSym        :: Symbol
  , FunProto -> Int
protoIndex      :: Int
  , FunProto -> Maybe String
protoSect       :: Maybe String
  , FunProto -> Maybe String
protoComdat     :: Maybe String
  } deriving Int -> FunProto -> ShowS
[FunProto] -> ShowS
FunProto -> String
(Int -> FunProto -> ShowS)
-> (FunProto -> String) -> ([FunProto] -> ShowS) -> Show FunProto
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FunProto -> ShowS
showsPrec :: Int -> FunProto -> ShowS
$cshow :: FunProto -> String
show :: FunProto -> String
$cshowList :: [FunProto] -> ShowS
showList :: [FunProto] -> ShowS
Show

-- | Push a function prototype on to the prototype stack.
pushFunProto :: FunProto -> Parse ()
pushFunProto :: FunProto -> Parse ()
pushFunProto FunProto
p = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psFunProtos = psFunProtos ps Seq.|> p }

-- | Take a single function prototype off of the prototype stack.
popFunProto :: Parse FunProto
popFunProto :: Parse FunProto
popFunProto  = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  case Seq FunProto -> ViewL FunProto
forall a. Seq a -> ViewL a
Seq.viewl (ParseState -> Seq FunProto
psFunProtos ParseState
ps) of
    ViewL FunProto
Seq.EmptyL   -> String -> Parse FunProto
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty function prototype stack"
    FunProto
p Seq.:< Seq FunProto
ps' -> do
      ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psFunProtos = ps' })
      FunProto -> Parse FunProto
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return FunProto
p


-- Parsing Environment ---------------------------------------------------------

data Env = Env
  { Env -> Symtab
envSymtab  :: Symtab
  , Env -> [String]
envContext :: [String]
  } deriving Int -> Env -> ShowS
[Env] -> ShowS
Env -> String
(Int -> Env -> ShowS)
-> (Env -> String) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Env -> ShowS
showsPrec :: Int -> Env -> ShowS
$cshow :: Env -> String
show :: Env -> String
$cshowList :: [Env] -> ShowS
showList :: [Env] -> ShowS
Show

emptyEnv :: Env
emptyEnv :: Env
emptyEnv  = Env
  { envSymtab :: Symtab
envSymtab  = Symtab
forall a. Monoid a => a
mempty
  , envContext :: [String]
envContext = [String]
forall a. Monoid a => a
mempty
  }

-- | Extend the symbol table for an environment, yielding a new environment.
extendSymtab :: Symtab -> Env -> Env
extendSymtab :: Symtab -> Env -> Env
extendSymtab Symtab
symtab Env
env = Env
env { envSymtab = envSymtab env `mappend` symtab }

-- | Add a label to the context of an environment, yielding a new environment.
addLabel :: String -> Env -> Env
addLabel :: String -> Env -> Env
addLabel String
l Env
env = Env
env { envContext = l : envContext env }

getContext :: Parse [String]
getContext :: Parse [String]
getContext  = ReaderT Env (StateT ParseState (Except Error)) [String]
-> Parse [String]
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (Env -> [String]
envContext (Env -> [String])
-> ReaderT Env (StateT ParseState (Except Error)) Env
-> ReaderT Env (StateT ParseState (Except Error)) [String]
forall a b.
(a -> b)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReaderT Env (StateT ParseState (Except Error)) Env
forall r (m :: * -> *). MonadReader r m => m r
ask)


data Symtab = Symtab
  { Symtab -> ValueSymtab
symValueSymtab :: ValueSymtab
  , Symtab -> TypeSymtab
symTypeSymtab  :: TypeSymtab
  } deriving (Int -> Symtab -> ShowS
[Symtab] -> ShowS
Symtab -> String
(Int -> Symtab -> ShowS)
-> (Symtab -> String) -> ([Symtab] -> ShowS) -> Show Symtab
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Symtab -> ShowS
showsPrec :: Int -> Symtab -> ShowS
$cshow :: Symtab -> String
show :: Symtab -> String
$cshowList :: [Symtab] -> ShowS
showList :: [Symtab] -> ShowS
Show)

instance Semigroup Symtab where
  Symtab
l <> :: Symtab -> Symtab -> Symtab
<> Symtab
r = Symtab
    { symValueSymtab :: ValueSymtab
symValueSymtab = Symtab -> ValueSymtab
symValueSymtab Symtab
l ValueSymtab -> ValueSymtab -> ValueSymtab
forall a. Semigroup a => a -> a -> a
<> Symtab -> ValueSymtab
symValueSymtab Symtab
r
    , symTypeSymtab :: TypeSymtab
symTypeSymtab  = Symtab -> TypeSymtab
symTypeSymtab  Symtab
l TypeSymtab -> TypeSymtab -> TypeSymtab
forall a. Semigroup a => a -> a -> a
<> Symtab -> TypeSymtab
symTypeSymtab  Symtab
r
    }

instance Monoid Symtab where
  mempty :: Symtab
mempty = Symtab
    { symValueSymtab :: ValueSymtab
symValueSymtab = ValueSymtab
emptyValueSymtab
    , symTypeSymtab :: TypeSymtab
symTypeSymtab  = TypeSymtab
forall a. Monoid a => a
mempty
    }

  mappend :: Symtab -> Symtab -> Symtab
mappend = Symtab -> Symtab -> Symtab
forall a. Semigroup a => a -> a -> a
(<>)

withSymtab :: Symtab -> Parse a -> Parse a
withSymtab :: forall a. Symtab -> Parse a -> Parse a
withSymtab Symtab
symtab Parse a
body = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ do
  (Env -> Env)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
(Env -> Env)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Symtab -> Env -> Env
extendSymtab Symtab
symtab) (Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
body)

-- | Run a computation with an extended value symbol table.
withValueSymtab :: ValueSymtab -> Parse a -> Parse a
withValueSymtab :: forall a. ValueSymtab -> Parse a -> Parse a
withValueSymtab ValueSymtab
symtab = Symtab -> Parse a -> Parse a
forall a. Symtab -> Parse a -> Parse a
withSymtab (Symtab
forall a. Monoid a => a
mempty { symValueSymtab = symtab })

-- | Retrieve the value symbol table.
getValueSymtab :: Finalize ValueSymtab
getValueSymtab :: Finalize ValueSymtab
getValueSymtab = ReaderT Env (Except Error) ValueSymtab -> Finalize ValueSymtab
forall a. ReaderT Env (Except Error) a -> Finalize a
Finalize (Symtab -> ValueSymtab
symValueSymtab (Symtab -> ValueSymtab) -> (Env -> Symtab) -> Env -> ValueSymtab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Symtab
envSymtab (Env -> ValueSymtab)
-> ReaderT Env (Except Error) Env
-> ReaderT Env (Except Error) ValueSymtab
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (Except Error) Env
forall r (m :: * -> *). MonadReader r m => m r
ask)

-- | Run a computation with an extended type symbol table.
withTypeSymtab :: TypeSymtab -> Parse a -> Parse a
withTypeSymtab :: forall a. TypeSymtab -> Parse a -> Parse a
withTypeSymtab TypeSymtab
symtab = Symtab -> Parse a -> Parse a
forall a. Symtab -> Parse a -> Parse a
withSymtab (Symtab
forall a. Monoid a => a
mempty { symTypeSymtab = symtab })

-- | Retrieve the type symbol table.
getTypeSymtab :: Parse TypeSymtab
getTypeSymtab :: Parse TypeSymtab
getTypeSymtab  = ReaderT Env (StateT ParseState (Except Error)) TypeSymtab
-> Parse TypeSymtab
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (Symtab -> TypeSymtab
symTypeSymtab (Symtab -> TypeSymtab) -> (Env -> Symtab) -> Env -> TypeSymtab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Symtab
envSymtab (Env -> TypeSymtab)
-> ReaderT Env (StateT ParseState (Except Error)) Env
-> ReaderT Env (StateT ParseState (Except Error)) TypeSymtab
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) Env
forall r (m :: * -> *). MonadReader r m => m r
ask)

-- | Label a sub-computation with its context.
label :: String -> Parse a -> Parse a
label :: forall a. String -> Parse a -> Parse a
label String
l Parse a
m = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ do
  (Env -> Env)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
(Env -> Env)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (String -> Env -> Env
addLabel String
l) (Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
m)

-- | Fail, taking into account the current context.
failWithContext :: String -> Parse a
failWithContext :: forall a. String -> Parse a
failWithContext String
msg = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ do
  Env
env <- ReaderT Env (StateT ParseState (Except Error)) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  Error -> ReaderT Env (StateT ParseState (Except Error)) a
forall a. Error -> ReaderT Env (StateT ParseState (Except Error)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
    { errMessage :: String
errMessage = String
msg
    , errContext :: [String]
errContext = Env -> [String]
envContext Env
env
    }

-- | Attempt to find the type id in the type symbol table, when that fails,
-- look it up in the type table.
getType :: Int -> Parse Type
getType :: Int -> Parse (Type' Ident)
getType Int
ref = do
  TypeSymtab
symtab <- Parse TypeSymtab
getTypeSymtab
  case Int -> IntMap Ident -> Maybe Ident
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ref (TypeSymtab -> IntMap Ident
tsById TypeSymtab
symtab) of
    Just Ident
i  -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> Type' Ident
forall ident. ident -> Type' ident
Alias Ident
i)
    Maybe Ident
Nothing -> Int -> Parse (Type' Ident)
getType' Int
ref

-- | Find the id associated with a type alias.
getTypeId :: Ident -> Parse Int
getTypeId :: Ident -> Parse Int
getTypeId Ident
n = do
  TypeSymtab
symtab <- Parse TypeSymtab
getTypeSymtab
  case Ident -> Map Ident Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
n (TypeSymtab -> Map Ident Int
tsByName TypeSymtab
symtab) of
    Just Int
ix -> Int -> Parse Int
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
ix
    Maybe Int
Nothing -> String -> Parse Int
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown type alias " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Int -> ((?config::Config) => Doc) -> Doc
forall a. Int -> ((?config::Config) => a) -> a
ppLLVM Int
llvmVlatest (Ident -> Doc
forall a. LLVMPretty a => Fmt a
llvmPP Ident
n)))


-- Value Symbol Table ----------------------------------------------------------

type SymName = Either String Int

data ValueSymtab =
  ValueSymtab
  { ValueSymtab -> IntMap SymName
valSymtab :: IntMap.IntMap SymName
  , ValueSymtab -> IntMap SymName
bbSymtab  :: IntMap.IntMap SymName
  , ValueSymtab -> IntMap SymName
fnSymtab  :: IntMap.IntMap SymName
  } deriving (Int -> ValueSymtab -> ShowS
[ValueSymtab] -> ShowS
ValueSymtab -> String
(Int -> ValueSymtab -> ShowS)
-> (ValueSymtab -> String)
-> ([ValueSymtab] -> ShowS)
-> Show ValueSymtab
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueSymtab -> ShowS
showsPrec :: Int -> ValueSymtab -> ShowS
$cshow :: ValueSymtab -> String
show :: ValueSymtab -> String
$cshowList :: [ValueSymtab] -> ShowS
showList :: [ValueSymtab] -> ShowS
Show)

instance Semigroup ValueSymtab where
  ValueSymtab
l <> :: ValueSymtab -> ValueSymtab -> ValueSymtab
<> ValueSymtab
r = ValueSymtab
    { valSymtab :: IntMap SymName
valSymtab = ValueSymtab -> IntMap SymName
valSymtab ValueSymtab
l IntMap SymName -> IntMap SymName -> IntMap SymName
forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` ValueSymtab -> IntMap SymName
valSymtab ValueSymtab
r
    , bbSymtab :: IntMap SymName
bbSymtab  = ValueSymtab -> IntMap SymName
bbSymtab ValueSymtab
l  IntMap SymName -> IntMap SymName -> IntMap SymName
forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` ValueSymtab -> IntMap SymName
bbSymtab ValueSymtab
r
    , fnSymtab :: IntMap SymName
fnSymtab  = ValueSymtab -> IntMap SymName
fnSymtab ValueSymtab
l  IntMap SymName -> IntMap SymName -> IntMap SymName
forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` ValueSymtab -> IntMap SymName
fnSymtab ValueSymtab
r
    }

instance Monoid ValueSymtab where
  mappend :: ValueSymtab -> ValueSymtab -> ValueSymtab
mappend = ValueSymtab -> ValueSymtab -> ValueSymtab
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ValueSymtab
mempty = ValueSymtab
    { valSymtab :: IntMap SymName
valSymtab = IntMap SymName
forall a. IntMap a
IntMap.empty
    , bbSymtab :: IntMap SymName
bbSymtab  = IntMap SymName
forall a. IntMap a
IntMap.empty
    , fnSymtab :: IntMap SymName
fnSymtab  = IntMap SymName
forall a. IntMap a
IntMap.empty
    }

renderName :: SymName -> String
renderName :: SymName -> String
renderName  = ShowS -> (Int -> String) -> SymName -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ShowS
forall a. a -> a
id Int -> String
forall a. Show a => a -> String
show

mkBlockLabel :: SymName -> BlockLabel
mkBlockLabel :: SymName -> BlockLabel
mkBlockLabel  = (String -> BlockLabel)
-> (Int -> BlockLabel) -> SymName -> BlockLabel
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Ident -> BlockLabel
Named (Ident -> BlockLabel) -> (String -> Ident) -> String -> BlockLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
Ident) Int -> BlockLabel
Anon

emptyValueSymtab :: ValueSymtab
emptyValueSymtab :: ValueSymtab
emptyValueSymtab  = ValueSymtab
forall a. Monoid a => a
mempty

addEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addEntry Int
i String
n ValueSymtab
t = ValueSymtab
t { valSymtab = IntMap.insert i (Left n) (valSymtab t) }

addBBEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addBBEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addBBEntry Int
i String
n ValueSymtab
t = ValueSymtab
t { bbSymtab = IntMap.insert i (Left n) (bbSymtab t) }

addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab
addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab
addBBAnon Int
i Int
n ValueSymtab
t = ValueSymtab
t { bbSymtab = IntMap.insert i (Right n) (bbSymtab t) }

addFNEntry :: Int -> Int -> String -> ValueSymtab -> ValueSymtab
-- TODO: do we ever need to be able to look up the offset?
addFNEntry :: Int -> Int -> String -> ValueSymtab -> ValueSymtab
addFNEntry Int
i Int
_o String
n ValueSymtab
t = ValueSymtab
t { fnSymtab = IntMap.insert i (Left n) (fnSymtab t) }

addFwdFNEntry :: Int -> Int -> ValueSymtab -> ValueSymtab
addFwdFNEntry :: Int -> Int -> ValueSymtab -> ValueSymtab
addFwdFNEntry Int
i Int
o ValueSymtab
t = ValueSymtab
t { fnSymtab = IntMap.insert i (Right o) (fnSymtab t) }

-- | Lookup the name of an entry. Returns @Nothing@ when it's not present.
entryNameMb :: Int -> Parse (Maybe String)
entryNameMb :: Int -> Parse (Maybe String)
entryNameMb Int
n = do
  ValueSymtab
symtab <- Finalize ValueSymtab -> Parse ValueSymtab
forall a. Finalize a -> Parse a
liftFinalize Finalize ValueSymtab
getValueSymtab
  Maybe String -> Parse (Maybe String)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> Parse (Maybe String))
-> Maybe String -> Parse (Maybe String)
forall a b. (a -> b) -> a -> b
$! (SymName -> String) -> Maybe SymName -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymName -> String
renderName
         (Maybe SymName -> Maybe String) -> Maybe SymName -> Maybe String
forall a b. (a -> b) -> a -> b
$  Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueSymtab -> IntMap SymName
valSymtab ValueSymtab
symtab) Maybe SymName -> Maybe SymName -> Maybe SymName
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
            Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueSymtab -> IntMap SymName
fnSymtab ValueSymtab
symtab)

-- | Lookup the name of an entry.
entryName :: Int -> Parse String
entryName :: Int -> Parse String
entryName Int
n = do
  Maybe String
mentry <- Int -> Parse (Maybe String)
entryNameMb Int
n
  case Maybe String
mentry of
    Just String
name -> String -> Parse String
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return String
name
    Maybe String
Nothing   ->
      do Bool
isRel  <- Parse Bool
getRelIds
         ValueSymtab
symtab <- Finalize ValueSymtab -> Parse ValueSymtab
forall a. Finalize a -> Parse a
liftFinalize Finalize ValueSymtab
getValueSymtab
         String -> Parse String
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parse String) -> String -> Parse String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
           [ String
"entry " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Bool
isRel then String
" (relative)" else String
"")
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is missing from the symbol table"
           , ValueSymtab -> String
forall a. Show a => a -> String
show ValueSymtab
symtab ]

-- | Lookup the name of a basic block.
bbEntryName :: Int -> Finalize (Maybe BlockLabel)
bbEntryName :: Int -> Finalize (Maybe BlockLabel)
bbEntryName Int
n = do
  ValueSymtab
symtab <- Finalize ValueSymtab
getValueSymtab
  Maybe BlockLabel -> Finalize (Maybe BlockLabel)
forall a. a -> Finalize a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymName -> BlockLabel
mkBlockLabel (SymName -> BlockLabel) -> Maybe SymName -> Maybe BlockLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueSymtab -> IntMap SymName
bbSymtab ValueSymtab
symtab))

-- | Lookup the name of a basic block.
requireBbEntryName :: Int -> Finalize BlockLabel
requireBbEntryName :: Int -> Finalize BlockLabel
requireBbEntryName Int
n = do
  Maybe BlockLabel
mb <- Int -> Finalize (Maybe BlockLabel)
bbEntryName Int
n
  case Maybe BlockLabel
mb of
    Just BlockLabel
l  -> BlockLabel -> Finalize BlockLabel
forall a. a -> Finalize a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockLabel
l
    Maybe BlockLabel
Nothing -> String -> Finalize BlockLabel
forall a. String -> Finalize a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"basic block " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has no id")

-- Type Symbol Tables ----------------------------------------------------------

data TypeSymtab = TypeSymtab
  { TypeSymtab -> IntMap Ident
tsById   :: IntMap.IntMap Ident
  , TypeSymtab -> Map Ident Int
tsByName :: Map.Map Ident Int
  } deriving Int -> TypeSymtab -> ShowS
[TypeSymtab] -> ShowS
TypeSymtab -> String
(Int -> TypeSymtab -> ShowS)
-> (TypeSymtab -> String)
-> ([TypeSymtab] -> ShowS)
-> Show TypeSymtab
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeSymtab -> ShowS
showsPrec :: Int -> TypeSymtab -> ShowS
$cshow :: TypeSymtab -> String
show :: TypeSymtab -> String
$cshowList :: [TypeSymtab] -> ShowS
showList :: [TypeSymtab] -> ShowS
Show

instance Semigroup TypeSymtab where
  TypeSymtab
l <> :: TypeSymtab -> TypeSymtab -> TypeSymtab
<> TypeSymtab
r = TypeSymtab
    { tsById :: IntMap Ident
tsById   = TypeSymtab -> IntMap Ident
tsById   TypeSymtab
l IntMap Ident -> IntMap Ident -> IntMap Ident
forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` TypeSymtab -> IntMap Ident
tsById TypeSymtab
r
    , tsByName :: Map Ident Int
tsByName = TypeSymtab -> Map Ident Int
tsByName TypeSymtab
l Map Ident Int -> Map Ident Int -> Map Ident Int
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` TypeSymtab -> Map Ident Int
tsByName TypeSymtab
r
    }

instance Monoid TypeSymtab where
  mempty :: TypeSymtab
mempty = TypeSymtab
    { tsById :: IntMap Ident
tsById   = IntMap Ident
forall a. IntMap a
IntMap.empty
    , tsByName :: Map Ident Int
tsByName = Map Ident Int
forall k a. Map k a
Map.empty
    }

  mappend :: TypeSymtab -> TypeSymtab -> TypeSymtab
mappend = TypeSymtab -> TypeSymtab -> TypeSymtab
forall a. Semigroup a => a -> a -> a
(<>)

addTypeSymbol :: Int -> Ident -> TypeSymtab -> TypeSymtab
addTypeSymbol :: Int -> Ident -> TypeSymtab -> TypeSymtab
addTypeSymbol Int
ix Ident
n TypeSymtab
ts = TypeSymtab
ts
  { tsById   = IntMap.insert ix n (tsById ts)
  , tsByName = Map.insert n ix (tsByName ts)
  }


-- Metadata Kind Table ---------------------------------------------------------

data KindTable = KindTable
  { KindTable -> IntMap String
ktNames :: IntMap.IntMap String
  } deriving (Int -> KindTable -> ShowS
[KindTable] -> ShowS
KindTable -> String
(Int -> KindTable -> ShowS)
-> (KindTable -> String)
-> ([KindTable] -> ShowS)
-> Show KindTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KindTable -> ShowS
showsPrec :: Int -> KindTable -> ShowS
$cshow :: KindTable -> String
show :: KindTable -> String
$cshowList :: [KindTable] -> ShowS
showList :: [KindTable] -> ShowS
Show)

emptyKindTable :: KindTable
emptyKindTable :: KindTable
emptyKindTable  = KindTable
  { ktNames :: IntMap String
ktNames = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IntMap.fromList
    [ (Int
0, String
"dbg"   )
    , (Int
1, String
"tbaa"  )
    , (Int
2, String
"prof"  )
    , (Int
3, String
"fpmath")
    , (Int
4, String
"range" )
    ]
  }

addKind :: Int -> String -> Parse ()
addKind :: Int -> String -> Parse ()
addKind Int
kind String
name = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  let KindTable { IntMap String
ktNames :: KindTable -> IntMap String
ktNames :: IntMap String
.. } = ParseState -> KindTable
psKinds ParseState
ps
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psKinds = KindTable { ktNames = IntMap.insert kind name ktNames } }

getKind :: Int -> Parse String
getKind :: Int -> Parse String
getKind Int
kind = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  let KindTable { IntMap String
ktNames :: KindTable -> IntMap String
ktNames :: IntMap String
.. } = ParseState -> KindTable
psKinds ParseState
ps
  case Int -> IntMap String -> Maybe String
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
kind IntMap String
ktNames of
    Just String
name -> String -> Parse String
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return String
name
    Maybe String
Nothing   -> String -> Parse String
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown kind id: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
kind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nKind table: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ KindTable -> String
forall a. Show a => a -> String
show (ParseState -> KindTable
psKinds ParseState
ps))

-- Partial Symbols -------------------------------------------------------------

newtype StringTable = Strtab BS.ByteString
  deriving (Int -> StringTable -> ShowS
[StringTable] -> ShowS
StringTable -> String
(Int -> StringTable -> ShowS)
-> (StringTable -> String)
-> ([StringTable] -> ShowS)
-> Show StringTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StringTable -> ShowS
showsPrec :: Int -> StringTable -> ShowS
$cshow :: StringTable -> String
show :: StringTable -> String
$cshowList :: [StringTable] -> ShowS
showList :: [StringTable] -> ShowS
Show)
--newtype SymbolTable = Symtab BS.ByteString

mkStrtab :: BS.ByteString -> StringTable
mkStrtab :: ByteString -> StringTable
mkStrtab = ByteString -> StringTable
Strtab

--mkSymtab :: BS.ByteString -> SymbolTable
--mkSymtab = Symtab

resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol (Strtab ByteString
bs) Int
start Int
len =
  String -> Symbol
Symbol (String -> Symbol) -> String -> Symbol
forall a b. (a -> b) -> a -> b
$ [Word8] -> String
UTF8.decode ([Word8] -> String) -> [Word8] -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
len (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
start ByteString
bs

-- Finalize Monad --------------------------------------------------------------

newtype Finalize a = Finalize
  { forall a. Finalize a -> ReaderT Env (Except Error) a
unFinalize :: ReaderT Env (Except Error) a
  } deriving ((forall a b. (a -> b) -> Finalize a -> Finalize b)
-> (forall a b. a -> Finalize b -> Finalize a) -> Functor Finalize
forall a b. a -> Finalize b -> Finalize a
forall a b. (a -> b) -> Finalize a -> Finalize b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Finalize a -> Finalize b
fmap :: forall a b. (a -> b) -> Finalize a -> Finalize b
$c<$ :: forall a b. a -> Finalize b -> Finalize a
<$ :: forall a b. a -> Finalize b -> Finalize a
Functor, Functor Finalize
Functor Finalize =>
(forall a. a -> Finalize a)
-> (forall a b. Finalize (a -> b) -> Finalize a -> Finalize b)
-> (forall a b c.
    (a -> b -> c) -> Finalize a -> Finalize b -> Finalize c)
-> (forall a b. Finalize a -> Finalize b -> Finalize b)
-> (forall a b. Finalize a -> Finalize b -> Finalize a)
-> Applicative Finalize
forall a. a -> Finalize a
forall a b. Finalize a -> Finalize b -> Finalize a
forall a b. Finalize a -> Finalize b -> Finalize b
forall a b. Finalize (a -> b) -> Finalize a -> Finalize b
forall a b c.
(a -> b -> c) -> Finalize a -> Finalize b -> Finalize c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Finalize a
pure :: forall a. a -> Finalize a
$c<*> :: forall a b. Finalize (a -> b) -> Finalize a -> Finalize b
<*> :: forall a b. Finalize (a -> b) -> Finalize a -> Finalize b
$cliftA2 :: forall a b c.
(a -> b -> c) -> Finalize a -> Finalize b -> Finalize c
liftA2 :: forall a b c.
(a -> b -> c) -> Finalize a -> Finalize b -> Finalize c
$c*> :: forall a b. Finalize a -> Finalize b -> Finalize b
*> :: forall a b. Finalize a -> Finalize b -> Finalize b
$c<* :: forall a b. Finalize a -> Finalize b -> Finalize a
<* :: forall a b. Finalize a -> Finalize b -> Finalize a
Applicative)

instance Monad Finalize where
#if !MIN_VERSION_base(4,11,0)
  {-# INLINE return #-}
  return = pure
#endif

  {-# INLINE (>>=) #-}
  Finalize ReaderT Env (Except Error) a
m >>= :: forall a b. Finalize a -> (a -> Finalize b) -> Finalize b
>>= a -> Finalize b
f = ReaderT Env (Except Error) b -> Finalize b
forall a. ReaderT Env (Except Error) a -> Finalize a
Finalize (ReaderT Env (Except Error) a
m ReaderT Env (Except Error) a
-> (a -> ReaderT Env (Except Error) b)
-> ReaderT Env (Except Error) b
forall a b.
ReaderT Env (Except Error) a
-> (a -> ReaderT Env (Except Error) b)
-> ReaderT Env (Except Error) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Finalize b -> ReaderT Env (Except Error) b
forall a. Finalize a -> ReaderT Env (Except Error) a
unFinalize (Finalize b -> ReaderT Env (Except Error) b)
-> (a -> Finalize b) -> a -> ReaderT Env (Except Error) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Finalize b
f)

#if !MIN_VERSION_base(4,13,0)
  {-# INLINE fail #-}
  fail = failWithContext'
#endif

instance MonadFail Finalize where
  {-# INLINE fail #-}
  fail :: forall a. String -> Finalize a
fail = String -> Finalize a
forall a. String -> Finalize a
failWithContext'

instance Alternative Finalize where
  {-# INLINE empty #-}
  empty :: forall a. Finalize a
empty = String -> Finalize a
forall a. String -> Finalize a
failWithContext' String
"empty"

  {-# INLINE (<|>) #-}
  Finalize a
a <|> :: forall a. Finalize a -> Finalize a -> Finalize a
<|> Finalize a
b = ReaderT Env (Except Error) a -> Finalize a
forall a. ReaderT Env (Except Error) a -> Finalize a
Finalize (ReaderT Env (Except Error) a -> Finalize a)
-> ReaderT Env (Except Error) a -> Finalize a
forall a b. (a -> b) -> a -> b
$ ReaderT Env (Except Error) a
-> (Error -> ReaderT Env (Except Error) a)
-> ReaderT Env (Except Error) a
forall a.
ReaderT Env (Except Error) a
-> (Error -> ReaderT Env (Except Error) a)
-> ReaderT Env (Except Error) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Finalize a -> ReaderT Env (Except Error) a
forall a. Finalize a -> ReaderT Env (Except Error) a
unFinalize Finalize a
a) (ReaderT Env (Except Error) a
-> Error -> ReaderT Env (Except Error) a
forall a b. a -> b -> a
const (Finalize a -> ReaderT Env (Except Error) a
forall a. Finalize a -> ReaderT Env (Except Error) a
unFinalize Finalize a
b))

instance MonadPlus Finalize where
  {-# INLINE mzero #-}
  mzero :: forall a. Finalize a
mzero = String -> Finalize a
forall a. String -> Finalize a
failWithContext' String
"mzero"

  {-# INLINE mplus #-}
  mplus :: forall a. Finalize a -> Finalize a -> Finalize a
mplus = Finalize a -> Finalize a -> Finalize a
forall a. Finalize a -> Finalize a -> Finalize a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- | Fail, taking into account the current context.
failWithContext' :: String -> Finalize a
failWithContext' :: forall a. String -> Finalize a
failWithContext' String
msg =
  ReaderT Env (Except Error) a -> Finalize a
forall a. ReaderT Env (Except Error) a -> Finalize a
Finalize (ReaderT Env (Except Error) a -> Finalize a)
-> ReaderT Env (Except Error) a -> Finalize a
forall a b. (a -> b) -> a -> b
$
  do Env
env <- ReaderT Env (Except Error) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
     Error -> ReaderT Env (Except Error) a
forall a. Error -> ReaderT Env (Except Error) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
       { errMessage :: String
errMessage = String
msg
       , errContext :: [String]
errContext = Env -> [String]
envContext Env
env
       }

liftFinalize :: Finalize a -> Parse a
liftFinalize :: forall a. Finalize a -> Parse a
liftFinalize (Finalize ReaderT Env (Except Error) a
m) =
  do Env
env <- ReaderT Env (StateT ParseState (Except Error)) Env -> Parse Env
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
     case Except Error a -> Either Error a
forall e a. Except e a -> Either e a
runExcept (ReaderT Env (Except Error) a -> Env -> Except Error a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env (Except Error) a
m Env
env) of
       Left Error
err -> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (Error -> ReaderT Env (StateT ParseState (Except Error)) a
forall a. Error -> ReaderT Env (StateT ParseState (Except Error)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
err)
       Right a
a -> a -> Parse a
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a