{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}

module Unison.Runtime.Interface
  ( startRuntime,
    withRuntime,
    standalone,
    runStandalone,
    StoredCache
      ( -- Exported for tests
        SCache
      ),
    decodeStandalone,
    RuntimeHost (..),
    Runtime,
    terminate,

    -- * Exported for tests
    getStoredCache,
    putStoredCache,

    -- * error serialization (these should live in unison-cli, but they still have some call sites here)
    prettyError,
    prettyRuntimeExn,
    renderDecompError,
    tabulateErrors,
  )
where

import Control.Concurrent.STM as STM
import Control.Exception (fromException, tryJust)
import Control.Monad
import Control.Monad.State
import Data.Binary.Get (runGetOrFail)
import Data.Bitraversable (bitraverse)
import Data.ByteString.Lazy qualified as BL
import Data.Bytes.Get (MonadGet)
import Data.Bytes.Put (MonadPut, runPutL)
import Data.Bytes.Serial
import Data.Foldable
import Data.IORef
import Data.List qualified as L
import Data.Map.Strict qualified as Map
import Data.Set as Set (filter, fromList, map, notMember, singleton, (\\))
import Data.Set qualified as Set
import Data.Text (isPrefixOf)
import Data.Text as Text (unpack)
import Data.Void (absurd)
import System.FilePath
import Unison.ABT qualified as ABT
import Unison.Builtin.Decls qualified as RF
import Unison.Codebase.CodeLookup (CodeLookup (..))
import Unison.Codebase.MainTerm (builtinIOTestTypes, builtinMain)
import Unison.Codebase.Runtime (CompileOpts (..), Response (..))
import Unison.Codebase.Runtime.Profile (Profile (..), ProfileSpec (..), foldedProfile, fullProfile, miniProfile)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import Unison.ConstructorReference qualified as RF
import Unison.DataDeclaration (Decl, declFields, declTypeDependencies)
import Unison.Hashing.V2.Convert qualified as Hashing
import Unison.LabeledDependency qualified as RF
import Unison.Parser.Ann (Ann (External))
import Unison.Prelude
import Unison.PrettyPrintEnv
import Unison.PrettyPrintEnv qualified as PPE
import Unison.Reference (Reference)
import Unison.Reference qualified as RF
import Unison.Referent qualified as RF (pattern Ref)
import Unison.Runtime
import Unison.Runtime.ANF as ANF
import Unison.Runtime.ANF.Optimize as ANF
import Unison.Runtime.ANF.Rehash as ANF (rehashGroups)
import Unison.Runtime.ANF.Serialize as ANF (getGroupCurrent, getOptInfos, putGroup, putOptInfos)
import Unison.Runtime.Builtin
import Unison.Runtime.Decompile (DecompError, DecompResult, decompile)
import Unison.Runtime.Decompile qualified as Decomp
import Unison.Runtime.Exception (RuntimeExn (BU, PE), die)
import Unison.Runtime.Foreign.Function (functionUnreplacements)
import Unison.Runtime.InternalError (CompileExn (CE))
import Unison.Runtime.MCode
  ( Args (..),
    CombIx (..),
    GInstr (..),
    GSection (..),
    RCombs,
    RefNums (..),
    absurdCombs,
    combTypes,
    emitComb,
    emptyRNs,
    resolveCombs,
    sanitizeCombsOfForeignFuncs,
  )
import Unison.Runtime.MCode.Serialize
import Unison.Runtime.Machine
  ( ActiveThreads,
    CCache (..),
    Combs,
    Tracer (..),
    apply0,
    baseCCache,
    cacheAdd,
    cacheAdd0,
    eval0,
    expandSandbox,
    preEvalTopLevelConstants,
    refLookup,
    refNumTm,
    refNumsTm,
    refNumsTy,
    resolveSection,
  )
import Unison.Runtime.Pattern
import Unison.Runtime.Profiling
import Unison.Runtime.Serialize as SER
import Unison.Runtime.Stack
import Unison.Runtime.TypeTags qualified as TT
import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualified qualified as HQ (toText)
import Unison.Syntax.NamePrinter (prettyHashQualified, prettyReference)
import Unison.Syntax.TermPrinter
import Unison.Term qualified as Tm
import Unison.Type qualified as Type
import Unison.Util.EnumContainers as EC
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Pretty as P
import Unison.Util.Recursion qualified as Rec
import UnliftIO qualified
import UnliftIO.Concurrent qualified as UnliftIO

type Term v = Tm.Term v ()

type Type v = Type.Type v ()

-- Note that these annotations are suggestions at best, since in many places codebase refs, intermediate refs, and
-- floated refs are all intermingled.
type CodebaseReference = Reference

-- Note that these annotations are suggestions at best, since in many places codebase refs, intermediate refs, and
-- floated refs are all intermingled.
type IntermediateReference = Reference

-- Note that these annotations are suggestions at best, since in many places codebase refs, intermediate refs, and
-- floated refs are all intermingled.
type FloatedReference = Reference

data Remapping from to = Remap
  { forall from to. Remapping from to -> Map from to
remap :: Map.Map from to,
    forall from to. Remapping from to -> Map to from
backmap :: Map.Map to from
  }

instance (Ord from, Ord to) => Semigroup (Remapping from to) where
  Remap Map from to
r1 Map to from
b1 <> :: Remapping from to -> Remapping from to -> Remapping from to
<> Remap Map from to
r2 Map to from
b2 = Map from to -> Map to from -> Remapping from to
forall from to. Map from to -> Map to from -> Remapping from to
Remap (Map from to
r1 Map from to -> Map from to -> Map from to
forall a. Semigroup a => a -> a -> a
<> Map from to
r2) (Map to from
b1 Map to from -> Map to from -> Map to from
forall a. Semigroup a => a -> a -> a
<> Map to from
b2)

instance (Ord from, Ord to) => Monoid (Remapping from to) where
  mempty :: Remapping from to
mempty = Map from to -> Map to from -> Remapping from to
forall from to. Map from to -> Map to from -> Remapping from to
Remap Map from to
forall a. Monoid a => a
mempty Map to from
forall a. Monoid a => a
mempty

data EvalCtx = ECtx
  { EvalCtx -> DataSpec
dspec :: DataSpec,
    EvalCtx -> Remapping Reference Reference
floatRemap :: Remapping CodebaseReference FloatedReference,
    EvalCtx -> Remapping Reference Reference
intermedRemap :: Remapping FloatedReference IntermediateReference,
    EvalCtx -> Map Reference (FloatName Symbol)
floatNames :: Map.Map FloatedReference (FloatName Symbol),
    EvalCtx -> Map Reference (Map Word64 (Term Symbol))
decompTm :: Map.Map Reference (Map.Map Word64 (Term Symbol)),
    EvalCtx -> CCache ()
ccache :: CCache ()
  }

uncurryDspec :: DataSpec -> Map.Map ConstructorReference Int
uncurryDspec :: DataSpec -> Map ConstructorReference Int
uncurryDspec = [(ConstructorReference, Int)] -> Map ConstructorReference Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ConstructorReference, Int)] -> Map ConstructorReference Int)
-> (DataSpec -> [(ConstructorReference, Int)])
-> DataSpec
-> Map ConstructorReference Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Reference, Either [Int] [Int]) -> [(ConstructorReference, Int)])
-> [(Reference, Either [Int] [Int])]
-> [(ConstructorReference, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Reference, Either [Int] [Int]) -> [(ConstructorReference, Int)]
forall {r} {b}.
(r, Either [b] [b]) -> [(GConstructorReference r, b)]
f ([(Reference, Either [Int] [Int])]
 -> [(ConstructorReference, Int)])
-> (DataSpec -> [(Reference, Either [Int] [Int])])
-> DataSpec
-> [(ConstructorReference, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataSpec -> [(Reference, Either [Int] [Int])]
forall k a. Map k a -> [(k, a)]
Map.toList
  where
    f :: (r, Either [b] [b]) -> [(GConstructorReference r, b)]
f (r
r, Either [b] [b]
l) = (Word64 -> b -> (GConstructorReference r, b))
-> [Word64] -> [b] -> [(GConstructorReference r, b)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Word64
n b
c -> (r -> Word64 -> GConstructorReference r
forall r. r -> Word64 -> GConstructorReference r
ConstructorReference r
r Word64
n, b
c)) [Word64
0 ..] ([b] -> [(GConstructorReference r, b)])
-> [b] -> [(GConstructorReference r, b)]
forall a b. (a -> b) -> a -> b
$ ([b] -> [b]) -> ([b] -> [b]) -> Either [b] [b] -> [b]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [b] -> [b]
forall a. a -> a
id [b] -> [b]
forall a. a -> a
id Either [b] [b]
l

cacheContext :: CCache () -> EvalCtx
cacheContext :: CCache () -> EvalCtx
cacheContext =
  DataSpec
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (FloatName Symbol)
-> Map Reference (Map Word64 (Term Symbol))
-> CCache ()
-> EvalCtx
ECtx DataSpec
builtinDataSpec Remapping Reference Reference
forall a. Monoid a => a
mempty Remapping Reference Reference
forall a. Monoid a => a
mempty Map Reference (FloatName Symbol)
forall a. Monoid a => a
mempty
    (Map Reference (Map Word64 (Term Symbol)) -> CCache () -> EvalCtx)
-> ([(Reference, Map Word64 (Term Symbol))]
    -> Map Reference (Map Word64 (Term Symbol)))
-> [(Reference, Map Word64 (Term Symbol))]
-> CCache ()
-> EvalCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Reference, Map Word64 (Term Symbol))]
-> Map Reference (Map Word64 (Term Symbol))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    ([(Reference, Map Word64 (Term Symbol))] -> CCache () -> EvalCtx)
-> [(Reference, Map Word64 (Term Symbol))] -> CCache () -> EvalCtx
forall a b. (a -> b) -> a -> b
$ Map Reference Word64 -> [Reference]
forall k a. Map k a -> [k]
Map.keys Map Reference Word64
builtinTermNumbering
      [Reference]
-> (Reference -> (Reference, Map Word64 (Term Symbol)))
-> [(Reference, Map Word64 (Term Symbol))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Reference
r -> (Reference
r, Word64 -> Term Symbol -> Map Word64 (Term Symbol)
forall k a. k -> a -> Map k a
Map.singleton Word64
0 (() -> Reference -> Term Symbol
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
Tm.ref () Reference
r))

baseContext :: Bool -> IO EvalCtx
baseContext :: Bool -> IO EvalCtx
baseContext Bool
sandboxed = CCache () -> EvalCtx
cacheContext (CCache () -> EvalCtx) -> IO (CCache ()) -> IO EvalCtx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO (CCache ())
baseCCache Bool
sandboxed

resolveTermRef ::
  CodeLookup Symbol IO () ->
  RF.Reference ->
  IO (Term Symbol)
resolveTermRef :: CodeLookup Symbol IO () -> Reference -> IO (Term Symbol)
resolveTermRef CodeLookup Symbol IO ()
_ b :: Reference
b@(RF.Builtin Text
_) =
  [Word] -> [Char] -> IO (Term Symbol)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (Term Symbol)) -> [Char] -> IO (Term Symbol)
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown builtin term reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
b
resolveTermRef CodeLookup Symbol IO ()
cl r :: Reference
r@(RF.DerivedId Id
i) =
  CodeLookup Symbol IO () -> Id -> IO (Maybe (Term Symbol))
forall v (m :: * -> *) a.
CodeLookup v m a -> Id -> m (Maybe (Term v a))
getTerm CodeLookup Symbol IO ()
cl Id
i IO (Maybe (Term Symbol))
-> (Maybe (Term Symbol) -> IO (Term Symbol)) -> IO (Term Symbol)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Term Symbol)
Nothing -> [Word] -> [Char] -> IO (Term Symbol)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (Term Symbol)) -> [Char] -> IO (Term Symbol)
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown term reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
r
    Just Term Symbol
tm -> Term Symbol -> IO (Term Symbol)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term Symbol
tm

allocType ::
  EvalCtx ->
  RF.Reference ->
  Either [Int] [Int] ->
  IO EvalCtx
allocType :: EvalCtx -> Reference -> Either [Int] [Int] -> IO EvalCtx
allocType EvalCtx
_ b :: Reference
b@(RF.Builtin Text
_) Either [Int] [Int]
_ =
  [Word] -> [Char] -> IO EvalCtx
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO EvalCtx) -> [Char] -> IO EvalCtx
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown builtin type reference: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
b
allocType EvalCtx
ctx Reference
r Either [Int] [Int]
cons =
  EvalCtx -> IO EvalCtx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvalCtx -> IO EvalCtx) -> EvalCtx -> IO EvalCtx
forall a b. (a -> b) -> a -> b
$ EvalCtx
ctx {dspec = Map.insert r cons $ dspec ctx}

recursiveDeclDeps ::
  CodeLookup Symbol IO () ->
  Decl Symbol () ->
  -- (type deps, term deps)
  StateT (Set RF.LabeledDependency) IO (Set Reference, Set Reference)
recursiveDeclDeps :: CodeLookup Symbol IO ()
-> Decl Symbol ()
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
recursiveDeclDeps CodeLookup Symbol IO ()
cl Decl Symbol ()
d = do
  Set LabeledDependency
seen0 <- StateT (Set LabeledDependency) IO (Set LabeledDependency)
forall s (m :: * -> *). MonadState s m => m s
get
  let seen :: Set LabeledDependency
seen = Set LabeledDependency
seen0 Set LabeledDependency
-> Set LabeledDependency -> Set LabeledDependency
forall a. Semigroup a => a -> a -> a
<> (Reference -> LabeledDependency)
-> Set Reference -> Set LabeledDependency
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Reference -> LabeledDependency
RF.typeRef Set Reference
deps
  Set LabeledDependency -> StateT (Set LabeledDependency) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Set LabeledDependency
seen
  let newDeps :: Set Reference
newDeps = (Reference -> Bool) -> Set Reference -> Set Reference
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Reference
r -> LabeledDependency -> Set LabeledDependency -> Bool
forall a. Ord a => a -> Set a -> Bool
notMember (Reference -> LabeledDependency
RF.typeRef Reference
r) Set LabeledDependency
seen0) Set Reference
deps
  (Set Reference, Set Reference)
rec <-
    (Set Reference -> [Reference]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Reference
newDeps) [Reference]
-> ([Reference]
    -> StateT
         (Set LabeledDependency) IO (Set Reference, Set Reference))
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a b. a -> (a -> b) -> b
& (Reference
 -> StateT
      (Set LabeledDependency) IO (Set Reference, Set Reference))
-> [Reference]
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM \Reference
r -> do
      case Reference
r of
        RF.DerivedId Id
i ->
          IO (Maybe (Decl Symbol ()))
-> StateT (Set LabeledDependency) IO (Maybe (Decl Symbol ()))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Set LabeledDependency) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CodeLookup Symbol IO () -> Id -> IO (Maybe (Decl Symbol ()))
forall v (m :: * -> *) a.
CodeLookup v m a -> Id -> m (Maybe (Decl v a))
getTypeDeclaration CodeLookup Symbol IO ()
cl Id
i) StateT (Set LabeledDependency) IO (Maybe (Decl Symbol ()))
-> (Maybe (Decl Symbol ())
    -> StateT
         (Set LabeledDependency) IO (Set Reference, Set Reference))
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a b.
StateT (Set LabeledDependency) IO a
-> (a -> StateT (Set LabeledDependency) IO b)
-> StateT (Set LabeledDependency) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Decl Symbol ()
d -> CodeLookup Symbol IO ()
-> Decl Symbol ()
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
recursiveDeclDeps CodeLookup Symbol IO ()
cl Decl Symbol ()
d
            Maybe (Decl Symbol ())
Nothing -> (Set Reference, Set Reference)
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a. a -> StateT (Set LabeledDependency) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Reference, Set Reference)
forall a. Monoid a => a
mempty
        Reference
_ -> (Set Reference, Set Reference)
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a. a -> StateT (Set LabeledDependency) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Reference, Set Reference)
forall a. Monoid a => a
mempty
  pure $ (Set Reference
deps, Set Reference
forall a. Monoid a => a
mempty) (Set Reference, Set Reference)
-> (Set Reference, Set Reference) -> (Set Reference, Set Reference)
forall a. Semigroup a => a -> a -> a
<> (Set Reference, Set Reference)
rec
  where
    deps :: Set Reference
deps = Decl Symbol () -> Set Reference
forall v a. Ord v => Decl v a -> Set Reference
declTypeDependencies Decl Symbol ()
d

categorize :: RF.LabeledDependency -> (Set Reference, Set Reference)
categorize :: LabeledDependency -> (Set Reference, Set Reference)
categorize =
  \case
    RF.TypeReference Reference
ref -> (Reference -> Set Reference
forall a. a -> Set a
Set.singleton Reference
ref, Set Reference
forall a. Monoid a => a
mempty)
    RF.ConReference (RF.ConstructorReference Reference
ref Word64
_conId) ConstructorType
_conType -> (Reference -> Set Reference
forall a. a -> Set a
Set.singleton Reference
ref, Set Reference
forall a. Monoid a => a
mempty)
    RF.TermReference Reference
ref -> (Set Reference
forall a. Monoid a => a
mempty, Reference -> Set Reference
forall a. a -> Set a
Set.singleton Reference
ref)

recursiveTermDeps ::
  CodeLookup Symbol IO () ->
  Term Symbol ->
  -- (type deps, term deps)
  StateT (Set RF.LabeledDependency) IO (Set Reference, Set Reference)
recursiveTermDeps :: CodeLookup Symbol IO ()
-> Term Symbol
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
recursiveTermDeps CodeLookup Symbol IO ()
cl Term Symbol
tm = do
  Set LabeledDependency
seen0 <- StateT (Set LabeledDependency) IO (Set LabeledDependency)
forall s (m :: * -> *). MonadState s m => m s
get
  let seen :: Set LabeledDependency
seen = Set LabeledDependency
seen0 Set LabeledDependency
-> Set LabeledDependency -> Set LabeledDependency
forall a. Semigroup a => a -> a -> a
<> Set LabeledDependency
deps
  Set LabeledDependency -> StateT (Set LabeledDependency) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Set LabeledDependency
seen
  (Set Reference, Set Reference)
rec <-
    (Set LabeledDependency -> [LabeledDependency]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set LabeledDependency
deps Set LabeledDependency
-> Set LabeledDependency -> Set LabeledDependency
forall a. Ord a => Set a -> Set a -> Set a
\\ Set LabeledDependency
seen0)) [LabeledDependency]
-> ([LabeledDependency]
    -> StateT
         (Set LabeledDependency) IO (Set Reference, Set Reference))
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a b. a -> (a -> b) -> b
& (LabeledDependency
 -> StateT
      (Set LabeledDependency) IO (Set Reference, Set Reference))
-> [LabeledDependency]
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM \LabeledDependency
r ->
      case LabeledDependency
r of
        RF.ConReference (RF.ConstructorReference (RF.DerivedId Id
refId) Word64
_conId) ConstructorType
_conType -> Id
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
handleTypeReferenceId Id
refId
        RF.TypeReference (RF.DerivedId Id
refId) -> Id
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
handleTypeReferenceId Id
refId
        RF.TermReference Reference
r -> CodeLookup Symbol IO ()
-> Reference
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
recursiveRefDeps CodeLookup Symbol IO ()
cl Reference
r
        LabeledDependency
_ -> (Set Reference, Set Reference)
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a. a -> StateT (Set LabeledDependency) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Reference, Set Reference)
forall a. Monoid a => a
mempty
  pure $ (LabeledDependency -> (Set Reference, Set Reference))
-> Set LabeledDependency -> (Set Reference, Set Reference)
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LabeledDependency -> (Set Reference, Set Reference)
categorize Set LabeledDependency
deps (Set Reference, Set Reference)
-> (Set Reference, Set Reference) -> (Set Reference, Set Reference)
forall a. Semigroup a => a -> a -> a
<> (Set Reference, Set Reference)
rec
  where
    handleTypeReferenceId :: RF.Id -> StateT (Set RF.LabeledDependency) IO (Set Reference, Set Reference)
    handleTypeReferenceId :: Id
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
handleTypeReferenceId Id
refId =
      IO (Maybe (Decl Symbol ()))
-> StateT (Set LabeledDependency) IO (Maybe (Decl Symbol ()))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Set LabeledDependency) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CodeLookup Symbol IO () -> Id -> IO (Maybe (Decl Symbol ()))
forall v (m :: * -> *) a.
CodeLookup v m a -> Id -> m (Maybe (Decl v a))
getTypeDeclaration CodeLookup Symbol IO ()
cl Id
refId) StateT (Set LabeledDependency) IO (Maybe (Decl Symbol ()))
-> (Maybe (Decl Symbol ())
    -> StateT
         (Set LabeledDependency) IO (Set Reference, Set Reference))
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a b.
StateT (Set LabeledDependency) IO a
-> (a -> StateT (Set LabeledDependency) IO b)
-> StateT (Set LabeledDependency) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Decl Symbol ()
d -> CodeLookup Symbol IO ()
-> Decl Symbol ()
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
recursiveDeclDeps CodeLookup Symbol IO ()
cl Decl Symbol ()
d
        Maybe (Decl Symbol ())
Nothing -> (Set Reference, Set Reference)
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a. a -> StateT (Set LabeledDependency) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Reference, Set Reference)
forall a. Monoid a => a
mempty
    deps :: Set LabeledDependency
deps = Term Symbol -> Set LabeledDependency
forall v vt at ap a.
(Ord v, Ord vt) =>
Term2 vt at ap v a -> Set LabeledDependency
Tm.labeledDependencies Term Symbol
tm

recursiveRefDeps ::
  CodeLookup Symbol IO () ->
  Reference ->
  StateT (Set RF.LabeledDependency) IO (Set Reference, Set Reference)
recursiveRefDeps :: CodeLookup Symbol IO ()
-> Reference
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
recursiveRefDeps CodeLookup Symbol IO ()
cl (RF.DerivedId Id
i) =
  IO (Maybe (Term Symbol))
-> StateT (Set LabeledDependency) IO (Maybe (Term Symbol))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Set LabeledDependency) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CodeLookup Symbol IO () -> Id -> IO (Maybe (Term Symbol))
forall v (m :: * -> *) a.
CodeLookup v m a -> Id -> m (Maybe (Term v a))
getTerm CodeLookup Symbol IO ()
cl Id
i) StateT (Set LabeledDependency) IO (Maybe (Term Symbol))
-> (Maybe (Term Symbol)
    -> StateT
         (Set LabeledDependency) IO (Set Reference, Set Reference))
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a b.
StateT (Set LabeledDependency) IO a
-> (a -> StateT (Set LabeledDependency) IO b)
-> StateT (Set LabeledDependency) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Term Symbol
tm -> CodeLookup Symbol IO ()
-> Term Symbol
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
recursiveTermDeps CodeLookup Symbol IO ()
cl Term Symbol
tm
    Maybe (Term Symbol)
Nothing -> (Set Reference, Set Reference)
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a. a -> StateT (Set LabeledDependency) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Reference, Set Reference)
forall a. Monoid a => a
mempty
recursiveRefDeps CodeLookup Symbol IO ()
_ Reference
_ = (Set Reference, Set Reference)
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
forall a. a -> StateT (Set LabeledDependency) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Reference, Set Reference)
forall a. Monoid a => a
mempty

recursiveIRefDeps ::
  Map.Map Reference (SuperGroup Reference Symbol) ->
  Set Reference ->
  [Reference] ->
  Set Reference
recursiveIRefDeps :: Map Reference (SuperGroup Reference Symbol)
-> Set Reference -> [Reference] -> Set Reference
recursiveIRefDeps Map Reference (SuperGroup Reference Symbol)
cl Set Reference
seen0 [Reference]
rfs = Set Reference
srfs Set Reference -> Set Reference -> Set Reference
forall a. Semigroup a => a -> a -> a
<> (Reference -> Set Reference) -> [Reference] -> Set Reference
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Reference -> Set Reference
f [Reference]
rfs
  where
    seen :: Set Reference
seen = Set Reference
seen0 Set Reference -> Set Reference -> Set Reference
forall a. Semigroup a => a -> a -> a
<> Set Reference
srfs
    srfs :: Set Reference
srfs = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
Set.fromList [Reference]
rfs
    f :: Reference -> Set Reference
f = (SuperGroup Reference Symbol -> Set Reference)
-> Maybe (SuperGroup Reference Symbol) -> Set Reference
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map Reference (SuperGroup Reference Symbol)
-> Set Reference -> SuperGroup Reference Symbol -> Set Reference
recursiveGroupDeps Map Reference (SuperGroup Reference Symbol)
cl Set Reference
seen) (Maybe (SuperGroup Reference Symbol) -> Set Reference)
-> (Reference -> Maybe (SuperGroup Reference Symbol))
-> Reference
-> Set Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference
 -> Map Reference (SuperGroup Reference Symbol)
 -> Maybe (SuperGroup Reference Symbol))
-> Map Reference (SuperGroup Reference Symbol)
-> Reference
-> Maybe (SuperGroup Reference Symbol)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference
-> Map Reference (SuperGroup Reference Symbol)
-> Maybe (SuperGroup Reference Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Reference (SuperGroup Reference Symbol)
cl

recursiveGroupDeps ::
  Map.Map Reference (SuperGroup Reference Symbol) ->
  Set Reference ->
  SuperGroup Reference Symbol ->
  Set Reference
recursiveGroupDeps :: Map Reference (SuperGroup Reference Symbol)
-> Set Reference -> SuperGroup Reference Symbol -> Set Reference
recursiveGroupDeps Map Reference (SuperGroup Reference Symbol)
cl Set Reference
seen0 SuperGroup Reference Symbol
grp = Set Reference
deps Set Reference -> Set Reference -> Set Reference
forall a. Semigroup a => a -> a -> a
<> Map Reference (SuperGroup Reference Symbol)
-> Set Reference -> [Reference] -> Set Reference
recursiveIRefDeps Map Reference (SuperGroup Reference Symbol)
cl Set Reference
seen [Reference]
depl
  where
    depl :: [Reference]
depl = (Reference -> Bool) -> [Reference] -> [Reference]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Reference -> Set Reference -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Reference
seen0) ([Reference] -> [Reference]) -> [Reference] -> [Reference]
forall a b. (a -> b) -> a -> b
$ SuperGroup Reference Symbol -> [Reference]
forall ref v. (Ord ref, Var v) => SuperGroup ref v -> [ref]
groupTermLinks SuperGroup Reference Symbol
grp
    deps :: Set Reference
deps = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
Set.fromList [Reference]
depl
    seen :: Set Reference
seen = Set Reference
seen0 Set Reference -> Set Reference -> Set Reference
forall a. Semigroup a => a -> a -> a
<> Set Reference
deps

recursiveIntermedDeps ::
  Map.Map Reference (SuperGroup Reference Symbol) ->
  [Reference] ->
  [(Reference, SuperGroup Reference Symbol)]
recursiveIntermedDeps :: Map Reference (SuperGroup Reference Symbol)
-> [Reference] -> [(Reference, SuperGroup Reference Symbol)]
recursiveIntermedDeps Map Reference (SuperGroup Reference Symbol)
cl [Reference]
rfs = (Reference -> Maybe (Reference, SuperGroup Reference Symbol))
-> [Reference] -> [(Reference, SuperGroup Reference Symbol)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Reference -> Maybe (Reference, SuperGroup Reference Symbol)
f ([Reference] -> [(Reference, SuperGroup Reference Symbol)])
-> [Reference] -> [(Reference, SuperGroup Reference Symbol)]
forall a b. (a -> b) -> a -> b
$ Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList Set Reference
ds
  where
    ds :: Set Reference
ds = Map Reference (SuperGroup Reference Symbol)
-> Set Reference -> [Reference] -> Set Reference
recursiveIRefDeps Map Reference (SuperGroup Reference Symbol)
cl Set Reference
forall a. Monoid a => a
mempty [Reference]
rfs
    f :: Reference -> Maybe (Reference, SuperGroup Reference Symbol)
f Reference
rf = (SuperGroup Reference Symbol
 -> (Reference, SuperGroup Reference Symbol))
-> Maybe (SuperGroup Reference Symbol)
-> Maybe (Reference, SuperGroup Reference Symbol)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Reference
rf,) (Reference
-> Map Reference (SuperGroup Reference Symbol)
-> Maybe (SuperGroup Reference Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
rf Map Reference (SuperGroup Reference Symbol)
cl)

collectDeps ::
  CodeLookup Symbol IO () ->
  Term Symbol ->
  IO ([(Reference, Either [Int] [Int])], [Reference])
collectDeps :: CodeLookup Symbol IO ()
-> Term Symbol
-> IO ([(Reference, Either [Int] [Int])], [Reference])
collectDeps CodeLookup Symbol IO ()
cl Term Symbol
tm = do
  (Set Reference
tys, Set Reference
tms) <- StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
-> Set LabeledDependency -> IO (Set Reference, Set Reference)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (CodeLookup Symbol IO ()
-> Term Symbol
-> StateT (Set LabeledDependency) IO (Set Reference, Set Reference)
recursiveTermDeps CodeLookup Symbol IO ()
cl Term Symbol
tm) Set LabeledDependency
forall a. Monoid a => a
mempty
  (,Set Reference -> [Reference]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Reference
tms) ([(Reference, Either [Int] [Int])]
 -> ([(Reference, Either [Int] [Int])], [Reference]))
-> IO [(Reference, Either [Int] [Int])]
-> IO ([(Reference, Either [Int] [Int])], [Reference])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Reference -> IO (Reference, Either [Int] [Int]))
-> [Reference] -> IO [(Reference, Either [Int] [Int])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Reference -> IO (Reference, Either [Int] [Int])
getDecl (Set Reference -> [Reference]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Reference
tys))
  where
    getDecl :: Reference -> IO (Reference, Either [Int] [Int])
getDecl ty :: Reference
ty@(RF.DerivedId Id
i) =
      (Reference
ty,) (Either [Int] [Int] -> (Reference, Either [Int] [Int]))
-> (Maybe (Decl Symbol ()) -> Either [Int] [Int])
-> Maybe (Decl Symbol ())
-> (Reference, Either [Int] [Int])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either [Int] [Int]
-> (Decl Symbol () -> Either [Int] [Int])
-> Maybe (Decl Symbol ())
-> Either [Int] [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Int] -> Either [Int] [Int]
forall a b. b -> Either a b
Right []) Decl Symbol () -> Either [Int] [Int]
forall v a. Var v => Decl v a -> Either [Int] [Int]
declFields
        (Maybe (Decl Symbol ()) -> (Reference, Either [Int] [Int]))
-> IO (Maybe (Decl Symbol ()))
-> IO (Reference, Either [Int] [Int])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeLookup Symbol IO () -> Id -> IO (Maybe (Decl Symbol ()))
forall v (m :: * -> *) a.
CodeLookup v m a -> Id -> m (Maybe (Decl v a))
getTypeDeclaration CodeLookup Symbol IO ()
cl Id
i
    getDecl Reference
r = (Reference, Either [Int] [Int])
-> IO (Reference, Either [Int] [Int])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference
r, [Int] -> Either [Int] [Int]
forall a b. b -> Either a b
Right [])

collectRefDeps ::
  CodeLookup Symbol IO () ->
  Reference ->
  IO ([(Reference, Either [Int] [Int])], [Reference])
collectRefDeps :: CodeLookup Symbol IO ()
-> Reference -> IO ([(Reference, Either [Int] [Int])], [Reference])
collectRefDeps CodeLookup Symbol IO ()
cl Reference
r = do
  Term Symbol
tm <- CodeLookup Symbol IO () -> Reference -> IO (Term Symbol)
resolveTermRef CodeLookup Symbol IO ()
cl Reference
r
  ([(Reference, Either [Int] [Int])]
tyrs, [Reference]
tmrs) <- CodeLookup Symbol IO ()
-> Term Symbol
-> IO ([(Reference, Either [Int] [Int])], [Reference])
collectDeps CodeLookup Symbol IO ()
cl Term Symbol
tm
  ([(Reference, Either [Int] [Int])], [Reference])
-> IO ([(Reference, Either [Int] [Int])], [Reference])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Reference, Either [Int] [Int])]
tyrs, Reference
r Reference -> [Reference] -> [Reference]
forall a. a -> [a] -> [a]
: [Reference]
tmrs)

backrefAdd ::
  Map.Map Reference (Map.Map Word64 (Term Symbol)) ->
  EvalCtx ->
  EvalCtx
backrefAdd :: Map Reference (Map Word64 (Term Symbol)) -> EvalCtx -> EvalCtx
backrefAdd Map Reference (Map Word64 (Term Symbol))
m ctx :: EvalCtx
ctx@ECtx {Map Reference (Map Word64 (Term Symbol))
$sel:decompTm:ECtx :: EvalCtx -> Map Reference (Map Word64 (Term Symbol))
decompTm :: Map Reference (Map Word64 (Term Symbol))
decompTm} =
  EvalCtx
ctx {decompTm = m <> decompTm}

remapAdd :: (Ord from, Ord to) => Map.Map from to -> Remapping from to -> Remapping from to
remapAdd :: forall from to.
(Ord from, Ord to) =>
Map from to -> Remapping from to -> Remapping from to
remapAdd Map from to
m Remap {Map from to
$sel:remap:Remap :: forall from to. Remapping from to -> Map from to
remap :: Map from to
remap, Map to from
$sel:backmap:Remap :: forall from to. Remapping from to -> Map to from
backmap :: Map to from
backmap} =
  Remap {$sel:remap:Remap :: Map from to
remap = Map from to
m Map from to -> Map from to -> Map from to
forall a. Semigroup a => a -> a -> a
<> Map from to
remap, $sel:backmap:Remap :: Map to from
backmap = Map to from
tm Map to from -> Map to from -> Map to from
forall a. Semigroup a => a -> a -> a
<> Map to from
backmap}
  where
    tm :: Map to from
tm = [(to, from)] -> Map to from
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(to, from)] -> Map to from)
-> ([(from, to)] -> [(to, from)]) -> [(from, to)] -> Map to from
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((from, to) -> (to, from)) -> [(from, to)] -> [(to, from)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(from
x, to
y) -> (to
y, from
x)) ([(from, to)] -> Map to from) -> [(from, to)] -> Map to from
forall a b. (a -> b) -> a -> b
$ Map from to -> [(from, to)]
forall k a. Map k a -> [(k, a)]
Map.toList Map from to
m

floatRemapAdd :: Map.Map Reference Reference -> EvalCtx -> EvalCtx
floatRemapAdd :: Map Reference Reference -> EvalCtx -> EvalCtx
floatRemapAdd Map Reference Reference
m ctx :: EvalCtx
ctx@ECtx {Remapping Reference Reference
$sel:floatRemap:ECtx :: EvalCtx -> Remapping Reference Reference
floatRemap :: Remapping Reference Reference
floatRemap} =
  EvalCtx
ctx {floatRemap = remapAdd m floatRemap}

floatNamesAdd ::
  Map.Map Reference (FloatName Symbol) -> EvalCtx -> EvalCtx
floatNamesAdd :: Map Reference (FloatName Symbol) -> EvalCtx -> EvalCtx
floatNamesAdd Map Reference (FloatName Symbol)
m ctx :: EvalCtx
ctx@ECtx {Map Reference (FloatName Symbol)
$sel:floatNames:ECtx :: EvalCtx -> Map Reference (FloatName Symbol)
floatNames :: Map Reference (FloatName Symbol)
floatNames} =
  EvalCtx
ctx {floatNames = Map.union m floatNames}

intermedRemapAdd :: Map.Map Reference Reference -> EvalCtx -> EvalCtx
intermedRemapAdd :: Map Reference Reference -> EvalCtx -> EvalCtx
intermedRemapAdd Map Reference Reference
m ctx :: EvalCtx
ctx@ECtx {Remapping Reference Reference
$sel:intermedRemap:ECtx :: EvalCtx -> Remapping Reference Reference
intermedRemap :: Remapping Reference Reference
intermedRemap} =
  EvalCtx
ctx {intermedRemap = remapAdd m intermedRemap}

baseToIntermed :: EvalCtx -> CodebaseReference -> Maybe IntermediateReference
baseToIntermed :: EvalCtx -> Reference -> Maybe Reference
baseToIntermed EvalCtx
ctx Reference
r = do
  Reference
r <- Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Map Reference Reference -> Maybe Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Maybe Reference)
-> Remapping Reference Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx
  Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Map Reference Reference -> Maybe Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Maybe Reference)
-> Remapping Reference Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx

-- Runs references through the forward maps to get intermediate
-- references. Works on both base and floated references.
toIntermed :: EvalCtx -> Reference -> IntermediateReference
toIntermed :: EvalCtx -> Reference -> Reference
toIntermed EvalCtx
ctx Reference
r
  | Reference
r <- Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Reference
r Reference
r (Map Reference Reference -> Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Reference)
-> Remapping Reference Reference -> Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx,
    Just Reference
r <- Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Map Reference Reference -> Maybe Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Maybe Reference)
-> Remapping Reference Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx =
      Reference
r
toIntermed EvalCtx
_ Reference
r = Reference
r

floatToIntermed :: EvalCtx -> FloatedReference -> Maybe IntermediateReference
floatToIntermed :: EvalCtx -> Reference -> Maybe Reference
floatToIntermed EvalCtx
ctx Reference
r =
  Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Map Reference Reference -> Maybe Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Maybe Reference)
-> Remapping Reference Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx

intermedToBase :: EvalCtx -> IntermediateReference -> Maybe CodebaseReference
intermedToBase :: EvalCtx -> Reference -> Maybe Reference
intermedToBase EvalCtx
ctx Reference
r = do
  Reference
r <- Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Map Reference Reference -> Maybe Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap (Remapping Reference Reference -> Maybe Reference)
-> Remapping Reference Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx
  Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Map Reference Reference -> Maybe Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap (Remapping Reference Reference -> Maybe Reference)
-> Remapping Reference Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx

-- Runs references through the backmaps with defaults at all steps.
backmapRef :: EvalCtx -> Reference -> CodebaseReference
backmapRef :: EvalCtx -> Reference -> Reference
backmapRef EvalCtx
ctx Reference
r0 = Reference
r2
  where
    r1 :: Reference
r1 = Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Reference
r0 Reference
r0 (Map Reference Reference -> Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap (Remapping Reference Reference -> Reference)
-> Remapping Reference Reference -> Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx
    r2 :: Reference
r2 = Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Reference
r1 Reference
r1 (Map Reference Reference -> Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap (Remapping Reference Reference -> Reference)
-> Remapping Reference Reference -> Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx

-- Runs references through the backmaps with defaults at all steps.
maybeBackmapRef :: EvalCtx -> Reference -> Maybe CodebaseReference
maybeBackmapRef :: EvalCtx -> Reference -> Maybe Reference
maybeBackmapRef EvalCtx
ctx Reference
r0 = do
  Reference
r1 <- Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r0 (Map Reference Reference -> Maybe Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap (Remapping Reference Reference -> Maybe Reference)
-> Remapping Reference Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx
  Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r1 (Map Reference Reference -> Maybe Reference)
-> (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap (Remapping Reference Reference -> Maybe Reference)
-> Remapping Reference Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx

performRehash ::
  Map.Map Reference (SuperGroup Reference Symbol) ->
  EvalCtx ->
  (EvalCtx, Map Reference Reference, [(Reference, SuperGroup Reference Symbol)])
performRehash :: Map Reference (SuperGroup Reference Symbol)
-> EvalCtx
-> (EvalCtx, Map Reference Reference,
    [(Reference, SuperGroup Reference Symbol)])
performRehash Map Reference (SuperGroup Reference Symbol)
rgrp0 EvalCtx
ctx =
  (Map Reference Reference -> EvalCtx -> EvalCtx
intermedRemapAdd Map Reference Reference
rrefs EvalCtx
ctx, Map Reference Reference
rrefs, Map Reference (SuperGroup Reference Symbol)
-> [(Reference, SuperGroup Reference Symbol)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Reference (SuperGroup Reference Symbol)
rrgrp)
  where
    frs :: Map Reference Reference
frs = Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx
    irs :: Map Reference Reference
irs = Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx
    f :: Bool -> Reference -> Reference
f Bool
b Reference
r
      | Bool -> Bool
not Bool
b,
        Reference
r Reference -> Map Reference (SuperGroup Reference Symbol) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Reference (SuperGroup Reference Symbol)
rgrp0,
        Reference
r <- Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Reference
r Reference
r Map Reference Reference
frs,
        Just Reference
r <- Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r Map Reference Reference
irs =
          Reference
r
      | Bool
otherwise = Reference
r

    (Map Reference Reference
rrefs, Map Reference (SuperGroup Reference Symbol)
rrgrp) =
      case Map Reference (SuperGroup Reference Symbol)
-> Either
     (Text, [Referent])
     (Map Reference Reference,
      Map Reference (SuperGroup Reference Symbol))
rehashGroups (Map Reference (SuperGroup Reference Symbol)
 -> Either
      (Text, [Referent])
      (Map Reference Reference,
       Map Reference (SuperGroup Reference Symbol)))
-> Map Reference (SuperGroup Reference Symbol)
-> Either
     (Text, [Referent])
     (Map Reference Reference,
      Map Reference (SuperGroup Reference Symbol))
forall a b. (a -> b) -> a -> b
$ (SuperGroup Reference Symbol -> SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall a b. (a -> b) -> Map Reference a -> Map Reference b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Bool -> Reference -> Reference)
-> SuperGroup Reference Symbol -> SuperGroup Reference Symbol
forall v ref0 ref1.
Var v =>
(Bool -> ref0 -> ref1) -> SuperGroup ref0 v -> SuperGroup ref1 v
overGroupLinks Bool -> Reference -> Reference
f) Map Reference (SuperGroup Reference Symbol)
rgrp0 of
        Left (Text
msg, [Referent]
refs) -> [Char]
-> (Map Reference Reference,
    Map Reference (SuperGroup Reference Symbol))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> (Map Reference Reference,
     Map Reference (SuperGroup Reference Symbol)))
-> [Char]
-> (Map Reference Reference,
    Map Reference (SuperGroup Reference Symbol))
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Referent] -> [Char]
forall a. Show a => a -> [Char]
show [Referent]
refs
        Right (Map Reference Reference,
 Map Reference (SuperGroup Reference Symbol))
p -> (Map Reference Reference,
 Map Reference (SuperGroup Reference Symbol))
p

loadCode ::
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  EvalCtx ->
  [Reference] ->
  IO (EvalCtx, [(Reference, SuperGroup Reference Symbol)])
loadCode :: CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Reference Symbol)])
loadCode CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [Reference]
tmrs = do
  Map Reference (SuperGroup Reference Symbol)
igs <- TVar (Map Reference (SuperGroup Reference Symbol))
-> IO (Map Reference (SuperGroup Reference Symbol))
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (Map Reference (SuperGroup Reference Symbol))
forall prof.
CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
intermed (CCache () -> TVar (Map Reference (SuperGroup Reference Symbol)))
-> CCache () -> TVar (Map Reference (SuperGroup Reference Symbol))
forall a b. (a -> b) -> a -> b
$ EvalCtx -> CCache ()
ccache EvalCtx
ctx)
  Reference -> Bool
q <-
    CCache () -> IO (Map Reference Word64)
forall prof. CCache prof -> IO (Map Reference Word64)
refNumsTm (EvalCtx -> CCache ()
ccache EvalCtx
ctx) IO (Map Reference Word64)
-> (Map Reference Word64 -> Reference -> Bool)
-> IO (Reference -> Bool)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map Reference Word64
m Reference
r -> case Reference
r of
      RF.DerivedId {}
        | Just Reference
r <- EvalCtx -> Reference -> Maybe Reference
baseToIntermed EvalCtx
ctx Reference
r -> Reference
r Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Reference Word64
m
        | Just Reference
r <- EvalCtx -> Reference -> Maybe Reference
floatToIntermed EvalCtx
ctx Reference
r -> Reference
r Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Reference Word64
m
        | Bool
otherwise -> Bool
True
      Reference
_ -> Bool
False
  let ([Reference]
new, [Reference]
old) = (Reference -> Bool) -> [Reference] -> ([Reference], [Reference])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition Reference -> Bool
q [Reference]
tmrs
      odeps :: [(Reference, SuperGroup Reference Symbol)]
odeps = Map Reference (SuperGroup Reference Symbol)
-> [Reference] -> [(Reference, SuperGroup Reference Symbol)]
recursiveIntermedDeps Map Reference (SuperGroup Reference Symbol)
igs ([Reference] -> [(Reference, SuperGroup Reference Symbol)])
-> [Reference] -> [(Reference, SuperGroup Reference Symbol)]
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Reference -> Reference
toIntermed EvalCtx
ctx (Reference -> Reference) -> [Reference] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Reference]
old
  [(Id, Term Symbol)]
itms <-
    (Reference -> IO (Id, Term Symbol))
-> [Reference] -> IO [(Id, Term Symbol)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\Reference
r -> (Reference -> Id
RF.unsafeId Reference
r,) (Term Symbol -> (Id, Term Symbol))
-> IO (Term Symbol) -> IO (Id, Term Symbol)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeLookup Symbol IO () -> Reference -> IO (Term Symbol)
resolveTermRef CodeLookup Symbol IO ()
cl Reference
r) [Reference]
new
  let im :: Map Id (Symbol, Term Symbol)
im = Map Id (Term Symbol) -> Map Id (Symbol, Term Symbol)
forall v a. Var v => Map Id (Term v a) -> Map Id (v, Term v a)
Tm.unhashComponent ([(Id, Term Symbol)] -> Map Id (Term Symbol)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Id, Term Symbol)]
itms)
      (Map Symbol Reference
subvs, Map Reference (FloatName Symbol)
fnames, Map Reference (SuperGroup Reference Symbol)
rgrp0, Map Reference (Map Word64 (Term Symbol))
rbkr) = HasCallStack =>
PrettyPrintEnv
-> EvalCtx
-> Map Id (Symbol, Term Symbol)
-> (Map Symbol Reference, Map Reference (FloatName Symbol),
    Map Reference (SuperGroup Reference Symbol),
    Map Reference (Map Word64 (Term Symbol)))
PrettyPrintEnv
-> EvalCtx
-> Map Id (Symbol, Term Symbol)
-> (Map Symbol Reference, Map Reference (FloatName Symbol),
    Map Reference (SuperGroup Reference Symbol),
    Map Reference (Map Word64 (Term Symbol)))
intermediateTerms PrettyPrintEnv
ppe EvalCtx
ctx Map Id (Symbol, Term Symbol)
im
      lubvs :: Symbol -> Reference
lubvs Symbol
r = case Symbol -> Map Symbol Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
r Map Symbol Reference
subvs of
        Just Reference
r -> Reference
r
        Maybe Reference
Nothing -> [Char] -> Reference
forall a. HasCallStack => [Char] -> a
error [Char]
"loadCode: variable missing for float refs"
      vm :: Map Reference Reference
vm = (Id -> Reference) -> Map Id Reference -> Map Reference Reference
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Id -> Reference
forall h t. Id' h -> Reference' t h
RF.DerivedId (Map Id Reference -> Map Reference Reference)
-> (Map Id (Symbol, Term Symbol) -> Map Id Reference)
-> Map Id (Symbol, Term Symbol)
-> Map Reference Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Symbol, Term Symbol) -> Reference)
-> Map Id (Symbol, Term Symbol) -> Map Id Reference
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Symbol -> Reference
lubvs (Symbol -> Reference)
-> ((Symbol, Term Symbol) -> Symbol)
-> (Symbol, Term Symbol)
-> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol, Term Symbol) -> Symbol
forall a b. (a, b) -> a
fst) (Map Id (Symbol, Term Symbol) -> Map Reference Reference)
-> Map Id (Symbol, Term Symbol) -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ Map Id (Symbol, Term Symbol)
im
      int :: Bool -> Reference -> Reference
int Bool
b Reference
r = if Bool
b then Reference
r else EvalCtx -> Reference -> Reference
toIntermed EvalCtx
ctx Reference
r
      (EvalCtx
ctx', Map Reference Reference
_, [(Reference, SuperGroup Reference Symbol)]
rgrp) =
        Map Reference (SuperGroup Reference Symbol)
-> EvalCtx
-> (EvalCtx, Map Reference Reference,
    [(Reference, SuperGroup Reference Symbol)])
performRehash
          ((SuperGroup Reference Symbol -> SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall a b. (a -> b) -> Map Reference a -> Map Reference b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Bool -> Reference -> Reference)
-> SuperGroup Reference Symbol -> SuperGroup Reference Symbol
forall v ref0 ref1.
Var v =>
(Bool -> ref0 -> ref1) -> SuperGroup ref0 v -> SuperGroup ref1 v
overGroupLinks Bool -> Reference -> Reference
int) Map Reference (SuperGroup Reference Symbol)
rgrp0)
          (Map Reference (FloatName Symbol) -> EvalCtx -> EvalCtx
floatNamesAdd Map Reference (FloatName Symbol)
fnames (EvalCtx -> EvalCtx) -> EvalCtx -> EvalCtx
forall a b. (a -> b) -> a -> b
$ Map Reference Reference -> EvalCtx -> EvalCtx
floatRemapAdd Map Reference Reference
vm EvalCtx
ctx)
  (EvalCtx, [(Reference, SuperGroup Reference Symbol)])
-> IO (EvalCtx, [(Reference, SuperGroup Reference Symbol)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Map Reference (Map Word64 (Term Symbol)) -> EvalCtx -> EvalCtx
backrefAdd Map Reference (Map Word64 (Term Symbol))
rbkr EvalCtx
ctx', [(Reference, SuperGroup Reference Symbol)]
rgrp [(Reference, SuperGroup Reference Symbol)]
-> [(Reference, SuperGroup Reference Symbol)]
-> [(Reference, SuperGroup Reference Symbol)]
forall a. [a] -> [a] -> [a]
++ [(Reference, SuperGroup Reference Symbol)]
odeps)

loadDeps ::
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  EvalCtx ->
  [(Reference, Either [Int] [Int])] ->
  [Reference] ->
  IO (EvalCtx, [(Reference, Code Reference)])
loadDeps :: CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, Code Reference)])
loadDeps CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [(Reference, Either [Int] [Int])]
tyrs [Reference]
tmrs = do
  let cc :: CCache ()
cc = EvalCtx -> CCache ()
ccache EvalCtx
ctx
  Map Reference (Set Reference)
sand <- TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (Map Reference (Set Reference))
forall prof. CCache prof -> TVar (Map Reference (Set Reference))
sandbox CCache ()
cc)
  (Reference, Either [Int] [Int]) -> Bool
p <-
    CCache () -> IO (Map Reference Word64)
forall prof. CCache prof -> IO (Map Reference Word64)
refNumsTy CCache ()
cc IO (Map Reference Word64)
-> (Map Reference Word64
    -> (Reference, Either [Int] [Int]) -> Bool)
-> IO ((Reference, Either [Int] [Int]) -> Bool)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map Reference Word64
m (Reference
r, Either [Int] [Int]
_) -> case Reference
r of
      RF.DerivedId {} ->
        Reference
r Reference -> DataSpec -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` EvalCtx -> DataSpec
dspec EvalCtx
ctx
          Bool -> Bool -> Bool
|| Reference
r Reference -> Map Reference Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Reference Word64
m
      Reference
_ -> Bool
False
  EvalCtx
ctx <- (EvalCtx -> (Reference, Either [Int] [Int]) -> IO EvalCtx)
-> EvalCtx -> [(Reference, Either [Int] [Int])] -> IO EvalCtx
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Reference -> Either [Int] [Int] -> IO EvalCtx)
-> (Reference, Either [Int] [Int]) -> IO EvalCtx
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Reference -> Either [Int] [Int] -> IO EvalCtx)
 -> (Reference, Either [Int] [Int]) -> IO EvalCtx)
-> (EvalCtx -> Reference -> Either [Int] [Int] -> IO EvalCtx)
-> EvalCtx
-> (Reference, Either [Int] [Int])
-> IO EvalCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalCtx -> Reference -> Either [Int] [Int] -> IO EvalCtx
allocType) EvalCtx
ctx ([(Reference, Either [Int] [Int])] -> IO EvalCtx)
-> [(Reference, Either [Int] [Int])] -> IO EvalCtx
forall a b. (a -> b) -> a -> b
$ ((Reference, Either [Int] [Int]) -> Bool)
-> [(Reference, Either [Int] [Int])]
-> [(Reference, Either [Int] [Int])]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Reference, Either [Int] [Int]) -> Bool
p [(Reference, Either [Int] [Int])]
tyrs
  let tyAdd :: Set Reference
tyAdd = [Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
Set.fromList ([Reference] -> Set Reference) -> [Reference] -> Set Reference
forall a b. (a -> b) -> a -> b
$ (Reference, Either [Int] [Int]) -> Reference
forall a b. (a, b) -> a
fst ((Reference, Either [Int] [Int]) -> Reference)
-> [(Reference, Either [Int] [Int])] -> [Reference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, Either [Int] [Int])]
tyrs
  (EvalCtx
ctx', [(Reference, SuperGroup Reference Symbol)]
rgrp) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Reference Symbol)])
loadCode CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [Reference]
tmrs
  [(Reference, Code Reference)]
crgrp <- ((Reference, SuperGroup Reference Symbol)
 -> IO (Reference, Code Reference))
-> [(Reference, SuperGroup Reference Symbol)]
-> IO [(Reference, Code Reference)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (CodeLookup Symbol IO ()
-> EvalCtx
-> (Reference, SuperGroup Reference Symbol)
-> IO (Reference, Code Reference)
checkCacheability CodeLookup Symbol IO ()
cl EvalCtx
ctx') [(Reference, SuperGroup Reference Symbol)]
rgrp
  (EvalCtx
ctx', [(Reference, Code Reference)]
crgrp) (EvalCtx, [(Reference, Code Reference)])
-> IO () -> IO (EvalCtx, [(Reference, Code Reference)])
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Set Reference
-> [(Reference, Code Reference)]
-> [(Reference, Set Reference)]
-> CCache ()
-> IO ()
forall p.
RuntimeProfiler p =>
Set Reference
-> [(Reference, Code Reference)]
-> [(Reference, Set Reference)]
-> CCache p
-> IO ()
cacheAdd0 Set Reference
tyAdd [(Reference, Code Reference)]
crgrp (Map Reference (Set Reference)
-> [(Reference, SuperGroup Reference Symbol)]
-> [(Reference, Set Reference)]
expandSandbox Map Reference (Set Reference)
sand [(Reference, SuperGroup Reference Symbol)]
rgrp) CCache ()
cc

checkCacheability ::
  CodeLookup Symbol IO () ->
  EvalCtx ->
  (IntermediateReference, SuperGroup Reference Symbol) ->
  IO (IntermediateReference, Code Reference)
checkCacheability :: CodeLookup Symbol IO ()
-> EvalCtx
-> (Reference, SuperGroup Reference Symbol)
-> IO (Reference, Code Reference)
checkCacheability CodeLookup Symbol IO ()
cl EvalCtx
ctx (Reference
r, SuperGroup Reference Symbol
sg) =
  Maybe Reference -> IO (Maybe (Type Symbol))
getTermType Maybe Reference
mayCodebaseRef IO (Maybe (Type Symbol))
-> (Maybe (Type Symbol) -> IO (Reference, Code Reference))
-> IO (Reference, Code Reference)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- A term's result is cacheable iff it has no arrows in its type,
    -- this is sufficient since top-level definitions can't have effects without a delay.
    Just Type Symbol
typ
      | Bool -> Bool
not (Algebra (Term' F Symbol ()) Bool -> Type Symbol -> Bool
forall a. Algebra (Term' F Symbol ()) a -> Type Symbol -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
Rec.cata Algebra (Term' F Symbol ()) Bool
forall v a. TypeF v a Bool -> Bool
hasArrows Type Symbol
typ) ->
          (Reference, Code Reference) -> IO (Reference, Code Reference)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference
r, SuperGroup Reference Symbol -> Cacheability -> Code Reference
forall ref. SuperGroup ref Symbol -> Cacheability -> Code ref
CodeRep SuperGroup Reference Symbol
sg Cacheability
Cacheable)
    Maybe (Type Symbol)
_ -> (Reference, Code Reference) -> IO (Reference, Code Reference)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference
r, SuperGroup Reference Symbol -> Cacheability -> Code Reference
forall ref. SuperGroup ref Symbol -> Cacheability -> Code ref
CodeRep SuperGroup Reference Symbol
sg Cacheability
Uncacheable)
  where
    mayCodebaseRef :: Maybe CodebaseReference
    mayCodebaseRef :: Maybe Reference
mayCodebaseRef = EvalCtx -> Reference -> Maybe Reference
maybeBackmapRef EvalCtx
ctx Reference
r
    getTermType :: Maybe CodebaseReference -> IO (Maybe (Type Symbol))
    getTermType :: Maybe Reference -> IO (Maybe (Type Symbol))
getTermType = \case
      Just (RF.DerivedId Id
i) ->
        CodeLookup Symbol IO () -> Id -> IO (Maybe (Type Symbol))
forall v (m :: * -> *) a.
CodeLookup v m a -> Id -> m (Maybe (Type v a))
getTypeOfTerm CodeLookup Symbol IO ()
cl Id
i IO (Maybe (Type Symbol))
-> (Maybe (Type Symbol) -> IO (Maybe (Type Symbol)))
-> IO (Maybe (Type Symbol))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Type Symbol
t -> Maybe (Type Symbol) -> IO (Maybe (Type Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Type Symbol) -> IO (Maybe (Type Symbol)))
-> Maybe (Type Symbol) -> IO (Maybe (Type Symbol))
forall a b. (a -> b) -> a -> b
$ Type Symbol -> Maybe (Type Symbol)
forall a. a -> Maybe a
Just Type Symbol
t
          Maybe (Type Symbol)
Nothing -> Maybe (Type Symbol) -> IO (Maybe (Type Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type Symbol)
forall a. Maybe a
Nothing
      Just (RF.Builtin {}) -> Maybe (Type Symbol) -> IO (Maybe (Type Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Type Symbol) -> IO (Maybe (Type Symbol)))
-> Maybe (Type Symbol) -> IO (Maybe (Type Symbol))
forall a b. (a -> b) -> a -> b
$ Maybe (Type Symbol)
forall a. Maybe a
Nothing
      Maybe Reference
Nothing -> Maybe (Type Symbol) -> IO (Maybe (Type Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type Symbol)
forall a. Maybe a
Nothing
    hasArrows :: Type.TypeF v a Bool -> Bool
    hasArrows :: forall v a. TypeF v a Bool -> Bool
hasArrows TypeF v a Bool
abt = case TypeF v a Bool -> ABT F v Bool
forall (f :: * -> *) v a x. Term' f v a x -> ABT f v x
ABT.out' TypeF v a Bool
abt of
      (ABT.Tm F Bool
f) -> case F Bool
f of
        Type.Arrow Bool
_ Bool
_ -> Bool
True
        F Bool
other -> F Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or F Bool
other
      ABT F v Bool
t -> ABT F v Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ABT F v Bool
t

decompileCtx ::
  EnumMap Word64 Reference -> EvalCtx -> Val -> DecompResult Symbol
decompileCtx :: EnumMap Word64 Reference -> EvalCtx -> Val -> DecompResult Symbol
decompileCtx EnumMap Word64 Reference
crs EvalCtx
ctx = (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Val
-> DecompResult Symbol
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
ib ((Word64 -> Word64 -> Maybe (Term Symbol))
 -> Val -> DecompResult Symbol)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Val
-> DecompResult Symbol
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 Reference
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm EnumMap Word64 Reference
crs Remapping Reference Reference
fr Remapping Reference Reference
ir Map Reference (Map Word64 (Term Symbol))
dt
  where
    ib :: Reference -> Maybe Reference
ib = EvalCtx -> Reference -> Maybe Reference
intermedToBase EvalCtx
ctx
    fr :: Remapping Reference Reference
fr = EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx
    ir :: Remapping Reference Reference
ir = EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx
    dt :: Map Reference (Map Word64 (Term Symbol))
dt = EvalCtx -> Map Reference (Map Word64 (Term Symbol))
decompTm EvalCtx
ctx

interpEvalDirect ::
  ActiveThreads ->
  IO () ->
  IORef EvalCtx ->
  Maybe ProfileComm ->
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  Term Symbol ->
  IO (Either Error (Response DecompError, Term Symbol))
interpEvalDirect :: ActiveThreads
-> IO ()
-> IORef EvalCtx
-> Maybe ProfileComm
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
interpEvalDirect ActiveThreads
activeThreads IO ()
cleanupThreads IORef EvalCtx
ctxVar Maybe ProfileComm
prof CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe Term Symbol
tm =
  IO (Either Error (Response DecompError, Term Symbol))
-> IO (Either Error (Response DecompError, Term Symbol))
forall a. IO (Either Error a) -> IO (Either Error a)
catchErrors (IO (Either Error (Response DecompError, Term Symbol))
 -> IO (Either Error (Response DecompError, Term Symbol)))
-> IO (Either Error (Response DecompError, Term Symbol))
-> IO (Either Error (Response DecompError, Term Symbol))
forall a b. (a -> b) -> a -> b
$ do
    EvalCtx
ctx <- IORef EvalCtx -> IO EvalCtx
forall a. IORef a -> IO a
readIORef IORef EvalCtx
ctxVar
    ([(Reference, Either [Int] [Int])]
tyrs, [Reference]
tmrs) <- CodeLookup Symbol IO ()
-> Term Symbol
-> IO ([(Reference, Either [Int] [Int])], [Reference])
collectDeps CodeLookup Symbol IO ()
cl Term Symbol
tm
    (EvalCtx
ctx, [(Reference, Code Reference)]
_) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, Code Reference)])
loadDeps CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [(Reference, Either [Int] [Int])]
tyrs [Reference]
tmrs
    (EvalCtx
ctx, [(Reference, Code Reference)]
_, Reference
init) <- HasCallStack =>
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, Code Reference)], Reference)
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, Code Reference)], Reference)
prepareEvaluation PrettyPrintEnv
ppe Term Symbol
tm EvalCtx
ctx
    Word64
initw <- CCache () -> Reference -> IO Word64
forall prof. CCache prof -> Reference -> IO Word64
refNumTm (EvalCtx -> CCache ()
ccache EvalCtx
ctx) Reference
init
    IORef EvalCtx -> EvalCtx -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef EvalCtx
ctxVar EvalCtx
ctx
    PrettyPrintEnv
-> EvalCtx
-> Maybe ProfileComm
-> ActiveThreads
-> Word64
-> IO (Either Error (Response DecompError, Term Symbol))
evalInContext PrettyPrintEnv
ppe EvalCtx
ctx Maybe ProfileComm
prof ActiveThreads
activeThreads Word64
initw
      IO (Either Error (Response DecompError, Term Symbol))
-> IO () -> IO (Either Error (Response DecompError, Term Symbol))
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.finally` IO ()
cleanupThreads

profileEval ::
  ActiveThreads ->
  IO () ->
  IORef EvalCtx ->
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  Maybe String ->
  Term Symbol ->
  IO (Either Error (Response DecompError, Term Symbol))
profileEval :: ActiveThreads
-> IO ()
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Maybe [Char]
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
profileEval ActiveThreads
actThr IO ()
cleanThr IORef EvalCtx
ctxVar CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe Maybe [Char]
mout Term Symbol
tm = do
  ProfileComm
prof <- IO ProfileComm
spawnProfiler
  Either Error (Response DecompError, Term Symbol)
result <-
    ActiveThreads
-> IO ()
-> IORef EvalCtx
-> Maybe ProfileComm
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
interpEvalDirect ActiveThreads
actThr IO ()
cleanThr IORef EvalCtx
ctxVar (ProfileComm -> Maybe ProfileComm
forall a. a -> Maybe a
Just ProfileComm
prof) CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe Term Symbol
tm
  case Either Error (Response DecompError, Term Symbol)
result of
    Left Error
err -> Either Error (Response DecompError, Term Symbol)
-> IO (Either Error (Response DecompError, Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error (Response DecompError, Term Symbol)
 -> IO (Either Error (Response DecompError, Term Symbol)))
-> Either Error (Response DecompError, Term Symbol)
-> IO (Either Error (Response DecompError, Term Symbol))
forall a b. (a -> b) -> a -> b
$ Error -> Either Error (Response DecompError, Term Symbol)
forall a b. a -> Either a b
Left Error
err
    Right (Response DecompError
errs, Term Symbol
tmr) -> case ProfileComm
prof of
      PC CombIx -> K -> IO ()
_ IO ()
finish IO (Profile Word64)
getProf -> do
        IO ()
finish
        EvalCtx
ectx <- IORef EvalCtx -> IO EvalCtx
forall a. IORef a -> IO a
readIORef IORef EvalCtx
ctxVar
        let fnames :: Map Reference (Pretty ColorText)
fnames = (FloatName Symbol -> Pretty ColorText)
-> Map Reference (FloatName Symbol)
-> Map Reference (Pretty ColorText)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (PrettyPrintEnv -> FloatName Symbol -> Pretty ColorText
forall v.
Var v =>
PrettyPrintEnv -> FloatName v -> Pretty ColorText
prettyFloatName PrettyPrintEnv
ppe) (EvalCtx -> Map Reference (FloatName Symbol)
floatNames EvalCtx
ectx)
        Profile Word64
pout <- EvalCtx -> Profile Word64 -> Profile Word64
forall {k}. EvalCtx -> Profile k -> Profile k
backReferenceProfile EvalCtx
ectx (Profile Word64 -> Profile Word64)
-> IO (Profile Word64) -> IO (Profile Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Profile Word64)
getProf
        case Maybe [Char]
mout of
          Just [Char]
loc
            | [Char] -> Bool
forall {a}. (Eq a, IsString a) => a -> Bool
ticky ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
takeExtension [Char]
loc -> do
                [Char] -> [Char] -> IO ()
writeFile [Char]
loc ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv
-> Map Reference (Pretty ColorText) -> Profile Word64 -> [Char]
forall k.
Ord k =>
PrettyPrintEnv
-> Map Reference (Pretty ColorText) -> Profile k -> [Char]
foldedProfile PrettyPrintEnv
ppe Map Reference (Pretty ColorText)
fnames Profile Word64
pout
                pure $ (Response DecompError, Term Symbol)
-> Either Error (Response DecompError, Term Symbol)
forall a b. b -> Either a b
Right (Response DecompError
errs, Term Symbol
tmr)
            | Bool
otherwise -> do
                [Char] -> [Char] -> IO ()
writeFile [Char]
loc ([Char] -> IO ())
-> (Pretty ColorText -> [Char]) -> Pretty ColorText -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Pretty ColorText -> [Char]
toPlain Width
0 (Pretty ColorText -> IO ()) -> Pretty ColorText -> IO ()
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv
-> Map Reference (Pretty ColorText)
-> Profile Word64
-> Pretty ColorText
forall k.
Ord k =>
PrettyPrintEnv
-> Map Reference (Pretty ColorText)
-> Profile k
-> Pretty ColorText
fullProfile PrettyPrintEnv
ppe Map Reference (Pretty ColorText)
fnames Profile Word64
pout
                pure $ (Response DecompError, Term Symbol)
-> Either Error (Response DecompError, Term Symbol)
forall a b. b -> Either a b
Right (Response DecompError
errs, Term Symbol
tmr)
          Maybe [Char]
Nothing ->
            Either Error (Response DecompError, Term Symbol)
-> IO (Either Error (Response DecompError, Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error (Response DecompError, Term Symbol)
 -> IO (Either Error (Response DecompError, Term Symbol)))
-> Either Error (Response DecompError, Term Symbol)
-> IO (Either Error (Response DecompError, Term Symbol))
forall a b. (a -> b) -> a -> b
$ (Response DecompError, Term Symbol)
-> Either Error (Response DecompError, Term Symbol)
forall a b. b -> Either a b
Right (Response DecompError
errs Response DecompError
-> Response DecompError -> Response DecompError
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Response DecompError
forall e. Pretty ColorText -> Response e
Profile (PrettyPrintEnv
-> Map Reference (Pretty ColorText)
-> Profile Word64
-> Pretty ColorText
forall k.
Ord k =>
PrettyPrintEnv
-> Map Reference (Pretty ColorText)
-> Profile k
-> Pretty ColorText
miniProfile PrettyPrintEnv
ppe Map Reference (Pretty ColorText)
fnames Profile Word64
pout), Term Symbol
tmr)
  where
    ticky :: a -> Bool
ticky a
".ticks" = Bool
True
    ticky a
".folded" = Bool
True
    ticky a
_ = Bool
False

    backReferenceProfile :: EvalCtx -> Profile k -> Profile k
backReferenceProfile (ECtx {DataSpec
Map Reference (Map Word64 (Term Symbol))
Map Reference (FloatName Symbol)
CCache ()
Remapping Reference Reference
$sel:dspec:ECtx :: EvalCtx -> DataSpec
$sel:floatRemap:ECtx :: EvalCtx -> Remapping Reference Reference
$sel:intermedRemap:ECtx :: EvalCtx -> Remapping Reference Reference
$sel:floatNames:ECtx :: EvalCtx -> Map Reference (FloatName Symbol)
$sel:decompTm:ECtx :: EvalCtx -> Map Reference (Map Word64 (Term Symbol))
$sel:ccache:ECtx :: EvalCtx -> CCache ()
dspec :: DataSpec
floatRemap :: Remapping Reference Reference
intermedRemap :: Remapping Reference Reference
floatNames :: Map Reference (FloatName Symbol)
decompTm :: Map Reference (Map Word64 (Term Symbol))
ccache :: CCache ()
..}) (Prof Int
tot ProfTrie k Int
tr Map k Reference
refs) =
      Int -> ProfTrie k Int -> Map k Reference -> Profile k
forall k. Int -> ProfTrie k Int -> Map k Reference -> Profile k
Prof Int
tot ProfTrie k Int
tr (Reference -> Reference
f (Reference -> Reference) -> Map k Reference -> Map k Reference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map k Reference
refs)
      where
        f :: Reference -> Reference
f Reference
r = Reference -> Maybe Reference -> Reference
forall a. a -> Maybe a -> a
fromMaybe Reference
r (Maybe Reference -> Reference) -> Maybe Reference -> Reference
forall a b. (a -> b) -> a -> b
$ Remapping Reference Reference
-> Remapping Reference Reference -> Reference -> Maybe Reference
backReference Remapping Reference Reference
floatRemap Remapping Reference Reference
intermedRemap Reference
r

interpEval ::
  ActiveThreads ->
  IO () ->
  IORef EvalCtx ->
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  ProfileSpec ->
  Term Symbol ->
  IO (Either Error (Response DecompError, Term Symbol))
interpEval :: ActiveThreads
-> IO ()
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> ProfileSpec
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
interpEval ActiveThreads
actThr IO ()
cleanThr IORef EvalCtx
ctxVar CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe = \case
  ProfileSpec
NoProf ->
    ActiveThreads
-> IO ()
-> IORef EvalCtx
-> Maybe ProfileComm
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
interpEvalDirect ActiveThreads
actThr IO ()
cleanThr IORef EvalCtx
ctxVar Maybe ProfileComm
forall a. Maybe a
Nothing CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe
  ProfileSpec
MiniProf -> ActiveThreads
-> IO ()
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Maybe [Char]
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
profileEval ActiveThreads
actThr IO ()
cleanThr IORef EvalCtx
ctxVar CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe Maybe [Char]
forall a. Maybe a
Nothing
  FullProf [Char]
file -> ActiveThreads
-> IO ()
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Maybe [Char]
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
profileEval ActiveThreads
actThr IO ()
cleanThr IORef EvalCtx
ctxVar CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe (Maybe [Char]
 -> Term Symbol
 -> IO (Either Error (Response DecompError, Term Symbol)))
-> Maybe [Char]
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
file

interpCompile ::
  Text ->
  IORef EvalCtx ->
  CompileOpts ->
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  Reference ->
  FilePath ->
  IO (Maybe Error)
interpCompile :: Text
-> IORef EvalCtx
-> CompileOpts
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Reference
-> [Char]
-> IO (Maybe Error)
interpCompile Text
version IORef EvalCtx
ctxVar CompileOpts
_copts CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe Reference
rf [Char]
path = IO () -> IO (Maybe Error)
tryM (IO () -> IO (Maybe Error)) -> IO () -> IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ do
  EvalCtx
ctx <- IORef EvalCtx -> IO EvalCtx
forall a. IORef a -> IO a
readIORef IORef EvalCtx
ctxVar
  ([(Reference, Either [Int] [Int])]
tyrs, [Reference]
tmrs) <- CodeLookup Symbol IO ()
-> Reference -> IO ([(Reference, Either [Int] [Int])], [Reference])
collectRefDeps CodeLookup Symbol IO ()
cl Reference
rf
  (EvalCtx
ctx, [(Reference, Code Reference)]
_) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, Code Reference)])
loadDeps CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [(Reference, Either [Int] [Int])]
tyrs [Reference]
tmrs
  let cc :: CCache ()
cc = EvalCtx -> CCache ()
ccache EvalCtx
ctx
      lk :: Map Reference Word64 -> Maybe Word64
lk Map Reference Word64
m = (Reference -> Map Reference Word64 -> Maybe Word64)
-> Map Reference Word64 -> Reference -> Maybe Word64
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> Map Reference Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Reference Word64
m (Reference -> Maybe Word64) -> Maybe Reference -> Maybe Word64
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EvalCtx -> Reference -> Maybe Reference
baseToIntermed EvalCtx
ctx Reference
rf
  Just Word64
w <- Map Reference Word64 -> Maybe Word64
lk (Map Reference Word64 -> Maybe Word64)
-> IO (Map Reference Word64) -> IO (Maybe Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache ()
cc)
  let combIx :: CombIx
combIx = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
rf Word64
w Word64
0
  StoredCache
sto <- CCache () -> Word64 -> IO StoredCache
standalone CCache ()
cc Word64
w
  [Char] -> ByteString -> IO ()
BL.writeFile [Char]
path (ByteString -> IO ()) -> (Put -> ByteString) -> Put -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutL (Put -> IO ()) -> Put -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => Text -> m ()
serialize (Text -> Put) -> Text -> Put
forall a b. (a -> b) -> a -> b
$ Text
version
    Text -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => Text -> m ()
serialize (Text -> Put) -> Text -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Reference -> Text
RF.showShort Int
8 Reference
rf
    CombIx -> Put
forall (m :: * -> *). MonadPut m => CombIx -> m ()
putCombIx CombIx
combIx
    StoredCache -> Put
forall (m :: * -> *). MonadPut m => StoredCache -> m ()
putStoredCache StoredCache
sto

backrefLifted ::
  Reference ->
  Term Symbol ->
  [(Reference, Term Symbol)] ->
  Map.Map Reference (Map.Map Word64 (Term Symbol))
backrefLifted :: Reference
-> Term Symbol
-> [(Reference, Term Symbol)]
-> Map Reference (Map Word64 (Term Symbol))
backrefLifted Reference
ref (Tm.Ann' Term Symbol
tm Type Symbol
_) [(Reference, Term Symbol)]
dcmp = Reference
-> Term Symbol
-> [(Reference, Term Symbol)]
-> Map Reference (Map Word64 (Term Symbol))
backrefLifted Reference
ref Term Symbol
tm [(Reference, Term Symbol)]
dcmp
backrefLifted Reference
ref Term Symbol
tm [(Reference, Term Symbol)]
dcmp =
  [(Reference, Map Word64 (Term Symbol))]
-> Map Reference (Map Word64 (Term Symbol))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Reference, Map Word64 (Term Symbol))]
 -> Map Reference (Map Word64 (Term Symbol)))
-> ([(Reference, Term Symbol)]
    -> [(Reference, Map Word64 (Term Symbol))])
-> [(Reference, Term Symbol)]
-> Map Reference (Map Word64 (Term Symbol))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Reference, Term Symbol) -> (Reference, Map Word64 (Term Symbol)))
-> [(Reference, Term Symbol)]
-> [(Reference, Map Word64 (Term Symbol))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Reference, Term Symbol)
  -> (Reference, Map Word64 (Term Symbol)))
 -> [(Reference, Term Symbol)]
 -> [(Reference, Map Word64 (Term Symbol))])
-> ((Term Symbol -> Map Word64 (Term Symbol))
    -> (Reference, Term Symbol)
    -> (Reference, Map Word64 (Term Symbol)))
-> (Term Symbol -> Map Word64 (Term Symbol))
-> [(Reference, Term Symbol)]
-> [(Reference, Map Word64 (Term Symbol))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term Symbol -> Map Word64 (Term Symbol))
-> (Reference, Term Symbol)
-> (Reference, Map Word64 (Term Symbol))
forall a b. (a -> b) -> (Reference, a) -> (Reference, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Word64 -> Term Symbol -> Map Word64 (Term Symbol)
forall k a. k -> a -> Map k a
Map.singleton Word64
0) ([(Reference, Term Symbol)]
 -> Map Reference (Map Word64 (Term Symbol)))
-> [(Reference, Term Symbol)]
-> Map Reference (Map Word64 (Term Symbol))
forall a b. (a -> b) -> a -> b
$ (Reference
ref, Term Symbol
tm) (Reference, Term Symbol)
-> [(Reference, Term Symbol)] -> [(Reference, Term Symbol)]
forall a. a -> [a] -> [a]
: [(Reference, Term Symbol)]
dcmp

intermediateTerms ::
  (HasCallStack) =>
  PrettyPrintEnv ->
  EvalCtx ->
  Map RF.Id (Symbol, Term Symbol) ->
  ( Map.Map Symbol Reference,
    Map.Map Reference (FloatName Symbol),
    Map.Map Reference (SuperGroup Reference Symbol),
    Map.Map Reference (Map.Map Word64 (Term Symbol))
  )
intermediateTerms :: HasCallStack =>
PrettyPrintEnv
-> EvalCtx
-> Map Id (Symbol, Term Symbol)
-> (Map Symbol Reference, Map Reference (FloatName Symbol),
    Map Reference (SuperGroup Reference Symbol),
    Map Reference (Map Word64 (Term Symbol)))
intermediateTerms PrettyPrintEnv
ppe EvalCtx
ctx Map Id (Symbol, Term Symbol)
rtms =
  case EvalCtx
-> Map Symbol Reference
-> [(Symbol, Term Symbol)]
-> (Map Symbol Reference, Map Reference (FloatName Symbol),
    Map Reference (Term Symbol), Map Reference (Term Symbol))
normalizeGroup EvalCtx
ctx Map Symbol Reference
orig (Map Id (Symbol, Term Symbol) -> [(Symbol, Term Symbol)]
forall k a. Map k a -> [a]
Map.elems Map Id (Symbol, Term Symbol)
rtms) of
    (Map Symbol Reference
subvs, Map Reference (FloatName Symbol)
fnames, Map Reference (Term Symbol)
cmbs, Map Reference (Term Symbol)
dcmp) ->
      (Map Symbol Reference
subvs, Map Reference (FloatName Symbol)
fnames, (Reference -> Term Symbol -> SuperGroup Reference Symbol)
-> Map Reference (Term Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Reference -> Term Symbol -> SuperGroup Reference Symbol
f Map Reference (Term Symbol)
cmbs, (Term Symbol -> Map Word64 (Term Symbol))
-> Map Reference (Term Symbol)
-> Map Reference (Map Word64 (Term Symbol))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Word64 -> Term Symbol -> Map Word64 (Term Symbol)
forall k a. k -> a -> Map k a
Map.singleton Word64
0) Map Reference (Term Symbol)
dcmp)
      where
        f :: Reference -> Term Symbol -> SuperGroup Reference Symbol
f Reference
ref =
          Term Symbol -> SuperGroup Reference Symbol
forall v a. Var v => Term v a -> SuperGroup Reference v
superNormalize
            (Term Symbol -> SuperGroup Reference Symbol)
-> (Term Symbol -> Term Symbol)
-> Term Symbol
-> SuperGroup Reference Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataSpec -> Term Symbol -> Term Symbol
forall v. Var v => DataSpec -> Term v -> Term v
splitPatterns (EvalCtx -> DataSpec
dspec EvalCtx
ctx)
            (Term Symbol -> Term Symbol)
-> (Term Symbol -> Term Symbol) -> Term Symbol -> Term Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Term Symbol -> Term Symbol
forall v a. (Var v, Monoid a) => Text -> Term v a -> Term v a
addDefaultCases Text
tmName
          where
            tmName :: Text
tmName = HashQualified Name -> Text
HQ.toText (HashQualified Name -> Text)
-> (Referent -> HashQualified Name) -> Referent -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv -> Referent -> HashQualified Name
termName PrettyPrintEnv
ppe (Referent -> Text) -> Referent -> Text
forall a b. (a -> b) -> a -> b
$ Reference -> Referent
RF.Ref Reference
ref
  where
    orig :: Map Symbol Reference
orig =
      [(Symbol, Reference)] -> Map Symbol Reference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        ([(Symbol, Reference)] -> Map Symbol Reference)
-> (Map Id Symbol -> [(Symbol, Reference)])
-> Map Id Symbol
-> Map Symbol Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Id, Symbol) -> (Symbol, Reference))
-> [(Id, Symbol)] -> [(Symbol, Reference)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Id
x, Symbol
y) -> (Symbol
y, Id -> Reference
forall h t. Id' h -> Reference' t h
RF.DerivedId Id
x))
        ([(Id, Symbol)] -> [(Symbol, Reference)])
-> (Map Id Symbol -> [(Id, Symbol)])
-> Map Id Symbol
-> [(Symbol, Reference)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Id Symbol -> [(Id, Symbol)]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map Id Symbol -> Map Symbol Reference)
-> Map Id Symbol -> Map Symbol Reference
forall a b. (a -> b) -> a -> b
$ ((Symbol, Term Symbol) -> Symbol)
-> Map Id (Symbol, Term Symbol) -> Map Id Symbol
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Symbol, Term Symbol) -> Symbol
forall a b. (a, b) -> a
fst Map Id (Symbol, Term Symbol)
rtms

normalizeTerm ::
  EvalCtx ->
  Term Symbol ->
  ( Reference,
    Map Reference Reference,
    Map Reference (FloatName Symbol),
    Map Reference (Term Symbol),
    Map Reference (Map.Map Word64 (Term Symbol))
  )
normalizeTerm :: EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol), Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
normalizeTerm EvalCtx
ctx Term Symbol
tm =
  (Term Symbol, Map Reference Reference,
 Map Reference (FloatName Symbol), [(Reference, Term Symbol)],
 [(Reference, Term Symbol)])
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol), Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
absorb
    ((Term Symbol, Map Reference Reference,
  Map Reference (FloatName Symbol), [(Reference, Term Symbol)],
  [(Reference, Term Symbol)])
 -> (Reference, Map Reference Reference,
     Map Reference (FloatName Symbol), Map Reference (Term Symbol),
     Map Reference (Map Word64 (Term Symbol))))
-> (Term Symbol
    -> (Term Symbol, Map Reference Reference,
        Map Reference (FloatName Symbol), [(Reference, Term Symbol)],
        [(Reference, Term Symbol)]))
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol), Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Symbol Reference
-> Term Symbol
-> (Term Symbol, Map Reference Reference,
    Map Reference (FloatName Symbol), [(Reference, Term Symbol)],
    [(Reference, Term Symbol)])
forall v a.
(Var v, Monoid a) =>
Map v Reference
-> Term v a
-> (Term v a, Map Reference Reference, Map Reference (FloatName v),
    [(Reference, Term v a)], [(Reference, Term v a)])
lamLift Map Symbol Reference
orig
    (Term Symbol
 -> (Term Symbol, Map Reference Reference,
     Map Reference (FloatName Symbol), [(Reference, Term Symbol)],
     [(Reference, Term Symbol)]))
-> (Term Symbol -> Term Symbol)
-> Term Symbol
-> (Term Symbol, Map Reference Reference,
    Map Reference (FloatName Symbol), [(Reference, Term Symbol)],
    [(Reference, Term Symbol)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ConstructorReference Int -> Term Symbol -> Term Symbol
forall v a.
(Var v, Monoid a) =>
Map ConstructorReference Int -> Term v a -> Term v a
saturate (DataSpec -> Map ConstructorReference Int
uncurryDspec (DataSpec -> Map ConstructorReference Int)
-> DataSpec -> Map ConstructorReference Int
forall a b. (a -> b) -> a -> b
$ EvalCtx -> DataSpec
dspec EvalCtx
ctx)
    (Term Symbol -> Term Symbol)
-> (Term Symbol -> Term Symbol) -> Term Symbol -> Term Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term Symbol -> Term Symbol
forall v a. (Var v, Monoid a) => Term v a -> Term v a
inlineAlias
    (Term Symbol
 -> (Reference, Map Reference Reference,
     Map Reference (FloatName Symbol), Map Reference (Term Symbol),
     Map Reference (Map Word64 (Term Symbol))))
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol), Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
forall a b. (a -> b) -> a -> b
$ Term Symbol
tm
  where
    orig :: Map Symbol Reference
orig
      | Tm.LetRecNamed' [(Symbol, Term Symbol)]
bs Term Symbol
_ <- Term Symbol
tm =
          ((Id, Term Symbol) -> Reference)
-> Map Symbol (Id, Term Symbol) -> Map Symbol Reference
forall a b. (a -> b) -> Map Symbol a -> Map Symbol b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Id -> Reference
forall h t. Id' h -> Reference' t h
RF.DerivedId (Id -> Reference)
-> ((Id, Term Symbol) -> Id) -> (Id, Term Symbol) -> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Term Symbol) -> Id
forall a b. (a, b) -> a
fst)
            (Map Symbol (Id, Term Symbol) -> Map Symbol Reference)
-> (Map Symbol (Term Symbol) -> Map Symbol (Id, Term Symbol))
-> Map Symbol (Term Symbol)
-> Map Symbol Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Symbol (Term Symbol) -> Map Symbol (Id, Term Symbol)
forall v a. Var v => Map v (Term v a) -> Map v (Id, Term v a)
Hashing.hashTermComponentsWithoutTypes
            (Map Symbol (Term Symbol) -> Map Symbol Reference)
-> Map Symbol (Term Symbol) -> Map Symbol Reference
forall a b. (a -> b) -> a -> b
$ [(Symbol, Term Symbol)] -> Map Symbol (Term Symbol)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Symbol, Term Symbol)]
bs
      | Bool
otherwise = Map Symbol Reference
forall a. Monoid a => a
mempty
    absorb :: (Term Symbol, Map Reference Reference,
 Map Reference (FloatName Symbol), [(Reference, Term Symbol)],
 [(Reference, Term Symbol)])
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol), Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
absorb (Term Symbol
ll, Map Reference Reference
frem, Map Reference (FloatName Symbol)
fnames, [(Reference, Term Symbol)]
bs, [(Reference, Term Symbol)]
dcmp) =
      let ref :: Reference
ref = Id -> Reference
forall h t. Id' h -> Reference' t h
RF.DerivedId (Id -> Reference) -> Id -> Reference
forall a b. (a -> b) -> a -> b
$ Term Symbol -> Id
forall v a. Var v => Term v a -> Id
Hashing.hashClosedTerm Term Symbol
ll
       in (Reference
ref, Map Reference Reference
frem, Map Reference (FloatName Symbol)
fnames, [(Reference, Term Symbol)] -> Map Reference (Term Symbol)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Reference, Term Symbol)] -> Map Reference (Term Symbol))
-> [(Reference, Term Symbol)] -> Map Reference (Term Symbol)
forall a b. (a -> b) -> a -> b
$ (Reference
ref, Term Symbol
ll) (Reference, Term Symbol)
-> [(Reference, Term Symbol)] -> [(Reference, Term Symbol)]
forall a. a -> [a] -> [a]
: [(Reference, Term Symbol)]
bs, Reference
-> Term Symbol
-> [(Reference, Term Symbol)]
-> Map Reference (Map Word64 (Term Symbol))
backrefLifted Reference
ref Term Symbol
tm [(Reference, Term Symbol)]
dcmp)

normalizeGroup ::
  EvalCtx ->
  Map Symbol Reference ->
  [(Symbol, Term Symbol)] ->
  ( Map Symbol Reference,
    Map Reference (FloatName Symbol),
    Map Reference (Term Symbol),
    Map Reference (Term Symbol)
  )
normalizeGroup :: EvalCtx
-> Map Symbol Reference
-> [(Symbol, Term Symbol)]
-> (Map Symbol Reference, Map Reference (FloatName Symbol),
    Map Reference (Term Symbol), Map Reference (Term Symbol))
normalizeGroup EvalCtx
ctx Map Symbol Reference
orig [(Symbol, Term Symbol)]
gr0 = case Map Symbol Reference
-> [(Symbol, Term Symbol)]
-> ([(Symbol, Id)], [(Reference, FloatName Symbol)],
    [(Reference, Term Symbol)], [(Reference, Term Symbol)])
forall v a.
(Var v, Monoid a) =>
Map v Reference
-> [(v, Term v a)]
-> ([(v, Id)], [(Reference, FloatName v)], [(Reference, Term v a)],
    [(Reference, Term v a)])
lamLiftGroup Map Symbol Reference
orig [(Symbol, Term Symbol)]
gr of
  ([(Symbol, Id)]
subvis, [(Reference, FloatName Symbol)]
fnames, [(Reference, Term Symbol)]
cmbs, [(Reference, Term Symbol)]
dcmp) ->
    let subvs :: [(Symbol, Reference)]
subvs = (((Symbol, Id) -> (Symbol, Reference))
-> [(Symbol, Id)] -> [(Symbol, Reference)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Symbol, Id) -> (Symbol, Reference))
 -> [(Symbol, Id)] -> [(Symbol, Reference)])
-> ((Id -> Reference) -> (Symbol, Id) -> (Symbol, Reference))
-> (Id -> Reference)
-> [(Symbol, Id)]
-> [(Symbol, Reference)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id -> Reference) -> (Symbol, Id) -> (Symbol, Reference)
forall a b. (a -> b) -> (Symbol, a) -> (Symbol, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Id -> Reference
forall h t. Id' h -> Reference' t h
RF.DerivedId [(Symbol, Id)]
subvis
        subrs :: Map Referent Referent
subrs = [(Referent, Referent)] -> Map Referent Referent
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Referent, Referent)] -> Map Referent Referent)
-> [(Referent, Referent)] -> Map Referent Referent
forall a b. (a -> b) -> a -> b
$ ((Symbol, Reference) -> Maybe (Referent, Referent))
-> [(Symbol, Reference)] -> [(Referent, Referent)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (Symbol, Reference) -> Maybe (Referent, Referent)
f [(Symbol, Reference)]
subvs
     in ( [(Symbol, Reference)] -> Map Symbol Reference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Symbol, Reference)]
subvs,
          [(Reference, FloatName Symbol)] -> Map Reference (FloatName Symbol)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Reference, FloatName Symbol)]
fnames,
          [(Reference, Term Symbol)] -> Map Reference (Term Symbol)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Reference, Term Symbol)] -> Map Reference (Term Symbol))
-> [(Reference, Term Symbol)] -> Map Reference (Term Symbol)
forall a b. (a -> b) -> a -> b
$
            (((Reference, Term Symbol) -> (Reference, Term Symbol))
-> [(Reference, Term Symbol)] -> [(Reference, Term Symbol)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Reference, Term Symbol) -> (Reference, Term Symbol))
 -> [(Reference, Term Symbol)] -> [(Reference, Term Symbol)])
-> ((Term Symbol -> Term Symbol)
    -> (Reference, Term Symbol) -> (Reference, Term Symbol))
-> (Term Symbol -> Term Symbol)
-> [(Reference, Term Symbol)]
-> [(Reference, Term Symbol)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term Symbol -> Term Symbol)
-> (Reference, Term Symbol) -> (Reference, Term Symbol)
forall a b. (a -> b) -> (Reference, a) -> (Reference, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Map Referent Referent
-> Map Reference Reference -> Term Symbol -> Term Symbol
forall v a.
Ord v =>
Map Referent Referent
-> Map Reference Reference -> Term v a -> Term v a
Tm.updateDependencies Map Referent Referent
subrs Map Reference Reference
forall a. Monoid a => a
mempty) [(Reference, Term Symbol)]
cmbs,
          [(Reference, Term Symbol)] -> Map Reference (Term Symbol)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Reference, Term Symbol)]
dcmp
        )
  where
    gr :: [(Symbol, Term Symbol)]
gr = (Term Symbol -> Term Symbol)
-> (Symbol, Term Symbol) -> (Symbol, Term Symbol)
forall a b. (a -> b) -> (Symbol, a) -> (Symbol, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map ConstructorReference Int -> Term Symbol -> Term Symbol
forall v a.
(Var v, Monoid a) =>
Map ConstructorReference Int -> Term v a -> Term v a
saturate (DataSpec -> Map ConstructorReference Int
uncurryDspec (DataSpec -> Map ConstructorReference Int)
-> DataSpec -> Map ConstructorReference Int
forall a b. (a -> b) -> a -> b
$ EvalCtx -> DataSpec
dspec EvalCtx
ctx) (Term Symbol -> Term Symbol)
-> (Term Symbol -> Term Symbol) -> Term Symbol -> Term Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term Symbol -> Term Symbol
forall v a. (Var v, Monoid a) => Term v a -> Term v a
inlineAlias) ((Symbol, Term Symbol) -> (Symbol, Term Symbol))
-> [(Symbol, Term Symbol)] -> [(Symbol, Term Symbol)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Symbol, Term Symbol)]
gr0
    f :: (Symbol, Reference) -> Maybe (Referent, Referent)
f (Symbol
v, Reference
r) = (,Reference -> Referent
RF.Ref Reference
r) (Referent -> (Referent, Referent))
-> (Reference -> Referent) -> Reference -> (Referent, Referent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent
RF.Ref (Reference -> (Referent, Referent))
-> Maybe Reference -> Maybe (Referent, Referent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbol -> Map Symbol Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
v Map Symbol Reference
orig

intermediateTerm ::
  (HasCallStack) =>
  PrettyPrintEnv ->
  EvalCtx ->
  Term Symbol ->
  ( Reference,
    Map.Map Reference Reference,
    Map.Map Reference (FloatName Symbol),
    Map.Map Reference (SuperGroup Reference Symbol),
    Map.Map Reference (Map.Map Word64 (Term Symbol))
  )
intermediateTerm :: HasCallStack =>
PrettyPrintEnv
-> EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol),
    Map Reference (SuperGroup Reference Symbol),
    Map Reference (Map Word64 (Term Symbol)))
intermediateTerm PrettyPrintEnv
ppe EvalCtx
ctx Term Symbol
tm =
  case EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol), Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
normalizeTerm EvalCtx
ctx Term Symbol
tm of
    (Reference
ref, Map Reference Reference
frem, Map Reference (FloatName Symbol)
fnames, Map Reference (Term Symbol)
cmbs, Map Reference (Map Word64 (Term Symbol))
dcmp) ->
      (Reference
ref, Map Reference Reference
frem, Map Reference (FloatName Symbol)
fnames, (Term Symbol -> SuperGroup Reference Symbol)
-> Map Reference (Term Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall a b. (a -> b) -> Map Reference a -> Map Reference b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term Symbol -> SuperGroup Reference Symbol
f Map Reference (Term Symbol)
cmbs, Map Reference (Map Word64 (Term Symbol))
dcmp)
      where
        tmName :: Text
tmName = HashQualified Name -> Text
HQ.toText (HashQualified Name -> Text)
-> (Referent -> HashQualified Name) -> Referent -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv -> Referent -> HashQualified Name
termName PrettyPrintEnv
ppe (Referent -> Text) -> Referent -> Text
forall a b. (a -> b) -> a -> b
$ Reference -> Referent
RF.Ref Reference
ref
        f :: Term Symbol -> SuperGroup Reference Symbol
f =
          Term Symbol -> SuperGroup Reference Symbol
forall v a. Var v => Term v a -> SuperGroup Reference v
superNormalize
            (Term Symbol -> SuperGroup Reference Symbol)
-> (Term Symbol -> Term Symbol)
-> Term Symbol
-> SuperGroup Reference Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataSpec -> Term Symbol -> Term Symbol
forall v. Var v => DataSpec -> Term v -> Term v
splitPatterns (EvalCtx -> DataSpec
dspec EvalCtx
ctx)
            (Term Symbol -> Term Symbol)
-> (Term Symbol -> Term Symbol) -> Term Symbol -> Term Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Term Symbol -> Term Symbol
forall v a. (Var v, Monoid a) => Text -> Term v a -> Term v a
addDefaultCases Text
tmName

prepareEvaluation ::
  (HasCallStack) =>
  PrettyPrintEnv ->
  Term Symbol ->
  EvalCtx ->
  IO (EvalCtx, [(Reference, Code Reference)], Reference)
prepareEvaluation :: HasCallStack =>
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, Code Reference)], Reference)
prepareEvaluation PrettyPrintEnv
ppe Term Symbol
tm EvalCtx
ctx = do
  [Reference]
missing <- [(Reference, Code Reference)] -> CCache () -> IO [Reference]
forall p.
RuntimeProfiler p =>
[(Reference, Code Reference)] -> CCache p -> IO [Reference]
cacheAdd [(Reference, Code Reference)]
rcode (EvalCtx -> CCache ()
ccache EvalCtx
ctx')
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> ([Reference] -> Bool) -> [Reference] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Reference] -> Bool) -> [Reference] -> Bool
forall a b. (a -> b) -> a -> b
$ [Reference]
missing) (IO () -> IO ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> [Char] -> [Char]
reportBug [Char]
"E029347" ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [Char]
"Error in prepareEvaluation, cache is missing: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Reference] -> [Char]
forall a. Show a => a -> [Char]
show [Reference]
missing
  pure (Map Reference (Map Word64 (Term Symbol)) -> EvalCtx -> EvalCtx
backrefAdd Map Reference (Map Word64 (Term Symbol))
rbkr EvalCtx
ctx', [(Reference, Code Reference)]
rcode, Reference
rmn)
  where
    uncacheable :: SuperGroup ref Symbol -> Code ref
uncacheable SuperGroup ref Symbol
g = SuperGroup ref Symbol -> Cacheability -> Code ref
forall ref. SuperGroup ref Symbol -> Cacheability -> Code ref
CodeRep SuperGroup ref Symbol
g Cacheability
Uncacheable
    (Reference
rmn0, Map Reference Reference
frem, Map Reference (FloatName Symbol)
fnames, Map Reference (SuperGroup Reference Symbol)
rgrp0, Map Reference (Map Word64 (Term Symbol))
rbkr) = HasCallStack =>
PrettyPrintEnv
-> EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol),
    Map Reference (SuperGroup Reference Symbol),
    Map Reference (Map Word64 (Term Symbol)))
PrettyPrintEnv
-> EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (FloatName Symbol),
    Map Reference (SuperGroup Reference Symbol),
    Map Reference (Map Word64 (Term Symbol)))
intermediateTerm PrettyPrintEnv
ppe EvalCtx
ctx Term Symbol
tm
    int :: Bool -> Reference -> Reference
int Bool
b Reference
r
      | Bool
b Bool -> Bool -> Bool
|| Reference -> Map Reference (SuperGroup Reference Symbol) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Reference
r Map Reference (SuperGroup Reference Symbol)
rgrp0 = Reference
r
      | Bool
otherwise = EvalCtx -> Reference -> Reference
toIntermed EvalCtx
ctx Reference
r
    (EvalCtx
ctx', Map Reference Reference
rrefs, [(Reference, SuperGroup Reference Symbol)]
rgrp) =
      Map Reference (SuperGroup Reference Symbol)
-> EvalCtx
-> (EvalCtx, Map Reference Reference,
    [(Reference, SuperGroup Reference Symbol)])
performRehash
        (((SuperGroup Reference Symbol -> SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall a b. (a -> b) -> Map Reference a -> Map Reference b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SuperGroup Reference Symbol -> SuperGroup Reference Symbol)
 -> Map Reference (SuperGroup Reference Symbol)
 -> Map Reference (SuperGroup Reference Symbol))
-> ((Bool -> Reference -> Reference)
    -> SuperGroup Reference Symbol -> SuperGroup Reference Symbol)
-> (Bool -> Reference -> Reference)
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Reference -> Reference)
-> SuperGroup Reference Symbol -> SuperGroup Reference Symbol
forall v ref0 ref1.
Var v =>
(Bool -> ref0 -> ref1) -> SuperGroup ref0 v -> SuperGroup ref1 v
overGroupLinks) Bool -> Reference -> Reference
int (Map Reference (SuperGroup Reference Symbol)
 -> Map Reference (SuperGroup Reference Symbol))
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall a b. (a -> b) -> a -> b
$ Map Reference (SuperGroup Reference Symbol)
rgrp0)
        (Map Reference (FloatName Symbol) -> EvalCtx -> EvalCtx
floatNamesAdd Map Reference (FloatName Symbol)
fnames (EvalCtx -> EvalCtx) -> EvalCtx -> EvalCtx
forall a b. (a -> b) -> a -> b
$ Map Reference Reference -> EvalCtx -> EvalCtx
floatRemapAdd Map Reference Reference
frem EvalCtx
ctx)
    rcode :: [(Reference, Code Reference)]
rcode = (SuperGroup Reference Symbol -> Code Reference)
-> (Reference, SuperGroup Reference Symbol)
-> (Reference, Code Reference)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SuperGroup Reference Symbol -> Code Reference
forall {ref}. SuperGroup ref Symbol -> Code ref
uncacheable ((Reference, SuperGroup Reference Symbol)
 -> (Reference, Code Reference))
-> [(Reference, SuperGroup Reference Symbol)]
-> [(Reference, Code Reference)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, SuperGroup Reference Symbol)]
rgrp
    rmn :: Reference
rmn = case Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
rmn0 Map Reference Reference
rrefs of
      Just Reference
r -> Reference
r
      Maybe Reference
Nothing -> [Char] -> Reference
forall a. HasCallStack => [Char] -> a
error [Char]
"prepareEvaluation: could not remap main ref"

watchHook :: IORef Val -> XStack -> IO ()
watchHook :: IORef Val -> XStack -> IO ()
watchHook IORef Val
r XStack
xstk = (() :: Constraint) => Stack -> IO Val
Stack -> IO Val
peek (XStack -> Stack
packXStack XStack
xstk) IO Val -> (Val -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef Val -> Val -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Val
r

backReferenceTm ::
  EnumMap Word64 Reference ->
  Remapping CodebaseReference FloatedReference ->
  Remapping FloatedReference IntermediateReference ->
  Map.Map CodebaseReference (Map.Map Word64 (Term Symbol)) ->
  Word64 ->
  Word64 ->
  Maybe (Term Symbol)
backReferenceTm :: EnumMap Word64 Reference
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm EnumMap Word64 Reference
ws Remapping Reference Reference
frs Remapping Reference Reference
irs Map Reference (Map Word64 (Term Symbol))
dcm Word64
c Word64
i = do
  Reference
r <- Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
c EnumMap Word64 Reference
ws
  Reference
r <- Remapping Reference Reference
-> Remapping Reference Reference -> Reference -> Maybe Reference
backReference Remapping Reference Reference
frs Remapping Reference Reference
irs Reference
r
  -- look up original ref in decompile info
  Map Word64 (Term Symbol)
bs <- Reference
-> Map Reference (Map Word64 (Term Symbol))
-> Maybe (Map Word64 (Term Symbol))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r Map Reference (Map Word64 (Term Symbol))
dcm
  Word64 -> Map Word64 (Term Symbol) -> Maybe (Term Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word64
i Map Word64 (Term Symbol)
bs

backReference ::
  Remapping CodebaseReference FloatedReference ->
  Remapping FloatedReference IntermediateReference ->
  Reference ->
  Maybe Reference
backReference :: Remapping Reference Reference
-> Remapping Reference Reference -> Reference -> Maybe Reference
backReference Remapping Reference Reference
frs Remapping Reference Reference
irs Reference
r = do
  -- backmap from function replacements
  Reference
r <- Reference -> Maybe Reference
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference -> Maybe Reference) -> Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Reference
r Reference
r Map Reference Reference
functionUnreplacements
  -- backmap intermediate ref to floated ref
  Reference
r <- Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap Remapping Reference Reference
irs)
  -- backmap floated ref to original ref
  pure $ Reference -> Reference -> Map Reference Reference -> Reference
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Reference
r Reference
r (Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap Remapping Reference Reference
frs)

evalInContext ::
  PrettyPrintEnv ->
  EvalCtx ->
  Maybe ProfileComm ->
  ActiveThreads ->
  Word64 ->
  IO (Either Error (Response DecompError, Term Symbol))
evalInContext :: PrettyPrintEnv
-> EvalCtx
-> Maybe ProfileComm
-> ActiveThreads
-> Word64
-> IO (Either Error (Response DecompError, Term Symbol))
evalInContext PrettyPrintEnv
ppe EvalCtx
ctx Maybe ProfileComm
prof ActiveThreads
activeThreads Word64
w = do
  IORef Val
r <- Val -> IO (IORef Val)
forall a. a -> IO (IORef a)
newIORef (BVal -> Val
boxedVal BVal
BlackHole)
  EnumMap Word64 Reference
crs <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
combRefs (CCache () -> TVar (EnumMap Word64 Reference))
-> CCache () -> TVar (EnumMap Word64 Reference)
forall a b. (a -> b) -> a -> b
$ EvalCtx -> CCache ()
ccache EvalCtx
ctx)
  let hook :: XStack -> IO ()
hook = IORef Val -> XStack -> IO ()
watchHook IORef Val
r
      decom :: Val -> DecompResult Symbol
decom = EnumMap Word64 Reference -> EvalCtx -> Val -> DecompResult Symbol
decompileCtx EnumMap Word64 Reference
crs EvalCtx
ctx
      mkResponse :: Set e -> Response e
mkResponse Set e
errs =
        if Set e -> Bool
forall a. Set a -> Bool
Set.null Set e
errs
          then Response e
forall e. Response e
EmptyResponse
          else [e] -> Response e
forall e. [e] -> Response e
DecompErrs ([e] -> Response e) -> [e] -> Response e
forall a b. (a -> b) -> a -> b
$ Set e -> [e]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set e
errs
      finish :: Either Error Val
-> Either Error (Response DecompError, Term Symbol)
finish = (Val -> (Response DecompError, Term Symbol))
-> Either Error Val
-> Either Error (Response DecompError, Term Symbol)
forall a b. (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Set DecompError -> Response DecompError)
-> DecompResult Symbol -> (Response DecompError, Term Symbol)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Set DecompError -> Response DecompError
forall {e}. Set e -> Response e
mkResponse (DecompResult Symbol -> (Response DecompError, Term Symbol))
-> (Val -> DecompResult Symbol)
-> Val
-> (Response DecompError, Term Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> DecompResult Symbol
decom)

      prettyError :: SomeException -> Maybe Error
prettyError SomeException
e =
        Maybe
  (PrettyPrintEnv, Reference -> Reference,
   Val -> DecompResult Symbol)
-> RuntimeExn -> Error
RuntimeExn ((PrettyPrintEnv, Reference -> Reference,
 Val -> DecompResult Symbol)
-> Maybe
     (PrettyPrintEnv, Reference -> Reference,
      Val -> DecompResult Symbol)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrettyPrintEnv
ppe, EvalCtx -> Reference -> Reference
backmapRef EvalCtx
ctx, Val -> DecompResult Symbol
decom)) (RuntimeExn -> Error) -> Maybe RuntimeExn -> Maybe Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe RuntimeExn
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
          Maybe Error -> Maybe Error -> Maybe Error
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PrettyPrintEnv
-> (Val -> DecompResult Symbol) -> RuntimePanic -> Error
RuntimePanic PrettyPrintEnv
ppe Val -> DecompResult Symbol
decom (RuntimePanic -> Error) -> Maybe RuntimePanic -> Maybe Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe RuntimePanic
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e

      debugText :: Bool -> Val -> Tracer
debugText Bool
fancy Val
val = case Val -> DecompResult Symbol
decom Val
val of
        (Set DecompError
errs, Term Symbol
dv)
          | Set DecompError -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set DecompError
errs ->
              [Char] -> Tracer
SimpleTrace ([Char] -> Tracer)
-> (Pretty ColorText -> [Char]) -> Pretty ColorText -> Tracer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty ColorText -> [Char]
debugTextFormat Bool
fancy (Pretty ColorText -> Tracer) -> Pretty ColorText -> Tracer
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term Symbol
dv
          | Bool
otherwise ->
              [Char] -> [Char] -> [Char] -> Tracer
MsgTrace
                (Bool -> Pretty ColorText -> [Char]
debugTextFormat Bool
fancy (Pretty ColorText -> [Char]) -> Pretty ColorText -> [Char]
forall a b. (a -> b) -> a -> b
$ Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs)
                (Val -> [Char]
forall a. Show a => a -> [Char]
show Val
val)
                (Bool -> Pretty ColorText -> [Char]
debugTextFormat Bool
fancy (Pretty ColorText -> [Char]) -> Pretty ColorText -> [Char]
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term Symbol
dv)

  Either Error Val
result <-
    (() -> IO Val) -> Either Error () -> IO (Either Error Val)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Either Error a -> f (Either Error b)
traverse (IO Val -> () -> IO Val
forall a b. a -> b -> a
const (IO Val -> () -> IO Val) -> IO Val -> () -> IO Val
forall a b. (a -> b) -> a -> b
$ IORef Val -> IO Val
forall a. IORef a -> IO a
readIORef IORef Val
r) (Either Error () -> IO (Either Error Val))
-> (IO () -> IO (Either Error ()))
-> IO ()
-> IO (Either Error Val)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (SomeException -> Maybe Error) -> IO () -> IO (Either Error ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust SomeException -> Maybe Error
prettyError (IO () -> IO (Either Error Val)) -> IO () -> IO (Either Error Val)
forall a b. (a -> b) -> a -> b
$
      IO () -> (ProfileComm -> IO ()) -> Maybe ProfileComm -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Maybe (XStack -> IO ())
-> CCache () -> ActiveThreads -> Word64 -> IO ()
forall p.
RuntimeProfiler p =>
Maybe (XStack -> IO ())
-> CCache p -> ActiveThreads -> Word64 -> IO ()
apply0 (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
    MutableArray# RealWorld BVal #)
 -> IO ())
-> Maybe
     ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
         MutableArray# RealWorld BVal #)
      -> IO ())
forall a. a -> Maybe a
Just (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld BVal #)
-> IO ()
XStack -> IO ()
hook) (EvalCtx -> CCache ()
ccache EvalCtx
ctx) {tracer = debugText} ActiveThreads
activeThreads Word64
w)
        (\ProfileComm
pc -> Maybe (XStack -> IO ())
-> CCache ProfileComm -> ActiveThreads -> Word64 -> IO ()
forall p.
RuntimeProfiler p =>
Maybe (XStack -> IO ())
-> CCache p -> ActiveThreads -> Word64 -> IO ()
apply0 (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
    MutableArray# RealWorld BVal #)
 -> IO ())
-> Maybe
     ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
         MutableArray# RealWorld BVal #)
      -> IO ())
forall a. a -> Maybe a
Just (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld BVal #)
-> IO ()
XStack -> IO ()
hook) (EvalCtx -> CCache ()
ccache EvalCtx
ctx) {tracer = debugText, profiler = pc} ActiveThreads
activeThreads Word64
w)
        Maybe ProfileComm
prof

  pure $ Either Error Val
-> Either Error (Response DecompError, Term Symbol)
finish Either Error Val
result

executeMainComb ::
  CombIx ->
  CCache () ->
  IO (Either Error ())
executeMainComb :: CombIx -> CCache () -> IO (Either Error ())
executeMainComb CombIx
init CCache ()
cc = do
  MSection
rSection <- CCache () -> Section -> IO MSection
forall p. CCache p -> Section -> IO MSection
resolveSection CCache ()
cc (Section -> IO MSection) -> Section -> IO MSection
forall a b. (a -> b) -> a -> b
$ GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (Reference -> PackedTag -> Args -> GInstr CombIx
forall comb. Reference -> PackedTag -> Args -> GInstr comb
Pack Reference
RF.unitRef PackedTag
TT.unitTag Args
ZArgs) (Section -> Section) -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Bool -> CombIx -> CombIx -> Args -> Section
forall comb. Bool -> CombIx -> comb -> Args -> GSection comb
Call Bool
True CombIx
init CombIx
init (Int -> Args
VArg1 Int
0)
  Either RuntimeExn ()
result <- IO () -> IO (Either RuntimeExn ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try (IO () -> IO (Either RuntimeExn ()))
-> IO () -> IO (Either RuntimeExn ())
forall a b. (a -> b) -> a -> b
$ CCache () -> ActiveThreads -> MSection -> IO ()
forall p.
RuntimeProfiler p =>
CCache p -> ActiveThreads -> MSection -> IO ()
eval0 CCache ()
cc ActiveThreads
forall a. Maybe a
Nothing MSection
rSection
  (RuntimeExn -> IO Error)
-> (() -> IO ()) -> Either RuntimeExn () -> IO (Either Error ())
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse RuntimeExn -> IO Error
contextualizeErr () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either RuntimeExn ()
result
  where
    contextualizeErr :: RuntimeExn -> IO Error
contextualizeErr RuntimeExn
re = do
      EnumMap Word64 Reference
crs <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
combRefs CCache ()
cc)
      let ctx :: EvalCtx
ctx = CCache () -> EvalCtx
cacheContext CCache ()
cc
          decom :: Val -> DecompResult Symbol
decom =
            (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Val
-> DecompResult Symbol
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile (EvalCtx -> Reference -> Maybe Reference
intermedToBase EvalCtx
ctx) ((Word64 -> Word64 -> Maybe (Term Symbol))
 -> Val -> DecompResult Symbol)
-> (Map Reference (Map Word64 (Term Symbol))
    -> Word64 -> Word64 -> Maybe (Term Symbol))
-> Map Reference (Map Word64 (Term Symbol))
-> Val
-> DecompResult Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumMap Word64 Reference
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm EnumMap Word64 Reference
crs (EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx) (EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx) (Map Reference (Map Word64 (Term Symbol))
 -> Val -> DecompResult Symbol)
-> Map Reference (Map Word64 (Term Symbol))
-> Val
-> DecompResult Symbol
forall a b. (a -> b) -> a -> b
$
              EvalCtx -> Map Reference (Map Word64 (Term Symbol))
decompTm EvalCtx
ctx
      Error -> IO Error
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> IO Error) -> Error -> IO Error
forall a b. (a -> b) -> a -> b
$ Maybe
  (PrettyPrintEnv, Reference -> Reference,
   Val -> DecompResult Symbol)
-> RuntimeExn -> Error
RuntimeExn ((PrettyPrintEnv, Reference -> Reference,
 Val -> DecompResult Symbol)
-> Maybe
     (PrettyPrintEnv, Reference -> Reference,
      Val -> DecompResult Symbol)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrettyPrintEnv
forall a. Monoid a => a
mempty, Reference -> Reference
forall a. a -> a
id, Val -> DecompResult Symbol
decom)) RuntimeExn
re

catchErrors :: IO (Either Error a) -> IO (Either Error a)
catchErrors :: forall a. IO (Either Error a) -> IO (Either Error a)
catchErrors IO (Either Error a)
sub =
  IO (Either Error a)
sub IO (Either Error a)
-> (CompileExn -> IO (Either Error a)) -> IO (Either Error a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`UnliftIO.catch` (Either Error a -> IO (Either Error a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error a -> IO (Either Error a))
-> (CompileExn -> Either Error a)
-> CompileExn
-> IO (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a)
-> (CompileExn -> Error) -> CompileExn -> Either Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileExn -> Error
CompileExn) IO (Either Error a)
-> (RuntimeExn -> IO (Either Error a)) -> IO (Either Error a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`UnliftIO.catch` (Either Error a -> IO (Either Error a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error a -> IO (Either Error a))
-> (RuntimeExn -> Either Error a)
-> RuntimeExn
-> IO (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a)
-> (RuntimeExn -> Error) -> RuntimeExn -> Either Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe
  (PrettyPrintEnv, Reference -> Reference,
   Val -> DecompResult Symbol)
-> RuntimeExn -> Error
RuntimeExn Maybe
  (PrettyPrintEnv, Reference -> Reference,
   Val -> DecompResult Symbol)
forall a. Maybe a
Nothing)

decodeStandalone ::
  BL.ByteString ->
  Either String (Text, Text, CombIx, StoredCache)
decodeStandalone :: ByteString -> Either [Char] (Text, Text, CombIx, StoredCache)
decodeStandalone ByteString
b = ((ByteString, ByteOffset, [Char]) -> [Char])
-> ((ByteString, ByteOffset, (Text, Text, CombIx, StoredCache))
    -> (Text, Text, CombIx, StoredCache))
-> Either
     (ByteString, ByteOffset, [Char])
     (ByteString, ByteOffset, (Text, Text, CombIx, StoredCache))
-> Either [Char] (Text, Text, CombIx, StoredCache)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ByteString, ByteOffset, [Char]) -> [Char]
forall {a} {b} {c}. (a, b, c) -> c
thd (ByteString, ByteOffset, (Text, Text, CombIx, StoredCache))
-> (Text, Text, CombIx, StoredCache)
forall {a} {b} {c}. (a, b, c) -> c
thd (Either
   (ByteString, ByteOffset, [Char])
   (ByteString, ByteOffset, (Text, Text, CombIx, StoredCache))
 -> Either [Char] (Text, Text, CombIx, StoredCache))
-> Either
     (ByteString, ByteOffset, [Char])
     (ByteString, ByteOffset, (Text, Text, CombIx, StoredCache))
-> Either [Char] (Text, Text, CombIx, StoredCache)
forall a b. (a -> b) -> a -> b
$ Get (Text, Text, CombIx, StoredCache)
-> ByteString
-> Either
     (ByteString, ByteOffset, [Char])
     (ByteString, ByteOffset, (Text, Text, CombIx, StoredCache))
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, [Char]) (ByteString, ByteOffset, a)
runGetOrFail Get (Text, Text, CombIx, StoredCache)
g ByteString
b
  where
    thd :: (a, b, c) -> c
thd (a
_, b
_, c
x) = c
x
    g :: Get (Text, Text, CombIx, StoredCache)
g =
      (,,,)
        (Text
 -> Text
 -> CombIx
 -> StoredCache
 -> (Text, Text, CombIx, StoredCache))
-> Get Text
-> Get
     (Text
      -> CombIx -> StoredCache -> (Text, Text, CombIx, StoredCache))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m Text
deserialize
        Get
  (Text
   -> CombIx -> StoredCache -> (Text, Text, CombIx, StoredCache))
-> Get Text
-> Get (CombIx -> StoredCache -> (Text, Text, CombIx, StoredCache))
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Text
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m Text
deserialize
        Get (CombIx -> StoredCache -> (Text, Text, CombIx, StoredCache))
-> Get CombIx
-> Get (StoredCache -> (Text, Text, CombIx, StoredCache))
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get CombIx
forall (m :: * -> *). MonadGet m => m CombIx
getCombIx
        Get (StoredCache -> (Text, Text, CombIx, StoredCache))
-> Get StoredCache -> Get (Text, Text, CombIx, StoredCache)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get StoredCache
forall (m :: * -> *). MonadGet m => m StoredCache
getStoredCache

-- | Whether the runtime is hosted within a persistent session or as a one-off process.
-- This affects the amount of clean-up and book-keeping the runtime does.
data RuntimeHost
  = OneOff
  | Persistent

startRuntime :: Bool -> RuntimeHost -> Text -> IO (Runtime Symbol)
startRuntime :: Bool -> RuntimeHost -> Text -> IO (Runtime Symbol)
startRuntime Bool
sandboxed RuntimeHost
runtimeHost Text
version = do
  IORef EvalCtx
ctxVar <- EvalCtx -> IO (IORef EvalCtx)
forall a. a -> IO (IORef a)
newIORef (EvalCtx -> IO (IORef EvalCtx)) -> IO EvalCtx -> IO (IORef EvalCtx)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> IO EvalCtx
baseContext Bool
sandboxed
  (ActiveThreads
activeThreads, IO ()
cleanupThreads) <- case RuntimeHost
runtimeHost of
    -- Don't bother tracking open threads when running standalone, they'll all be cleaned up
    -- when the process itself exits.
    RuntimeHost
OneOff -> (ActiveThreads, IO ()) -> IO (ActiveThreads, IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ActiveThreads
forall a. Maybe a
Nothing, () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    -- Track all forked threads so that they can be killed when the main process returns,
    -- otherwise they'll be orphaned and left running.
    RuntimeHost
Persistent -> do
      IORef (Set ThreadId)
activeThreads <- Set ThreadId -> IO (IORef (Set ThreadId))
forall a. a -> IO (IORef a)
newIORef Set ThreadId
forall a. Set a
Set.empty
      let cleanupThreads :: IO ()
cleanupThreads = do
            Set ThreadId
threads <- IORef (Set ThreadId) -> IO (Set ThreadId)
forall a. IORef a -> IO a
readIORef IORef (Set ThreadId)
activeThreads
            (ThreadId -> IO ()) -> Set ThreadId -> IO ()
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
UnliftIO.killThread Set ThreadId
threads
      (ActiveThreads, IO ()) -> IO (ActiveThreads, IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IORef (Set ThreadId) -> ActiveThreads
forall a. a -> Maybe a
Just IORef (Set ThreadId)
activeThreads, IO ()
cleanupThreads)
  pure $
    Runtime
      { $sel:terminate:Runtime :: IO ()
terminate = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
        $sel:evaluate:Runtime :: CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> ProfileSpec
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
evaluate = ActiveThreads
-> IO ()
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> ProfileSpec
-> Term Symbol
-> IO (Either Error (Response DecompError, Term Symbol))
interpEval ActiveThreads
activeThreads IO ()
cleanupThreads IORef EvalCtx
ctxVar,
        $sel:compileTo:Runtime :: CompileOpts
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Reference
-> [Char]
-> IO (Maybe Error)
compileTo = Text
-> IORef EvalCtx
-> CompileOpts
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Reference
-> [Char]
-> IO (Maybe Error)
interpCompile Text
version IORef EvalCtx
ctxVar,
        $sel:mainType:Runtime :: Type Symbol Ann
mainType = Ann -> Type Symbol Ann
forall v a. Var v => a -> Type v a
builtinMain Ann
External,
        $sel:ioTestTypes:Runtime :: NESet (Type Symbol Ann)
ioTestTypes = Ann -> NESet (Type Symbol Ann)
forall v a. (Ord v, Var v) => a -> NESet (Type v a)
builtinIOTestTypes Ann
External
      }

withRuntime :: (MonadUnliftIO m) => Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
withRuntime :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Bool -> RuntimeHost -> Text -> (Runtime Symbol -> m a) -> m a
withRuntime Bool
sandboxed RuntimeHost
runtimeHost Text
version Runtime Symbol -> m a
action =
  m (Runtime Symbol)
-> (Runtime Symbol -> m ()) -> (Runtime Symbol -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket (IO (Runtime Symbol) -> m (Runtime Symbol)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Runtime Symbol) -> m (Runtime Symbol))
-> IO (Runtime Symbol) -> m (Runtime Symbol)
forall a b. (a -> b) -> a -> b
$ Bool -> RuntimeHost -> Text -> IO (Runtime Symbol)
startRuntime Bool
sandboxed RuntimeHost
runtimeHost Text
version) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Runtime Symbol -> IO ()) -> Runtime Symbol -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Runtime Symbol -> IO ()
forall {e} {e'} {v}. Runtime e e' v -> IO ()
terminate) Runtime Symbol -> m a
action

tryM :: IO () -> IO (Maybe Error)
tryM :: IO () -> IO (Maybe Error)
tryM =
  (IO (Maybe Error)
 -> (RuntimeExn -> IO (Maybe Error)) -> IO (Maybe Error))
-> (RuntimeExn -> IO (Maybe Error))
-> IO (Maybe Error)
-> IO (Maybe Error)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Maybe Error)
-> (RuntimeExn -> IO (Maybe Error)) -> IO (Maybe Error)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
UnliftIO.catch (Maybe Error -> IO (Maybe Error)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Error -> IO (Maybe Error))
-> (RuntimeExn -> Maybe Error) -> RuntimeExn -> IO (Maybe Error)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Maybe Error
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Maybe Error)
-> (RuntimeExn -> Error) -> RuntimeExn -> Maybe Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe
  (PrettyPrintEnv, Reference -> Reference,
   Val -> DecompResult Symbol)
-> RuntimeExn -> Error
RuntimeExn Maybe
  (PrettyPrintEnv, Reference -> Reference,
   Val -> DecompResult Symbol)
forall a. Maybe a
Nothing)
    (IO (Maybe Error) -> IO (Maybe Error))
-> (IO () -> IO (Maybe Error)) -> IO () -> IO (Maybe Error)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (Maybe Error)
 -> (CompileExn -> IO (Maybe Error)) -> IO (Maybe Error))
-> (CompileExn -> IO (Maybe Error))
-> IO (Maybe Error)
-> IO (Maybe Error)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Maybe Error)
-> (CompileExn -> IO (Maybe Error)) -> IO (Maybe Error)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
UnliftIO.catch (Maybe Error -> IO (Maybe Error)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Error -> IO (Maybe Error))
-> (CompileExn -> Maybe Error) -> CompileExn -> IO (Maybe Error)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Maybe Error
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Maybe Error)
-> (CompileExn -> Error) -> CompileExn -> Maybe Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileExn -> Error
CompileExn)
    (IO (Maybe Error) -> IO (Maybe Error))
-> (IO () -> IO (Maybe Error)) -> IO () -> IO (Maybe Error)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> Maybe Error) -> IO () -> IO (Maybe Error)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Error -> () -> Maybe Error
forall a b. a -> b -> a
const Maybe Error
forall a. Maybe a
Nothing)

runStandalone :: Bool -> StoredCache -> CombIx -> IO (Either Error ())
runStandalone :: Bool -> StoredCache -> CombIx -> IO (Either Error ())
runStandalone Bool
sandboxed StoredCache
sc CombIx
init =
  Bool -> StoredCache -> IO (CCache ())
restoreCache Bool
sandboxed StoredCache
sc IO (CCache ())
-> (CCache () -> IO (Either Error ())) -> IO (Either Error ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CombIx -> CCache () -> IO (Either Error ())
executeMainComb CombIx
init

-- | A version of the Code Cache designed to be serialized to disk as
-- standalone bytecode.
data StoredCache
  = SCache
      (EnumMap Word64 Combs)
      (EnumMap Word64 Reference)
      (EnumSet Word64)
      (OptInfos Reference Symbol)
      (EnumMap Word64 Reference)
      Word64
      Word64
      (Map Reference (SuperGroup Reference Symbol))
      (Map Reference Word64)
      (Map Reference Word64)
      (Map Reference (Set Reference))
  deriving (Int -> StoredCache -> [Char] -> [Char]
[StoredCache] -> [Char] -> [Char]
StoredCache -> [Char]
(Int -> StoredCache -> [Char] -> [Char])
-> (StoredCache -> [Char])
-> ([StoredCache] -> [Char] -> [Char])
-> Show StoredCache
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> StoredCache -> [Char] -> [Char]
showsPrec :: Int -> StoredCache -> [Char] -> [Char]
$cshow :: StoredCache -> [Char]
show :: StoredCache -> [Char]
$cshowList :: [StoredCache] -> [Char] -> [Char]
showList :: [StoredCache] -> [Char] -> [Char]
Show, StoredCache -> StoredCache -> Bool
(StoredCache -> StoredCache -> Bool)
-> (StoredCache -> StoredCache -> Bool) -> Eq StoredCache
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoredCache -> StoredCache -> Bool
== :: StoredCache -> StoredCache -> Bool
$c/= :: StoredCache -> StoredCache -> Bool
/= :: StoredCache -> StoredCache -> Bool
Eq)

putStoredCache :: (MonadPut m) => StoredCache -> m ()
putStoredCache :: forall (m :: * -> *). MonadPut m => StoredCache -> m ()
putStoredCache (SCache EnumMap Word64 Combs
cs EnumMap Word64 Reference
crs EnumSet Word64
cacheableCombs OptInfos Reference Symbol
oinfo EnumMap Word64 Reference
trs Word64
ftm Word64
fty Map Reference (SuperGroup Reference Symbol)
int Map Reference Word64
rtm Map Reference Word64
rty Map Reference (Set Reference)
sbs) = do
  (Word64 -> m ()) -> (Combs -> m ()) -> EnumMap Word64 Combs -> m ()
forall (m :: * -> *) k v.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> (v -> m ()) -> EnumMap k v -> m ()
putEnumMap Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat ((Word64 -> m ()) -> (GComb Void CombIx -> m ()) -> Combs -> m ()
forall (m :: * -> *) k v.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> (v -> m ()) -> EnumMap k v -> m ()
putEnumMap Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat ((Void -> m ()) -> GComb Void CombIx -> m ()
forall (m :: * -> *) clos comb.
MonadPut m =>
(clos -> m ()) -> GComb clos comb -> m ()
putComb Void -> m ()
forall a. Void -> a
absurd)) EnumMap Word64 Combs
cs
  (Word64 -> m ())
-> (Reference -> m ()) -> EnumMap Word64 Reference -> m ()
forall (m :: * -> *) k v.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> (v -> m ()) -> EnumMap k v -> m ()
putEnumMap Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat Reference -> m ()
forall (m :: * -> *). MonadPut m => Reference -> m ()
putReference EnumMap Word64 Reference
crs
  (Word64 -> m ()) -> EnumSet Word64 -> m ()
forall (m :: * -> *) k.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> EnumSet k -> m ()
putEnumSet Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat EnumSet Word64
cacheableCombs
  OptInfos Reference Symbol -> m ()
forall (m :: * -> *) v.
(MonadPut m, Var v) =>
OptInfos Reference v -> m ()
putOptInfos OptInfos Reference Symbol
oinfo
  (Word64 -> m ())
-> (Reference -> m ()) -> EnumMap Word64 Reference -> m ()
forall (m :: * -> *) k v.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> (v -> m ()) -> EnumMap k v -> m ()
putEnumMap Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat Reference -> m ()
forall (m :: * -> *). MonadPut m => Reference -> m ()
putReference EnumMap Word64 Reference
trs
  Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat Word64
ftm
  Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat Word64
fty
  (Reference -> m ())
-> (SuperGroup Reference Symbol -> m ())
-> Map Reference (SuperGroup Reference Symbol)
-> m ()
forall (m :: * -> *) a b.
MonadPut m =>
(a -> m ()) -> (b -> m ()) -> Map a b -> m ()
putMap Reference -> m ()
forall (m :: * -> *). MonadPut m => Reference -> m ()
putReference (Map Reference Word64 -> Bool -> SuperGroup Reference Symbol -> m ()
forall (m :: * -> *) v.
(MonadPut m, Var v) =>
Map Reference Word64 -> Bool -> SuperGroup Reference v -> m ()
putGroup Map Reference Word64
forall a. Monoid a => a
mempty Bool
False) Map Reference (SuperGroup Reference Symbol)
int
  (Reference -> m ())
-> (Word64 -> m ()) -> Map Reference Word64 -> m ()
forall (m :: * -> *) a b.
MonadPut m =>
(a -> m ()) -> (b -> m ()) -> Map a b -> m ()
putMap Reference -> m ()
forall (m :: * -> *). MonadPut m => Reference -> m ()
putReference Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat Map Reference Word64
rtm
  (Reference -> m ())
-> (Word64 -> m ()) -> Map Reference Word64 -> m ()
forall (m :: * -> *) a b.
MonadPut m =>
(a -> m ()) -> (b -> m ()) -> Map a b -> m ()
putMap Reference -> m ()
forall (m :: * -> *). MonadPut m => Reference -> m ()
putReference Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat Map Reference Word64
rty
  (Reference -> m ())
-> (Set Reference -> m ()) -> Map Reference (Set Reference) -> m ()
forall (m :: * -> *) a b.
MonadPut m =>
(a -> m ()) -> (b -> m ()) -> Map a b -> m ()
putMap Reference -> m ()
forall (m :: * -> *). MonadPut m => Reference -> m ()
putReference ((Reference -> m ()) -> Set Reference -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadPut m) =>
(a -> m ()) -> f a -> m ()
putFoldable Reference -> m ()
forall (m :: * -> *). MonadPut m => Reference -> m ()
putReference) Map Reference (Set Reference)
sbs

getStoredCache :: (MonadGet m) => m StoredCache
getStoredCache :: forall (m :: * -> *). MonadGet m => m StoredCache
getStoredCache =
  EnumMap Word64 Combs
-> EnumMap Word64 Reference
-> EnumSet Word64
-> OptInfos Reference Symbol
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
SCache
    (EnumMap Word64 Combs
 -> EnumMap Word64 Reference
 -> EnumSet Word64
 -> OptInfos Reference Symbol
 -> EnumMap Word64 Reference
 -> Word64
 -> Word64
 -> Map Reference (SuperGroup Reference Symbol)
 -> Map Reference Word64
 -> Map Reference Word64
 -> Map Reference (Set Reference)
 -> StoredCache)
-> m (EnumMap Word64 Combs)
-> m (EnumMap Word64 Reference
      -> EnumSet Word64
      -> OptInfos Reference Symbol
      -> EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64 -> m Combs -> m (EnumMap Word64 Combs)
forall (m :: * -> *) k v.
(MonadGet m, EnumKey k) =>
m k -> m v -> m (EnumMap k v)
getEnumMap m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat (m Word64 -> m (GComb Void CombIx) -> m Combs
forall (m :: * -> *) k v.
(MonadGet m, EnumKey k) =>
m k -> m v -> m (EnumMap k v)
getEnumMap m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat m (GComb Void CombIx)
forall (m :: * -> *). MonadGet m => m (GComb Void CombIx)
getComb)
    m (EnumMap Word64 Reference
   -> EnumSet Word64
   -> OptInfos Reference Symbol
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (EnumMap Word64 Reference)
-> m (EnumSet Word64
      -> OptInfos Reference Symbol
      -> EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Word64 -> m Reference -> m (EnumMap Word64 Reference)
forall (m :: * -> *) k v.
(MonadGet m, EnumKey k) =>
m k -> m v -> m (EnumMap k v)
getEnumMap m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat m Reference
forall (m :: * -> *). MonadGet m => m Reference
getReference
    m (EnumSet Word64
   -> OptInfos Reference Symbol
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (EnumSet Word64)
-> m (OptInfos Reference Symbol
      -> EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Word64 -> m (EnumSet Word64)
forall (m :: * -> *) k.
(MonadGet m, EnumKey k) =>
m k -> m (EnumSet k)
getEnumSet m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat
    m (OptInfos Reference Symbol
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (OptInfos Reference Symbol)
-> m (EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (OptInfos Reference Symbol)
forall (m :: * -> *) v.
(MonadGet m, Var v) =>
m (OptInfos Reference v)
getOptInfos
    m (EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (EnumMap Word64 Reference)
-> m (Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Word64 -> m Reference -> m (EnumMap Word64 Reference)
forall (m :: * -> *) k v.
(MonadGet m, EnumKey k) =>
m k -> m v -> m (EnumMap k v)
getEnumMap m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat m Reference
forall (m :: * -> *). MonadGet m => m Reference
getReference
    m (Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m Word64
-> m (Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat
    m (Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m Word64
-> m (Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat
    m (Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (Map Reference (SuperGroup Reference Symbol))
-> m (Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Reference
-> m (SuperGroup Reference Symbol)
-> m (Map Reference (SuperGroup Reference Symbol))
forall (m :: * -> *) a b.
(MonadGet m, Ord a) =>
m a -> m b -> m (Map a b)
getMap m Reference
forall (m :: * -> *). MonadGet m => m Reference
getReference m (SuperGroup Reference Symbol)
forall (m :: * -> *) v.
(MonadGet m, Var v) =>
m (SuperGroup Reference v)
getGroupCurrent
    m (Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (Map Reference Word64)
-> m (Map Reference Word64
      -> Map Reference (Set Reference) -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Reference -> m Word64 -> m (Map Reference Word64)
forall (m :: * -> *) a b.
(MonadGet m, Ord a) =>
m a -> m b -> m (Map a b)
getMap m Reference
forall (m :: * -> *). MonadGet m => m Reference
getReference m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat
    m (Map Reference Word64
   -> Map Reference (Set Reference) -> StoredCache)
-> m (Map Reference Word64)
-> m (Map Reference (Set Reference) -> StoredCache)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Reference -> m Word64 -> m (Map Reference Word64)
forall (m :: * -> *) a b.
(MonadGet m, Ord a) =>
m a -> m b -> m (Map a b)
getMap m Reference
forall (m :: * -> *). MonadGet m => m Reference
getReference m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat
    m (Map Reference (Set Reference) -> StoredCache)
-> m (Map Reference (Set Reference)) -> m StoredCache
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Reference
-> m (Set Reference) -> m (Map Reference (Set Reference))
forall (m :: * -> *) a b.
(MonadGet m, Ord a) =>
m a -> m b -> m (Map a b)
getMap m Reference
forall (m :: * -> *). MonadGet m => m Reference
getReference ([Reference] -> Set Reference
forall a. Ord a => [a] -> Set a
fromList ([Reference] -> Set Reference)
-> m [Reference] -> m (Set Reference)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Reference -> m [Reference]
forall (m :: * -> *) a. MonadGet m => m a -> m [a]
getList m Reference
forall (m :: * -> *). MonadGet m => m Reference
getReference)

debugTextFormat :: Bool -> Pretty ColorText -> String
debugTextFormat :: Bool -> Pretty ColorText -> [Char]
debugTextFormat Bool
fancy =
  Width -> Pretty ColorText -> [Char]
render Width
50
  where
    render :: Width -> Pretty ColorText -> [Char]
render = if Bool
fancy then Width -> Pretty ColorText -> [Char]
toANSI else Width -> Pretty ColorText -> [Char]
toPlain

restoreCache :: Bool -> StoredCache -> IO (CCache ())
restoreCache :: Bool -> StoredCache -> IO (CCache ())
restoreCache Bool
sandboxed (SCache EnumMap Word64 Combs
cs EnumMap Word64 Reference
crs EnumSet Word64
cacheableCombs OptInfos Reference Symbol
opt EnumMap Word64 Reference
trs Word64
ftm Word64
fty Map Reference (SuperGroup Reference Symbol)
int Map Reference Word64
rtm Map Reference Word64
rty Map Reference (Set Reference)
sbs) = do
  CCache ()
cc <-
    Bool
-> (Bool -> Val -> Tracer)
-> ()
-> TVar (EnumMap Word64 Combs)
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumSet Word64)
-> TVar (OptInfos Reference Symbol)
-> TVar (EnumMap Word64 Reference)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Reference Symbol))
-> TVar (Map Reference Word64)
-> TVar (Map Reference Word64)
-> TVar (Map Reference (Set Reference))
-> CCache ()
forall prof.
Bool
-> (Bool -> Val -> Tracer)
-> prof
-> TVar (EnumMap Word64 Combs)
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumSet Word64)
-> TVar (OptInfos Reference Symbol)
-> TVar (EnumMap Word64 Reference)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Reference Symbol))
-> TVar (Map Reference Word64)
-> TVar (Map Reference Word64)
-> TVar (Map Reference (Set Reference))
-> CCache prof
CCache Bool
sandboxed Bool -> Val -> Tracer
debugText ()
      (TVar (EnumMap Word64 Combs)
 -> TVar (EnumMap Word64 MCombs)
 -> TVar (EnumMap Word64 Reference)
 -> TVar (EnumSet Word64)
 -> TVar (OptInfos Reference Symbol)
 -> TVar (EnumMap Word64 Reference)
 -> TVar Word64
 -> TVar Word64
 -> TVar (Map Reference (SuperGroup Reference Symbol))
 -> TVar (Map Reference Word64)
 -> TVar (Map Reference Word64)
 -> TVar (Map Reference (Set Reference))
 -> CCache ())
-> IO (TVar (EnumMap Word64 Combs))
-> IO
     (TVar (EnumMap Word64 MCombs)
      -> TVar (EnumMap Word64 Reference)
      -> TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap Word64 Combs -> IO (TVar (EnumMap Word64 Combs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 Combs
srcCombs
      IO
  (TVar (EnumMap Word64 MCombs)
   -> TVar (EnumMap Word64 Reference)
   -> TVar (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (EnumMap Word64 MCombs))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 MCombs -> IO (TVar (EnumMap Word64 MCombs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 MCombs
combs
      IO
  (TVar (EnumMap Word64 Reference)
   -> TVar (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (EnumMap Word64 Reference))
-> IO
     (TVar (EnumSet Word64)
      -> TVar (OptInfos Reference Symbol)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 Reference -> IO (TVar (EnumMap Word64 Reference))
forall a. a -> IO (TVar a)
newTVarIO (EnumMap Word64 Reference
crs EnumMap Word64 Reference
-> EnumMap Word64 Reference -> EnumMap Word64 Reference
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Reference
builtinTermBackref)
      IO
  (TVar (EnumSet Word64)
   -> TVar (OptInfos Reference Symbol)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (EnumSet Word64))
-> IO
     (TVar (OptInfos Reference Symbol)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumSet Word64 -> IO (TVar (EnumSet Word64))
forall a. a -> IO (TVar a)
newTVarIO EnumSet Word64
cacheableCombs
      IO
  (TVar (OptInfos Reference Symbol)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (OptInfos Reference Symbol))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OptInfos Reference Symbol -> IO (TVar (OptInfos Reference Symbol))
forall a. a -> IO (TVar a)
newTVarIO (OptInfos Reference Symbol
opt OptInfos Reference Symbol
-> OptInfos Reference Symbol -> OptInfos Reference Symbol
forall a. Semigroup a => a -> a -> a
<> OptInfos Reference Symbol
builtinOptInfo)
      IO
  (TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (EnumMap Word64 Reference))
-> IO
     (TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 Reference -> IO (TVar (EnumMap Word64 Reference))
forall a. a -> IO (TVar a)
newTVarIO (EnumMap Word64 Reference
trs EnumMap Word64 Reference
-> EnumMap Word64 Reference -> EnumMap Word64 Reference
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Reference
builtinTypeBackref)
      IO
  (TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar Word64)
-> IO
     (TVar Word64
      -> TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word64 -> IO (TVar Word64)
forall a. a -> IO (TVar a)
newTVarIO Word64
ftm
      IO
  (TVar Word64
   -> TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar Word64)
-> IO
     (TVar (Map Reference (SuperGroup Reference Symbol))
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word64 -> IO (TVar Word64)
forall a. a -> IO (TVar a)
newTVarIO Word64
fty
      IO
  (TVar (Map Reference (SuperGroup Reference Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (Map Reference (SuperGroup Reference Symbol)))
-> IO
     (TVar (Map Reference Word64)
      -> TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference))
      -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference (SuperGroup Reference Symbol)
-> IO (TVar (Map Reference (SuperGroup Reference Symbol)))
forall a. a -> IO (TVar a)
newTVarIO Map Reference (SuperGroup Reference Symbol)
int
      IO
  (TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache ())
-> IO (TVar (Map Reference Word64))
-> IO
     (TVar (Map Reference Word64)
      -> TVar (Map Reference (Set Reference)) -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference Word64 -> IO (TVar (Map Reference Word64))
forall a. a -> IO (TVar a)
newTVarIO (Map Reference Word64
rtm Map Reference Word64
-> Map Reference Word64 -> Map Reference Word64
forall a. Semigroup a => a -> a -> a
<> Map Reference Word64
builtinTermNumbering)
      IO
  (TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference)) -> CCache ())
-> IO (TVar (Map Reference Word64))
-> IO (TVar (Map Reference (Set Reference)) -> CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference Word64 -> IO (TVar (Map Reference Word64))
forall a. a -> IO (TVar a)
newTVarIO (Map Reference Word64
rty Map Reference Word64
-> Map Reference Word64 -> Map Reference Word64
forall a. Semigroup a => a -> a -> a
<> Map Reference Word64
builtinTypeNumbering)
      IO (TVar (Map Reference (Set Reference)) -> CCache ())
-> IO (TVar (Map Reference (Set Reference))) -> IO (CCache ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Reference (Set Reference)
-> IO (TVar (Map Reference (Set Reference)))
forall a. a -> IO (TVar a)
newTVarIO (Map Reference (Set Reference)
sbs Map Reference (Set Reference)
-> Map Reference (Set Reference) -> Map Reference (Set Reference)
forall a. Semigroup a => a -> a -> a
<> Map Reference (Set Reference)
baseSandboxInfo)
  let (EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs) =
        EnumMap Word64 Combs
srcCombs
          EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 Combs)
-> EnumMap Word64 Combs
forall a b. a -> (a -> b) -> b
& Bool
-> Set ForeignFunc -> EnumMap Word64 Combs -> EnumMap Word64 Combs
sanitizeCombsOfForeignFuncs Bool
sandboxed Set ForeignFunc
sandboxedForeignFuncs
          EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx))
-> EnumMap Word64 (GCombs Val CombIx)
forall a b. a -> (a -> b) -> b
& EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx)
forall cix any.
EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
absurdCombs
          EnumMap Word64 (GCombs Val CombIx)
-> (EnumMap Word64 (GCombs Val CombIx)
    -> [(Word64, GCombs Val CombIx)])
-> [(Word64, GCombs Val CombIx)]
forall a b. a -> (a -> b) -> b
& EnumMap Word64 (GCombs Val CombIx) -> [(Word64, GCombs Val CombIx)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList
          [(Word64, GCombs Val CombIx)]
-> ([(Word64, GCombs Val CombIx)]
    -> (EnumMap Word64 (GCombs Val CombIx),
        EnumMap Word64 (GCombs Val CombIx)))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> (a -> b) -> b
& ((Word64, GCombs Val CombIx)
 -> (EnumMap Word64 (GCombs Val CombIx),
     EnumMap Word64 (GCombs Val CombIx)))
-> [(Word64, GCombs Val CombIx)]
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
            ( \(Word64
k, GCombs Val CombIx
v) ->
                if Word64
k Word64 -> EnumSet Word64 -> Bool
forall k. EnumKey k => k -> EnumSet k -> Bool
`member` EnumSet Word64
cacheableCombs
                  then (Word64 -> GCombs Val CombIx -> EnumMap Word64 (GCombs Val CombIx)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
k GCombs Val CombIx
v, EnumMap Word64 (GCombs Val CombIx)
forall a. Monoid a => a
mempty)
                  else (EnumMap Word64 (GCombs Val CombIx)
forall a. Monoid a => a
mempty, Word64 -> GCombs Val CombIx -> EnumMap Word64 (GCombs Val CombIx)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
k GCombs Val CombIx
v)
            )
  EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx) -> CCache () -> IO ()
forall p.
RuntimeProfiler p =>
EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx) -> CCache p -> IO ()
preEvalTopLevelConstants EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs CCache ()
cc
  pure CCache ()
cc
  where
    decom :: Val -> DecompResult Symbol
decom =
      (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Val
-> DecompResult Symbol
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile
        (Maybe Reference -> Reference -> Maybe Reference
forall a b. a -> b -> a
const Maybe Reference
forall a. Maybe a
Nothing)
        (EnumMap Word64 Reference
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm EnumMap Word64 Reference
crs Remapping Reference Reference
forall a. Monoid a => a
mempty Remapping Reference Reference
forall a. Monoid a => a
mempty Map Reference (Map Word64 (Term Symbol))
forall a. Monoid a => a
mempty)
    debugText :: Bool -> Val -> Tracer
debugText Bool
fancy Val
c = case Val -> DecompResult Symbol
decom Val
c of
      (Set DecompError
errs, Term Symbol
dv)
        | Set DecompError -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set DecompError
errs ->
            [Char] -> Tracer
SimpleTrace ([Char] -> Tracer)
-> (Pretty ColorText -> [Char]) -> Pretty ColorText -> Tracer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty ColorText -> [Char]
debugTextFormat Bool
fancy (Pretty ColorText -> Tracer) -> Pretty ColorText -> Tracer
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
PPE.empty Term Symbol
dv
        | Bool
otherwise ->
            [Char] -> [Char] -> [Char] -> Tracer
MsgTrace
              (Bool -> Pretty ColorText -> [Char]
debugTextFormat Bool
fancy (Pretty ColorText -> [Char]) -> Pretty ColorText -> [Char]
forall a b. (a -> b) -> a -> b
$ Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs)
              (Val -> [Char]
forall a. Show a => a -> [Char]
show Val
c)
              (Bool -> Pretty ColorText -> [Char]
debugTextFormat Bool
fancy (Pretty ColorText -> [Char]) -> Pretty ColorText -> [Char]
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
PPE.empty Term Symbol
dv)
    rns :: RefNums
rns = RefNums
emptyRNs {dnum = refLookup "ty" builtinTypeNumbering}
    rf :: Word64 -> Reference
rf Word64
k = EnumMap Word64 Reference
builtinTermBackref EnumMap Word64 Reference -> Word64 -> Reference
forall k a. EnumKey k => EnumMap k a -> k -> a
! Word64
k
    srcCombs :: EnumMap Word64 Combs
    srcCombs :: EnumMap Word64 Combs
srcCombs =
      let builtinCombs :: EnumMap Word64 Combs
builtinCombs = (Word64 -> SuperNormal Reference Symbol -> Combs)
-> EnumMap Word64 (SuperNormal Reference Symbol)
-> EnumMap Word64 Combs
forall k a b.
EnumKey k =>
(k -> a -> b) -> EnumMap k a -> EnumMap k b
mapWithKey (\Word64
k SuperNormal Reference Symbol
v -> forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal Reference v)
-> Combs
emitComb @Symbol RefNums
rns (Word64 -> Reference
rf Word64
k) Word64
k RCtx Symbol
forall a. Monoid a => a
mempty (Word64
0, SuperNormal Reference Symbol
v)) EnumMap Word64 (SuperNormal Reference Symbol)
numberedTermLookup
       in EnumMap Word64 Combs
builtinCombs EnumMap Word64 Combs
-> EnumMap Word64 Combs -> EnumMap Word64 Combs
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Combs
cs
    combs :: EnumMap Word64 (RCombs Val)
    combs :: EnumMap Word64 MCombs
combs =
      EnumMap Word64 Combs
srcCombs
        EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 Combs)
-> EnumMap Word64 Combs
forall a b. a -> (a -> b) -> b
& Bool
-> Set ForeignFunc -> EnumMap Word64 Combs -> EnumMap Word64 Combs
sanitizeCombsOfForeignFuncs Bool
sandboxed Set ForeignFunc
sandboxedForeignFuncs
        EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx))
-> EnumMap Word64 (GCombs Val CombIx)
forall a b. a -> (a -> b) -> b
& EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx)
forall cix any.
EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
absurdCombs
        EnumMap Word64 (GCombs Val CombIx)
-> (EnumMap Word64 (GCombs Val CombIx) -> EnumMap Word64 MCombs)
-> EnumMap Word64 MCombs
forall a b. a -> (a -> b) -> b
& Maybe (EnumMap Word64 MCombs)
-> EnumMap Word64 (GCombs Val CombIx) -> EnumMap Word64 MCombs
forall val.
Maybe (EnumMap Word64 (RCombs val))
-> EnumMap Word64 (GCombs val CombIx)
-> EnumMap Word64 (RCombs val)
resolveCombs Maybe (EnumMap Word64 MCombs)
forall a. Maybe a
Nothing

traceNeeded ::
  Reference ->
  Map Reference (SuperGroup Reference Symbol) ->
  IO (Map Reference (SuperGroup Reference Symbol))
traceNeeded :: Reference
-> Map Reference (SuperGroup Reference Symbol)
-> IO (Map Reference (SuperGroup Reference Symbol))
traceNeeded Reference
init Map Reference (SuperGroup Reference Symbol)
src = Map Reference (SuperGroup Reference Symbol)
-> Reference -> IO (Map Reference (SuperGroup Reference Symbol))
go Map Reference (SuperGroup Reference Symbol)
forall a. Monoid a => a
mempty Reference
init
  where
    go :: Map Reference (SuperGroup Reference Symbol)
-> Reference -> IO (Map Reference (SuperGroup Reference Symbol))
go Map Reference (SuperGroup Reference Symbol)
acc Reference
nx
      | Reference -> Bool
RF.isBuiltin Reference
nx = Map Reference (SuperGroup Reference Symbol)
-> IO (Map Reference (SuperGroup Reference Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Reference (SuperGroup Reference Symbol)
acc
      | Reference -> Map Reference (SuperGroup Reference Symbol) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Reference
nx Map Reference (SuperGroup Reference Symbol)
acc = Map Reference (SuperGroup Reference Symbol)
-> IO (Map Reference (SuperGroup Reference Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Reference (SuperGroup Reference Symbol)
acc
      | Just SuperGroup Reference Symbol
co <- Reference
-> Map Reference (SuperGroup Reference Symbol)
-> Maybe (SuperGroup Reference Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
nx Map Reference (SuperGroup Reference Symbol)
src =
          (Map Reference (SuperGroup Reference Symbol)
 -> Reference -> IO (Map Reference (SuperGroup Reference Symbol)))
-> Map Reference (SuperGroup Reference Symbol)
-> [Reference]
-> IO (Map Reference (SuperGroup Reference Symbol))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Map Reference (SuperGroup Reference Symbol)
-> Reference -> IO (Map Reference (SuperGroup Reference Symbol))
go (Reference
-> SuperGroup Reference Symbol
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference (SuperGroup Reference Symbol)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Reference
nx SuperGroup Reference Symbol
co Map Reference (SuperGroup Reference Symbol)
acc) (SuperGroup Reference Symbol -> [Reference]
forall ref v. (Ord ref, Var v) => SuperGroup ref v -> [ref]
groupTermLinks SuperGroup Reference Symbol
co)
      | Bool
otherwise =
          [Word]
-> [Char] -> IO (Map Reference (SuperGroup Reference Symbol))
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (Map Reference (SuperGroup Reference Symbol)))
-> [Char] -> IO (Map Reference (SuperGroup Reference Symbol))
forall a b. (a -> b) -> a -> b
$ [Char]
"traceNeeded: unknown combinator: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Reference -> [Char]
forall a. Show a => a -> [Char]
show Reference
nx

buildSCache ::
  EnumMap Word64 Reference ->
  EnumMap Word64 Combs ->
  EnumSet Word64 ->
  OptInfos Reference Symbol ->
  EnumMap Word64 Reference ->
  Word64 ->
  Word64 ->
  Map Reference (SuperGroup Reference Symbol) ->
  Map Reference Word64 ->
  Map Reference Word64 ->
  Map Reference (Set Reference) ->
  StoredCache
buildSCache :: EnumMap Word64 Reference
-> EnumMap Word64 Combs
-> EnumSet Word64
-> OptInfos Reference Symbol
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
buildSCache EnumMap Word64 Reference
crsrc EnumMap Word64 Combs
cssrc EnumSet Word64
cacheableCombs OptInfos Reference Symbol
optsrc EnumMap Word64 Reference
trsrc Word64
ftm Word64
fty Map Reference (SuperGroup Reference Symbol)
int Map Reference Word64
rtmsrc Map Reference Word64
rtysrc Map Reference (Set Reference)
sndbx =
  EnumMap Word64 Combs
-> EnumMap Word64 Reference
-> EnumSet Word64
-> OptInfos Reference Symbol
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
SCache
    EnumMap Word64 Combs
cs
    EnumMap Word64 Reference
crs
    EnumSet Word64
cacheableCombs
    OptInfos Reference Symbol
opt
    EnumMap Word64 Reference
trs
    Word64
ftm
    Word64
fty
    Map Reference (SuperGroup Reference Symbol)
int
    Map Reference Word64
rtm
    (Map Reference Word64 -> Map Reference Word64
restrictTyR Map Reference Word64
rtysrc)
    (Map Reference (Set Reference) -> Map Reference (Set Reference)
forall a. Map Reference a -> Map Reference a
restrictTmR Map Reference (Set Reference)
sndbx)
  where
    termRefs :: Set Reference
termRefs = Map Reference (SuperGroup Reference Symbol) -> Set Reference
forall k a. Map k a -> Set k
Map.keysSet Map Reference (SuperGroup Reference Symbol)
int

    -- Retain just the Reference->Word mappings for needed code
    rtm :: Map Reference Word64
    rtm :: Map Reference Word64
rtm = Map Reference Word64 -> Map Reference Word64
forall a. Map Reference a -> Map Reference a
restrictTmR Map Reference Word64
rtmsrc

    -- Retain numbers that correspond to the above termRefs
    combKeys :: EnumSet Word64
    combKeys :: EnumSet Word64
combKeys = (Word64 -> EnumSet Word64)
-> Map Reference Word64 -> EnumSet Word64
forall m a. Monoid m => (a -> m) -> Map Reference a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word64 -> EnumSet Word64
forall k. EnumKey k => k -> EnumSet k
setSingleton Map Reference Word64
rtm

    crs :: EnumMap Word64 Reference
crs = EnumMap Word64 Reference -> EnumMap Word64 Reference
forall a. EnumMap Word64 a -> EnumMap Word64 a
restrictTmW EnumMap Word64 Reference
crsrc

    cs :: EnumMap Word64 Combs
    cs :: EnumMap Word64 Combs
cs = EnumMap Word64 Combs -> EnumMap Word64 Combs
forall a. EnumMap Word64 a -> EnumMap Word64 a
restrictTmW EnumMap Word64 Combs
cssrc

    opt :: OptInfos Reference Symbol
opt = (Map Reference Int -> Map Reference Int)
-> (Map Reference (InlineInfo Reference Symbol)
    -> Map Reference (InlineInfo Reference Symbol))
-> OptInfos Reference Symbol
-> OptInfos Reference Symbol
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Map Reference Int -> Map Reference Int
forall a. Map Reference a -> Map Reference a
restrictTmR Map Reference (InlineInfo Reference Symbol)
-> Map Reference (InlineInfo Reference Symbol)
forall a. Map Reference a -> Map Reference a
restrictTmR OptInfos Reference Symbol
optsrc

    typeKeys :: EnumSet Word64
typeKeys = [Word64] -> EnumSet Word64
forall k. EnumKey k => [k] -> EnumSet k
setFromList ([Word64] -> EnumSet Word64) -> [Word64] -> EnumSet Word64
forall a b. (a -> b) -> a -> b
$ ((Combs -> [Word64]) -> EnumMap Word64 Combs -> [Word64]
forall m a. Monoid m => (a -> m) -> EnumMap Word64 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Combs -> [Word64]) -> EnumMap Word64 Combs -> [Word64])
-> ((GComb Void CombIx -> [Word64]) -> Combs -> [Word64])
-> (GComb Void CombIx -> [Word64])
-> EnumMap Word64 Combs
-> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GComb Void CombIx -> [Word64]) -> Combs -> [Word64]
forall m a. Monoid m => (a -> m) -> EnumMap Word64 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) GComb Void CombIx -> [Word64]
forall any comb. GComb any comb -> [Word64]
combTypes EnumMap Word64 Combs
cs
    trs :: EnumMap Word64 Reference
trs = EnumMap Word64 Reference -> EnumMap Word64 Reference
forall a. EnumMap Word64 a -> EnumMap Word64 a
restrictTyW EnumMap Word64 Reference
trsrc
    typeRefs :: Set Reference
typeRefs = (Reference -> Set Reference)
-> EnumMap Word64 Reference -> Set Reference
forall m a. Monoid m => (a -> m) -> EnumMap Word64 a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Reference -> Set Reference
forall a. a -> Set a
Set.singleton EnumMap Word64 Reference
trs

    restrictTmW :: EnumMap Word64 a -> EnumMap Word64 a
    restrictTmW :: forall a. EnumMap Word64 a -> EnumMap Word64 a
restrictTmW EnumMap Word64 a
m = EnumMap Word64 a -> EnumSet Word64 -> EnumMap Word64 a
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
restrictKeys EnumMap Word64 a
m EnumSet Word64
combKeys
    restrictTmR :: Map Reference a -> Map Reference a
    restrictTmR :: forall a. Map Reference a -> Map Reference a
restrictTmR Map Reference a
m = Map Reference a -> Set Reference -> Map Reference a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map Reference a
m Set Reference
termRefs

    restrictTyW :: EnumMap Word64 a -> EnumMap Word64 a
restrictTyW EnumMap Word64 a
m = EnumMap Word64 a -> EnumSet Word64 -> EnumMap Word64 a
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
restrictKeys EnumMap Word64 a
m EnumSet Word64
typeKeys
    restrictTyR :: Map Reference Word64 -> Map Reference Word64
restrictTyR Map Reference Word64
m = Map Reference Word64 -> Set Reference -> Map Reference Word64
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map Reference Word64
m Set Reference
typeRefs

standalone :: CCache () -> Word64 -> IO StoredCache
standalone :: CCache () -> Word64 -> IO StoredCache
standalone CCache ()
cc Word64
init =
  TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
combRefs CCache ()
cc) IO (EnumMap Word64 Reference)
-> (EnumMap Word64 Reference -> IO StoredCache) -> IO StoredCache
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EnumMap Word64 Reference
crs ->
    case Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
init EnumMap Word64 Reference
crs of
      Just Reference
rinit ->
        EnumMap Word64 Reference
-> EnumMap Word64 Combs
-> EnumSet Word64
-> OptInfos Reference Symbol
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Reference Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
buildSCache EnumMap Word64 Reference
crs
          (EnumMap Word64 Combs
 -> EnumSet Word64
 -> OptInfos Reference Symbol
 -> EnumMap Word64 Reference
 -> Word64
 -> Word64
 -> Map Reference (SuperGroup Reference Symbol)
 -> Map Reference Word64
 -> Map Reference Word64
 -> Map Reference (Set Reference)
 -> StoredCache)
-> IO (EnumMap Word64 Combs)
-> IO
     (EnumSet Word64
      -> OptInfos Reference Symbol
      -> EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (EnumMap Word64 Combs) -> IO (EnumMap Word64 Combs)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (EnumMap Word64 Combs)
forall prof. CCache prof -> TVar (EnumMap Word64 Combs)
srcCombs CCache ()
cc)
          IO
  (EnumSet Word64
   -> OptInfos Reference Symbol
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (EnumSet Word64)
-> IO
     (OptInfos Reference Symbol
      -> EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (EnumSet Word64) -> IO (EnumSet Word64)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (EnumSet Word64)
forall prof. CCache prof -> TVar (EnumSet Word64)
cacheableCombs CCache ()
cc)
          IO
  (OptInfos Reference Symbol
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (OptInfos Reference Symbol)
-> IO
     (EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (OptInfos Reference Symbol) -> IO (OptInfos Reference Symbol)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (OptInfos Reference Symbol)
forall prof. CCache prof -> TVar (OptInfos Reference Symbol)
optInfos CCache ()
cc)
          IO
  (EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (EnumMap Word64 Reference)
-> IO
     (Word64
      -> Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (EnumMap Word64 Reference)
forall prof. CCache prof -> TVar (EnumMap Word64 Reference)
tagRefs CCache ()
cc)
          IO
  (Word64
   -> Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO Word64
-> IO
     (Word64
      -> Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshTm CCache ()
cc)
          IO
  (Word64
   -> Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO Word64
-> IO
     (Map Reference (SuperGroup Reference Symbol)
      -> Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar Word64
forall prof. CCache prof -> TVar Word64
freshTy CCache ()
cc)
          IO
  (Map Reference (SuperGroup Reference Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (Map Reference (SuperGroup Reference Symbol))
-> IO
     (Map Reference Word64
      -> Map Reference Word64
      -> Map Reference (Set Reference)
      -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TVar (Map Reference (SuperGroup Reference Symbol))
-> IO (Map Reference (SuperGroup Reference Symbol))
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (Map Reference (SuperGroup Reference Symbol))
forall prof.
CCache prof -> TVar (Map Reference (SuperGroup Reference Symbol))
intermed CCache ()
cc) IO (Map Reference (SuperGroup Reference Symbol))
-> (Map Reference (SuperGroup Reference Symbol)
    -> IO (Map Reference (SuperGroup Reference Symbol)))
-> IO (Map Reference (SuperGroup Reference Symbol))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reference
-> Map Reference (SuperGroup Reference Symbol)
-> IO (Map Reference (SuperGroup Reference Symbol))
traceNeeded Reference
rinit)
          IO
  (Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (Map Reference Word64)
-> IO
     (Map Reference Word64
      -> Map Reference (Set Reference) -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTm CCache ()
cc)
          IO
  (Map Reference Word64
   -> Map Reference (Set Reference) -> StoredCache)
-> IO (Map Reference Word64)
-> IO (Map Reference (Set Reference) -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (Map Reference Word64)
forall prof. CCache prof -> TVar (Map Reference Word64)
refTy CCache ()
cc)
          IO (Map Reference (Set Reference) -> StoredCache)
-> IO (Map Reference (Set Reference)) -> IO StoredCache
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Map Reference (Set Reference))
-> IO (Map Reference (Set Reference))
forall a. TVar a -> IO a
readTVarIO (CCache () -> TVar (Map Reference (Set Reference))
forall prof. CCache prof -> TVar (Map Reference (Set Reference))
sandbox CCache ()
cc)
      Maybe Reference
Nothing ->
        [Word] -> [Char] -> IO StoredCache
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO StoredCache) -> [Char] -> IO StoredCache
forall a b. (a -> b) -> a -> b
$ [Char]
"standalone: unknown combinator: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
init

renderDecompError :: DecompError -> Pretty P.ColorText
renderDecompError :: DecompError -> Pretty ColorText
renderDecompError = \case
  Decomp.BadBool Word64
n ->
    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"A boolean value had an unexpected constructor tag:",
        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> ([Char] -> Pretty ColorText) -> [Char] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorText -> Pretty ColorText
forall s. (IsString s, ListLike s Char) => s -> Pretty s
P.lit (ColorText -> Pretty ColorText)
-> ([Char] -> ColorText) -> [Char] -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ColorText
forall a. IsString a => [Char] -> a
fromString ([Char] -> Pretty ColorText) -> [Char] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n
      ]
  Decomp.BadUnboxed UnboxedTypeTag
tt ->
    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"An apparent numeric type had an unrecognized packed tag:",
        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ UnboxedTypeTag -> Pretty ColorText
printUnboxedTypeTag UnboxedTypeTag
tt
      ]
  Decomp.BadForeign Reference
rf ->
    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"A foreign value with no decompiled representation was encountered:",
        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Reference -> Pretty ColorText
prf Reference
rf
      ]
  Decomp.BadData Reference
rf ->
    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"A data type with no decompiled representation was encountered:",
        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Reference -> Pretty ColorText
prf Reference
rf
      ]
  Decomp.BadPAp Reference
rf ->
    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"A partial function application could not be decompiled: ",
        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Reference -> Pretty ColorText
prf Reference
rf
      ]
  Decomp.UnkComb Reference
rf ->
    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"A reference to an unknown function was encountered: ",
        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Reference -> Pretty ColorText
prf Reference
rf
      ]
  Decomp.UnkLocal Reference
rf Word64
n ->
    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Pretty ColorText
"A reference to an unknown portion to a function was encountered: ",
        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"function: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Reference -> Pretty ColorText
prf Reference
rf,
        Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"section: " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> ColorText -> Pretty ColorText
forall s. (IsString s, ListLike s Char) => s -> Pretty s
P.lit ([Char] -> ColorText
forall a. IsString a => [Char] -> a
fromString ([Char] -> ColorText) -> [Char] -> ColorText
forall a b. (a -> b) -> a -> b
$ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n)
      ]
  DecompError
Decomp.Cont -> Pretty ColorText
"A continuation value was encountered"
  DecompError
Decomp.Exn -> Pretty ColorText
"An exception value was encountered"
  DecompError
Decomp.Aff -> Pretty ColorText
"An affine info value was encountered"
  where
    prf :: Reference -> Pretty ColorText
prf = Pretty (SyntaxText' Reference) -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
P.syntaxToColor (Pretty (SyntaxText' Reference) -> Pretty ColorText)
-> (Reference -> Pretty (SyntaxText' Reference))
-> Reference
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Reference -> Pretty (SyntaxText' Reference)
prettyReference Int
10
    printUnboxedTypeTag :: UnboxedTypeTag -> Pretty ColorText
printUnboxedTypeTag = UnboxedTypeTag -> Pretty ColorText
forall a s. (Show a, IsString s) => a -> Pretty s
P.shown

tabulateErrors :: Set DecompError -> Pretty P.ColorText
tabulateErrors :: Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs | Set DecompError -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set DecompError
errs = Pretty ColorText
forall a. Monoid a => a
mempty
tabulateErrors Set DecompError
errs =
  Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
    Pretty ColorText
""
      Pretty ColorText -> [Pretty ColorText] -> [Pretty ColorText]
forall a. a -> [a] -> [a]
: Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"The following errors occured while decompiling:"
      Pretty ColorText -> [Pretty ColorText] -> [Pretty ColorText]
forall a. a -> [a] -> [a]
: (Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> (DecompError -> Pretty ColorText)
-> DecompError
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecompError -> Pretty ColorText
renderDecompError (DecompError -> Pretty ColorText)
-> [DecompError] -> [Pretty ColorText]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set DecompError -> [DecompError]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set DecompError
errs)

formatIssues :: (Applicative f) => (Word -> f (Pretty P.ColorText)) -> [Word] -> f (Pretty P.ColorText)
formatIssues :: forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText)) -> [Word] -> f (Pretty ColorText)
formatIssues Word -> f (Pretty ColorText)
issueFn [Word]
issues = do
  [Pretty ColorText]
issueMessages <- (Word -> f (Pretty ColorText)) -> [Word] -> f [Pretty ColorText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Word -> f (Pretty ColorText)
issueFn [Word]
issues
  pure $
    [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
      if [Word] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Word]
issues
        then [Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"Please report it at https://github.com/unisonweb/unison/issues/new/choose."]
        else
          [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"Please check if one of these known issues matches your situation:",
            Pretty ColorText
"",
            [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, ListLike s Char, IsString s) =>
f (Pretty s) -> Pretty s
P.bulleted [Pretty ColorText]
issueMessages,
            Pretty ColorText
"",
            Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"If not, please open a new one: https://github.com/unisonweb/unison/issues/new/choose"
          ]

prettyRuntimeExn' ::
  (Applicative f) =>
  PrettyPrintEnv ->
  (Reference -> Reference) ->
  (Val -> DecompResult Symbol) ->
  (Word -> f (Pretty P.ColorText)) ->
  RuntimeExn ->
  f (Pretty P.ColorText)
prettyRuntimeExn' :: forall (f :: * -> *).
Applicative f =>
PrettyPrintEnv
-> (Reference -> Reference)
-> (Val -> DecompResult Symbol)
-> (Word -> f (Pretty ColorText))
-> RuntimeExn
-> f (Pretty ColorText)
prettyRuntimeExn' PrettyPrintEnv
ppe Reference -> Reference
backmap Val -> DecompResult Symbol
decom Word -> f (Pretty ColorText)
issueFn = \case
  PE CallStack
_ [Word]
issues Pretty ColorText
err -> do
    Pretty ColorText
issueMessage <- (Word -> f (Pretty ColorText)) -> [Word] -> f (Pretty ColorText)
forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText)) -> [Word] -> f (Pretty ColorText)
formatIssues Word -> f (Pretty ColorText)
issueFn [Word]
issues
    pure $
      Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.fatalCallout (Pretty ColorText -> Pretty ColorText)
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
        [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"Sorry – I’ve encountered a Unison runtime error.",
          Pretty ColorText
"",
          Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 Pretty ColorText
err,
          Pretty ColorText
"",
          Pretty ColorText
issueMessage
        ]
  BU [(Reference, Int)]
tr0 Text
nm Val
c -> Pretty ColorText -> f (Pretty ColorText)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty ColorText -> f (Pretty ColorText))
-> (DecompResult Symbol -> Pretty ColorText)
-> DecompResult Symbol
-> f (Pretty ColorText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Pretty ColorText
"💔💥" (Pretty ColorText -> Pretty ColorText)
-> (DecompResult Symbol -> Pretty ColorText)
-> DecompResult Symbol
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.linesNonEmpty ([Pretty ColorText] -> Pretty ColorText)
-> (DecompResult Symbol -> [Pretty ColorText])
-> DecompResult Symbol
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv
-> [(Reference, Int)]
-> Text
-> DecompResult Symbol
-> [Pretty ColorText]
forall {v} {a} {a}.
(Var v, Num a, Show a, Ord a) =>
PrettyPrintEnv
-> [(Reference, a)]
-> Text
-> (Set DecompError, Term v a)
-> [Pretty ColorText]
bugMsg PrettyPrintEnv
ppe [(Reference, Int)]
tr Text
nm (DecompResult Symbol -> f (Pretty ColorText))
-> DecompResult Symbol -> f (Pretty ColorText)
forall a b. (a -> b) -> a -> b
$ Val -> DecompResult Symbol
decom Val
c
    where
      tr :: [(Reference, Int)]
tr = (Reference -> Reference) -> (Reference, Int) -> (Reference, Int)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Reference -> Reference
backmap ((Reference, Int) -> (Reference, Int))
-> [(Reference, Int)] -> [(Reference, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, Int)]
tr0
  where
    bugMsg :: PrettyPrintEnv
-> [(Reference, a)]
-> Text
-> (Set DecompError, Term v a)
-> [Pretty ColorText]
bugMsg PrettyPrintEnv
ppe [(Reference, a)]
tr Text
name (Set DecompError
errs, Term v a
tm)
      | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"blank expression" =
          [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"I encountered a" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
P.red (Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text Text
name) Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"with the following name/message:",
            Pretty ColorText
"",
            Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term v a -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term v a
tm,
            Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs,
            PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
forall {a}.
(Ord a, Num a, Show a) =>
PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
stackTrace PrettyPrintEnv
ppe [(Reference, a)]
tr
          ]
      | Text
"pattern match failure" Text -> Text -> Bool
`isPrefixOf` Text
name =
          [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"I've encountered a" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
P.red (Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text Text
name) Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"while scrutinizing:",
            Pretty ColorText
"",
            Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term v a -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term v a
tm,
            Pretty ColorText
"",
            Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"This happens when calling a function that doesn't handle all possible inputs",
            Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs,
            PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
forall {a}.
(Ord a, Num a, Show a) =>
PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
stackTrace PrettyPrintEnv
ppe [(Reference, a)]
tr
          ]
      | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"builtin.raise" =
          [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"The program halted with an unhandled exception:",
            Pretty ColorText
"",
            Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term v a -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term v a
tm,
            Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs,
            PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
forall {a}.
(Ord a, Num a, Show a) =>
PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
stackTrace PrettyPrintEnv
ppe [(Reference, a)]
tr
          ]
      | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"builtin.bug",
        RF.TupleTerm' [Tm.Text' Text
msg, Term v a
x] <- Term v a
tm,
        Text
"pattern match failure" Text -> Text -> Bool
`isPrefixOf` Text
msg =
          [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"I've encountered a" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
P.red (Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text Text
msg) Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"while scrutinizing:",
            Pretty ColorText
"",
            Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term v a -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term v a
x,
            Pretty ColorText
"",
            Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"This happens when calling a function that doesn't handle all possible inputs",
            Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs,
            PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
forall {a}.
(Ord a, Num a, Show a) =>
PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
stackTrace PrettyPrintEnv
ppe [(Reference, a)]
tr
          ]
      | Bool
otherwise =
          [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
"I've encountered a call to" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
P.red (Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text Text
name) Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
"with the following value:",
            Pretty ColorText
"",
            Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term v a -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term v a
tm,
            Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs,
            PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
forall {a}.
(Ord a, Num a, Show a) =>
PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
stackTrace PrettyPrintEnv
ppe [(Reference, a)]
tr
          ]
      where
        stackTrace :: PrettyPrintEnv -> [(Reference, a)] -> Pretty ColorText
stackTrace PrettyPrintEnv
_ [] = Pretty ColorText
forall a. Monoid a => a
mempty
        stackTrace PrettyPrintEnv
ppe [(Reference, a)]
tr = Pretty ColorText
"\nStack trace:\n" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 ([Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ (Reference, a) -> Pretty ColorText
f ((Reference, a) -> Pretty ColorText)
-> [(Reference, a)] -> [Pretty ColorText]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, a)]
tr)
          where
            f :: (Reference, a) -> Pretty ColorText
f (Reference
rf, a
n) = Pretty ColorText
name Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
count
              where
                count :: Pretty ColorText
count
                  | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1 = Pretty ColorText
" (" Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> a -> Pretty ColorText
forall a s. (Show a, IsString s) => a -> Pretty s
P.shown a
n Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
" copies)"
                  | Bool
otherwise = Pretty ColorText
""
                name :: Pretty ColorText
name = Pretty (SyntaxText' Reference) -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
P.syntaxToColor (Pretty (SyntaxText' Reference) -> Pretty ColorText)
-> (Referent -> Pretty (SyntaxText' Reference))
-> Referent
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashQualified Name -> Pretty (SyntaxText' Reference)
prettyHashQualified (HashQualified Name -> Pretty (SyntaxText' Reference))
-> (Referent -> HashQualified Name)
-> Referent
-> Pretty (SyntaxText' Reference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv -> Referent -> HashQualified Name
PPE.termName PrettyPrintEnv
ppe (Referent -> Pretty ColorText) -> Referent -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Reference -> Referent
RF.Ref Reference
rf

prettyRuntimeExn :: (Applicative f) => (Word -> f (Pretty P.ColorText)) -> RuntimeExn -> f (Pretty P.ColorText)
prettyRuntimeExn :: forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText))
-> RuntimeExn -> f (Pretty ColorText)
prettyRuntimeExn = PrettyPrintEnv
-> (Reference -> Reference)
-> (Val -> DecompResult Symbol)
-> (Word -> f (Pretty ColorText))
-> RuntimeExn
-> f (Pretty ColorText)
forall (f :: * -> *).
Applicative f =>
PrettyPrintEnv
-> (Reference -> Reference)
-> (Val -> DecompResult Symbol)
-> (Word -> f (Pretty ColorText))
-> RuntimeExn
-> f (Pretty ColorText)
prettyRuntimeExn' PrettyPrintEnv
forall a. Monoid a => a
mempty Reference -> Reference
forall a. a -> a
id ((Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Val
-> DecompResult Symbol
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \Word64
_ Word64
_ -> Maybe (Term Symbol)
forall a. Maybe a
Nothing)

-- |
--
--  __NB__: The only reason this is in the unison-runtime package is because it’s used in the tests. Otherwise it should move to unison-cli.
prettyError ::
  (Applicative f) =>
  -- | A function for displaying unisonweb/unison issue numbers (for example,
  --   `Unison.CommandLine.OutputMessages.showIssueUrl`).
  (Word -> f (Pretty P.ColorText)) ->
  Error ->
  f (Pretty P.ColorText)
prettyError :: forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText)) -> Error -> f (Pretty ColorText)
prettyError Word -> f (Pretty ColorText)
issueFn = \case
  UnstructuredError Text
text -> Pretty ColorText -> f (Pretty ColorText)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty ColorText -> f (Pretty ColorText))
-> Pretty ColorText -> f (Pretty ColorText)
forall a b. (a -> b) -> a -> b
$ Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
P.text Text
text
  CompileExn (CE CallStack
_ [Word]
issues [Char]
err) -> do
    Pretty ColorText
issueMessage <- (Word -> f (Pretty ColorText)) -> [Word] -> f (Pretty ColorText)
forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText)) -> [Word] -> f (Pretty ColorText)
formatIssues Word -> f (Pretty ColorText)
issueFn [Word]
issues
    pure $
      Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.fatalCallout (Pretty ColorText -> Pretty ColorText)
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$
        [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"Sorry – I've encountered a bug in the Unison runtime.",
          Pretty ColorText
"",
          Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
err,
          Pretty ColorText
"",
          Pretty ColorText
issueMessage
        ]
  RuntimeExn Maybe
  (PrettyPrintEnv, Reference -> Reference,
   Val -> DecompResult Symbol)
ctx RuntimeExn
re ->
    ((Word -> f (Pretty ColorText))
 -> RuntimeExn -> f (Pretty ColorText))
-> ((PrettyPrintEnv, Reference -> Reference,
     Val -> DecompResult Symbol)
    -> (Word -> f (Pretty ColorText))
    -> RuntimeExn
    -> f (Pretty ColorText))
-> Maybe
     (PrettyPrintEnv, Reference -> Reference,
      Val -> DecompResult Symbol)
-> (Word -> f (Pretty ColorText))
-> RuntimeExn
-> f (Pretty ColorText)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Word -> f (Pretty ColorText))
-> RuntimeExn -> f (Pretty ColorText)
forall (f :: * -> *).
Applicative f =>
(Word -> f (Pretty ColorText))
-> RuntimeExn -> f (Pretty ColorText)
prettyRuntimeExn (\(PrettyPrintEnv
ppe, Reference -> Reference
backmapRef, Val -> DecompResult Symbol
decom) -> PrettyPrintEnv
-> (Reference -> Reference)
-> (Val -> DecompResult Symbol)
-> (Word -> f (Pretty ColorText))
-> RuntimeExn
-> f (Pretty ColorText)
forall (f :: * -> *).
Applicative f =>
PrettyPrintEnv
-> (Reference -> Reference)
-> (Val -> DecompResult Symbol)
-> (Word -> f (Pretty ColorText))
-> RuntimeExn
-> f (Pretty ColorText)
prettyRuntimeExn' PrettyPrintEnv
ppe Reference -> Reference
backmapRef Val -> DecompResult Symbol
decom) Maybe
  (PrettyPrintEnv, Reference -> Reference,
   Val -> DecompResult Symbol)
ctx Word -> f (Pretty ColorText)
issueFn RuntimeExn
re
  RuntimePanic PrettyPrintEnv
ppe Val -> DecompResult Symbol
decom (Panic [Char]
msg Maybe Val
mval) ->
    Pretty ColorText -> f (Pretty ColorText)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty ColorText -> f (Pretty ColorText))
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> f (Pretty ColorText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Pretty ColorText
panicIcon (Pretty ColorText -> Pretty ColorText)
-> ([Pretty ColorText] -> Pretty ColorText)
-> [Pretty ColorText]
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.linesNonEmpty ([Pretty ColorText] -> f (Pretty ColorText))
-> [Pretty ColorText] -> f (Pretty ColorText)
forall a b. (a -> b) -> a -> b
$
      [ Pretty ColorText -> Pretty ColorText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Pretty ColorText
"The program halted with a runtime panic:",
        Pretty ColorText
"",
        [Char] -> Pretty ColorText
forall s. IsString s => [Char] -> Pretty s
P.string [Char]
msg
      ]
        [Pretty ColorText] -> [Pretty ColorText] -> [Pretty ColorText]
forall a. [a] -> [a] -> [a]
++ [Pretty ColorText]
-> (Val -> [Pretty ColorText]) -> Maybe Val -> [Pretty ColorText]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (DecompResult Symbol -> [Pretty ColorText]
render (DecompResult Symbol -> [Pretty ColorText])
-> (Val -> DecompResult Symbol) -> Val -> [Pretty ColorText]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> DecompResult Symbol
decom) Maybe Val
mval
    where
      panicIcon :: Pretty ColorText
panicIcon = Pretty ColorText
"💥🤯💥"
      render :: DecompResult Symbol -> [Pretty ColorText]
render (Set DecompError
errs, Term Symbol
tm) = [Pretty ColorText
"", Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Pretty ColorText
forall v a.
(HasCallStack, Var v) =>
PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term Symbol
tm, Set DecompError -> Pretty ColorText
tabulateErrors Set DecompError
errs]