{-# 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
  { errContext :: [String]
  , errMessage :: String
  } deriving (Show, Eq, Ord)

formatError :: Error -> String
formatError err
  | null (errContext err) = errMessage err
  | otherwise             = unlines
                          $ errMessage err
                          : "from:"
                          : map ('\t' :) (errContext err)

newtype Parse a = Parse
  { unParse :: ReaderT Env (StateT ParseState (Except Error)) a
  } deriving (Functor, Applicative, MonadFix)

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

  {-# INLINE (>>=) #-}
  Parse m >>= f = Parse (m >>= unParse . f)

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

instance MonadFail Parse where
  {-# INLINE fail #-}
  fail = failWithContext

instance Alternative Parse where
  {-# INLINE empty #-}
  empty = failWithContext "empty"

  {-# INLINE (<|>) #-}
  a <|> b = Parse $ catchError (unParse a) (const (unParse b))

instance MonadPlus Parse where
  {-# INLINE mzero #-}
  mzero = failWithContext "mzero"

  {-# INLINE mplus #-}
  mplus = (<|>)

runParse :: Parse a -> Either Error a
runParse (Parse m) =
  case runExcept (runStateT (runReaderT m emptyEnv) emptyParseState) of
    Left err     -> Left err
    Right (a, _) -> Right a

notImplemented :: Parse a
notImplemented  = fail "not implemented"

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

data ParseState = ParseState
  { psTypeTable     :: TypeTable
  , psTypeTableSize :: !Int
  , psValueTable    :: ValueTable
  , psStringTable   :: Maybe StringTable
  , psMdTable       :: ValueTable
  , psMdRefs        :: MdRefTable
  , psFunProtos     :: Seq.Seq FunProto
  , psNextResultId  :: !Int
  , psTypeName      :: Maybe String
  , psNextTypeId    :: !Int
  , psLastLoc       :: Maybe PDebugLoc
  , psKinds         :: !KindTable
  , psModVersion    :: !Int
  } deriving (Show)

-- | The initial parsing state.
emptyParseState :: ParseState
emptyParseState  = ParseState
  { psTypeTable     = IntMap.empty
  , psTypeTableSize = 0
  , psValueTable    = emptyValueTable False
  , psStringTable   = Nothing
  , psMdTable       = emptyValueTable False
  , psMdRefs        = IntMap.empty
  , psFunProtos     = Seq.empty
  , psNextResultId  = 0
  , psTypeName      = Nothing
  , psNextTypeId    = 0
  , psLastLoc       = Nothing
  , psKinds         = emptyKindTable
  , psModVersion    = 0
  }

-- | The next implicit result id.
nextResultId :: Parse Int
nextResultId  = Parse $ do
  ps <- get
  put ps { psNextResultId = psNextResultId ps + 1 }
  return (psNextResultId ps)

type PDebugLoc = DebugLoc' Int

setLastLoc :: PDebugLoc -> Parse ()
setLastLoc loc = Parse $ do
  ps <- get
  put $! ps { psLastLoc = Just loc }

setRelIds :: Bool -> Parse ()
setRelIds b = Parse $ do
  ps <- get
  put $! ps { psValueTable = (psValueTable ps) { valueRelIds = b }}

getRelIds :: Parse Bool
getRelIds  = do
  ps <- Parse get
  return (valueRelIds (psValueTable ps))

getLastLoc :: Parse PDebugLoc
getLastLoc  = do
  ps <- Parse get
  case psLastLoc ps of
    Just loc -> return loc
    Nothing  -> fail "No last location available"

setModVersion :: Int -> Parse ()
setModVersion v = Parse $ do
  ps <- get
  put $! ps { psModVersion = v }

getModVersion :: Parse Int
getModVersion = Parse (psModVersion <$> 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 m = Parse $ do
  ps  <- get
  put ps
    { psNextResultId = 0
    }
  res <- unParse m
  ps' <- get
  put ps'
    { psValueTable = psValueTable ps
    , psMdTable    = psMdTable ps
    , psMdRefs     = psMdRefs ps
    , psLastLoc    = Nothing
    }
  return res


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

type TypeTable = IntMap.IntMap Type

-- | Generate a type table, and a type symbol table.
mkTypeTable :: [Type] -> TypeTable
mkTypeTable  = IntMap.fromList . zip [0 ..]

-- | Exceptions contain a callstack, parsing context, explanation, and index
data BadForwardRef
  = BadTypeRef  CallStack [String] String Int
  | BadValueRef CallStack [String] String Int
    deriving (Show,Typeable)

instance X.Exception BadForwardRef

badRefError :: BadForwardRef -> Error
badRefError ref =
  let (stk, cxt, explanation, i, thing) =
        case ref of
          BadTypeRef  stk' cxt' explanation' i' -> (stk', cxt', explanation', i', "type")
          BadValueRef stk' cxt' explanation' i' -> (stk', cxt', explanation', i', "value")
  in Error cxt $ unlines ["bad forward reference to " ++ thing ++ ": " ++ show i
                         , "additional details: "
                         , explanation
                         , "with call stack: "
                         , prettyCallStack 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 cxt n =
  let explanation = "Bad reference into type table"
  in fromMaybe (X.throw (BadTypeRef callStack cxt explanation n)) . IntMap.lookup n

setTypeTable :: TypeTable -> Parse ()
setTypeTable table = Parse $ do
  ps <- get
  put ps { psTypeTable = table }

getTypeTable :: Parse TypeTable
getTypeTable  = Parse (psTypeTable <$> get)

setTypeTableSize :: Int -> Parse ()
setTypeTableSize n = Parse $ do
  ps <- get
  put ps { psTypeTableSize = n }

-- | Retrieve the current type name, failing if it hasn't been set.
getTypeName :: Parse Ident
getTypeName  = Parse $ do
  ps  <- get
  str <- case psTypeName ps of
    Just tn -> do
      put ps { psTypeName = Nothing }
      return tn
    Nothing -> do
      put ps { psNextTypeId = psNextTypeId ps + 1 }
      return (show (psNextTypeId ps))
  return (Ident str)

setTypeName :: String -> Parse ()
setTypeName name = Parse $ do
  ps <- get
  put ps { psTypeName = Just name }

-- | Lookup the value of a type; don't attempt to resolve to an alias.
getType' :: Int -> Parse Type
getType' ref = do
  ps <- Parse get
  unless (ref < psTypeTableSize ps)
    (fail ("type reference " ++ show ref ++ " is too large"))
  cxt <- getContext
  return (lookupTypeRef cxt ref (psTypeTable ps))

-- | Test to see if the type table has been added to already.
isTypeTableEmpty :: Parse Bool
isTypeTableEmpty  = Parse (IntMap.null . psTypeTable <$> get)

setStringTable :: StringTable -> Parse ()
setStringTable st = Parse $ do
  ps <- get
  put ps { psStringTable = Just st }

getStringTable :: Parse (Maybe StringTable)
getStringTable = Parse (psStringTable <$> get)

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

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

type PInstr = Instr' Int

data ValueTable = ValueTable
  { valueNextId  :: !Int
  , valueEntries :: IntMap.IntMap (Typed PValue)
  , strtabEntries :: IntMap.IntMap (Int, Int)
  , valueRelIds  :: Bool
  } deriving (Show)

emptyValueTable :: Bool -> ValueTable
emptyValueTable rel = ValueTable
  { valueNextId  = 0
  , valueEntries = IntMap.empty
  , strtabEntries = IntMap.empty
  , valueRelIds  = rel
  }

addValue :: Typed PValue -> ValueTable -> ValueTable
addValue tv vs = snd (addValue' tv vs)

addValue' :: Typed PValue -> ValueTable -> (Int,ValueTable)
addValue' tv vs = (valueNextId vs,vs')
  where
  vs' = 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 tv = Parse $ do
  ps <- get
  let vt = psValueTable ps
  put ps { psValueTable = addValue tv vt }
  return (valueNextId vt)

-- | Get the index for the next value.
nextValueId :: Parse Int
nextValueId  = Parse (valueNextId . psValueTable <$> get)

-- | Depending on whether or not relative ids are in use, adjust the id.
adjustId :: Int -> Parse Int
adjustId n = do
  vt <- getValueTable
  return (translateValueId vt 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 vt n | valueRelIds vt = fromIntegral adjusted
                      | otherwise      = n
  where
  adjusted :: Word32
  adjusted  = fromIntegral (valueNextId vt - n)

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

-- | When you know you have an absolute index.
lookupValueAbs :: Int -> Parse (Maybe (Typed PValue))
lookupValueAbs n = lookupValueTableAbs n `fmap` getValueTable

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

-- | Lookup a value in the value table.
lookupValue :: Int -> Parse (Maybe (Typed PValue))
lookupValue n = lookupValueTable n `fmap` 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 cxt n vt =
  let explanation = "Bad reference into a value table"
  in fromMaybe (X.throw (BadValueRef callStack cxt explanation n)) (lookupValueTableAbs n vt)

-- | Require that a value be present.
requireValue :: Int -> Parse (Typed PValue)
requireValue n = do
  mb <- lookupValue n
  case mb of
    Just tv -> return tv
    Nothing -> fail ("value " ++ show n ++ " is not defined")

-- | Get the current value table.
getValueTable :: Parse ValueTable
getValueTable  = Parse (psValueTable <$> 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  = valueNextId <$> getValueTable

-- | Set the current value table.
setValueTable :: ValueTable -> Parse ()
setValueTable vt = Parse $ do
  ps <- get
  put ps { psValueTable = vt }

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

fixValueTable_ :: (ValueTable -> Parse [Typed PValue]) -> Parse ()
fixValueTable_ k = fixValueTable $ \ vt -> do
  vs <- k vt
  return ((),vs)


type PValMd = ValMd' Int

type MdTable = ValueTable

getMdTable :: Parse MdTable
getMdTable  = Parse (psMdTable <$> get)

setMdTable :: MdTable -> Parse ()
setMdTable md = Parse $ do
  ps <- get
  put $! ps { psMdTable = md }

getMetadata :: Int -> Parse (Typed PValMd)
getMetadata ix = do
  ps <- Parse get
  case resolveMd ix ps of
    Just tv -> case typedValue tv of
      ValMd val -> return tv { typedValue = val }
      _         -> fail "unexpected non-metadata value in metadata table"
    Nothing -> fail ("metadata index " ++ show ix ++ " is not defined")

resolveMd :: Int -> ParseState -> Maybe (Typed PValue)
resolveMd ix ps = nodeRef `mplus` mdValue
  where
  reference = Typed (PrimType Metadata) . ValMd . ValMdRef
  nodeRef   = reference `fmap` IntMap.lookup ix (psMdRefs ps)
  mdValue   = lookupValueTableAbs ix (psMdTable ps)


type MdRefTable = IntMap.IntMap Int

setMdRefs :: MdRefTable -> Parse ()
setMdRefs refs = Parse $ do
  ps <- get
  put $! ps { psMdRefs = refs `IntMap.union` psMdRefs ps }


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

data FunProto = FunProto
  { protoType       :: Type
  , protoLinkage    :: Maybe Linkage
  , protoVisibility :: Maybe Visibility
  , protoGC         :: Maybe GC
  , protoSym        :: Symbol
  , protoIndex      :: Int
  , protoSect       :: Maybe String
  , protoComdat     :: Maybe String
  } deriving Show

-- | Push a function prototype on to the prototype stack.
pushFunProto :: FunProto -> Parse ()
pushFunProto p = Parse $ do
  ps <- get
  put ps { psFunProtos = psFunProtos ps Seq.|> p }

-- | Take a single function prototype off of the prototype stack.
popFunProto :: Parse FunProto
popFunProto  = do
  ps <- Parse get
  case Seq.viewl (psFunProtos ps) of
    Seq.EmptyL   -> fail "empty function prototype stack"
    p Seq.:< ps' -> do
      Parse (put ps { psFunProtos = ps' })
      return p


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

data Env = Env
  { envSymtab  :: Symtab
  , envContext :: [String]
  } deriving Show

emptyEnv :: Env
emptyEnv  = Env
  { envSymtab  = mempty
  , envContext = mempty
  }

-- | Extend the symbol table for an environment, yielding a new environment.
extendSymtab :: Symtab -> Env -> Env
extendSymtab symtab 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 l env = env { envContext = l : envContext env }

getContext :: Parse [String]
getContext  = Parse (envContext `fmap` ask)


data Symtab = Symtab
  { symValueSymtab :: ValueSymtab
  , symTypeSymtab  :: TypeSymtab
  } deriving (Show)

instance Semigroup Symtab where
  l <> r = Symtab
    { symValueSymtab = symValueSymtab l <> symValueSymtab r
    , symTypeSymtab  = symTypeSymtab  l <> symTypeSymtab  r
    }

instance Monoid Symtab where
  mempty = Symtab
    { symValueSymtab = emptyValueSymtab
    , symTypeSymtab  = mempty
    }

  mappend = (<>)

withSymtab :: Symtab -> Parse a -> Parse a
withSymtab symtab body = Parse $ do
  local (extendSymtab symtab) (unParse body)

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

-- | Retrieve the value symbol table.
getValueSymtab :: Finalize ValueSymtab
getValueSymtab = Finalize (symValueSymtab . envSymtab <$> ask)

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

-- | Retrieve the type symbol table.
getTypeSymtab :: Parse TypeSymtab
getTypeSymtab  = Parse (symTypeSymtab . envSymtab <$> ask)

-- | Label a sub-computation with its context.
label :: String -> Parse a -> Parse a
label l m = Parse $ do
  local (addLabel l) (unParse m)

-- | Fail, taking into account the current context.
failWithContext :: String -> Parse a
failWithContext msg = Parse $ do
  env <- ask
  throwError Error
    { errMessage = msg
    , errContext = envContext 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 ref = do
  symtab <- getTypeSymtab
  case IntMap.lookup ref (tsById symtab) of
    Just i  -> return (Alias i)
    Nothing -> getType' ref

-- | Find the id associated with a type alias.
getTypeId :: Ident -> Parse Int
getTypeId n = do
  symtab <- getTypeSymtab
  case Map.lookup n (tsByName symtab) of
    Just ix -> return ix
    Nothing -> fail ("unknown type alias " ++ show (ppLLVM llvmVlatest (llvmPP n)))


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

type SymName = Either String Int

data ValueSymtab =
  ValueSymtab
  { valSymtab :: IntMap.IntMap SymName
  , bbSymtab  :: IntMap.IntMap SymName
  , fnSymtab  :: IntMap.IntMap SymName
  } deriving (Show)

instance Semigroup ValueSymtab where
  l <> r = ValueSymtab
    { valSymtab = valSymtab l `IntMap.union` valSymtab r
    , bbSymtab  = bbSymtab l  `IntMap.union` bbSymtab r
    , fnSymtab  = fnSymtab l  `IntMap.union` fnSymtab r
    }

instance Monoid ValueSymtab where
  mappend = (<>)
  mempty = ValueSymtab
    { valSymtab = IntMap.empty
    , bbSymtab  = IntMap.empty
    , fnSymtab  = IntMap.empty
    }

renderName :: SymName -> String
renderName  = either id show

mkBlockLabel :: SymName -> BlockLabel
mkBlockLabel  = either (Named . Ident) Anon

emptyValueSymtab :: ValueSymtab
emptyValueSymtab  = mempty

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

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

addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab
addBBAnon i n t = 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 i _o n t = t { fnSymtab = IntMap.insert i (Left n) (fnSymtab t) }

addFwdFNEntry :: Int -> Int -> ValueSymtab -> ValueSymtab
addFwdFNEntry i o t = 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 n = do
  symtab <- liftFinalize getValueSymtab
  return $! fmap renderName
         $  IntMap.lookup n (valSymtab symtab) `mplus`
            IntMap.lookup n (fnSymtab symtab)

-- | Lookup the name of an entry.
entryName :: Int -> Parse String
entryName n = do
  mentry <- entryNameMb n
  case mentry of
    Just name -> return name
    Nothing   ->
      do isRel  <- getRelIds
         symtab <- liftFinalize getValueSymtab
         fail $ unlines
           [ "entry " ++ show n ++ (if isRel then " (relative)" else "")
              ++ " is missing from the symbol table"
           , show symtab ]

-- | Lookup the name of a basic block.
bbEntryName :: Int -> Finalize (Maybe BlockLabel)
bbEntryName n = do
  symtab <- getValueSymtab
  return (mkBlockLabel <$> IntMap.lookup n (bbSymtab symtab))

-- | Lookup the name of a basic block.
requireBbEntryName :: Int -> Finalize BlockLabel
requireBbEntryName n = do
  mb <- bbEntryName n
  case mb of
    Just l  -> return l
    Nothing -> fail ("basic block " ++ show n ++ " has no id")

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

data TypeSymtab = TypeSymtab
  { tsById   :: IntMap.IntMap Ident
  , tsByName :: Map.Map Ident Int
  } deriving Show

instance Semigroup TypeSymtab where
  l <> r = TypeSymtab
    { tsById   = tsById   l `IntMap.union` tsById r
    , tsByName = tsByName l `Map.union` tsByName r
    }

instance Monoid TypeSymtab where
  mempty = TypeSymtab
    { tsById   = IntMap.empty
    , tsByName = Map.empty
    }

  mappend = (<>)

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


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

data KindTable = KindTable
  { ktNames :: IntMap.IntMap String
  } deriving (Show)

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

addKind :: Int -> String -> Parse ()
addKind kind name = Parse $ do
  ps <- get
  let KindTable { .. } = psKinds ps
  put $! ps { psKinds = KindTable { ktNames = IntMap.insert kind name ktNames } }

getKind :: Int -> Parse String
getKind kind = do
  ps <- Parse get
  let KindTable { .. } = psKinds ps
  case IntMap.lookup kind ktNames of
    Just name -> return name
    Nothing   -> fail ("Unknown kind id: " ++ show kind ++ "\nKind table: " ++ show (psKinds ps))

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

newtype StringTable = Strtab BS.ByteString
  deriving (Show)
--newtype SymbolTable = Symtab BS.ByteString

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

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

resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol (Strtab bs) start len =
  Symbol $ UTF8.decode $ BS.unpack $ BS.take len $ BS.drop start bs

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

newtype Finalize a = Finalize
  { unFinalize :: ReaderT Env (Except Error) a
  } deriving (Functor, Applicative)

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

  {-# INLINE (>>=) #-}
  Finalize m >>= f = Finalize (m >>= unFinalize . f)

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

instance MonadFail Finalize where
  {-# INLINE fail #-}
  fail = failWithContext'

instance Alternative Finalize where
  {-# INLINE empty #-}
  empty = failWithContext' "empty"

  {-# INLINE (<|>) #-}
  a <|> b = Finalize $ catchError (unFinalize a) (const (unFinalize b))

instance MonadPlus Finalize where
  {-# INLINE mzero #-}
  mzero = failWithContext' "mzero"

  {-# INLINE mplus #-}
  mplus = (<|>)

-- | Fail, taking into account the current context.
failWithContext' :: String -> Finalize a
failWithContext' msg =
  Finalize $
  do env <- ask
     throwError Error
       { errMessage = msg
       , errContext = envContext env
       }

liftFinalize :: Finalize a -> Parse a
liftFinalize (Finalize m) =
  do env <- Parse ask
     case runExcept (runReaderT m env) of
       Left err -> Parse (throwError err)
       Right a -> return a