{-# LANGUAGE LambdaCase, BlockArguments, OrPatterns #-}
-- | This module contains the 'TermParser' abstraction, which provides utilities for
-- interpreting and parsing 'Term's
module GHC.Debugger.Runtime.Term.Parser where

import Data.Functor
import Control.Applicative
import Control.Monad

import GHC
import GHC.Driver.Env
import GHC.Core.DataCon (dataConName)
import GHC.Plugins (falseDataCon, trueDataCon, splitFunTy, boolTy)
import GHC.Runtime.Eval
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Interpreter as Interp
import GHC.Types.Name (nameOccName)
import GHC.Types.Name.Occurrence (occNameString)
import qualified Colog.Core as Logger
import GHC.Utils.Outputable (text, (<+>), ppr)
import Control.Monad.Reader
import GHC.Core.TyCo.Compare
import GHC.Stack

import GHC.Debugger.Monad

import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote
import qualified GHC.Debugger.Runtime.Compile as Comp

-- | The main entry point for running the 'TermParser'.
obtainParsedTerm
  :: String
  -> Int
  -> Bool
  -> Type
  -> ForeignHValue
  -> TermParser a
  -> Debugger (Either [TermParseError] a)
obtainParsedTerm :: forall a.
String
-> Int
-> Bool
-> Type
-> ForeignHValue
-> TermParser a
-> Debugger (Either [TermParseError] a)
obtainParsedTerm String
label Int
depth Bool
force Type
ty ForeignHValue
fhv TermParser a
term_parser = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  term <- liftIO $ cvObtainTerm hsc_env depth force ty fhv
  runTermParserLogged label (checkType ty *> term_parser) term


--------------------------------------------------------------------------------
-- * Term parser abstraction
--------------------------------------------------------------------------------

data TermParseError = TermParseError { TermParseError -> String
getTermErrorMessage :: String }
  deriving (TermParseError -> TermParseError -> Bool
(TermParseError -> TermParseError -> Bool)
-> (TermParseError -> TermParseError -> Bool) -> Eq TermParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TermParseError -> TermParseError -> Bool
== :: TermParseError -> TermParseError -> Bool
$c/= :: TermParseError -> TermParseError -> Bool
/= :: TermParseError -> TermParseError -> Bool
Eq, Int -> TermParseError -> ShowS
[TermParseError] -> ShowS
TermParseError -> String
(Int -> TermParseError -> ShowS)
-> (TermParseError -> String)
-> ([TermParseError] -> ShowS)
-> Show TermParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TermParseError -> ShowS
showsPrec :: Int -> TermParseError -> ShowS
$cshow :: TermParseError -> String
show :: TermParseError -> String
$cshowList :: [TermParseError] -> ShowS
showList :: [TermParseError] -> ShowS
Show)

newtype TermParser a = TermParser { forall a.
TermParser a -> Term -> Debugger (Either [TermParseError] a)
runTermParser :: Term -> Debugger (Either [TermParseError] a) }

liftDebugger :: Debugger a -> TermParser a
liftDebugger :: forall a. Debugger a -> TermParser a
liftDebugger Debugger a
action = (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] a)) -> TermParser a)
-> (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a b. (a -> b) -> a -> b
$ \Term
_ -> a -> Either [TermParseError] a
forall a b. b -> Either a b
Right (a -> Either [TermParseError] a)
-> Debugger a -> Debugger (Either [TermParseError] a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger a
action

liftDebuggerOrFail :: Show e => Debugger (Either e a) -> TermParser a
liftDebuggerOrFail :: forall e a. Show e => Debugger (Either e a) -> TermParser a
liftDebuggerOrFail Debugger (Either e a)
action = do
  Debugger (Either e a) -> TermParser (Either e a)
forall a. Debugger a -> TermParser a
liftDebugger Debugger (Either e a)
action TermParser (Either e a)
-> (Either e a -> TermParser a) -> TermParser a
forall a b. TermParser a -> (a -> TermParser b) -> TermParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left e
e -> String -> TermParser a
forall a. HasCallStack => String -> TermParser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail (e -> String
forall a. Show a => a -> String
show e
e)
    Right a
x -> a -> TermParser a
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

instance MonadIO TermParser where
  liftIO :: forall a. IO a -> TermParser a
liftIO IO a
action = (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] a)) -> TermParser a)
-> (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a b. (a -> b) -> a -> b
$ \Term
_ -> a -> Either [TermParseError] a
forall a b. b -> Either a b
Right (a -> Either [TermParseError] a)
-> Debugger a -> Debugger (Either [TermParseError] a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> Debugger a
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
action

instance Functor TermParser where
  fmap :: forall a b. (a -> b) -> TermParser a -> TermParser b
fmap a -> b
f (TermParser Term -> Debugger (Either [TermParseError] a)
p) = (Term -> Debugger (Either [TermParseError] b)) -> TermParser b
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] b)) -> TermParser b)
-> (Term -> Debugger (Either [TermParseError] b)) -> TermParser b
forall a b. (a -> b) -> a -> b
$ \Term
term -> (Either [TermParseError] a -> Either [TermParseError] b)
-> Debugger (Either [TermParseError] a)
-> Debugger (Either [TermParseError] b)
forall a b. (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either [TermParseError] a -> Either [TermParseError] b
forall a b.
(a -> b) -> Either [TermParseError] a -> Either [TermParseError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Term -> Debugger (Either [TermParseError] a)
p Term
term)

instance Applicative TermParser where
  pure :: forall a. a -> TermParser a
pure a
x = (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] a)) -> TermParser a)
-> (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a b. (a -> b) -> a -> b
$ \Term
_ -> Either [TermParseError] a -> Debugger (Either [TermParseError] a)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either [TermParseError] a
forall a b. b -> Either a b
Right a
x)
  TermParser Term -> Debugger (Either [TermParseError] (a -> b))
pf <*> :: forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
<*> TermParser Term -> Debugger (Either [TermParseError] a)
pa = (Term -> Debugger (Either [TermParseError] b)) -> TermParser b
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] b)) -> TermParser b)
-> (Term -> Debugger (Either [TermParseError] b)) -> TermParser b
forall a b. (a -> b) -> a -> b
$ \Term
term -> do
    ef <- Term -> Debugger (Either [TermParseError] (a -> b))
pf Term
term
    case ef of
      Left [TermParseError]
err -> Either [TermParseError] b -> Debugger (Either [TermParseError] b)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TermParseError] -> Either [TermParseError] b
forall a b. a -> Either a b
Left [TermParseError]
err)
      Right a -> b
f -> (Either [TermParseError] a -> Either [TermParseError] b)
-> Debugger (Either [TermParseError] a)
-> Debugger (Either [TermParseError] b)
forall a b. (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either [TermParseError] a -> Either [TermParseError] b
forall a b.
(a -> b) -> Either [TermParseError] a -> Either [TermParseError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Term -> Debugger (Either [TermParseError] a)
pa Term
term)

instance Monad TermParser where
  TermParser Term -> Debugger (Either [TermParseError] a)
pa >>= :: forall a b. TermParser a -> (a -> TermParser b) -> TermParser b
>>= a -> TermParser b
f = (Term -> Debugger (Either [TermParseError] b)) -> TermParser b
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] b)) -> TermParser b)
-> (Term -> Debugger (Either [TermParseError] b)) -> TermParser b
forall a b. (a -> b) -> a -> b
$ \Term
term -> do
    ea <- Term -> Debugger (Either [TermParseError] a)
pa Term
term
    case ea of
      Left [TermParseError]
err -> Either [TermParseError] b -> Debugger (Either [TermParseError] b)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TermParseError] -> Either [TermParseError] b
forall a b. a -> Either a b
Left [TermParseError]
err)
      Right a
a -> TermParser b -> Term -> Debugger (Either [TermParseError] b)
forall a.
TermParser a -> Term -> Debugger (Either [TermParseError] a)
runTermParser (a -> TermParser b
f a
a) Term
term

instance Alternative TermParser where
  empty :: forall a. TermParser a
empty = TermParseError -> TermParser a
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError String
"TermParser.empty")
  TermParser Term -> Debugger (Either [TermParseError] a)
p1 <|> :: forall a. TermParser a -> TermParser a -> TermParser a
<|> TermParser Term -> Debugger (Either [TermParseError] a)
p2 = (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] a)) -> TermParser a)
-> (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a b. (a -> b) -> a -> b
$ \Term
term -> do
    res <- Term -> Debugger (Either [TermParseError] a)
p1 Term
term
    case res of
      Left [TermParseError]
e1 -> [TermParseError]
-> Debugger (Either [TermParseError] a)
-> Debugger (Either [TermParseError] a)
forall a.
[TermParseError]
-> Debugger (Either [TermParseError] a)
-> Debugger (Either [TermParseError] a)
attachErrors [TermParseError]
e1 (Debugger (Either [TermParseError] a)
 -> Debugger (Either [TermParseError] a))
-> Debugger (Either [TermParseError] a)
-> Debugger (Either [TermParseError] a)
forall a b. (a -> b) -> a -> b
$ Term -> Debugger (Either [TermParseError] a)
p2 Term
term
      Either [TermParseError] a
success -> Either [TermParseError] a -> Debugger (Either [TermParseError] a)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either [TermParseError] a
success

instance MonadFail TermParser where
  fail :: forall a. HasCallStack => String -> TermParser a
fail String
s = TermParseError -> TermParser a
forall a. TermParseError -> TermParser a
parseError (TermParseError -> TermParser a)
-> (String -> TermParseError) -> String -> TermParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TermParseError
TermParseError (String -> TermParser a) -> String -> TermParser a
forall a b. (a -> b) -> a -> b
$ String
s

attachErrors :: [TermParseError] -> Debugger (Either [TermParseError] a)
                                 -> Debugger (Either [TermParseError] a)
attachErrors :: forall a.
[TermParseError]
-> Debugger (Either [TermParseError] a)
-> Debugger (Either [TermParseError] a)
attachErrors [TermParseError]
errs Debugger (Either [TermParseError] a)
term_parser = do
  pres <- Debugger (Either [TermParseError] a)
term_parser
  case pres of
    Left [TermParseError]
new_errs -> Either [TermParseError] a -> Debugger (Either [TermParseError] a)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TermParseError] -> Either [TermParseError] a
forall a b. a -> Either a b
Left ([TermParseError] -> Either [TermParseError] a)
-> [TermParseError] -> Either [TermParseError] a
forall a b. (a -> b) -> a -> b
$ [TermParseError]
errs [TermParseError] -> [TermParseError] -> [TermParseError]
forall a. [a] -> [a] -> [a]
++ [TermParseError]
new_errs)
    Right a
res -> Either [TermParseError] a -> Debugger (Either [TermParseError] a)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either [TermParseError] a
forall a b. b -> Either a b
Right a
res)

parseError :: TermParseError -> TermParser a
parseError :: forall a. TermParseError -> TermParser a
parseError TermParseError
err = (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] a)) -> TermParser a)
-> (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a b. (a -> b) -> a -> b
$ \Term
_ -> Either [TermParseError] a -> Debugger (Either [TermParseError] a)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TermParseError] -> Either [TermParseError] a
forall a b. a -> Either a b
Left [TermParseError
err])

termTag :: Term -> String
termTag :: Term -> String
termTag Term{}         = String
"Term"
termTag Prim{}         = String
"Prim"
termTag Suspension{}   = String
"Suspension"
termTag NewtypeWrap{}  = String
"NewtypeWrap"
termTag RefWrap{}      = String
"RefWrap"

anyTerm :: TermParser Term
anyTerm :: TermParser Term
anyTerm = (Term -> Debugger (Either [TermParseError] Term))
-> TermParser Term
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] Term))
 -> TermParser Term)
-> (Term -> Debugger (Either [TermParseError] Term))
-> TermParser Term
forall a b. (a -> b) -> a -> b
$ \Term
term -> Either [TermParseError] Term
-> Debugger (Either [TermParseError] Term)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Either [TermParseError] Term
forall a b. b -> Either a b
Right Term
term)

ensureTerm :: TermParser Term
ensureTerm :: TermParser Term
ensureTerm = do
  t <- TermParser Term
anyTerm
  case t of
    Term{} -> Term -> TermParser Term
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
t
    Term
other -> TermParseError -> TermParser Term
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError (String -> TermParseError) -> String -> TermParseError
forall a b. (a -> b) -> a -> b
$ String
"expected Term, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Term -> String
termTag Term
other)

checkType :: Type -> TermParser ()
checkType :: Type -> TermParser ()
checkType Type
ty = do
  t <- TermParser Term
anyTerm
  unless (termType t `eqType` ty) (parseError (TermParseError "ty mismatch"))

traceTerm :: TermParser ()
traceTerm :: TermParser ()
traceTerm = do
  t <- TermParser Term
anyTerm
  liftDebugger $ logSDoc Logger.Debug (ppr t)

-- | Evaluate the currently focused term
seqTermP :: HasCallStack => TermParser a -> TermParser a
seqTermP :: forall a. HasCallStack => TermParser a -> TermParser a
seqTermP TermParser a
term_parser = do
  t <- TermParser Term
anyTerm
  hsc_env <- liftDebugger $ getSession
  focus (liftIO $ seqTerm hsc_env t)
        term_parser

-- | If a term is a suspension, make sure that it's a thunk and not just that we
-- reached the depth limit.
refreshTerm :: TermParser Term
refreshTerm :: TermParser Term
refreshTerm = do
  t <- TermParser Term
anyTerm
  case t of
    Suspension {} -> do
      t' <- Type -> ForeignHValue -> TermParser Term
foreignValueToTerm (Term -> Type
ty Term
t) (Term -> ForeignHValue
val Term
t)
      return t'
    Term
_ -> Term -> TermParser Term
forall a. a -> TermParser a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t


-- | Change the focus of the term parser onto the specified term.
focus :: TermParser Term -> TermParser a -> TermParser a
focus :: forall a. TermParser Term -> TermParser a -> TermParser a
focus TermParser Term
parse_term TermParser a
term_parser =
  TermParser Term
parse_term TermParser Term -> (Term -> TermParser a) -> TermParser a
forall a b. TermParser a -> (a -> TermParser b) -> TermParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Term
t ->
    (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a.
(Term -> Debugger (Either [TermParseError] a)) -> TermParser a
TermParser ((Term -> Debugger (Either [TermParseError] a)) -> TermParser a)
-> (Term -> Debugger (Either [TermParseError] a)) -> TermParser a
forall a b. (a -> b) -> a -> b
$ \Term
_ -> TermParser a -> Term -> Debugger (Either [TermParseError] a)
forall a.
TermParser a -> Term -> Debugger (Either [TermParseError] a)
runTermParser TermParser a
term_parser Term
t

-- | Focus on a new subtree, after forcing it to WHNF.
focusSeq :: HasCallStack => TermParser Term -> TermParser a -> TermParser a
focusSeq :: forall a.
HasCallStack =>
TermParser Term -> TermParser a -> TermParser a
focusSeq TermParser Term
parse_term TermParser a
term_parser = TermParser Term -> TermParser a -> TermParser a
forall a. TermParser Term -> TermParser a -> TermParser a
focus TermParser Term
parse_term (TermParser a -> TermParser a
forall a. HasCallStack => TermParser a -> TermParser a
seqTermP TermParser a
term_parser)

-- | Choose the nth subterm
subtermTerm :: Int -> TermParser Term
subtermTerm :: Int -> TermParser Term
subtermTerm Int
idx = do
  t <- TermParser Term
anyTerm
  case t of
    Term{[Term]
subTerms :: [Term]
subTerms :: Term -> [Term]
subTerms}
      | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Term] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
subTerms -> do
          -- liftDebugger $ logSDoc Logger.Debug (ppr subTerms)
          TermParser Term -> TermParser Term -> TermParser Term
forall a. TermParser Term -> TermParser a -> TermParser a
focus (Term -> TermParser Term
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Term]
subTerms [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
idx)) TermParser Term
refreshTerm
      | Bool
otherwise -> TermParseError -> TermParser Term
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError (String -> TermParseError) -> String -> TermParseError
forall a b. (a -> b) -> a -> b
$ String
"missing subterm index " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
idx)
    Term
other -> TermParseError -> TermParser Term
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError (String -> TermParseError) -> String -> TermParseError
forall a b. (a -> b) -> a -> b
$ String
"expected Term with subterms, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Term -> String
termTag Term
other)

-- | Choose the nth subterm, force it to WHNF and run the supplied parser on it.
subtermWith :: Int -> TermParser a -> TermParser a
subtermWith :: forall a. Int -> TermParser a -> TermParser a
subtermWith Int
idx TermParser a
term_parser = do
  TermParser Term -> TermParser a -> TermParser a
forall a.
HasCallStack =>
TermParser Term -> TermParser a -> TermParser a
focusSeq (Int -> TermParser Term
subtermTerm Int
idx) TermParser a
term_parser

matchOccNameTerm :: String -> a -> TermParser a
matchOccNameTerm :: forall a. String -> a -> TermParser a
matchOccNameTerm String
occName a
result = do
  Term{dc} <- TermParser Term
ensureTerm
  case dc of
    Left String
name | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
occName -> a -> TermParser a
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
    Either String DataCon
_ -> TermParser a
forall a. TermParser a
forall (f :: * -> *) a. Alternative f => f a
empty

matchDataConTerm :: DataCon -> a -> TermParser a
matchDataConTerm :: forall a. DataCon -> a -> TermParser a
matchDataConTerm DataCon
dataCon a
result = do
  Term{dc} <- TermParser Term
ensureTerm
  case dc of
    Right DataCon
dc' | DataCon
dc' DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
dataCon -> a -> TermParser a
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
    Either String DataCon
_ -> TermParser a
forall a. TermParser a
forall (f :: * -> *) a. Alternative f => f a
empty

matchConstructorTerm :: String -> TermParser ()
matchConstructorTerm :: String -> TermParser ()
matchConstructorTerm String
ctorName = do
  term <- TermParser Term
anyTerm
  case term of
    t :: Term
t@Term{} | Either String DataCon -> String
constructorName (Term -> Either String DataCon
dc Term
t) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ctorName -> () -> TermParser ()
forall a. a -> TermParser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             | Bool
otherwise ->
                TermParseError -> TermParser ()
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError (String
"expected: "
                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ctorName
                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" got: "
                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either String DataCon -> String
constructorName (Term -> Either String DataCon
dc Term
t)))
    Term
other ->
      TermParseError -> TermParser ()
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError (String
"expected Program term, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Term -> String
termTag Term
other))

constructorName :: Either String DataCon -> String
constructorName :: Either String DataCon -> String
constructorName = \case
  Left String
name -> String
name
  Right DataCon
dataCon -> OccName -> String
occNameString (OccName -> String) -> (Name -> OccName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ DataCon -> Name
dataConName DataCon
dataCon

newtypeWrapParser :: TermParser Term
newtypeWrapParser :: TermParser Term
newtypeWrapParser = do
  t <- TermParser Term
anyTerm
  case t of
    NewtypeWrap{Term
wrapped_term :: Term
wrapped_term :: Term -> Term
wrapped_term} -> Term -> TermParser Term
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
wrapped_term
    Term
other -> TermParseError -> TermParser Term
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError (String -> TermParseError) -> String -> TermParseError
forall a b. (a -> b) -> a -> b
$ String
"expected NewtypeWrap, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Term -> String
termTag Term
other)

-- | Parse a primitive value as a single word (Prim term)
primParser :: TermParser Word
primParser :: TermParser Word
primParser = do
  t <- TermParser Term
anyTerm
  case t of
    Prim{valRaw :: Term -> [Word]
valRaw=[Word
w64_tid]} -> Word -> TermParser Word
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
w64_tid
    Term
other -> do
      TermParseError -> TermParser Word
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError (String -> TermParseError) -> String -> TermParseError
forall a b. (a -> b) -> a -> b
$ String
"expected a Prim term, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Term -> String
termTag Term
other)

-- | Is the current focus a suspension?
isSuspension :: TermParser Bool
isSuspension :: TermParser Bool
isSuspension = TermParser Term -> TermParser Bool -> TermParser Bool
forall a. TermParser Term -> TermParser a -> TermParser a
focus TermParser Term
refreshTerm (TermParser Bool -> TermParser Bool)
-> TermParser Bool -> TermParser Bool
forall a b. (a -> b) -> a -> b
$ do
  t <- TermParser Term
anyTerm
  -- traceTerm
  case t of
    Suspension{} -> Bool -> TermParser Bool
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Term
_other -> do
      -- liftDebugger $ logSDoc Logger.Debug (text $ termTag other)
      Bool -> TermParser Bool
forall a. a -> TermParser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Obtain a Term from a ForeignHValue
foreignValueToTerm :: Type -> ForeignHValue -> TermParser Term
foreignValueToTerm :: Type -> ForeignHValue -> TermParser Term
foreignValueToTerm Type
ty ForeignHValue
fhv =
  Debugger Term -> TermParser Term
forall a. Debugger a -> TermParser a
liftDebugger (Debugger Term -> TermParser Term)
-> Debugger Term -> TermParser Term
forall a b. (a -> b) -> a -> b
$ do
    hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    liftIO $ cvObtainTerm hsc_env 2 False ty fhv

--------------------------------------------------------------------------------
-- * Logging parsers
--------------------------------------------------------------------------------

logTermParserMsg :: String -> String -> Debugger ()
logTermParserMsg :: String -> String -> Debugger ()
logTermParserMsg String
label String
msg =
  Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Debug (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[TermParser]" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
label SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
msg)

runTermParserLogged
  :: String
  -> TermParser a
  -> Term
  -> Debugger (Either [TermParseError] a)
runTermParserLogged :: forall a.
String
-> TermParser a -> Term -> Debugger (Either [TermParseError] a)
runTermParserLogged String
label TermParser a
term_parser Term
term = do
  String -> String -> Debugger ()
logTermParserMsg String
label String
"start"
  res <- TermParser a -> Term -> Debugger (Either [TermParseError] a)
forall a.
TermParser a -> Term -> Debugger (Either [TermParseError] a)
runTermParser TermParser a
term_parser Term
term
  case res of
    Left [TermParseError]
errs -> do
      String -> String -> Debugger ()
logTermParserMsg String
label (String
"failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((TermParseError -> String) -> [TermParseError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TermParseError -> String
getTermErrorMessage [TermParseError]
errs))
      Either [TermParseError] a -> Debugger (Either [TermParseError] a)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TermParseError] -> Either [TermParseError] a
forall a b. a -> Either a b
Left [TermParseError]
errs)
    Right a
a -> do
      String -> String -> Debugger ()
logTermParserMsg String
label String
"succeeded"
      Either [TermParseError] a -> Debugger (Either [TermParseError] a)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either [TermParseError] a
forall a b. b -> Either a b
Right a
a)

--------------------------------------------------------------------------------
-- * Base parsers
--------------------------------------------------------------------------------

tuple2Of :: TermParser a -> TermParser b -> TermParser (a, b)
tuple2Of :: forall a b. TermParser a -> TermParser b -> TermParser (a, b)
tuple2Of TermParser a
parserA TermParser b
parserB = (,) (a -> b -> (a, b)) -> TermParser a -> TermParser (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TermParser a -> TermParser a
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser a
parserA TermParser (b -> (a, b)) -> TermParser b -> TermParser (a, b)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser b -> TermParser b
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
1 TermParser b
parserB

boolParser :: TermParser Bool
boolParser :: TermParser Bool
boolParser =
  String -> Bool -> TermParser Bool
forall a. String -> a -> TermParser a
matchOccNameTerm String
"False" Bool
False
    TermParser Bool -> TermParser Bool -> TermParser Bool
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Bool -> TermParser Bool
forall a. String -> a -> TermParser a
matchOccNameTerm String
"True" Bool
True
    TermParser Bool -> TermParser Bool -> TermParser Bool
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DataCon -> Bool -> TermParser Bool
forall a. DataCon -> a -> TermParser a
matchDataConTerm DataCon
falseDataCon Bool
False
    TermParser Bool -> TermParser Bool -> TermParser Bool
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DataCon -> Bool -> TermParser Bool
forall a. DataCon -> a -> TermParser a
matchDataConTerm DataCon
trueDataCon Bool
True
    TermParser Bool -> TermParser Bool -> TermParser Bool
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TermParseError -> TermParser Bool
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError String
"expected Bool term")

-- | Parse a list, given a parser for each element.
-- The whole list will be forced.
parseList :: TermParser a -> TermParser [a]
parseList :: forall a. TermParser a -> TermParser [a]
parseList TermParser a
item_parser =
        (String -> TermParser ()
matchConstructorTerm String
"[]" TermParser () -> TermParser [a] -> TermParser [a]
forall a b. TermParser a -> TermParser b -> TermParser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [a] -> TermParser [a]
forall a. a -> TermParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    TermParser [a] -> TermParser [a] -> TermParser [a]
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
":" TermParser () -> TermParser [a] -> TermParser [a]
forall a b. TermParser a -> TermParser b -> TermParser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((:) (a -> [a] -> [a]) -> TermParser a -> TermParser ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TermParser a -> TermParser a
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser a
item_parser TermParser ([a] -> [a]) -> TermParser [a] -> TermParser [a]
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser [a] -> TermParser [a]
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
1 (TermParser a -> TermParser [a]
forall a. TermParser a -> TermParser [a]
parseList TermParser a
item_parser)))

-- | Parse an 'Int'
intParser :: TermParser Int
intParser :: TermParser Int
intParser = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> TermParser Word -> TermParser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermParser Word
wordParser

intPrimParser :: TermParser Int
intPrimParser :: TermParser Int
intPrimParser = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> TermParser Word -> TermParser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermParser Word
primParser

-- | Parse a 'Word'
wordParser :: TermParser Word
wordParser :: TermParser Word
wordParser = Int -> TermParser Word -> TermParser Word
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser Word
primParser

wordPrimParser :: TermParser Word
wordPrimParser :: TermParser Word
wordPrimParser = TermParser Word
primParser

-- | Parse a 'String' term
stringParser :: TermParser String
stringParser :: TermParser String
stringParser = do
  Term{val=string_fv} <- TermParser Term
anyTerm
  liftDebugger $
    expectRight =<< Remote.evalString (Remote.untypedRef string_fv)

-- | Parse a 'Maybe' something
maybeParser :: TermParser a -> TermParser (Maybe a)
maybeParser :: forall a. TermParser a -> TermParser (Maybe a)
maybeParser TermParser a
just_p = do
  (String -> TermParser ()
matchConstructorTerm String
"Nothing" TermParser () -> Maybe a -> TermParser (Maybe a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe a
forall a. Maybe a
Nothing)
  TermParser (Maybe a)
-> TermParser (Maybe a) -> TermParser (Maybe a)
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> TermParser ()
matchConstructorTerm String
"Just" TermParser () -> TermParser (Maybe a) -> TermParser (Maybe a)
forall a b. TermParser a -> TermParser b -> TermParser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> TermParser a -> TermParser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TermParser a -> TermParser a
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser a
just_p))

--------------------------------------------------------------------------------
-- * VarValue
--------------------------------------------------------------------------------

-- | Parse a term which is a 'ValValue'
varValueParser :: TermParser (Term, Bool)
varValueParser :: TermParser (Term, Bool)
varValueParser =
  (,) (Term -> Bool -> (Term, Bool))
-> TermParser Term -> TermParser (Bool -> (Term, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser Term
programTermParser TermParser (Bool -> (Term, Bool))
-> TermParser Bool -> TermParser (Term, Bool)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser Bool -> TermParser Bool
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
1 TermParser Bool
boolParser

--------------------------------------------------------------------------------
-- * VarFields
--------------------------------------------------------------------------------

-- | Parse a term which is a 'Program VarFields'
varFieldsParser :: TermParser [(String, Term)]
varFieldsParser :: TermParser [(String, Term)]
varFieldsParser =
  TermParser Term
-> TermParser [(String, Term)] -> TermParser [(String, Term)]
forall a.
HasCallStack =>
TermParser Term -> TermParser a -> TermParser a
focusSeq TermParser Term
newtypeWrapParser (TermParser [(String, Term)] -> TermParser [(String, Term)])
-> TermParser [(String, Term)] -> TermParser [(String, Term)]
forall a b. (a -> b) -> a -> b
$
    -- Program [(IO String, VarFieldValue)]
    TermParser Term
-> TermParser [(String, Term)] -> TermParser [(String, Term)]
forall a.
HasCallStack =>
TermParser Term -> TermParser a -> TermParser a
focusSeq TermParser Term
programTermParser (TermParser [(String, Term)] -> TermParser [(String, Term)])
-> TermParser [(String, Term)] -> TermParser [(String, Term)]
forall a b. (a -> b) -> a -> b
$
        -- [(IO String, VarFieldValue)]
        TermParser (String, Term) -> TermParser [(String, Term)]
forall a. TermParser a -> TermParser [a]
parseList TermParser (String, Term)
parseFieldItem

  where
    -- Parses an item of type (IO String, VarFieldValue)
    parseFieldItem :: TermParser (String, Term)
    parseFieldItem :: TermParser (String, Term)
parseFieldItem = (,) (String -> Term -> (String, Term))
-> TermParser String -> TermParser (Term -> (String, Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TermParser String -> TermParser String
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser String
parseFieldLabel TermParser (Term -> (String, Term))
-> TermParser Term -> TermParser (String, Term)
forall a b. TermParser (a -> b) -> TermParser a -> TermParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
1 TermParser Term
varFieldValueParser

    parseFieldLabel :: TermParser String
    parseFieldLabel :: TermParser String
parseFieldLabel = do
      ioStrTerm <- TermParser Term
anyTerm
      interp <- liftDebugger $ hscInterp <$> getSession
      case ioStrTerm of
        (Suspension{} ; Term{})
          -> IO String -> TermParser String
forall a. IO a -> TermParser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> TermParser String) -> IO String -> TermParser String
forall a b. (a -> b) -> a -> b
$ Interp -> ForeignHValue -> IO String
evalString Interp
interp (Term -> ForeignHValue
val Term
ioStrTerm)
        Term
_ -> TermParseError -> TermParser String
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError String
"parseFieldLabel expected a val")

varFieldTupleParser :: TermParser (Term, Term)
varFieldTupleParser :: TermParser (Term, Term)
varFieldTupleParser = TermParser Term -> TermParser Term -> TermParser (Term, Term)
forall a b. TermParser a -> TermParser b -> TermParser (a, b)
tuple2Of TermParser Term
anyTerm TermParser Term
anyTerm

varFieldValueParser :: TermParser Term
varFieldValueParser :: TermParser Term
varFieldValueParser = Int -> TermParser Term
subtermTerm Int
0

--------------------------------------------------------------------------------
-- * Program Parser
--------------------------------------------------------------------------------

-- | Parses and evaluates a "Program" term.
programTermParser :: TermParser Term
programTermParser :: TermParser Term
programTermParser =
        TermParser Term
programPureParser
    TermParser Term -> TermParser Term -> TermParser Term
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TermParser Term
programApParser
    TermParser Term -> TermParser Term -> TermParser Term
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TermParser Term
programBranchParser
    TermParser Term -> TermParser Term -> TermParser Term
forall a. TermParser a -> TermParser a -> TermParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TermParser Term
programAskThunkParser
  where
    programPureParser :: TermParser Term
programPureParser = do
      String -> TermParser ()
matchConstructorTerm String
"PureProgram"
      Int -> TermParser Term
subtermTerm Int
0

    programApParser :: TermParser Term
programApParser = do
      String -> TermParser ()
matchConstructorTerm String
"ProgramAp"
      p1 <- Int -> TermParser Term -> TermParser Term
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 TermParser Term
programTermParser
      p2 <- subtermWith 1 programTermParser
      case (p1, p2) of
        ( (Suspension{} ; Term{}), (Suspension{} ; Term{}) ) -> do
          let (Type
_, Type
_arg_ty, Type
res_ty) = Type -> (Type, Type, Type)
splitFunTy (Term -> Type
termType Term
p1)
          res <- Debugger ForeignHValue -> TermParser ForeignHValue
forall a. Debugger a -> TermParser a
liftDebugger (Debugger ForeignHValue -> TermParser ForeignHValue)
-> Debugger ForeignHValue -> TermParser ForeignHValue
forall a b. (a -> b) -> a -> b
$
            Either BadEvalStatus ForeignHValue -> Debugger ForeignHValue
forall e a. Exception e => Either e a -> Debugger a
expectRight (Either BadEvalStatus ForeignHValue -> Debugger ForeignHValue)
-> Debugger (Either BadEvalStatus ForeignHValue)
-> Debugger ForeignHValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RemoteExpr HValue -> Debugger (Either BadEvalStatus ForeignHValue)
forall a.
RemoteExpr a -> Debugger (Either BadEvalStatus (ForeignRef a))
Remote.eval
              (ForeignHValue -> RemoteExpr (ZonkAny 0 -> HValue)
forall a. ForeignHValue -> RemoteExpr a
Remote.untypedRef (Term -> ForeignHValue
val Term
p1) RemoteExpr (ZonkAny 0 -> HValue)
-> RemoteExpr (ZonkAny 0) -> RemoteExpr HValue
forall a b. RemoteExpr (a -> b) -> RemoteExpr a -> RemoteExpr b
`Remote.app` ForeignHValue -> RemoteExpr (ZonkAny 0)
forall a. ForeignHValue -> RemoteExpr a
Remote.untypedRef (Term -> ForeignHValue
val Term
p2))
          foreignValueToTerm res_ty res
        (Term, Term)
_ -> TermParseError -> TermParser Term
forall a. TermParseError -> TermParser a
parseError (String -> TermParseError
TermParseError String
"programApParser: expected two vals")

    programBranchParser :: TermParser Term
programBranchParser = do
      String -> TermParser ()
matchConstructorTerm String
"ProgramBranch"
      cond <- Int -> TermParser Bool -> TermParser Bool
forall a. Int -> TermParser a -> TermParser a
subtermWith Int
0 (TermParser Term -> TermParser Bool -> TermParser Bool
forall a.
HasCallStack =>
TermParser Term -> TermParser a -> TermParser a
focusSeq TermParser Term
programTermParser TermParser Bool
boolParser)
      if cond then do
            subtermWith 1 programTermParser
           else do
            subtermWith 2 programTermParser

    programAskThunkParser :: TermParser Term
programAskThunkParser = do
      String -> TermParser ()
matchConstructorTerm String
"ProgramAskThunk"
      -- Get what we need to check THUNKiness for
      is_thunk <- TermParser Term -> TermParser Bool -> TermParser Bool
forall a. TermParser Term -> TermParser a -> TermParser a
focus (Int -> TermParser Term
subtermTerm Int
1) TermParser Bool
isSuspension
      bool_fv <- liftDebugger $ reifyBool is_thunk
      foreignValueToTerm boolTy bool_fv

reifyBool :: Bool -> Debugger ForeignHValue
reifyBool :: Bool -> Debugger ForeignHValue
reifyBool Bool
b = String -> Debugger ForeignHValue
Comp.compileRaw (Bool -> String
forall a. Show a => a -> String
show Bool
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":: Bool")