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

module Unison.Runtime.Interface
  ( startRuntime,
    withRuntime,
    startNativeRuntime,
    standalone,
    runStandalone,
    StoredCache,
    decodeStandalone,
    RuntimeHost (..),
    Runtime (..),
  )
where

import Control.Concurrent.STM as STM
import Control.Exception (throwIO)
import Control.Monad
-- import Data.Bits (shiftL)

import Control.Monad.State
import Data.Binary.Get (runGetOrFail)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Bytes.Get (MonadGet, getWord8, runGetS)
import Data.Bytes.Put (MonadPut, putWord32be, runPutL, runPutS)
import Data.Bytes.Serial
import Data.Foldable
import Data.Function (on)
import Data.IORef
import Data.List qualified as L
import Data.Map.Strict qualified as Map
import Data.Sequence qualified as Seq (fromList)
import Data.Set as Set
  ( filter,
    fromList,
    map,
    notMember,
    singleton,
    (\\),
  )
import Data.Set qualified as Set
import Data.Text as Text (isPrefixOf, pack, unpack)
import GHC.IO.Exception (IOErrorType (NoSuchThing, OtherError, PermissionDenied), IOException (ioe_description, ioe_type))
import GHC.Stack (callStack)
import Network.Simple.TCP (Socket, acceptFork, listen, recv, send)
import Network.Socket (PortNumber, socketPort)
import System.Directory
  ( XdgDirectory (XdgCache),
    createDirectoryIfMissing,
    getXdgDirectory,
  )
import System.Environment (getArgs)
import System.Exit (ExitCode (..))
import System.FilePath ((<.>), (</>))
import System.Process
  ( CmdSpec (RawCommand, ShellCommand),
    CreateProcess (..),
    StdStream (..),
    callProcess,
    proc,
    readCreateProcessWithExitCode,
    shell,
    waitForProcess,
    withCreateProcess,
  )
import Unison.Builtin.Decls qualified as RF
import Unison.Codebase.CodeLookup (CodeLookup (..))
import Unison.Codebase.MainTerm (builtinIOTestTypes, builtinMain)
import Unison.Codebase.Runtime (CompileOpts (..), Error, Runtime (..))
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.ANF as ANF
import Unison.Runtime.ANF.Rehash as ANF (rehashGroups)
import Unison.Runtime.ANF.Serialize as ANF
  ( getGroup,
    getVersionedValue,
    putGroup,
    serializeValue,
  )
import Unison.Runtime.Builtin
import Unison.Runtime.Decompile
import Unison.Runtime.Exception
import Unison.Runtime.MCode
  ( Args (..),
    CombIx (..),
    Combs,
    GInstr (..),
    GSection (..),
    RCombs,
    RefNums (..),
    combDeps,
    combTypes,
    emitComb,
    emptyRNs,
    rCombIx,
    resolveCombs,
  )
import Unison.Runtime.MCode.Serialize
import Unison.Runtime.Machine
  ( ActiveThreads,
    CCache (..),
    Tracer (..),
    apply0,
    baseCCache,
    cacheAdd,
    cacheAdd0,
    eval0,
    expandSandbox,
    refLookup,
    refNumTm,
    refNumsTm,
    refNumsTy,
    reifyValue,
    resolveSection,
  )
import Unison.Runtime.Pattern
import Unison.Runtime.Serialize as SER
import Unison.Runtime.Stack
import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualified qualified as HQ (toText)
import Unison.Syntax.NamePrinter (prettyHashQualified)
import Unison.Syntax.TermPrinter
import Unison.Term qualified as Tm
import Unison.Util.EnumContainers as EC
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Pretty as P
import UnliftIO qualified
import UnliftIO.Concurrent qualified as UnliftIO

type Term v = Tm.Term v ()

data Remapping = Remap
  { Remapping -> Map Reference Reference
remap :: Map.Map Reference Reference,
    Remapping -> Map Reference Reference
backmap :: Map.Map Reference Reference
  }

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

instance Monoid Remapping where
  mempty :: Remapping
mempty = Map Reference Reference -> Map Reference Reference -> Remapping
Remap Map Reference Reference
forall a. Monoid a => a
mempty Map Reference Reference
forall a. Monoid a => a
mempty

data EvalCtx = ECtx
  { EvalCtx -> DataSpec
dspec :: DataSpec,
    EvalCtx -> Remapping
floatRemap :: Remapping,
    EvalCtx -> Remapping
intermedRemap :: Remapping,
    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
-> Remapping
-> Map Reference (Map Word64 (Term Symbol))
-> CCache
-> EvalCtx
ECtx DataSpec
builtinDataSpec Remapping
forall a. Monoid a => a
mempty Remapping
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
_) =
  [Char] -> IO (Term Symbol)
forall a. HasCallStack => [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 -> [Char] -> IO (Term Symbol)
forall a. HasCallStack => [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]
_ =
  [Char] -> IO EvalCtx
forall a. HasCallStack => [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 Symbol) ->
  Set Reference ->
  [Reference] ->
  Set Reference
recursiveIRefDeps :: Map Reference (SuperGroup Symbol)
-> Set Reference -> [Reference] -> Set Reference
recursiveIRefDeps Map Reference (SuperGroup 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 Symbol -> Set Reference)
-> Maybe (SuperGroup 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 Symbol)
-> Set Reference -> SuperGroup Symbol -> Set Reference
recursiveGroupDeps Map Reference (SuperGroup Symbol)
cl Set Reference
seen) (Maybe (SuperGroup Symbol) -> Set Reference)
-> (Reference -> Maybe (SuperGroup Symbol))
-> Reference
-> Set Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference
 -> Map Reference (SuperGroup Symbol) -> Maybe (SuperGroup Symbol))
-> Map Reference (SuperGroup Symbol)
-> Reference
-> Maybe (SuperGroup Symbol)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference
-> Map Reference (SuperGroup Symbol) -> Maybe (SuperGroup Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Reference (SuperGroup Symbol)
cl

recursiveGroupDeps ::
  Map.Map Reference (SuperGroup Symbol) ->
  Set Reference ->
  SuperGroup Symbol ->
  Set Reference
recursiveGroupDeps :: Map Reference (SuperGroup Symbol)
-> Set Reference -> SuperGroup Symbol -> Set Reference
recursiveGroupDeps Map Reference (SuperGroup Symbol)
cl Set Reference
seen0 SuperGroup Symbol
grp = Set Reference
deps Set Reference -> Set Reference -> Set Reference
forall a. Semigroup a => a -> a -> a
<> Map Reference (SuperGroup Symbol)
-> Set Reference -> [Reference] -> Set Reference
recursiveIRefDeps Map Reference (SuperGroup 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 Symbol -> [Reference]
forall v. Var v => SuperGroup v -> [Reference]
groupTermLinks SuperGroup 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 Symbol) ->
  [Reference] ->
  [(Reference, SuperGroup Symbol)]
recursiveIntermedDeps :: Map Reference (SuperGroup Symbol)
-> [Reference] -> [(Reference, SuperGroup Symbol)]
recursiveIntermedDeps Map Reference (SuperGroup Symbol)
cl [Reference]
rfs = (Reference -> Maybe (Reference, SuperGroup Symbol))
-> [Reference] -> [(Reference, SuperGroup 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 Symbol)
f ([Reference] -> [(Reference, SuperGroup Symbol)])
-> [Reference] -> [(Reference, SuperGroup 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 Symbol)
-> Set Reference -> [Reference] -> Set Reference
recursiveIRefDeps Map Reference (SuperGroup Symbol)
cl Set Reference
forall a. Monoid a => a
mempty [Reference]
rfs
    f :: Reference -> Maybe (Reference, SuperGroup Symbol)
f Reference
rf = (SuperGroup Symbol -> (Reference, SuperGroup Symbol))
-> Maybe (SuperGroup Symbol)
-> Maybe (Reference, SuperGroup 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 Symbol) -> Maybe (SuperGroup Symbol)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
rf Map Reference (SuperGroup 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 :: Map.Map Reference Reference -> Remapping -> Remapping
remapAdd :: Map Reference Reference -> Remapping -> Remapping
remapAdd Map Reference Reference
m Remap {Map Reference Reference
$sel:remap:Remap :: Remapping -> Map Reference Reference
remap :: Map Reference Reference
remap, Map Reference Reference
$sel:backmap:Remap :: Remapping -> Map Reference Reference
backmap :: Map Reference Reference
backmap} =
  Remap {$sel:remap:Remap :: Map Reference Reference
remap = Map Reference Reference
m Map Reference Reference
-> Map Reference Reference -> Map Reference Reference
forall a. Semigroup a => a -> a -> a
<> Map Reference Reference
remap, $sel:backmap:Remap :: Map Reference Reference
backmap = Map Reference Reference
tm Map Reference Reference
-> Map Reference Reference -> Map Reference Reference
forall a. Semigroup a => a -> a -> a
<> Map Reference Reference
backmap}
  where
    tm :: Map Reference Reference
tm = [(Reference, Reference)] -> Map Reference Reference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Reference, Reference)] -> Map Reference Reference)
-> ([(Reference, Reference)] -> [(Reference, Reference)])
-> [(Reference, Reference)]
-> Map Reference Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Reference, Reference) -> (Reference, Reference))
-> [(Reference, Reference)] -> [(Reference, Reference)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Reference
x, Reference
y) -> (Reference
y, Reference
x)) ([(Reference, Reference)] -> Map Reference Reference)
-> [(Reference, Reference)] -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ Map Reference Reference -> [(Reference, Reference)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Reference Reference
m

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

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

baseToIntermed :: EvalCtx -> Reference -> Maybe Reference
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 -> Map Reference Reference)
-> Remapping
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
remap (Remapping -> Maybe Reference) -> Remapping -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
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 -> Map Reference Reference)
-> Remapping
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
remap (Remapping -> Maybe Reference) -> Remapping -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
intermedRemap EvalCtx
ctx

-- Runs references through the forward maps to get intermediate
-- references. Works on both base and floated references.
toIntermed :: EvalCtx -> Reference -> Reference
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 -> Map Reference Reference) -> Remapping -> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
remap (Remapping -> Reference) -> Remapping -> Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
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 -> Map Reference Reference)
-> Remapping
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
remap (Remapping -> Maybe Reference) -> Remapping -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
intermedRemap EvalCtx
ctx =
      Reference
r
toIntermed EvalCtx
_ Reference
r = Reference
r

floatToIntermed :: EvalCtx -> Reference -> Maybe Reference
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 -> Map Reference Reference)
-> Remapping
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
remap (Remapping -> Maybe Reference) -> Remapping -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
intermedRemap EvalCtx
ctx

intermedToBase :: EvalCtx -> Reference -> Maybe Reference
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 -> Map Reference Reference)
-> Remapping
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
backmap (Remapping -> Maybe Reference) -> Remapping -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
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 -> Map Reference Reference)
-> Remapping
-> Maybe Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
backmap (Remapping -> Maybe Reference) -> Remapping -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
floatRemap EvalCtx
ctx

-- Runs references through the backmaps with defaults at all steps.
backmapRef :: EvalCtx -> Reference -> Reference
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 -> Map Reference Reference) -> Remapping -> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
backmap (Remapping -> Reference) -> Remapping -> Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
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 -> Map Reference Reference) -> Remapping -> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Remapping -> Map Reference Reference
backmap (Remapping -> Reference) -> Remapping -> Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
floatRemap EvalCtx
ctx

performRehash ::
  Map.Map Reference (SuperGroup Symbol) ->
  EvalCtx ->
  (EvalCtx, Map Reference Reference, [(Reference, SuperGroup Symbol)])
performRehash :: Map Reference (SuperGroup Symbol)
-> EvalCtx
-> (EvalCtx, Map Reference Reference,
    [(Reference, SuperGroup Symbol)])
performRehash Map Reference (SuperGroup Symbol)
rgrp0 EvalCtx
ctx =
  (Map Reference Reference -> EvalCtx -> EvalCtx
intermedRemapAdd Map Reference Reference
rrefs EvalCtx
ctx, Map Reference Reference
rrefs, Map Reference (SuperGroup Symbol)
-> [(Reference, SuperGroup Symbol)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Reference (SuperGroup Symbol)
rrgrp)
  where
    frs :: Map Reference Reference
frs = Remapping -> Map Reference Reference
remap (Remapping -> Map Reference Reference)
-> Remapping -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
floatRemap EvalCtx
ctx
    irs :: Map Reference Reference
irs = Remapping -> Map Reference Reference
remap (Remapping -> Map Reference Reference)
-> Remapping -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping
intermedRemap EvalCtx
ctx
    f :: Bool -> Reference -> Reference
f Bool
b Reference
r
      | Bool -> Bool
not Bool
b,
        Reference
r Reference -> Map Reference (SuperGroup Symbol) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Reference (SuperGroup 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 Symbol)
rrgrp) =
      case Map Reference (SuperGroup Symbol)
-> Either
     (Text, [Referent])
     (Map Reference Reference, Map Reference (SuperGroup Symbol))
forall v.
Var v =>
Map Reference (SuperGroup v)
-> Either
     (Text, [Referent])
     (Map Reference Reference, Map Reference (SuperGroup v))
rehashGroups (Map Reference (SuperGroup Symbol)
 -> Either
      (Text, [Referent])
      (Map Reference Reference, Map Reference (SuperGroup Symbol)))
-> Map Reference (SuperGroup Symbol)
-> Either
     (Text, [Referent])
     (Map Reference Reference, Map Reference (SuperGroup Symbol))
forall a b. (a -> b) -> a -> b
$ (SuperGroup Symbol -> SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup 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 Symbol -> SuperGroup Symbol
forall v.
Var v =>
(Bool -> Reference -> Reference) -> SuperGroup v -> SuperGroup v
overGroupLinks Bool -> Reference -> Reference
f) Map Reference (SuperGroup Symbol)
rgrp0 of
        Left (Text
msg, [Referent]
refs) -> [Char]
-> (Map Reference Reference, Map Reference (SuperGroup Symbol))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> (Map Reference Reference, Map Reference (SuperGroup Symbol)))
-> [Char]
-> (Map Reference Reference, Map Reference (SuperGroup 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 Symbol))
p -> (Map Reference Reference, Map Reference (SuperGroup Symbol))
p

loadCode ::
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  EvalCtx ->
  [Reference] ->
  IO (EvalCtx, [(Reference, SuperGroup Symbol)])
loadCode :: CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)])
loadCode CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [Reference]
tmrs = do
  Map Reference (SuperGroup Symbol)
igs <- TVar (Map Reference (SuperGroup Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed (CCache -> TVar (Map Reference (SuperGroup Symbol)))
-> CCache -> TVar (Map Reference (SuperGroup Symbol))
forall a b. (a -> b) -> a -> b
$ EvalCtx -> CCache
ccache EvalCtx
ctx)
  Reference -> Bool
q <-
    CCache -> 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 Symbol)]
odeps = Map Reference (SuperGroup Symbol)
-> [Reference] -> [(Reference, SuperGroup Symbol)]
recursiveIntermedDeps Map Reference (SuperGroup Symbol)
igs ([Reference] -> [(Reference, SuperGroup Symbol)])
-> [Reference] -> [(Reference, SuperGroup 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 (SuperGroup Symbol)
rgrp0, Map Reference (Map Word64 (Term Symbol))
rbkr) = HasCallStack =>
PrettyPrintEnv
-> EvalCtx
-> Map Id (Symbol, Term Symbol)
-> (Map Symbol Reference, Map Reference (SuperGroup Symbol),
    Map Reference (Map Word64 (Term Symbol)))
PrettyPrintEnv
-> EvalCtx
-> Map Id (Symbol, Term Symbol)
-> (Map Symbol Reference, Map Reference (SuperGroup 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 Symbol)]
rgrp) =
        Map Reference (SuperGroup Symbol)
-> EvalCtx
-> (EvalCtx, Map Reference Reference,
    [(Reference, SuperGroup Symbol)])
performRehash
          ((SuperGroup Symbol -> SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup 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 Symbol -> SuperGroup Symbol
forall v.
Var v =>
(Bool -> Reference -> Reference) -> SuperGroup v -> SuperGroup v
overGroupLinks Bool -> Reference -> Reference
int) Map Reference (SuperGroup Symbol)
rgrp0)
          (Map Reference Reference -> EvalCtx -> EvalCtx
floatRemapAdd Map Reference Reference
vm EvalCtx
ctx)
  (EvalCtx, [(Reference, SuperGroup Symbol)])
-> IO (EvalCtx, [(Reference, SuperGroup 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 Symbol)]
rgrp [(Reference, SuperGroup Symbol)]
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, SuperGroup Symbol)]
forall a. [a] -> [a] -> [a]
++ [(Reference, SuperGroup Symbol)]
odeps)

loadDeps ::
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  EvalCtx ->
  [(Reference, Either [Int] [Int])] ->
  [Reference] ->
  IO (EvalCtx, [(Reference, SuperGroup Symbol)])
loadDeps :: CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)])
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))
sandbox CCache
cc)
  (Reference, Either [Int] [Int]) -> Bool
p <-
    CCache -> 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
  out :: (EvalCtx, [(Reference, SuperGroup Symbol)])
out@(EvalCtx
_, [(Reference, SuperGroup Symbol)]
rgrp) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)])
loadCode CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [Reference]
tmrs
  (EvalCtx, [(Reference, SuperGroup Symbol)])
out (EvalCtx, [(Reference, SuperGroup Symbol)])
-> IO () -> IO (EvalCtx, [(Reference, SuperGroup Symbol)])
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Set Reference
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, Set Reference)]
-> CCache
-> IO ()
cacheAdd0 Set Reference
tyAdd [(Reference, SuperGroup Symbol)]
rgrp (Map Reference (Set Reference)
-> [(Reference, SuperGroup Symbol)] -> [(Reference, Set Reference)]
expandSandbox Map Reference (Set Reference)
sand [(Reference, SuperGroup Symbol)]
rgrp) CCache
cc

compileValue :: Reference -> [(Reference, SuperGroup Symbol)] -> Value
compileValue :: Reference -> [(Reference, SuperGroup Symbol)] -> Value
compileValue Reference
base =
  (Value -> Value -> Value) -> Value -> Value -> Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Value -> Value -> Value
pair (Reference -> Value
rf Reference
base) (Value -> Value)
-> ([(Reference, SuperGroup Symbol)] -> Value)
-> [(Reference, SuperGroup Symbol)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> Value)
-> ([(Reference, SuperGroup Symbol)] -> BLit)
-> [(Reference, SuperGroup Symbol)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Value -> BLit
List (Seq Value -> BLit)
-> ([(Reference, SuperGroup Symbol)] -> Seq Value)
-> [(Reference, SuperGroup Symbol)]
-> BLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Seq Value
forall a. [a] -> Seq a
Seq.fromList ([Value] -> Seq Value)
-> ([(Reference, SuperGroup Symbol)] -> [Value])
-> [(Reference, SuperGroup Symbol)]
-> Seq Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Reference, SuperGroup Symbol) -> Value)
-> [(Reference, SuperGroup Symbol)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Reference, SuperGroup Symbol) -> Value
cpair
  where
    rf :: Reference -> Value
rf = BLit -> Value
ANF.BLit (BLit -> Value) -> (Reference -> BLit) -> Reference -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Referent -> BLit
TmLink (Referent -> BLit) -> (Reference -> Referent) -> Reference -> BLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent
RF.Ref
    cons :: Value -> Value -> Value
cons Value
x Value
y = Reference -> Word64 -> [Word64] -> [Value] -> Value
Data Reference
RF.pairRef Word64
0 [] [Value
x, Value
y]
    tt :: Value
tt = Reference -> Word64 -> [Word64] -> [Value] -> Value
Data Reference
RF.unitRef Word64
0 [] []
    code :: SuperGroup Symbol -> Value
code SuperGroup Symbol
sg = BLit -> Value
ANF.BLit (SuperGroup Symbol -> BLit
Code SuperGroup Symbol
sg)
    pair :: Value -> Value -> Value
pair Value
x Value
y = Value -> Value -> Value
cons Value
x (Value -> Value -> Value
cons Value
y Value
tt)
    cpair :: (Reference, SuperGroup Symbol) -> Value
cpair (Reference
r, SuperGroup Symbol
sg) = Value -> Value -> Value
pair (Reference -> Value
rf Reference
r) (SuperGroup Symbol -> Value
code SuperGroup Symbol
sg)

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

nativeEval ::
  FilePath ->
  IORef EvalCtx ->
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  Term Symbol ->
  IO (Either Error ([Error], Term Symbol))
nativeEval :: [Char]
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Term Symbol
-> IO (Either Error ([Error], Term Symbol))
nativeEval [Char]
executable IORef EvalCtx
ctxVar CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe Term Symbol
tm = IO (Either Error ([Error], Term Symbol))
-> IO (Either Error ([Error], Term Symbol))
forall a. IO (Either Error a) -> IO (Either Error a)
catchInternalErrors (IO (Either Error ([Error], Term Symbol))
 -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], Term Symbol))
-> IO (Either Error ([Error], 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, SuperGroup Symbol)]
codes) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)])
loadDeps CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [(Reference, Either [Int] [Int])]
tyrs [Reference]
tmrs
  (EvalCtx
ctx, [(Reference, SuperGroup Symbol)]
tcodes, Reference
base) <- HasCallStack =>
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)], Reference)
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)], Reference)
prepareEvaluation PrettyPrintEnv
ppe Term Symbol
tm EvalCtx
ctx
  IORef EvalCtx -> EvalCtx -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef EvalCtx
ctxVar EvalCtx
ctx
  -- Note: port 0 mean choosing an arbitrary available port.
  -- We then ask what port was actually chosen.
  HostPreference
-> [Char]
-> ((Socket, SockAddr) -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], Term Symbol))
forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
HostPreference -> [Char] -> ((Socket, SockAddr) -> m r) -> m r
listen HostPreference
"127.0.0.1" [Char]
"0" (((Socket, SockAddr) -> IO (Either Error ([Error], Term Symbol)))
 -> IO (Either Error ([Error], Term Symbol)))
-> ((Socket, SockAddr) -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ \(Socket
serv, SockAddr
_) ->
    Socket -> IO PortNumber
socketPort Socket
serv IO PortNumber
-> (PortNumber -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], 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
>>= \PortNumber
port ->
      [Char]
-> PrettyPrintEnv
-> EvalCtx
-> Socket
-> PortNumber
-> [(Reference, SuperGroup Symbol)]
-> Reference
-> IO (Either Error ([Error], Term Symbol))
nativeEvalInContext
        [Char]
executable
        PrettyPrintEnv
ppe
        EvalCtx
ctx
        Socket
serv
        PortNumber
port
        (((Reference, SuperGroup Symbol)
 -> (Reference, SuperGroup Symbol) -> Bool)
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, SuperGroup Symbol)]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Reference -> Reference -> Bool)
-> ((Reference, SuperGroup Symbol) -> Reference)
-> (Reference, SuperGroup Symbol)
-> (Reference, SuperGroup Symbol)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Reference, SuperGroup Symbol) -> Reference
forall a b. (a, b) -> a
fst) ([(Reference, SuperGroup Symbol)]
 -> [(Reference, SuperGroup Symbol)])
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, SuperGroup Symbol)]
forall a b. (a -> b) -> a -> b
$ [(Reference, SuperGroup Symbol)]
tcodes [(Reference, SuperGroup Symbol)]
-> [(Reference, SuperGroup Symbol)]
-> [(Reference, SuperGroup Symbol)]
forall a. [a] -> [a] -> [a]
++ [(Reference, SuperGroup Symbol)]
codes)
        Reference
base

interpEval ::
  ActiveThreads ->
  IO () ->
  IORef EvalCtx ->
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  Term Symbol ->
  IO (Either Error ([Error], Term Symbol))
interpEval :: ActiveThreads
-> IO ()
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Term Symbol
-> IO (Either Error ([Error], Term Symbol))
interpEval ActiveThreads
activeThreads IO ()
cleanupThreads IORef EvalCtx
ctxVar CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe Term Symbol
tm =
  IO (Either Error ([Error], Term Symbol))
-> IO (Either Error ([Error], Term Symbol))
forall a. IO (Either Error a) -> IO (Either Error a)
catchInternalErrors (IO (Either Error ([Error], Term Symbol))
 -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], Term Symbol))
-> IO (Either Error ([Error], 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, SuperGroup Symbol)]
_) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)])
loadDeps CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [(Reference, Either [Int] [Int])]
tyrs [Reference]
tmrs
    (EvalCtx
ctx, [(Reference, SuperGroup Symbol)]
_, Reference
init) <- HasCallStack =>
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)], Reference)
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)], Reference)
prepareEvaluation PrettyPrintEnv
ppe Term Symbol
tm EvalCtx
ctx
    Word64
initw <- CCache -> 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
-> ActiveThreads
-> Word64
-> IO (Either Error ([Error], Term Symbol))
evalInContext PrettyPrintEnv
ppe EvalCtx
ctx ActiveThreads
activeThreads Word64
initw
      IO (Either Error ([Error], Term Symbol))
-> IO () -> IO (Either Error ([Error], Term Symbol))
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.finally` IO ()
cleanupThreads

ensureExists :: (HasCallStack) => CreateProcess -> (CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText) -> IO ()
ensureExists :: HasCallStack =>
CreateProcess
-> (CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error)
-> IO ()
ensureExists CreateProcess
cmd CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
err =
  IO (Maybe (Either (Int, [Char], [Char]) IOException))
ccall IO (Maybe (Either (Int, [Char], [Char]) IOException))
-> (Maybe (Either (Int, [Char], [Char]) IOException) -> 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
>>= \case
    Maybe (Either (Int, [Char], [Char]) IOException)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Either (Int, [Char], [Char]) IOException
failure -> Error -> IO ()
forall a. HasCallStack => Error -> IO a
dieP (Error -> IO ()) -> Error -> IO ()
forall a b. (a -> b) -> a -> b
$ CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
err (CreateProcess -> CmdSpec
cmdspec CreateProcess
cmd) Either (Int, [Char], [Char]) IOException
failure
  where
    call :: IO (Maybe (Either (Int, [Char], [Char]) IOException))
call =
      CreateProcess -> [Char] -> IO (ExitCode, [Char], [Char])
readCreateProcessWithExitCode CreateProcess
cmd [Char]
"" IO (ExitCode, [Char], [Char])
-> ((ExitCode, [Char], [Char])
    -> IO (Maybe (Either (Int, [Char], [Char]) IOException)))
-> IO (Maybe (Either (Int, [Char], [Char]) IOException))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (ExitCode
ExitSuccess, [Char]
_stdout, [Char]
_stderr) -> Maybe (Either (Int, [Char], [Char]) IOException)
-> IO (Maybe (Either (Int, [Char], [Char]) IOException))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either (Int, [Char], [Char]) IOException)
forall a. Maybe a
Nothing
        (ExitFailure Int
exitCode, [Char]
stdout, [Char]
stderr) -> Maybe (Either (Int, [Char], [Char]) IOException)
-> IO (Maybe (Either (Int, [Char], [Char]) IOException))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Int, [Char], [Char]) IOException
-> Maybe (Either (Int, [Char], [Char]) IOException)
forall a. a -> Maybe a
Just ((Int, [Char], [Char]) -> Either (Int, [Char], [Char]) IOException
forall a b. a -> Either a b
Left (Int
exitCode, [Char]
stdout, [Char]
stderr)))
    ccall :: IO (Maybe (Either (Int, [Char], [Char]) IOException))
ccall = IO (Maybe (Either (Int, [Char], [Char]) IOException))
call IO (Maybe (Either (Int, [Char], [Char]) IOException))
-> (IOException
    -> IO (Maybe (Either (Int, [Char], [Char]) IOException)))
-> IO (Maybe (Either (Int, [Char], [Char]) IOException))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`UnliftIO.catch` \(IOException
e :: IOException) -> Maybe (Either (Int, [Char], [Char]) IOException)
-> IO (Maybe (Either (Int, [Char], [Char]) IOException))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either (Int, [Char], [Char]) IOException)
 -> IO (Maybe (Either (Int, [Char], [Char]) IOException)))
-> (Either (Int, [Char], [Char]) IOException
    -> Maybe (Either (Int, [Char], [Char]) IOException))
-> Either (Int, [Char], [Char]) IOException
-> IO (Maybe (Either (Int, [Char], [Char]) IOException))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Int, [Char], [Char]) IOException
-> Maybe (Either (Int, [Char], [Char]) IOException)
forall a. a -> Maybe a
Just (Either (Int, [Char], [Char]) IOException
 -> IO (Maybe (Either (Int, [Char], [Char]) IOException)))
-> Either (Int, [Char], [Char]) IOException
-> IO (Maybe (Either (Int, [Char], [Char]) IOException))
forall a b. (a -> b) -> a -> b
$ IOException -> Either (Int, [Char], [Char]) IOException
forall a b. b -> Either a b
Right IOException
e

ensureRuntimeExists :: (HasCallStack) => FilePath -> IO ()
ensureRuntimeExists :: HasCallStack => [Char] -> IO ()
ensureRuntimeExists [Char]
executable =
  HasCallStack =>
CreateProcess
-> (CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error)
-> IO ()
CreateProcess
-> (CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error)
-> IO ()
ensureExists CreateProcess
cmd CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
runtimeErrMsg
  where
    cmd :: CreateProcess
cmd = [Char] -> [[Char]] -> CreateProcess
proc [Char]
executable [[Char]
"--help"]

ensureRacoExists :: (HasCallStack) => IO ()
ensureRacoExists :: HasCallStack => IO ()
ensureRacoExists = HasCallStack =>
CreateProcess
-> (CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error)
-> IO ()
CreateProcess
-> (CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error)
-> IO ()
ensureExists ([Char] -> CreateProcess
shell [Char]
"raco help") CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
racoErrMsg

prettyCmdSpec :: CmdSpec -> Pretty ColorText
prettyCmdSpec :: CmdSpec -> Error
prettyCmdSpec = \case
  ShellCommand [Char]
string -> [Char] -> Error
forall a. IsString a => [Char] -> a
fromString [Char]
string
  System.Process.RawCommand [Char]
filePath [[Char]]
args ->
    Error -> [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
P.sep Error
" " ([Char] -> Error
forall a. IsString a => [Char] -> a
fromString [Char]
filePath Error -> [Error] -> [Error]
forall a. a -> [a] -> [a]
: ([Char] -> Error) -> [[Char]] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map [Char] -> Error
forall a. IsString a => [Char] -> a
fromString [[Char]]
args)

prettyCallError :: Either (Int, String, String) IOException -> Pretty ColorText
prettyCallError :: Either (Int, [Char], [Char]) IOException -> Error
prettyCallError = \case
  Right IOException
ex ->
    [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Error -> Error) -> ([Char] -> Error) -> [Char] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Error
forall a. IsString a => [Char] -> a
fromString ([Char] -> Error) -> [Char] -> Error
forall a b. (a -> b) -> a -> b
$ [Char]
"The error type was: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IOErrorType -> [Char]
forall a. Show a => a -> [Char]
show (IOException -> IOErrorType
ioe_type IOException
ex) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"', and the message is:",
        Error
"",
        Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 ([Char] -> Error
forall a. IsString a => [Char] -> a
fromString (IOException -> [Char]
ioe_description IOException
ex))
      ]
  Left (Int
errCode, [Char]
stdout, [Char]
stderr) ->
    let prettyExitCode :: Error
prettyExitCode = Error
"The exit code was" Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> [Char] -> Error
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
errCode)
     in if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
stdout Bool -> Bool -> Bool
&& [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
stderr
          then Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ Error
prettyExitCode Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
" but there was no output."
          else
            [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
              [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ Error
prettyExitCode Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
"and the output was:",
                Error
"",
                Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN
                  Width
2
                  if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
stdout
                    then [Char] -> Error
forall a. IsString a => [Char] -> a
fromString [Char]
stderr
                    else
                      if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
stderr
                        then [Char] -> Error
forall a. IsString a => [Char] -> a
fromString [Char]
stdout
                        else [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$ [[Char] -> Error
forall a. IsString a => [Char] -> a
fromString [Char]
stdout, Error
"", Error
"---", Error
"", [Char] -> Error
forall a. IsString a => [Char] -> a
fromString [Char]
stderr]
              ]

-- https://hackage.haskell.org/package/process-1.6.18.0/docs/System-Process.html#t:CreateProcess
-- https://hackage.haskell.org/package/base-4.19.0.0/docs/GHC-IO-Exception.html#t:IOError
-- https://hackage.haskell.org/package/base-4.19.0.0/docs/GHC-IO-Exception.html#t:IOErrorType
runtimeErrMsg :: CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText
runtimeErrMsg :: CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
runtimeErrMsg CmdSpec
c Either (Int, [Char], [Char]) IOException
error =
  case Either (Int, [Char], [Char]) IOException
error of
    Right (IOException -> IOErrorType
ioe_type -> IOErrorType
NoSuchThing) ->
      [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
        [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap Error
"I couldn't find the Unison native runtime. I tried to start it with:",
          Error
"",
          Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ CmdSpec -> Error
prettyCmdSpec CmdSpec
c,
          Error
"",
          Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
            Error
"If that doesn't look right, you can use the `--runtime-path` command line \
            \argument to specify the correct path for the executable."
        ]
    Right (IOException -> IOErrorType
ioe_type -> IOErrorType
PermissionDenied) ->
      [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
        [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
            Error
"I got a 'Permission Denied' error when trying to start the \
            \Unison native runtime with:",
          Error
"",
          Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ CmdSpec -> Error
prettyCmdSpec CmdSpec
c,
          Error
"",
          Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
            Error
"Please check the permisssions (e.g. check that the directory is accessible, \
            \and that the program is marked executable).",
          Error
"",
          Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
            Error
"If it looks like I'm calling the wrong executable altogether, you can use the \
            \`--runtime-path` command line argument to specify the correct one."
        ]
    Either (Int, [Char], [Char]) IOException
_ ->
      [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
        [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
            Error
"I got an error when starting the Unison native runtime using:",
          Error
"",
          Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (CmdSpec -> Error
prettyCmdSpec CmdSpec
c),
          Error
"",
          Either (Int, [Char], [Char]) IOException -> Error
prettyCallError Either (Int, [Char], [Char]) IOException
error
        ]

racoErrMsg :: CmdSpec -> Either (Int, String, String) IOException -> Pretty ColorText
racoErrMsg :: CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
racoErrMsg CmdSpec
c = \case
  Right (IOException -> IOErrorType
ioe_type -> e :: IOErrorType
e@IOErrorType
OtherError) ->
    [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Error -> Error) -> ([Char] -> Error) -> [Char] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Error
forall a. IsString a => [Char] -> a
fromString ([Char] -> Error) -> [Char] -> Error
forall a b. (a -> b) -> a -> b
$
          [Char]
"Sorry, I got an error of type '"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IOErrorType -> [Char]
forall a. Show a => a -> [Char]
show IOErrorType
e
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' when I ran `raco`, \
               \and I'm not sure what to do about it.",
        Error
"",
        Error
"For debugging purposes, the full command was:",
        Error
"",
        Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (CmdSpec -> Error
prettyCmdSpec CmdSpec
c)
      ]
  Either (Int, [Char], [Char]) IOException
error ->
    [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
      [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
          Error
"I can't seem to call `raco`. Please ensure Racket \
          \is installed.",
        Error
"",
        Either (Int, [Char], [Char]) IOException -> Error
prettyCallError Either (Int, [Char], [Char]) IOException
error,
        Error
"",
        Error
"See",
        Error
"",
        Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 Error
"https://download.racket-lang.org/",
        Error
"",
        Error
"for how to install Racket manually."
      ]

nativeCompile ::
  FilePath ->
  IORef EvalCtx ->
  CompileOpts ->
  CodeLookup Symbol IO () ->
  PrettyPrintEnv ->
  Reference ->
  FilePath ->
  IO (Maybe Error)
nativeCompile :: [Char]
-> IORef EvalCtx
-> CompileOpts
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Reference
-> [Char]
-> IO (Maybe Error)
nativeCompile [Char]
executable IORef EvalCtx
ctxVar CompileOpts
copts CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe Reference
base [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
base
  (EvalCtx
ctx, [(Reference, SuperGroup Symbol)]
codes) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)])
loadDeps CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [(Reference, Either [Int] [Int])]
tyrs [Reference]
tmrs
  Just Reference
ibase <- Maybe Reference -> IO (Maybe Reference)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Reference -> IO (Maybe Reference))
-> Maybe Reference -> IO (Maybe Reference)
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Reference -> Maybe Reference
baseToIntermed EvalCtx
ctx Reference
base
  CompileOpts
-> [Char]
-> [(Reference, SuperGroup Symbol)]
-> Reference
-> [Char]
-> IO ()
nativeCompileCodes CompileOpts
copts [Char]
executable [(Reference, SuperGroup Symbol)]
codes Reference
ibase [Char]
path

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, SuperGroup Symbol)]
_) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)])
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)
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 (SuperGroup Symbol),
    Map.Map Reference (Map.Map Word64 (Term Symbol))
  )
intermediateTerms :: HasCallStack =>
PrettyPrintEnv
-> EvalCtx
-> Map Id (Symbol, Term Symbol)
-> (Map Symbol Reference, Map Reference (SuperGroup 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 (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 (Term Symbol)
cmbs, Map Reference (Term Symbol)
dcmp) ->
      (Map Symbol Reference
subvs, (Reference -> Term Symbol -> SuperGroup Symbol)
-> Map Reference (Term Symbol) -> Map Reference (SuperGroup Symbol)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Reference -> Term Symbol -> SuperGroup 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 Symbol
f Reference
ref =
          Term Symbol -> SuperGroup Symbol
forall v a. Var v => Term v a -> SuperGroup v
superNormalize
            (Term Symbol -> SuperGroup Symbol)
-> (Term Symbol -> Term Symbol) -> Term Symbol -> SuperGroup 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 (Term Symbol),
    Map Reference (Map.Map Word64 (Term Symbol))
  )
normalizeTerm :: EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
normalizeTerm EvalCtx
ctx Term Symbol
tm =
  (Term Symbol, Map Reference Reference, [(Reference, Term Symbol)],
 [(Reference, Term Symbol)])
-> (Reference, Map Reference Reference,
    Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
absorb
    ((Term Symbol, Map Reference Reference, [(Reference, Term Symbol)],
  [(Reference, Term Symbol)])
 -> (Reference, Map Reference Reference,
     Map Reference (Term Symbol),
     Map Reference (Map Word64 (Term Symbol))))
-> (Term Symbol
    -> (Term Symbol, Map Reference Reference,
        [(Reference, Term Symbol)], [(Reference, Term Symbol)]))
-> Term Symbol
-> (Reference, Map Reference Reference,
    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,
    [(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, [(Reference, Term v a)],
    [(Reference, Term v a)])
lamLift Map Symbol Reference
orig
    (Term Symbol
 -> (Term Symbol, Map Reference Reference,
     [(Reference, Term Symbol)], [(Reference, Term Symbol)]))
-> (Term Symbol -> Term Symbol)
-> Term Symbol
-> (Term Symbol, Map Reference Reference,
    [(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 (Term Symbol),
     Map Reference (Map Word64 (Term Symbol))))
-> Term Symbol
-> (Reference, Map Reference Reference,
    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, [(Reference, Term Symbol)],
 [(Reference, Term Symbol)])
-> (Reference, Map Reference Reference,
    Map Reference (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
absorb (Term Symbol
ll, Map Reference Reference
frem, [(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, [(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 (Term Symbol),
    Map Reference (Term Symbol)
  )
normalizeGroup :: EvalCtx
-> Map Symbol Reference
-> [(Symbol, Term Symbol)]
-> (Map Symbol Reference, 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, Term Symbol)],
    [(Reference, Term Symbol)])
forall v a.
(Var v, Monoid a) =>
Map v Reference
-> [(v, Term v a)]
-> ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)])
lamLiftGroup Map Symbol Reference
orig [(Symbol, Term Symbol)]
gr of
  ([(Symbol, Id)]
subvis, [(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, 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 (SuperGroup Symbol),
    Map.Map Reference (Map.Map Word64 (Term Symbol))
  )
intermediateTerm :: HasCallStack =>
PrettyPrintEnv
-> EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (SuperGroup 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 (Term Symbol),
    Map Reference (Map Word64 (Term Symbol)))
normalizeTerm EvalCtx
ctx Term Symbol
tm of
    (Reference
ref, Map Reference Reference
frem, Map Reference (Term Symbol)
cmbs, Map Reference (Map Word64 (Term Symbol))
dcmp) -> (Reference
ref, Map Reference Reference
frem, (Term Symbol -> SuperGroup Symbol)
-> Map Reference (Term Symbol) -> Map Reference (SuperGroup 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 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 Symbol
f =
          Term Symbol -> SuperGroup Symbol
forall v a. Var v => Term v a -> SuperGroup v
superNormalize
            (Term Symbol -> SuperGroup Symbol)
-> (Term Symbol -> Term Symbol) -> Term Symbol -> SuperGroup 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, SuperGroup Symbol)], Reference)
prepareEvaluation :: HasCallStack =>
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, SuperGroup Symbol)], Reference)
prepareEvaluation PrettyPrintEnv
ppe Term Symbol
tm EvalCtx
ctx = do
  [Reference]
missing <- [(Reference, SuperGroup Symbol)] -> CCache -> IO [Reference]
cacheAdd [(Reference, SuperGroup Symbol)]
rgrp (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, SuperGroup Symbol)]
rgrp, Reference
rmn)
  where
    (Reference
rmn0, Map Reference Reference
frem, Map Reference (SuperGroup Symbol)
rgrp0, Map Reference (Map Word64 (Term Symbol))
rbkr) = HasCallStack =>
PrettyPrintEnv
-> EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (SuperGroup Symbol),
    Map Reference (Map Word64 (Term Symbol)))
PrettyPrintEnv
-> EvalCtx
-> Term Symbol
-> (Reference, Map Reference Reference,
    Map Reference (SuperGroup 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 Symbol) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Reference
r Map Reference (SuperGroup Symbol)
rgrp0 = Reference
r
      | Bool
otherwise = EvalCtx -> Reference -> Reference
toIntermed EvalCtx
ctx Reference
r
    (EvalCtx
ctx', Map Reference Reference
rrefs, [(Reference, SuperGroup Symbol)]
rgrp) =
      Map Reference (SuperGroup Symbol)
-> EvalCtx
-> (EvalCtx, Map Reference Reference,
    [(Reference, SuperGroup Symbol)])
performRehash
        (((SuperGroup Symbol -> SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup 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 Symbol -> SuperGroup Symbol)
 -> Map Reference (SuperGroup Symbol)
 -> Map Reference (SuperGroup Symbol))
-> ((Bool -> Reference -> Reference)
    -> SuperGroup Symbol -> SuperGroup Symbol)
-> (Bool -> Reference -> Reference)
-> Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Reference -> Reference)
-> SuperGroup Symbol -> SuperGroup Symbol
forall v.
Var v =>
(Bool -> Reference -> Reference) -> SuperGroup v -> SuperGroup v
overGroupLinks) Bool -> Reference -> Reference
int Map Reference (SuperGroup Symbol)
rgrp0)
        (Map Reference Reference -> EvalCtx -> EvalCtx
floatRemapAdd Map Reference Reference
frem EvalCtx
ctx)
    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 Closure -> Stack 'UN -> Stack 'BX -> IO ()
watchHook :: IORef Closure -> Stack 'UN -> Stack 'BX -> IO ()
watchHook IORef Closure
r Stack 'UN
_ Stack 'BX
bstk = Stack 'BX -> IO (Elem 'BX)
forall (b :: Mem). MEM b => Stack b -> IO (Elem b)
peek Stack 'BX
bstk IO Closure -> (Closure -> 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 Closure -> Closure -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Closure
r

backReferenceTm ::
  EnumMap Word64 Reference ->
  Remapping ->
  Remapping ->
  Map.Map Reference (Map.Map Word64 (Term Symbol)) ->
  Word64 ->
  Word64 ->
  Maybe (Term Symbol)
backReferenceTm :: EnumMap Word64 Reference
-> Remapping
-> Remapping
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm EnumMap Word64 Reference
ws Remapping
frs Remapping
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
  -- 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 -> Map Reference Reference
backmap Remapping
irs)
  -- backmap floated ref to original ref
  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 (Remapping -> Map Reference Reference
backmap Remapping
frs)
  -- 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

ucrEvalProc :: FilePath -> [String] -> CreateProcess
ucrEvalProc :: [Char] -> [[Char]] -> CreateProcess
ucrEvalProc [Char]
executable [[Char]]
args =
  ([Char] -> [[Char]] -> CreateProcess
proc [Char]
executable [[Char]]
args)
    { std_in = Inherit,
      std_out = Inherit,
      std_err = Inherit
    }

ucrCompileProc :: FilePath -> [String] -> CreateProcess
ucrCompileProc :: [Char] -> [[Char]] -> CreateProcess
ucrCompileProc [Char]
executable [[Char]]
args =
  ([Char] -> [[Char]] -> CreateProcess
proc [Char]
executable [[Char]]
args)
    { std_in = CreatePipe,
      std_out = Inherit,
      std_err = Inherit
    }

receiveAll :: Socket -> IO ByteString
receiveAll :: Socket -> IO ByteString
receiveAll Socket
sock = [ByteString] -> IO ByteString
read []
  where
    read :: [ByteString] -> IO ByteString
read [ByteString]
acc =
      Socket -> Int -> IO (Maybe ByteString)
forall (m :: * -> *).
MonadIO m =>
Socket -> Int -> m (Maybe ByteString)
recv Socket
sock Int
4096 IO (Maybe ByteString)
-> (Maybe ByteString -> IO ByteString) -> IO ByteString
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 ByteString
chunk -> [ByteString] -> IO ByteString
read (ByteString
chunk ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
acc)
        Maybe ByteString
Nothing -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat ([ByteString] -> IO ByteString) -> [ByteString] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
acc

data NativeResult
  = Success Value
  | Bug Text Value
  | Error Text

deserializeNativeResponse :: ByteString -> NativeResult
deserializeNativeResponse :: ByteString -> NativeResult
deserializeNativeResponse =
  Get NativeResult -> ByteString -> NativeResult
run (Get NativeResult -> ByteString -> NativeResult)
-> Get NativeResult -> ByteString -> NativeResult
forall a b. (a -> b) -> a -> b
$
    Get Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8 Get Word8 -> (Word8 -> Get NativeResult) -> Get NativeResult
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Word8
0 -> Value -> NativeResult
Success (Value -> NativeResult) -> Get Value -> Get NativeResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Value
forall (m :: * -> *). MonadGet m => m Value
getVersionedValue
      Word8
1 -> Text -> Value -> NativeResult
Bug (Text -> Value -> NativeResult)
-> Get Text -> Get (Value -> NativeResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
forall (m :: * -> *). MonadGet m => m Text
getText Get (Value -> NativeResult) -> Get Value -> Get NativeResult
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Value
forall (m :: * -> *). MonadGet m => m Value
getVersionedValue
      Word8
2 -> Text -> NativeResult
Error (Text -> NativeResult) -> Get Text -> Get NativeResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
forall (m :: * -> *). MonadGet m => m Text
getText
      Word8
_ -> NativeResult -> Get NativeResult
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NativeResult -> Get NativeResult)
-> NativeResult -> Get NativeResult
forall a b. (a -> b) -> a -> b
$ Text -> NativeResult
Error Text
"Unexpected result bytes tag"
  where
    run :: Get NativeResult -> ByteString -> NativeResult
run Get NativeResult
e ByteString
bs = ([Char] -> NativeResult)
-> (NativeResult -> NativeResult)
-> Either [Char] NativeResult
-> NativeResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> NativeResult
Error (Text -> NativeResult)
-> ([Char] -> Text) -> [Char] -> NativeResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack) NativeResult -> NativeResult
forall a. a -> a
id (Get NativeResult -> ByteString -> Either [Char] NativeResult
forall a. Get a -> ByteString -> Either [Char] a
runGetS Get NativeResult
e ByteString
bs)

-- Note: this currently does not support yielding values; instead it
-- just produces a result appropriate for unitary `run` commands. The
-- reason is that the executed code can cause output to occur, which
-- would interfere with using stdout to communicate the final value
-- back from the subprocess. We need a side channel to support both
-- output effects and result communication.
--
-- Strictly speaking, this also holds for input. Input effects will
-- just get EOF in this scheme, because the code communication has
-- taken over the input. This could probably be without a side
-- channel, but a side channel is probably better.
nativeEvalInContext ::
  FilePath ->
  PrettyPrintEnv ->
  EvalCtx ->
  Socket ->
  PortNumber ->
  [(Reference, SuperGroup Symbol)] ->
  Reference ->
  IO (Either Error ([Error], Term Symbol))
nativeEvalInContext :: [Char]
-> PrettyPrintEnv
-> EvalCtx
-> Socket
-> PortNumber
-> [(Reference, SuperGroup Symbol)]
-> Reference
-> IO (Either Error ([Error], Term Symbol))
nativeEvalInContext [Char]
executable PrettyPrintEnv
ppe EvalCtx
ctx Socket
serv PortNumber
port [(Reference, SuperGroup Symbol)]
codes Reference
base = do
  HasCallStack => [Char] -> IO ()
[Char] -> IO ()
ensureRuntimeExists [Char]
executable
  let cc :: CCache
cc = EvalCtx -> CCache
ccache EvalCtx
ctx
  EnumMap Word64 Reference
crs <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference))
-> TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a b. (a -> b) -> a -> b
$ CCache -> TVar (EnumMap Word64 Reference)
combRefs CCache
cc
  -- Seems a bit weird, but apparently this is how we do it
  [[Char]]
args <- IO [[Char]]
getArgs
  let bytes :: ByteString
bytes = Value -> ByteString
serializeValue (Value -> ByteString)
-> ([(Reference, SuperGroup Symbol)] -> Value)
-> [(Reference, SuperGroup Symbol)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> [(Reference, SuperGroup Symbol)] -> Value
compileValue Reference
base ([(Reference, SuperGroup Symbol)] -> ByteString)
-> [(Reference, SuperGroup Symbol)] -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Reference, SuperGroup Symbol)]
codes

      decodeResult :: NativeResult -> IO (Either Error ([Error], Term Symbol))
decodeResult (Error Text
msg) = Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ([Error], Term Symbol)
 -> IO (Either Error ([Error], Term Symbol)))
-> (Error -> Either Error ([Error], Term Symbol))
-> Error
-> IO (Either Error ([Error], Term Symbol))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ([Error], Term Symbol)
forall a b. a -> Either a b
Left (Error -> IO (Either Error ([Error], Term Symbol)))
-> Error -> IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ Text -> Error
forall s. IsString s => Text -> Pretty s
text Text
msg
      decodeResult (Bug Text
msg Value
val) =
        CCache -> Value -> IO (Either [Reference] Closure)
reifyValue CCache
cc Value
val IO (Either [Reference] Closure)
-> (Either [Reference] Closure
    -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], 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
          Left [Reference]
_ -> Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ([Error], Term Symbol)
 -> IO (Either Error ([Error], Term Symbol)))
-> (Error -> Either Error ([Error], Term Symbol))
-> Error
-> IO (Either Error ([Error], Term Symbol))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ([Error], Term Symbol)
forall a b. a -> Either a b
Left (Error -> IO (Either Error ([Error], Term Symbol)))
-> Error -> IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ Error
"missing references from bug result"
          Right Closure
cl ->
            Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ([Error], Term Symbol)
 -> IO (Either Error ([Error], Term Symbol)))
-> (DecompResult Symbol -> Either Error ([Error], Term Symbol))
-> DecompResult Symbol
-> IO (Either Error ([Error], Term Symbol))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ([Error], Term Symbol)
forall a b. a -> Either a b
Left (Error -> Either Error ([Error], Term Symbol))
-> (DecompResult Symbol -> Error)
-> DecompResult Symbol
-> Either Error ([Error], Term Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv
-> [(Reference, Int)] -> Text -> DecompResult Symbol -> Error
bugMsg PrettyPrintEnv
ppe [] Text
msg (DecompResult Symbol -> IO (Either Error ([Error], Term Symbol)))
-> DecompResult Symbol -> IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 Reference
-> EvalCtx -> Closure -> DecompResult Symbol
decompileCtx EnumMap Word64 Reference
crs EvalCtx
ctx Closure
cl
      decodeResult (Success Value
val) =
        CCache -> Value -> IO (Either [Reference] Closure)
reifyValue CCache
cc Value
val IO (Either [Reference] Closure)
-> (Either [Reference] Closure
    -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], 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
          Left [Reference]
_ -> Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ([Error], Term Symbol)
 -> IO (Either Error ([Error], Term Symbol)))
-> (Error -> Either Error ([Error], Term Symbol))
-> Error
-> IO (Either Error ([Error], Term Symbol))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ([Error], Term Symbol)
forall a b. a -> Either a b
Left (Error -> IO (Either Error ([Error], Term Symbol)))
-> Error -> IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ Error
"missing references from result"
          Right Closure
cl -> case EnumMap Word64 Reference
-> EvalCtx -> Closure -> DecompResult Symbol
decompileCtx EnumMap Word64 Reference
crs EvalCtx
ctx Closure
cl of
            (Set DecompError
errs, Term Symbol
dv) -> Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ([Error], Term Symbol)
 -> IO (Either Error ([Error], Term Symbol)))
-> Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ ([Error], Term Symbol) -> Either Error ([Error], Term Symbol)
forall a b. b -> Either a b
Right (Set DecompError -> [Error]
listErrors Set DecompError
errs, Term Symbol
dv)

      comm :: MVar ByteString -> (Socket, SockAddr) -> IO ()
comm MVar ByteString
mv (Socket
sock, SockAddr
_) = do
        let encodeNum :: Int -> ByteString
encodeNum = Put -> ByteString
runPutS (Put -> ByteString) -> (Int -> Put) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Put
forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32be (Word32 -> Put) -> (Int -> Word32) -> Int -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
send Socket
sock (ByteString -> IO ()) -> (Int -> ByteString) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString
encodeNum (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bytes
        Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
send Socket
sock ByteString
bytes
        Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
send Socket
sock (ByteString -> IO ()) -> (Int -> ByteString) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString
encodeNum (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
args
        [[Char]] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[Char]]
args (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
arg -> do
          let bs :: ByteString
bs = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
arg
          Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
send Socket
sock (ByteString -> IO ()) -> (Int -> ByteString) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString
encodeNum (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs
          Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
send Socket
sock ByteString
bs
        MVar ByteString -> ByteString -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
UnliftIO.putMVar MVar ByteString
mv (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Socket -> IO ByteString
receiveAll Socket
sock

      callout :: Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (Either Error ([Error], Term Symbol))
callout Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
ph = do
        MVar ByteString
mv <- IO (MVar ByteString)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
UnliftIO.newEmptyMVar
        ThreadId
tid <- Socket -> ((Socket, SockAddr) -> IO ()) -> IO ThreadId
forall (m :: * -> *).
MonadIO m =>
Socket -> ((Socket, SockAddr) -> IO ()) -> m ThreadId
acceptFork Socket
serv (((Socket, SockAddr) -> IO ()) -> IO ThreadId)
-> ((Socket, SockAddr) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar ByteString -> (Socket, SockAddr) -> IO ()
comm MVar ByteString
mv
        ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph IO ExitCode
-> (ExitCode -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], 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
          ExitCode
ExitSuccess ->
            NativeResult -> IO (Either Error ([Error], Term Symbol))
decodeResult (NativeResult -> IO (Either Error ([Error], Term Symbol)))
-> (ByteString -> NativeResult)
-> ByteString
-> IO (Either Error ([Error], Term Symbol))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> NativeResult
deserializeNativeResponse
              (ByteString -> IO (Either Error ([Error], Term Symbol)))
-> IO ByteString -> IO (Either Error ([Error], Term Symbol))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
UnliftIO.takeMVar MVar ByteString
mv
          ExitFailure Int
_ -> do
            ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
UnliftIO.killThread ThreadId
tid
            Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ([Error], Term Symbol)
 -> IO (Either Error ([Error], Term Symbol)))
-> (Error -> Either Error ([Error], Term Symbol))
-> Error
-> IO (Either Error ([Error], Term Symbol))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error ([Error], Term Symbol)
forall a b. a -> Either a b
Left (Error -> IO (Either Error ([Error], Term Symbol)))
-> Error -> IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ Error
"native evaluation failed"
      p :: CreateProcess
p = [Char] -> [[Char]] -> CreateProcess
ucrEvalProc [Char]
executable [[Char]
"-p", PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port]
      ucrError :: IOException -> IO (Either Error ([Error], Term Symbol))
ucrError (IOException
e :: IOException) = Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error ([Error], Term Symbol)
 -> IO (Either Error ([Error], Term Symbol)))
-> Either Error ([Error], Term Symbol)
-> IO (Either Error ([Error], Term Symbol))
forall a b. (a -> b) -> a -> b
$ Error -> Either Error ([Error], Term Symbol)
forall a b. a -> Either a b
Left (CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
runtimeErrMsg (CreateProcess -> CmdSpec
cmdspec CreateProcess
p) (IOException -> Either (Int, [Char], [Char]) IOException
forall a b. b -> Either a b
Right IOException
e))
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], Term Symbol))
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
p Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (Either Error ([Error], Term Symbol))
callout
    IO (Either Error ([Error], Term Symbol))
-> (IOException -> IO (Either Error ([Error], Term Symbol)))
-> IO (Either Error ([Error], Term Symbol))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`UnliftIO.catch` IOException -> IO (Either Error ([Error], Term Symbol))
ucrError

nativeCompileCodes ::
  CompileOpts ->
  FilePath ->
  [(Reference, SuperGroup Symbol)] ->
  Reference ->
  FilePath ->
  IO ()
nativeCompileCodes :: CompileOpts
-> [Char]
-> [(Reference, SuperGroup Symbol)]
-> Reference
-> [Char]
-> IO ()
nativeCompileCodes CompileOpts
copts [Char]
executable [(Reference, SuperGroup Symbol)]
codes Reference
base [Char]
path = do
  HasCallStack => [Char] -> IO ()
[Char] -> IO ()
ensureRuntimeExists [Char]
executable
  IO ()
HasCallStack => IO ()
ensureRacoExists
  [Char]
genDir <- XdgDirectory -> [Char] -> IO [Char]
getXdgDirectory XdgDirectory
XdgCache [Char]
"unisonlanguage/racket-tmp"
  Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
genDir
  let bytes :: ByteString
bytes = Value -> ByteString
serializeValue (Value -> ByteString)
-> ([(Reference, SuperGroup Symbol)] -> Value)
-> [(Reference, SuperGroup Symbol)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> [(Reference, SuperGroup Symbol)] -> Value
compileValue Reference
base ([(Reference, SuperGroup Symbol)] -> ByteString)
-> [(Reference, SuperGroup Symbol)] -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Reference, SuperGroup Symbol)]
codes
      srcPath :: [Char]
srcPath = [Char]
genDir [Char] -> [Char] -> [Char]
</> [Char]
path [Char] -> [Char] -> [Char]
<.> [Char]
"rkt"
      callout :: Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ()
callout (Just Handle
pin) Maybe Handle
_ Maybe Handle
_ ProcessHandle
ph = do
        Handle -> ByteString -> IO ()
BS.hPut Handle
pin (ByteString -> IO ()) -> (Int -> ByteString) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString) -> (Int -> Put) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Put
forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32be (Word32 -> Put) -> (Int -> Word32) -> Int -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bytes
        Handle -> ByteString -> IO ()
BS.hPut Handle
pin ByteString
bytes
        Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
UnliftIO.hClose Handle
pin
        ExitCode
_ <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
        pure ()
      callout Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
_ = [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"withCreateProcess didn't provide handles"
      ucrError :: IOException -> IO ()
ucrError (IOException
e :: IOException) =
        RuntimeExn -> IO ()
forall e a. Exception e => e -> IO a
throwIO (RuntimeExn -> IO ()) -> RuntimeExn -> IO ()
forall a b. (a -> b) -> a -> b
$ CallStack -> Error -> RuntimeExn
PE CallStack
HasCallStack => CallStack
callStack (CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
runtimeErrMsg (CreateProcess -> CmdSpec
cmdspec CreateProcess
p) (IOException -> Either (Int, [Char], [Char]) IOException
forall a b. b -> Either a b
Right IOException
e))
      racoError :: IOException -> IO a
racoError (IOException
e :: IOException) =
        RuntimeExn -> IO a
forall e a. Exception e => e -> IO a
throwIO (RuntimeExn -> IO a) -> RuntimeExn -> IO a
forall a b. (a -> b) -> a -> b
$ CallStack -> Error -> RuntimeExn
PE CallStack
HasCallStack => CallStack
callStack (CmdSpec -> Either (Int, [Char], [Char]) IOException -> Error
racoErrMsg (([Char] -> [[Char]] -> CmdSpec) -> CmdSpec
forall a. ([Char] -> [[Char]] -> a) -> a
makeRacoCmd [Char] -> [[Char]] -> CmdSpec
RawCommand) (IOException -> Either (Int, [Char], [Char]) IOException
forall a b. b -> Either a b
Right IOException
e))
      dargs :: [[Char]]
dargs = [[Char]
"-G", [Char]
srcPath]
      pargs :: [[Char]]
pargs
        | CompileOpts -> Bool
profile CompileOpts
copts = [Char]
"--profile" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
dargs
        | Bool
otherwise = [[Char]]
dargs
      p :: CreateProcess
p = [Char] -> [[Char]] -> CreateProcess
ucrCompileProc [Char]
executable [[Char]]
pargs
      makeRacoCmd :: (FilePath -> [String] -> a) -> a
      makeRacoCmd :: forall a. ([Char] -> [[Char]] -> a) -> a
makeRacoCmd [Char] -> [[Char]] -> a
f = [Char] -> [[Char]] -> a
f [Char]
"raco" [[Char]
"exe", [Char]
"-o", [Char]
path, [Char]
srcPath]
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
p Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ()
callout
    IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`UnliftIO.catch` IOException -> IO ()
ucrError
  ([Char] -> [[Char]] -> IO ()) -> IO ()
makeRacoCmd [Char] -> [[Char]] -> IO ()
callProcess
    IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`UnliftIO.catch` IOException -> IO ()
racoError

evalInContext ::
  PrettyPrintEnv ->
  EvalCtx ->
  ActiveThreads ->
  Word64 ->
  IO (Either Error ([Error], Term Symbol))
evalInContext :: PrettyPrintEnv
-> EvalCtx
-> ActiveThreads
-> Word64
-> IO (Either Error ([Error], Term Symbol))
evalInContext PrettyPrintEnv
ppe EvalCtx
ctx ActiveThreads
activeThreads Word64
w = do
  IORef Closure
r <- Closure -> IO (IORef Closure)
forall a. a -> IO (IORef a)
newIORef Closure
forall comb. GClosure comb
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)
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 :: Stack 'UN -> Stack 'BX -> IO ()
hook = IORef Closure -> Stack 'UN -> Stack 'BX -> IO ()
watchHook IORef Closure
r
      decom :: Closure -> DecompResult Symbol
decom = EnumMap Word64 Reference
-> EvalCtx -> Closure -> DecompResult Symbol
decompileCtx EnumMap Word64 Reference
crs EvalCtx
ctx
      finish :: Either Error Closure -> Either Error ([Error], Term Symbol)
finish = (Closure -> ([Error], Term Symbol))
-> Either Error Closure -> Either Error ([Error], 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 -> [Error])
-> DecompResult Symbol -> ([Error], 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 -> [Error]
listErrors (DecompResult Symbol -> ([Error], Term Symbol))
-> (Closure -> DecompResult Symbol)
-> Closure
-> ([Error], Term Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> DecompResult Symbol
decom)

      prettyError :: RuntimeExn -> Error
prettyError (PE CallStack
_ Error
p) = Error
p
      prettyError (BU [(Reference, Int)]
tr0 Text
nm Closure
c) =
        PrettyPrintEnv
-> [(Reference, Int)] -> Text -> DecompResult Symbol -> Error
bugMsg PrettyPrintEnv
ppe [(Reference, Int)]
tr Text
nm (DecompResult Symbol -> Error) -> DecompResult Symbol -> Error
forall a b. (a -> b) -> a -> b
$ Closure -> DecompResult Symbol
decom Closure
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 (EvalCtx -> Reference -> Reference
backmapRef EvalCtx
ctx) ((Reference, Int) -> (Reference, Int))
-> [(Reference, Int)] -> [(Reference, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, Int)]
tr0

      debugText :: Bool -> Closure -> Tracer
debugText Bool
fancy Closure
c = case Closure -> DecompResult Symbol
decom Closure
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) -> (Error -> [Char]) -> Error -> Tracer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Error -> [Char]
debugTextFormat Bool
fancy (Error -> Tracer) -> Error -> Tracer
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
pretty PrettyPrintEnv
ppe Term Symbol
dv
          | Bool
otherwise ->
              [Char] -> [Char] -> [Char] -> Tracer
MsgTrace
                (Bool -> Error -> [Char]
debugTextFormat Bool
fancy (Error -> [Char]) -> Error -> [Char]
forall a b. (a -> b) -> a -> b
$ Set DecompError -> Error
tabulateErrors Set DecompError
errs)
                (Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
c)
                (Bool -> Error -> [Char]
debugTextFormat Bool
fancy (Error -> [Char]) -> Error -> [Char]
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
pretty PrettyPrintEnv
ppe Term Symbol
dv)

  Either Error Closure
result <-
    (() -> IO Closure) -> Either Error () -> IO (Either Error Closure)
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 Closure -> () -> IO Closure
forall a b. a -> b -> a
const (IO Closure -> () -> IO Closure) -> IO Closure -> () -> IO Closure
forall a b. (a -> b) -> a -> b
$ IORef Closure -> IO Closure
forall a. IORef a -> IO a
readIORef IORef Closure
r)
      (Either Error () -> IO (Either Error Closure))
-> (Either RuntimeExn () -> Either Error ())
-> Either RuntimeExn ()
-> IO (Either Error Closure)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RuntimeExn -> Error) -> Either RuntimeExn () -> Either Error ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first RuntimeExn -> Error
prettyError
      (Either RuntimeExn () -> IO (Either Error Closure))
-> (IO () -> IO (Either RuntimeExn ()))
-> IO ()
-> IO (Either Error Closure)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO () -> IO (Either RuntimeExn ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try
      (IO () -> IO (Either Error Closure))
-> IO () -> IO (Either Error Closure)
forall a b. (a -> b) -> a -> b
$ Maybe (Stack 'UN -> Stack 'BX -> IO ())
-> CCache -> ActiveThreads -> Word64 -> IO ()
apply0 ((Stack 'UN -> Stack 'BX -> IO ())
-> Maybe (Stack 'UN -> Stack 'BX -> IO ())
forall a. a -> Maybe a
Just Stack 'UN -> Stack 'BX -> IO ()
hook) ((EvalCtx -> CCache
ccache EvalCtx
ctx) {tracer = debugText}) ActiveThreads
activeThreads Word64
w
  pure $ Either Error Closure -> Either Error ([Error], Term Symbol)
finish Either Error Closure
result

executeMainComb ::
  CombIx ->
  CCache ->
  IO (Either (Pretty ColorText) ())
executeMainComb :: CombIx -> CCache -> IO (Either Error ())
executeMainComb CombIx
init CCache
cc = do
  RSection
rSection <- CCache -> Section -> IO RSection
resolveSection CCache
cc (Section -> IO RSection) -> Section -> IO RSection
forall a b. (a -> b) -> a -> b
$ GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (Reference -> Word64 -> Args -> GInstr CombIx
forall comb. Reference -> Word64 -> Args -> GInstr comb
Pack Reference
RF.unitRef Word64
0 Args
ZArgs) (Section -> Section) -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Bool -> CombIx -> Args -> Section
forall comb. Bool -> comb -> Args -> GSection comb
Call Bool
True CombIx
init (Int -> Args
BArg1 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 ()))
-> (RSection -> IO ()) -> RSection -> IO (Either RuntimeExn ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CCache -> ActiveThreads -> RSection -> IO ()
eval0 CCache
cc ActiveThreads
forall a. Maybe a
Nothing (RSection -> IO (Either RuntimeExn ()))
-> RSection -> IO (Either RuntimeExn ())
forall a b. (a -> b) -> a -> b
$ RSection
rSection
  case Either RuntimeExn ()
result of
    Left RuntimeExn
err -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> IO Error -> IO (Either Error ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RuntimeExn -> IO Error
formatErr RuntimeExn
err
    Right () -> Either Error () -> IO (Either Error ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either Error ()
forall a b. b -> Either a b
Right ())
  where
    formatErr :: RuntimeExn -> IO Error
formatErr (PE CallStack
_ Error
msg) = Error -> IO Error
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Error
msg
    formatErr (BU [(Reference, Int)]
tr Text
nm Closure
c) = 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)
combRefs CCache
cc)
      let ctx :: EvalCtx
ctx = CCache -> EvalCtx
cacheContext CCache
cc
          decom :: Closure -> DecompResult Symbol
decom =
            (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Closure
-> DecompResult Symbol
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ()))
-> Closure
-> DecompResult v
decompile
              (EvalCtx -> Reference -> Maybe Reference
intermedToBase EvalCtx
ctx)
              ( EnumMap Word64 Reference
-> Remapping
-> Remapping
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm
                  EnumMap Word64 Reference
crs
                  (EvalCtx -> Remapping
floatRemap EvalCtx
ctx)
                  (EvalCtx -> Remapping
intermedRemap EvalCtx
ctx)
                  (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)
-> (DecompResult Symbol -> Error)
-> DecompResult Symbol
-> IO Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv
-> [(Reference, Int)] -> Text -> DecompResult Symbol -> Error
bugMsg PrettyPrintEnv
PPE.empty [(Reference, Int)]
tr Text
nm (DecompResult Symbol -> IO Error)
-> DecompResult Symbol -> IO Error
forall a b. (a -> b) -> a -> b
$ Closure -> DecompResult Symbol
decom Closure
c

bugMsg ::
  PrettyPrintEnv ->
  [(Reference, Int)] ->
  Text ->
  (Set DecompError, Term Symbol) ->
  Pretty ColorText
bugMsg :: PrettyPrintEnv
-> [(Reference, Int)] -> Text -> DecompResult Symbol -> Error
bugMsg PrettyPrintEnv
ppe [(Reference, Int)]
tr Text
name (Set DecompError
errs, Term Symbol
tm)
  | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"blank expression" =
      Error -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Error
icon (Error -> Error) -> ([Error] -> Error) -> [Error] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.linesNonEmpty ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$
        [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
            ( Error
"I encountered a"
                Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error -> Error
P.red (Text -> Error
forall s. IsString s => Text -> Pretty s
P.text Text
name)
                Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
"with the following name/message:"
            ),
          Error
"",
          Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
pretty PrettyPrintEnv
ppe Term Symbol
tm,
          Set DecompError -> Error
tabulateErrors Set DecompError
errs,
          PrettyPrintEnv -> [(Reference, Int)] -> Error
stackTrace PrettyPrintEnv
ppe [(Reference, Int)]
tr
        ]
  | Text
"pattern match failure" Text -> Text -> Bool
`isPrefixOf` Text
name =
      Error -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Error
icon (Error -> Error) -> ([Error] -> Error) -> [Error] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.linesNonEmpty ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$
        [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
            ( Error
"I've encountered a"
                Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error -> Error
P.red (Text -> Error
forall s. IsString s => Text -> Pretty s
P.text Text
name)
                Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
"while scrutinizing:"
            ),
          Error
"",
          Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
pretty PrettyPrintEnv
ppe Term Symbol
tm,
          Error
"",
          Error
"This happens when calling a function that doesn't handle all \
          \possible inputs",
          Set DecompError -> Error
tabulateErrors Set DecompError
errs,
          PrettyPrintEnv -> [(Reference, Int)] -> Error
stackTrace PrettyPrintEnv
ppe [(Reference, Int)]
tr
        ]
  | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"builtin.raise" =
      Error -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Error
icon (Error -> Error) -> ([Error] -> Error) -> [Error] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.linesNonEmpty ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$
        [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap (Error
"The program halted with an unhandled exception:"),
          Error
"",
          Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
pretty PrettyPrintEnv
ppe Term Symbol
tm,
          Set DecompError -> Error
tabulateErrors Set DecompError
errs,
          PrettyPrintEnv -> [(Reference, Int)] -> Error
stackTrace PrettyPrintEnv
ppe [(Reference, Int)]
tr
        ]
  | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"builtin.bug",
    RF.TupleTerm' [Tm.Text' Text
msg, Term Symbol
x] <- Term Symbol
tm,
    Text
"pattern match failure" Text -> Text -> Bool
`isPrefixOf` Text
msg =
      Error -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Error
icon (Error -> Error) -> ([Error] -> Error) -> [Error] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.linesNonEmpty ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$
        [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
            ( Error
"I've encountered a"
                Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error -> Error
P.red (Text -> Error
forall s. IsString s => Text -> Pretty s
P.text Text
msg)
                Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
"while scrutinizing:"
            ),
          Error
"",
          Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
pretty PrettyPrintEnv
ppe Term Symbol
x,
          Error
"",
          Error
"This happens when calling a function that doesn't handle all \
          \possible inputs",
          Set DecompError -> Error
tabulateErrors Set DecompError
errs,
          PrettyPrintEnv -> [(Reference, Int)] -> Error
stackTrace PrettyPrintEnv
ppe [(Reference, Int)]
tr
        ]
bugMsg PrettyPrintEnv
ppe [(Reference, Int)]
tr Text
name (Set DecompError
errs, Term Symbol
tm) =
  Error -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout Error
icon (Error -> Error) -> ([Error] -> Error) -> [Error] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.linesNonEmpty ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$
    [ Error -> Error
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
P.wrap
        ( Error
"I've encountered a call to"
            Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error -> Error
P.red (Text -> Error
forall s. IsString s => Text -> Pretty s
P.text Text
name)
            Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
"with the following value:"
        ),
      Error
"",
      Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
pretty PrettyPrintEnv
ppe Term Symbol
tm,
      Set DecompError -> Error
tabulateErrors Set DecompError
errs,
      PrettyPrintEnv -> [(Reference, Int)] -> Error
stackTrace PrettyPrintEnv
ppe [(Reference, Int)]
tr
    ]

stackTrace :: PrettyPrintEnv -> [(Reference, Int)] -> Pretty ColorText
stackTrace :: PrettyPrintEnv -> [(Reference, Int)] -> Error
stackTrace PrettyPrintEnv
_ [] = Error
forall a. Monoid a => a
mempty
stackTrace PrettyPrintEnv
ppe [(Reference, Int)]
tr = Error
"\nStack trace:\n" Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 ([Error] -> Error
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$ (Reference, Int) -> Error
f ((Reference, Int) -> Error) -> [(Reference, Int)] -> [Error]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, Int)]
tr)
  where
    f :: (Reference, Int) -> Error
f (Reference
rf, Int
n) = Error
name Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
count
      where
        count :: Error
count
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = Error
" (" Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> [Char] -> Error
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n) Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
" copies)"
          | Bool
otherwise = Error
""
        name :: Error
name =
          Pretty (SyntaxText' Reference) -> Error
forall r. Pretty (SyntaxText' r) -> Error
syntaxToColor
            (Pretty (SyntaxText' Reference) -> Error)
-> (Reference -> Pretty (SyntaxText' Reference))
-> Reference
-> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashQualified Name -> Pretty (SyntaxText' Reference)
prettyHashQualified
            (HashQualified Name -> Pretty (SyntaxText' Reference))
-> (Reference -> HashQualified Name)
-> Reference
-> Pretty (SyntaxText' Reference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv -> Referent -> HashQualified Name
PPE.termName PrettyPrintEnv
ppe
            (Referent -> HashQualified Name)
-> (Reference -> Referent) -> Reference -> HashQualified Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent
RF.Ref
            (Reference -> Error) -> Reference -> Error
forall a b. (a -> b) -> a -> b
$ Reference
rf

icon :: Pretty ColorText
icon :: Error
icon = Error
"💔💥"

catchInternalErrors ::
  IO (Either Error a) ->
  IO (Either Error a)
catchInternalErrors :: forall a. IO (Either Error a) -> IO (Either Error a)
catchInternalErrors 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` CompileExn -> IO (Either Error a)
forall {f :: * -> *} {b}.
Applicative f =>
CompileExn -> f (Either Error b)
hCE 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` RuntimeExn -> IO (Either Error a)
forall {f :: * -> *} {b}.
Applicative f =>
RuntimeExn -> f (Either Error b)
hRE
  where
    hCE :: CompileExn -> f (Either Error b)
hCE (CE CallStack
_ Error
e) = Either Error b -> f (Either Error b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error b -> f (Either Error b))
-> Either Error b -> f (Either Error b)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error b
forall a b. a -> Either a b
Left Error
e
    hRE :: RuntimeExn -> f (Either Error b)
hRE (PE CallStack
_ Error
e) = Either Error b -> f (Either Error b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error b -> f (Either Error b))
-> Either Error b -> f (Either Error b)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error b
forall a b. a -> Either a b
Left Error
e
    hRE (BU [(Reference, Int)]
_ Text
_ Closure
_) = Either Error b -> f (Either Error b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error b -> f (Either Error b))
-> Either Error b -> f (Either Error b)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error b
forall a b. a -> Either a b
Left Error
"impossible"

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
-> Term Symbol
-> IO (Either Error ([Error], Term Symbol))
evaluate = ActiveThreads
-> IO ()
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Term Symbol
-> IO (Either Error ([Error], 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
      }

startNativeRuntime :: Text -> FilePath -> IO (Runtime Symbol)
startNativeRuntime :: Text -> [Char] -> IO (Runtime Symbol)
startNativeRuntime Text
_version [Char]
executable = 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
False
  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
-> Term Symbol
-> IO (Either Error ([Error], Term Symbol))
evaluate = [Char]
-> IORef EvalCtx
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Term Symbol
-> IO (Either Error ([Error], Term Symbol))
nativeEval [Char]
executable IORef EvalCtx
ctxVar,
        $sel:compileTo:Runtime :: CompileOpts
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Reference
-> [Char]
-> IO (Maybe Error)
compileTo = [Char]
-> IORef EvalCtx
-> CompileOpts
-> CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> Reference
-> [Char]
-> IO (Maybe Error)
nativeCompile [Char]
executable 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 v. Runtime 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 RuntimeExn -> IO (Maybe Error)
forall {f :: * -> *}.
Applicative f =>
RuntimeExn -> f (Maybe Error)
hRE
    (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 CompileExn -> IO (Maybe Error)
forall {f :: * -> *}.
Applicative f =>
CompileExn -> f (Maybe Error)
hCE
    (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)
  where
    hCE :: CompileExn -> f (Maybe Error)
hCE (CE CallStack
_ Error
e) = Maybe Error -> f (Maybe Error)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Error -> f (Maybe Error)) -> Maybe Error -> f (Maybe Error)
forall a b. (a -> b) -> a -> b
$ Error -> Maybe Error
forall a. a -> Maybe a
Just Error
e
    hRE :: RuntimeExn -> f (Maybe Error)
hRE (PE CallStack
_ Error
e) = Maybe Error -> f (Maybe Error)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Error -> f (Maybe Error)) -> Maybe Error -> f (Maybe Error)
forall a b. (a -> b) -> a -> b
$ Error -> Maybe Error
forall a. a -> Maybe a
Just Error
e
    hRE (BU [(Reference, Int)]
_ Text
_ Closure
_) = Maybe Error -> f (Maybe Error)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Error -> f (Maybe Error)) -> Maybe Error -> f (Maybe Error)
forall a b. (a -> b) -> a -> b
$ Error -> Maybe Error
forall a. a -> Maybe a
Just Error
"impossible"

runStandalone :: StoredCache -> CombIx -> IO (Either (Pretty ColorText) ())
runStandalone :: StoredCache -> CombIx -> IO (Either Error ())
runStandalone StoredCache
sc CombIx
init =
  StoredCache -> IO CCache
restoreCache 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)
      (EnumMap Word64 Reference)
      Word64
      Word64
      (Map Reference (SuperGroup 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)

putStoredCache :: (MonadPut m) => StoredCache -> m ()
putStoredCache :: forall (m :: * -> *). MonadPut m => StoredCache -> m ()
putStoredCache (SCache EnumMap Word64 (EnumMap Word64 Comb)
cs EnumMap Word64 Reference
crs EnumMap Word64 Reference
trs Word64
ftm Word64
fty Map Reference (SuperGroup Symbol)
int Map Reference Word64
rtm Map Reference Word64
rty Map Reference (Set Reference)
sbs) = do
  (Word64 -> m ())
-> (EnumMap Word64 Comb -> m ())
-> EnumMap Word64 (EnumMap Word64 Comb)
-> 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 ()) -> (Comb -> m ()) -> EnumMap Word64 Comb -> 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 ((CombIx -> m ()) -> Comb -> m ()
forall (m :: * -> *) cix.
MonadPut m =>
(cix -> m ()) -> GComb cix -> m ()
putComb CombIx -> m ()
forall (m :: * -> *). MonadPut m => CombIx -> m ()
putCombIx)) EnumMap Word64 (EnumMap Word64 Comb)
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 ())
-> (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 Symbol -> m ())
-> Map Reference (SuperGroup 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
-> EnumMap Word64 Text -> SuperGroup Symbol -> m ()
forall (m :: * -> *) v.
(MonadPut m, Var v) =>
Map Reference Word64 -> EnumMap Word64 Text -> SuperGroup v -> m ()
putGroup Map Reference Word64
forall a. Monoid a => a
mempty EnumMap Word64 Text
forall a. Monoid a => a
mempty) Map Reference (SuperGroup 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 (EnumMap Word64 Comb)
-> EnumMap Word64 Reference
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
SCache
    (EnumMap Word64 (EnumMap Word64 Comb)
 -> EnumMap Word64 Reference
 -> EnumMap Word64 Reference
 -> Word64
 -> Word64
 -> Map Reference (SuperGroup Symbol)
 -> Map Reference Word64
 -> Map Reference Word64
 -> Map Reference (Set Reference)
 -> StoredCache)
-> m (EnumMap Word64 (EnumMap Word64 Comb))
-> m (EnumMap Word64 Reference
      -> EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup 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 (EnumMap Word64 Comb)
-> m (EnumMap Word64 (EnumMap Word64 Comb))
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 Comb -> m (EnumMap Word64 Comb)
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 CombIx -> m Comb
forall (m :: * -> *) cix. MonadGet m => m cix -> m (GComb cix)
getComb m CombIx
forall (m :: * -> *). MonadGet m => m CombIx
getCombIx))
    m (EnumMap Word64 Reference
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (EnumMap Word64 Reference)
-> m (EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup 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 (EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (EnumMap Word64 Reference)
-> m (Word64
      -> Word64
      -> Map Reference (SuperGroup 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 Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m Word64
-> m (Word64
      -> Map Reference (SuperGroup 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 Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m Word64
-> m (Map Reference (SuperGroup 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 Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (Map Reference (SuperGroup 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 Symbol) -> m (Map Reference (SuperGroup 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 Symbol)
forall (m :: * -> *) v. (MonadGet m, Var v) => m (SuperGroup v)
getGroup
    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 -> Error -> [Char]
debugTextFormat Bool
fancy =
  Width -> Error -> [Char]
render Width
50
  where
    render :: Width -> Error -> [Char]
render = if Bool
fancy then Width -> Error -> [Char]
toANSI else Width -> Error -> [Char]
toPlain

listErrors :: Set DecompError -> [Error]
listErrors :: Set DecompError -> [Error]
listErrors = (DecompError -> Error) -> [DecompError] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Width -> Error -> Error
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2 (Error -> Error) -> (DecompError -> Error) -> DecompError -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecompError -> Error
renderDecompError) ([DecompError] -> [Error])
-> (Set DecompError -> [DecompError]) -> Set DecompError -> [Error]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set DecompError -> [DecompError]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

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

restoreCache :: StoredCache -> IO CCache
restoreCache :: StoredCache -> IO CCache
restoreCache (SCache EnumMap Word64 (EnumMap Word64 Comb)
cs EnumMap Word64 Reference
crs EnumMap Word64 Reference
trs Word64
ftm Word64
fty Map Reference (SuperGroup Symbol)
int Map Reference Word64
rtm Map Reference Word64
rty Map Reference (Set Reference)
sbs) =
  EnumMap Word64 ForeignFunc
-> Bool
-> (Bool -> Closure -> Tracer)
-> TVar (EnumMap Word64 RCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumMap Word64 Reference)
-> TVar Word64
-> TVar Word64
-> TVar (Map Reference (SuperGroup Symbol))
-> TVar (Map Reference Word64)
-> TVar (Map Reference Word64)
-> TVar (Map Reference (Set Reference))
-> CCache
CCache EnumMap Word64 ForeignFunc
builtinForeigns Bool
False Bool -> Closure -> Tracer
debugText
    (TVar (EnumMap Word64 RCombs)
 -> TVar (EnumMap Word64 Reference)
 -> TVar (EnumMap Word64 Reference)
 -> TVar Word64
 -> TVar Word64
 -> TVar (Map Reference (SuperGroup Symbol))
 -> TVar (Map Reference Word64)
 -> TVar (Map Reference Word64)
 -> TVar (Map Reference (Set Reference))
 -> CCache)
-> IO (TVar (EnumMap Word64 RCombs))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup 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 RCombs -> IO (TVar (EnumMap Word64 RCombs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 RCombs
combs
    IO
  (TVar (EnumMap Word64 Reference)
   -> TVar (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar (EnumMap Word64 Reference))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar Word64
      -> TVar Word64
      -> TVar (Map Reference (SuperGroup 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 (EnumMap Word64 Reference)
   -> TVar Word64
   -> TVar Word64
   -> TVar (Map Reference (SuperGroup 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 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 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 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 Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar Word64)
-> IO
     (TVar (Map Reference (SuperGroup 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 Symbol))
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference Word64)
   -> TVar (Map Reference (Set Reference))
   -> CCache)
-> IO (TVar (Map Reference (SuperGroup 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 Symbol)
-> IO (TVar (Map Reference (SuperGroup Symbol)))
forall a. a -> IO (TVar a)
newTVarIO Map Reference (SuperGroup 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)
  where
    decom :: Closure -> DecompResult Symbol
decom =
      (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Closure
-> DecompResult Symbol
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ()))
-> Closure
-> 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
-> Remapping
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm EnumMap Word64 Reference
crs Remapping
forall a. Monoid a => a
mempty Remapping
forall a. Monoid a => a
mempty Map Reference (Map Word64 (Term Symbol))
forall a. Monoid a => a
mempty)
    debugText :: Bool -> Closure -> Tracer
debugText Bool
fancy Closure
c = case Closure -> DecompResult Symbol
decom Closure
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) -> (Error -> [Char]) -> Error -> Tracer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Error -> [Char]
debugTextFormat Bool
fancy (Error -> Tracer) -> Error -> Tracer
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
pretty PrettyPrintEnv
PPE.empty Term Symbol
dv
        | Bool
otherwise ->
            [Char] -> [Char] -> [Char] -> Tracer
MsgTrace
              (Bool -> Error -> [Char]
debugTextFormat Bool
fancy (Error -> [Char]) -> Error -> [Char]
forall a b. (a -> b) -> a -> b
$ Set DecompError -> Error
tabulateErrors Set DecompError
errs)
              (Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
c)
              (Bool -> Error -> [Char]
debugTextFormat Bool
fancy (Error -> [Char]) -> Error -> [Char]
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term Symbol -> Error
forall v a. Var v => PrettyPrintEnv -> Term v a -> Error
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
    combs :: EnumMap Word64 RCombs
    combs :: EnumMap Word64 RCombs
combs =
      let builtinCombs :: EnumMap Word64 (EnumMap Word64 Comb)
builtinCombs = (Word64 -> SuperNormal Symbol -> EnumMap Word64 Comb)
-> EnumMap Word64 (SuperNormal Symbol)
-> EnumMap Word64 (EnumMap Word64 Comb)
forall k a b.
EnumKey k =>
(k -> a -> b) -> EnumMap k a -> EnumMap k b
mapWithKey (\Word64
k SuperNormal Symbol
v -> forall v.
Var v =>
RefNums
-> Reference
-> Word64
-> RCtx v
-> (Word64, SuperNormal v)
-> EnumMap Word64 Comb
emitComb @Symbol RefNums
rns (Word64 -> Reference
rf Word64
k) Word64
k RCtx Symbol
forall a. Monoid a => a
mempty (Word64
0, SuperNormal Symbol
v)) EnumMap Word64 (SuperNormal Symbol)
numberedTermLookup
       in EnumMap Word64 (EnumMap Word64 Comb)
builtinCombs EnumMap Word64 (EnumMap Word64 Comb)
-> EnumMap Word64 (EnumMap Word64 Comb)
-> EnumMap Word64 (EnumMap Word64 Comb)
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 (EnumMap Word64 Comb)
cs
            EnumMap Word64 (EnumMap Word64 Comb)
-> (EnumMap Word64 (EnumMap Word64 Comb) -> EnumMap Word64 RCombs)
-> EnumMap Word64 RCombs
forall a b. a -> (a -> b) -> b
& Maybe (EnumMap Word64 RCombs)
-> EnumMap Word64 (EnumMap Word64 Comb) -> EnumMap Word64 RCombs
resolveCombs Maybe (EnumMap Word64 RCombs)
forall a. Maybe a
Nothing

traceNeeded ::
  Word64 ->
  EnumMap Word64 RCombs ->
  IO (EnumMap Word64 RCombs)
traceNeeded :: Word64 -> EnumMap Word64 RCombs -> IO (EnumMap Word64 RCombs)
traceNeeded Word64
init EnumMap Word64 RCombs
src = (EnumMap Word64 RCombs -> EnumMap Word64 RCombs)
-> IO (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EnumMap Word64 RCombs -> EnumSet Word64 -> EnumMap Word64 RCombs
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
`withoutKeys` EnumSet Word64
ks) (IO (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs))
-> IO (EnumMap Word64 RCombs) -> IO (EnumMap Word64 RCombs)
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 RCombs -> Word64 -> IO (EnumMap Word64 RCombs)
go EnumMap Word64 RCombs
forall a. Monoid a => a
mempty Word64
init
  where
    ks :: EnumSet Word64
ks = EnumMap Word64 (SuperNormal Symbol) -> EnumSet Word64
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap Word64 (SuperNormal Symbol)
numberedTermLookup
    go :: EnumMap Word64 RCombs -> Word64 -> IO (EnumMap Word64 RCombs)
go EnumMap Word64 RCombs
acc Word64
w
      | Word64 -> EnumMap Word64 RCombs -> Bool
forall k a. EnumKey k => k -> EnumMap k a -> Bool
hasKey Word64
w EnumMap Word64 RCombs
acc = EnumMap Word64 RCombs -> IO (EnumMap Word64 RCombs)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumMap Word64 RCombs
acc
      | Just RCombs
co <- Word64 -> EnumMap Word64 RCombs -> Maybe RCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
w EnumMap Word64 RCombs
src =
          (EnumMap Word64 RCombs -> Word64 -> IO (EnumMap Word64 RCombs))
-> EnumMap Word64 RCombs -> [Word64] -> IO (EnumMap Word64 RCombs)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM EnumMap Word64 RCombs -> Word64 -> IO (EnumMap Word64 RCombs)
go (Word64 -> RCombs -> EnumMap Word64 RCombs -> EnumMap Word64 RCombs
forall k a. EnumKey k => k -> a -> EnumMap k a -> EnumMap k a
mapInsert Word64
w RCombs
co EnumMap Word64 RCombs
acc) ((GComb RComb -> [Word64]) -> RCombs -> [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 (Comb -> [Word64]
combDeps (Comb -> [Word64])
-> (GComb RComb -> Comb) -> GComb RComb -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RComb -> CombIx) -> GComb RComb -> Comb
forall a b. (a -> b) -> GComb a -> GComb b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RComb -> CombIx
rCombIx) RCombs
co)
      | Bool
otherwise = [Char] -> IO (EnumMap Word64 RCombs)
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO (EnumMap Word64 RCombs))
-> [Char] -> IO (EnumMap Word64 RCombs)
forall a b. (a -> b) -> a -> b
$ [Char]
"traceNeeded: unknown combinator: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
w

buildSCache ::
  EnumMap Word64 Combs ->
  EnumMap Word64 Reference ->
  EnumMap Word64 Reference ->
  Word64 ->
  Word64 ->
  Map Reference (SuperGroup Symbol) ->
  Map Reference Word64 ->
  Map Reference Word64 ->
  Map Reference (Set Reference) ->
  StoredCache
buildSCache :: EnumMap Word64 (EnumMap Word64 Comb)
-> EnumMap Word64 Reference
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
buildSCache EnumMap Word64 (EnumMap Word64 Comb)
cs EnumMap Word64 Reference
crsrc EnumMap Word64 Reference
trsrc Word64
ftm Word64
fty Map Reference (SuperGroup Symbol)
intsrc Map Reference Word64
rtmsrc Map Reference Word64
rtysrc Map Reference (Set Reference)
sndbx =
  EnumMap Word64 (EnumMap Word64 Comb)
-> EnumMap Word64 Reference
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
SCache
    EnumMap Word64 (EnumMap Word64 Comb)
cs
    EnumMap Word64 Reference
crs
    EnumMap Word64 Reference
trs
    Word64
ftm
    Word64
fty
    (Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
forall a. Map Reference a -> Map Reference a
restrictTmR Map Reference (SuperGroup Symbol)
intsrc)
    (Map Reference Word64 -> Map Reference Word64
forall a. Map Reference a -> Map Reference a
restrictTmR Map Reference Word64
rtmsrc)
    (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
    combKeys :: EnumSet Word64
combKeys = EnumMap Word64 (EnumMap Word64 Comb) -> EnumSet Word64
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap Word64 (EnumMap Word64 Comb)
cs
    crs :: EnumMap Word64 Reference
crs = EnumMap Word64 Reference -> EnumMap Word64 Reference
restrictTmW EnumMap Word64 Reference
crsrc
    termRefs :: Set Reference
termRefs = (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
crs

    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
$ ((EnumMap Word64 Comb -> [Word64])
-> EnumMap Word64 (EnumMap Word64 Comb) -> [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 ((EnumMap Word64 Comb -> [Word64])
 -> EnumMap Word64 (EnumMap Word64 Comb) -> [Word64])
-> ((Comb -> [Word64]) -> EnumMap Word64 Comb -> [Word64])
-> (Comb -> [Word64])
-> EnumMap Word64 (EnumMap Word64 Comb)
-> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comb -> [Word64]) -> EnumMap Word64 Comb -> [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) Comb -> [Word64]
combTypes EnumMap Word64 (EnumMap Word64 Comb)
cs
    trs :: EnumMap Word64 Reference
trs = EnumMap Word64 Reference -> EnumMap Word64 Reference
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 Reference -> EnumMap Word64 Reference
restrictTmW EnumMap Word64 Reference
m = EnumMap Word64 Reference
-> EnumSet Word64 -> EnumMap Word64 Reference
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
restrictKeys EnumMap Word64 Reference
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 Reference -> EnumMap Word64 Reference
restrictTyW EnumMap Word64 Reference
m = EnumMap Word64 Reference
-> EnumSet Word64 -> EnumMap Word64 Reference
forall k a. EnumKey k => EnumMap k a -> EnumSet k -> EnumMap k a
restrictKeys EnumMap Word64 Reference
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 =
  EnumMap Word64 (EnumMap Word64 Comb)
-> EnumMap Word64 Reference
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
buildSCache
    (EnumMap Word64 (EnumMap Word64 Comb)
 -> EnumMap Word64 Reference
 -> EnumMap Word64 Reference
 -> Word64
 -> Word64
 -> Map Reference (SuperGroup Symbol)
 -> Map Reference Word64
 -> Map Reference Word64
 -> Map Reference (Set Reference)
 -> StoredCache)
-> IO (EnumMap Word64 (EnumMap Word64 Comb))
-> IO
     (EnumMap Word64 Reference
      -> EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup 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 RCombs) -> IO (EnumMap Word64 RCombs)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumMap Word64 RCombs)
combs CCache
cc) IO (EnumMap Word64 RCombs)
-> (EnumMap Word64 RCombs -> IO (EnumMap Word64 RCombs))
-> IO (EnumMap Word64 RCombs)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word64 -> EnumMap Word64 RCombs -> IO (EnumMap Word64 RCombs)
traceNeeded Word64
init IO (EnumMap Word64 RCombs)
-> (EnumMap Word64 RCombs
    -> IO (EnumMap Word64 (EnumMap Word64 Comb)))
-> IO (EnumMap Word64 (EnumMap Word64 Comb))
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 (EnumMap Word64 Comb)
-> IO (EnumMap Word64 (EnumMap Word64 Comb))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumMap Word64 (EnumMap Word64 Comb)
 -> IO (EnumMap Word64 (EnumMap Word64 Comb)))
-> (EnumMap Word64 RCombs -> EnumMap Word64 (EnumMap Word64 Comb))
-> EnumMap Word64 RCombs
-> IO (EnumMap Word64 (EnumMap Word64 Comb))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumMap Word64 RCombs -> EnumMap Word64 (EnumMap Word64 Comb)
unTieRCombs)
    IO
  (EnumMap Word64 Reference
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (EnumMap Word64 Reference)
-> IO
     (EnumMap Word64 Reference
      -> Word64
      -> Word64
      -> Map Reference (SuperGroup 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)
combRefs CCache
cc)
    IO
  (EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (EnumMap Word64 Reference)
-> IO
     (Word64
      -> Word64
      -> Map Reference (SuperGroup 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)
tagRefs CCache
cc)
    IO
  (Word64
   -> Word64
   -> Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO Word64
-> IO
     (Word64
      -> Map Reference (SuperGroup 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
freshTm CCache
cc)
    IO
  (Word64
   -> Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO Word64
-> IO
     (Map Reference (SuperGroup 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
freshTy CCache
cc)
    IO
  (Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (Map Reference (SuperGroup 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 Symbol))
-> IO (Map Reference (SuperGroup Symbol))
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference (SuperGroup Symbol))
intermed CCache
cc)
    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)
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)
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))
sandbox CCache
cc)
  where
    unTieRCombs :: EnumMap Word64 RCombs -> EnumMap Word64 Combs
    unTieRCombs :: EnumMap Word64 RCombs -> EnumMap Word64 (EnumMap Word64 Comb)
unTieRCombs = (RCombs -> EnumMap Word64 Comb)
-> EnumMap Word64 RCombs -> EnumMap Word64 (EnumMap Word64 Comb)
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RCombs -> EnumMap Word64 Comb)
 -> EnumMap Word64 RCombs -> EnumMap Word64 (EnumMap Word64 Comb))
-> ((RComb -> CombIx) -> RCombs -> EnumMap Word64 Comb)
-> (RComb -> CombIx)
-> EnumMap Word64 RCombs
-> EnumMap Word64 (EnumMap Word64 Comb)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GComb RComb -> Comb) -> RCombs -> EnumMap Word64 Comb
forall a b. (a -> b) -> EnumMap Word64 a -> EnumMap Word64 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GComb RComb -> Comb) -> RCombs -> EnumMap Word64 Comb)
-> ((RComb -> CombIx) -> GComb RComb -> Comb)
-> (RComb -> CombIx)
-> RCombs
-> EnumMap Word64 Comb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RComb -> CombIx) -> GComb RComb -> Comb
forall a b. (a -> b) -> GComb a -> GComb b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RComb -> CombIx)
 -> EnumMap Word64 RCombs -> EnumMap Word64 (EnumMap Word64 Comb))
-> (RComb -> CombIx)
-> EnumMap Word64 RCombs
-> EnumMap Word64 (EnumMap Word64 Comb)
forall a b. (a -> b) -> a -> b
$ RComb -> CombIx
rCombIx