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

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

    -- * Exported for tests
    getStoredCache,
    putStoredCache,
  )
where

import Control.Concurrent.STM as STM
import Control.Exception (throwIO)
import Control.Monad
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 Data.Void (absurd)
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.ABT qualified as ABT
import Unison.Builtin.Decls qualified as RF
import Unison.Codebase.CodeLookup (CodeLookup (..))
import Unison.Codebase.MainTerm (builtinIOTestTypes, builtinMain)
import Unison.Codebase.Runtime (CompileOpts (..), 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 (..),
    GInstr (..),
    GSection (..),
    RCombs,
    RefNums (..),
    absurdCombs,
    combTypes,
    emitComb,
    emptyRNs,
    resolveCombs,
    sanitizeCombsOfForeignFuncs,
  )
import Unison.Runtime.MCode.Serialize
import Unison.Runtime.Machine
  ( ActiveThreads,
    CCache (..),
    Combs,
    Tracer (..),
    apply0,
    baseCCache,
    cacheAdd,
    cacheAdd0,
    eval0,
    expandSandbox,
    preEvalTopLevelConstants,
    refLookup,
    refNumTm,
    refNumsTm,
    refNumsTy,
    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.Type qualified as Type
import Unison.Util.EnumContainers as EC
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Pretty as P
import Unison.Util.Recursion qualified as Rec
import UnliftIO qualified
import UnliftIO.Concurrent qualified as UnliftIO

type Term v = Tm.Term v ()

type Type v = Type.Type v ()

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

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

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

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

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

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

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

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

cacheContext :: CCache -> EvalCtx
cacheContext :: CCache -> EvalCtx
cacheContext =
  DataSpec
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (Map Word64 (Term Symbol))
-> CCache
-> EvalCtx
ECtx DataSpec
builtinDataSpec Remapping Reference Reference
forall a. Monoid a => a
mempty Remapping Reference Reference
forall a. Monoid a => a
mempty
    (Map Reference (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 :: (Ord from, Ord to) => Map.Map from to -> Remapping from to -> Remapping from to
remapAdd :: forall from to.
(Ord from, Ord to) =>
Map from to -> Remapping from to -> Remapping from to
remapAdd Map from to
m Remap {Map from to
$sel:remap:Remap :: forall from to. Remapping from to -> Map from to
remap :: Map from to
remap, Map to from
$sel:backmap:Remap :: forall from to. Remapping from to -> Map to from
backmap :: Map to from
backmap} =
  Remap {$sel:remap:Remap :: Map from to
remap = Map from to
m Map from to -> Map from to -> Map from to
forall a. Semigroup a => a -> a -> a
<> Map from to
remap, $sel:backmap:Remap :: Map to from
backmap = Map to from
tm Map to from -> Map to from -> Map to from
forall a. Semigroup a => a -> a -> a
<> Map to from
backmap}
  where
    tm :: Map to from
tm = [(to, from)] -> Map to from
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(to, from)] -> Map to from)
-> ([(from, to)] -> [(to, from)]) -> [(from, to)] -> Map to from
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((from, to) -> (to, from)) -> [(from, to)] -> [(to, from)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(from
x, to
y) -> (to
y, from
x)) ([(from, to)] -> Map to from) -> [(from, to)] -> Map to from
forall a b. (a -> b) -> a -> b
$ Map from to -> [(from, to)]
forall k a. Map k a -> [(k, a)]
Map.toList Map from to
m

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

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

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

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

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

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

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

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 Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx
    irs :: Map Reference Reference
irs = Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map from to
remap (Remapping Reference Reference -> Map Reference Reference)
-> Remapping Reference Reference -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx
    f :: Bool -> Reference -> Reference
f Bool
b Reference
r
      | Bool -> Bool
not Bool
b,
        Reference
r Reference -> Map Reference (SuperGroup 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))
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, Code)])
loadDeps :: CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, Code)])
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
  (EvalCtx
ctx', [(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
  [(Reference, Code)]
crgrp <- ((Reference, SuperGroup Symbol) -> IO (Reference, Code))
-> [(Reference, SuperGroup Symbol)] -> IO [(Reference, Code)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (CodeLookup Symbol IO ()
-> EvalCtx
-> (Reference, SuperGroup Symbol)
-> IO (Reference, Code)
checkCacheability CodeLookup Symbol IO ()
cl EvalCtx
ctx') [(Reference, SuperGroup Symbol)]
rgrp
  (EvalCtx
ctx', [(Reference, Code)]
crgrp) (EvalCtx, [(Reference, Code)])
-> IO () -> IO (EvalCtx, [(Reference, Code)])
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Set Reference
-> [(Reference, Code)]
-> [(Reference, Set Reference)]
-> CCache
-> IO ()
cacheAdd0 Set Reference
tyAdd [(Reference, Code)]
crgrp (Map Reference (Set Reference)
-> [(Reference, SuperGroup Symbol)] -> [(Reference, Set Reference)]
expandSandbox Map Reference (Set Reference)
sand [(Reference, SuperGroup Symbol)]
rgrp) CCache
cc

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

compileValue :: Reference -> [(Reference, Code)] -> Value
compileValue :: Reference -> [(Reference, Code)] -> 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, Code)] -> Value) -> [(Reference, Code)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLit -> Value
ANF.BLit (BLit -> Value)
-> ([(Reference, Code)] -> BLit) -> [(Reference, Code)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Value -> BLit
List (Seq Value -> BLit)
-> ([(Reference, Code)] -> Seq Value)
-> [(Reference, Code)]
-> 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, Code)] -> [Value])
-> [(Reference, Code)]
-> Seq Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Reference, Code) -> Value) -> [(Reference, Code)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Reference, Code) -> 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 -> [Value] -> Value
Data Reference
RF.pairRef Word64
0 [Value
x, Value
y]
    tt :: Value
tt = Reference -> Word64 -> [Value] -> Value
Data Reference
RF.unitRef Word64
0 []
    code :: Code -> Value
code Code
sg = BLit -> Value
ANF.BLit (Code -> BLit
Code Code
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, Code) -> Value
cpair (Reference
r, Code
sg) = Value -> Value -> Value
pair (Reference -> Value
rf Reference
r) (Code -> Value
code Code
sg)

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

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, Code)]
codes) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, Code)])
loadDeps CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [(Reference, Either [Int] [Int])]
tyrs [Reference]
tmrs
  (EvalCtx
ctx, [(Reference, Code)]
tcodes, Reference
base) <- HasCallStack =>
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, Code)], Reference)
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, Code)], 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, Code)]
-> Reference
-> IO (Either Error ([Error], Term Symbol))
nativeEvalInContext
        [Char]
executable
        PrettyPrintEnv
ppe
        EvalCtx
ctx
        Socket
serv
        PortNumber
port
        (((Reference, Code) -> (Reference, Code) -> Bool)
-> [(Reference, Code)] -> [(Reference, Code)]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Reference -> Reference -> Bool)
-> ((Reference, Code) -> Reference)
-> (Reference, Code)
-> (Reference, Code)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Reference, Code) -> Reference
forall a b. (a, b) -> a
fst) ([(Reference, Code)] -> [(Reference, Code)])
-> [(Reference, Code)] -> [(Reference, Code)]
forall a b. (a -> b) -> a -> b
$ [(Reference, Code)]
tcodes [(Reference, Code)] -> [(Reference, Code)] -> [(Reference, Code)]
forall a. [a] -> [a] -> [a]
++ [(Reference, Code)]
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, Code)]
_) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, Code)])
loadDeps CodeLookup Symbol IO ()
cl PrettyPrintEnv
ppe EvalCtx
ctx [(Reference, Either [Int] [Int])]
tyrs [Reference]
tmrs
    (EvalCtx
ctx, [(Reference, Code)]
_, Reference
init) <- HasCallStack =>
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, Code)], Reference)
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, Code)], 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, Code)]
codes) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, Code)])
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, Code)] -> Reference -> [Char] -> IO ()
nativeCompileCodes CompileOpts
copts [Char]
executable [(Reference, Code)]
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, Code)]
_) <- CodeLookup Symbol IO ()
-> PrettyPrintEnv
-> EvalCtx
-> [(Reference, Either [Int] [Int])]
-> [Reference]
-> IO (EvalCtx, [(Reference, Code)])
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, Code)], Reference)
prepareEvaluation :: HasCallStack =>
PrettyPrintEnv
-> Term Symbol
-> EvalCtx
-> IO (EvalCtx, [(Reference, Code)], Reference)
prepareEvaluation PrettyPrintEnv
ppe Term Symbol
tm EvalCtx
ctx = do
  [Reference]
missing <- [(Reference, Code)] -> CCache -> IO [Reference]
cacheAdd [(Reference, Code)]
rcode (EvalCtx -> CCache
ccache EvalCtx
ctx')
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> ([Reference] -> Bool) -> [Reference] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Reference] -> Bool) -> [Reference] -> Bool
forall a b. (a -> b) -> a -> b
$ [Reference]
missing) (IO () -> IO ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> [Char] -> [Char]
reportBug [Char]
"E029347" ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [Char]
"Error in prepareEvaluation, cache is missing: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Reference] -> [Char]
forall a. Show a => a -> [Char]
show [Reference]
missing
  pure (Map Reference (Map Word64 (Term Symbol)) -> EvalCtx -> EvalCtx
backrefAdd Map Reference (Map Word64 (Term Symbol))
rbkr EvalCtx
ctx', [(Reference, Code)]
rcode, Reference
rmn)
  where
    uncacheable :: SuperGroup Symbol -> Code
uncacheable SuperGroup Symbol
g = SuperGroup Symbol -> Cacheability -> Code
CodeRep SuperGroup Symbol
g Cacheability
Uncacheable
    (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)
 -> Map Reference (SuperGroup Symbol))
-> Map Reference (SuperGroup Symbol)
-> Map Reference (SuperGroup Symbol)
forall a b. (a -> b) -> a -> b
$ Map Reference (SuperGroup Symbol)
rgrp0)
        (Map Reference Reference -> EvalCtx -> EvalCtx
floatRemapAdd Map Reference Reference
frem EvalCtx
ctx)
    rcode :: [(Reference, Code)]
rcode = (SuperGroup Symbol -> Code)
-> (Reference, SuperGroup Symbol) -> (Reference, Code)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SuperGroup Symbol -> Code
uncacheable ((Reference, SuperGroup Symbol) -> (Reference, Code))
-> [(Reference, SuperGroup Symbol)] -> [(Reference, Code)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Reference, SuperGroup Symbol)]
rgrp
    rmn :: Reference
rmn = case Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
rmn0 Map Reference Reference
rrefs of
      Just Reference
r -> Reference
r
      Maybe Reference
Nothing -> [Char] -> Reference
forall a. HasCallStack => [Char] -> a
error [Char]
"prepareEvaluation: could not remap main ref"

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

backReferenceTm ::
  EnumMap Word64 Reference ->
  Remapping IntermediateReference CodebaseReference ->
  Remapping FloatedReference IntermediateReference ->
  Map.Map CodebaseReference (Map.Map Word64 (Term Symbol)) ->
  Word64 ->
  Word64 ->
  Maybe (Term Symbol)
backReferenceTm :: EnumMap Word64 Reference
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm EnumMap Word64 Reference
ws Remapping Reference Reference
frs Remapping Reference Reference
irs Map Reference (Map Word64 (Term Symbol))
dcm Word64
c Word64
i = do
  Reference
r <- Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
c EnumMap Word64 Reference
ws
  -- backmap intermediate ref to floated ref
  Reference
r <- Reference -> Map Reference Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r (Remapping Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap Remapping Reference Reference
irs)
  -- backmap floated ref to original ref
  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 Reference Reference -> Map Reference Reference
forall from to. Remapping from to -> Map to from
backmap Remapping Reference Reference
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, Code)] ->
  Reference ->
  IO (Either Error ([Error], Term Symbol))
nativeEvalInContext :: [Char]
-> PrettyPrintEnv
-> EvalCtx
-> Socket
-> PortNumber
-> [(Reference, Code)]
-> Reference
-> IO (Either Error ([Error], Term Symbol))
nativeEvalInContext [Char]
executable PrettyPrintEnv
ppe EvalCtx
ctx Socket
serv PortNumber
port [(Reference, Code)]
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, Code)] -> Value)
-> [(Reference, Code)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> [(Reference, Code)] -> Value
compileValue Reference
base ([(Reference, Code)] -> ByteString)
-> [(Reference, Code)] -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Reference, Code)]
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] Val)
reifyValue CCache
cc Value
val IO (Either [Reference] Val)
-> (Either [Reference] Val
    -> 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 Val
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 -> Val -> DecompResult Symbol
decompileCtx EnumMap Word64 Reference
crs EvalCtx
ctx Val
cl
      decodeResult (Success Value
val) =
        CCache -> Value -> IO (Either [Reference] Val)
reifyValue CCache
cc Value
val IO (Either [Reference] Val)
-> (Either [Reference] Val
    -> 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 Val
cl -> case EnumMap Word64 Reference -> EvalCtx -> Val -> DecompResult Symbol
decompileCtx EnumMap Word64 Reference
crs EvalCtx
ctx Val
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, Code)] ->
  Reference ->
  FilePath ->
  IO ()
nativeCompileCodes :: CompileOpts
-> [Char] -> [(Reference, Code)] -> Reference -> [Char] -> IO ()
nativeCompileCodes CompileOpts
copts [Char]
executable [(Reference, Code)]
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, Code)] -> Value)
-> [(Reference, Code)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> [(Reference, Code)] -> Value
compileValue Reference
base ([(Reference, Code)] -> ByteString)
-> [(Reference, Code)] -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Reference, Code)]
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 Val
r <- Val -> IO (IORef Val)
forall a. a -> IO (IORef a)
newIORef (BVal -> Val
boxedVal BVal
BlackHole)
  EnumMap Word64 Reference
crs <- TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumMap Word64 Reference)
combRefs (CCache -> TVar (EnumMap Word64 Reference))
-> CCache -> TVar (EnumMap Word64 Reference)
forall a b. (a -> b) -> a -> b
$ EvalCtx -> CCache
ccache EvalCtx
ctx)
  let hook :: XStack -> IO ()
hook = IORef Val -> XStack -> IO ()
watchHook IORef Val
r
      decom :: Val -> DecompResult Symbol
decom = EnumMap Word64 Reference -> EvalCtx -> Val -> DecompResult Symbol
decompileCtx EnumMap Word64 Reference
crs EvalCtx
ctx
      finish :: Either Error Val -> Either Error ([Error], Term Symbol)
finish = (Val -> ([Error], Term Symbol))
-> Either Error Val -> 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))
-> (Val -> DecompResult Symbol) -> Val -> ([Error], Term Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> DecompResult Symbol
decom)

      prettyError :: RuntimeExn -> Error
prettyError (PE CallStack
_ Error
p) = Error
p
      prettyError (BU [(Reference, Int)]
tr0 Text
nm Val
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
$ Val -> DecompResult Symbol
decom Val
c
        where
          tr :: [(Reference, Int)]
tr = (Reference -> Reference) -> (Reference, Int) -> (Reference, Int)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (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 -> Val -> Tracer
debugText Bool
fancy Val
val = case Val -> DecompResult Symbol
decom Val
val of
        (Set DecompError
errs, Term Symbol
dv)
          | Set DecompError -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set DecompError
errs ->
              [Char] -> Tracer
SimpleTrace ([Char] -> Tracer) -> (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)
                (Val -> [Char]
forall a. Show a => a -> [Char]
show Val
val)
                (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 Val
result <-
    (() -> IO Val) -> Either Error () -> IO (Either Error Val)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Either Error a -> f (Either Error b)
traverse (IO Val -> () -> IO Val
forall a b. a -> b -> a
const (IO Val -> () -> IO Val) -> IO Val -> () -> IO Val
forall a b. (a -> b) -> a -> b
$ IORef Val -> IO Val
forall a. IORef a -> IO a
readIORef IORef Val
r)
      (Either Error () -> IO (Either Error Val))
-> (Either RuntimeExn () -> Either Error ())
-> Either RuntimeExn ()
-> IO (Either Error Val)
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 Val))
-> (IO () -> IO (Either RuntimeExn ()))
-> IO ()
-> IO (Either Error Val)
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 Val)) -> IO () -> IO (Either Error Val)
forall a b. (a -> b) -> a -> b
$ Maybe (XStack -> IO ())
-> CCache -> ActiveThreads -> Word64 -> IO ()
apply0 (((# Int#, Int#, Int#, MutableByteArray# RealWorld,
    MutableArray# RealWorld BVal #)
 -> IO ())
-> Maybe
     ((# Int#, Int#, Int#, MutableByteArray# RealWorld,
         MutableArray# RealWorld BVal #)
      -> IO ())
forall a. a -> Maybe a
Just (# Int#, Int#, Int#, MutableByteArray# RealWorld,
   MutableArray# RealWorld BVal #)
-> IO ()
XStack -> IO ()
hook) ((EvalCtx -> CCache
ccache EvalCtx
ctx) {tracer = debugText}) ActiveThreads
activeThreads Word64
w
  pure $ Either Error Val -> Either Error ([Error], Term Symbol)
finish Either Error Val
result

executeMainComb ::
  CombIx ->
  CCache ->
  IO (Either (Pretty ColorText) ())
executeMainComb :: CombIx -> CCache -> IO (Either Error ())
executeMainComb CombIx
init CCache
cc = do
  MSection
rSection <- CCache -> Section -> IO MSection
resolveSection CCache
cc (Section -> IO MSection) -> Section -> IO MSection
forall a b. (a -> b) -> a -> b
$ GInstr CombIx -> Section -> Section
forall comb. GInstr comb -> GSection comb -> GSection comb
Ins (Reference -> PackedTag -> Args -> GInstr CombIx
forall comb. Reference -> PackedTag -> Args -> GInstr comb
Pack Reference
RF.unitRef (Word64 -> PackedTag
PackedTag Word64
0) Args
ZArgs) (Section -> Section) -> Section -> Section
forall a b. (a -> b) -> a -> b
$ Bool -> CombIx -> CombIx -> Args -> Section
forall comb. Bool -> CombIx -> comb -> Args -> GSection comb
Call Bool
True CombIx
init CombIx
init (Int -> Args
VArg1 Int
0)
  Either RuntimeExn ()
result <-
    IO () -> IO (Either RuntimeExn ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try (IO () -> IO (Either RuntimeExn ()))
-> (MSection -> IO ()) -> MSection -> IO (Either RuntimeExn ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CCache -> ActiveThreads -> MSection -> IO ()
eval0 CCache
cc ActiveThreads
forall a. Maybe a
Nothing (MSection -> IO (Either RuntimeExn ()))
-> MSection -> IO (Either RuntimeExn ())
forall a b. (a -> b) -> a -> b
$ MSection
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 Val
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 :: Val -> DecompResult Symbol
decom =
            (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Val
-> DecompResult Symbol
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile
              (EvalCtx -> Reference -> Maybe Reference
intermedToBase EvalCtx
ctx)
              ( EnumMap Word64 Reference
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm
                  EnumMap Word64 Reference
crs
                  (EvalCtx -> Remapping Reference Reference
floatRemap EvalCtx
ctx)
                  (EvalCtx -> Remapping Reference Reference
intermedRemap EvalCtx
ctx)
                  (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
$ Val -> DecompResult Symbol
decom Val
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
_ Val
_) = 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
_ Val
_) = 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 :: Bool -> StoredCache -> CombIx -> IO (Either (Pretty ColorText) ())
runStandalone :: Bool -> StoredCache -> CombIx -> IO (Either Error ())
runStandalone Bool
sandboxed StoredCache
sc CombIx
init =
  Bool -> StoredCache -> IO CCache
restoreCache Bool
sandboxed StoredCache
sc IO CCache
-> (CCache -> IO (Either Error ())) -> IO (Either Error ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CombIx -> CCache -> IO (Either Error ())
executeMainComb CombIx
init

-- | A version of the Code Cache designed to be serialized to disk as
-- standalone bytecode.
data StoredCache
  = SCache
      (EnumMap Word64 Combs)
      (EnumMap Word64 Reference)
      (EnumSet Word64)
      (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, StoredCache -> StoredCache -> Bool
(StoredCache -> StoredCache -> Bool)
-> (StoredCache -> StoredCache -> Bool) -> Eq StoredCache
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoredCache -> StoredCache -> Bool
== :: StoredCache -> StoredCache -> Bool
$c/= :: StoredCache -> StoredCache -> Bool
/= :: StoredCache -> StoredCache -> Bool
Eq)

putStoredCache :: (MonadPut m) => StoredCache -> m ()
putStoredCache :: forall (m :: * -> *). MonadPut m => StoredCache -> m ()
putStoredCache (SCache EnumMap Word64 Combs
cs EnumMap Word64 Reference
crs EnumSet Word64
cacheableCombs 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 ()) -> (Combs -> m ()) -> EnumMap Word64 Combs -> m ()
forall (m :: * -> *) k v.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> (v -> m ()) -> EnumMap k v -> m ()
putEnumMap Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat ((Word64 -> m ()) -> (GComb Void CombIx -> m ()) -> Combs -> m ()
forall (m :: * -> *) k v.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> (v -> m ()) -> EnumMap k v -> m ()
putEnumMap Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat ((Void -> m ()) -> GComb Void CombIx -> m ()
forall (m :: * -> *) clos comb.
MonadPut m =>
(clos -> m ()) -> GComb clos comb -> m ()
putComb Void -> m ()
forall a. Void -> a
absurd)) EnumMap Word64 Combs
cs
  (Word64 -> m ())
-> (Reference -> m ()) -> EnumMap Word64 Reference -> m ()
forall (m :: * -> *) k v.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> (v -> m ()) -> EnumMap k v -> m ()
putEnumMap Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat Reference -> m ()
forall (m :: * -> *). MonadPut m => Reference -> m ()
putReference EnumMap Word64 Reference
crs
  (Word64 -> m ()) -> EnumSet Word64 -> m ()
forall (m :: * -> *) k.
(MonadPut m, EnumKey k) =>
(k -> m ()) -> EnumSet k -> m ()
putEnumSet Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putNat EnumSet Word64
cacheableCombs
  (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
-> Map ForeignFunc Text -> SuperGroup Symbol -> m ()
forall (m :: * -> *) v.
(MonadPut m, Var v) =>
Map Reference Word64
-> Map ForeignFunc Text -> SuperGroup v -> m ()
putGroup Map Reference Word64
forall a. Monoid a => a
mempty Map ForeignFunc 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 Combs
-> EnumMap Word64 Reference
-> EnumSet Word64
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
SCache
    (EnumMap Word64 Combs
 -> EnumMap Word64 Reference
 -> EnumSet Word64
 -> EnumMap Word64 Reference
 -> Word64
 -> Word64
 -> Map Reference (SuperGroup Symbol)
 -> Map Reference Word64
 -> Map Reference Word64
 -> Map Reference (Set Reference)
 -> StoredCache)
-> m (EnumMap Word64 Combs)
-> m (EnumMap Word64 Reference
      -> EnumSet Word64
      -> 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 Combs -> m (EnumMap Word64 Combs)
forall (m :: * -> *) k v.
(MonadGet m, EnumKey k) =>
m k -> m v -> m (EnumMap k v)
getEnumMap m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat (m Word64 -> m (GComb Void CombIx) -> m Combs
forall (m :: * -> *) k v.
(MonadGet m, EnumKey k) =>
m k -> m v -> m (EnumMap k v)
getEnumMap m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat m (GComb Void CombIx)
forall (m :: * -> *). MonadGet m => m (GComb Void CombIx)
getComb)
    m (EnumMap Word64 Reference
   -> EnumSet Word64
   -> 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 (EnumSet Word64
      -> 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 (EnumSet Word64
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> m (EnumSet Word64)
-> 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 (EnumSet Word64)
forall (m :: * -> *) k.
(MonadGet m, EnumKey k) =>
m k -> m (EnumSet k)
getEnumSet m Word64
forall (m :: * -> *). MonadGet m => m Word64
getNat
    m (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 :: Bool -> StoredCache -> IO CCache
restoreCache :: Bool -> StoredCache -> IO CCache
restoreCache Bool
sandboxed (SCache EnumMap Word64 Combs
cs EnumMap Word64 Reference
crs EnumSet Word64
cacheableCombs 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
  CCache
cc <-
    Bool
-> (Bool -> Val -> Tracer)
-> TVar (EnumMap Word64 Combs)
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> TVar (EnumSet Word64)
-> 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 Bool
sandboxed Bool -> Val -> Tracer
debugText
      (TVar (EnumMap Word64 Combs)
 -> TVar (EnumMap Word64 MCombs)
 -> TVar (EnumMap Word64 Reference)
 -> TVar (EnumSet Word64)
 -> 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 Combs))
-> IO
     (TVar (EnumMap Word64 MCombs)
      -> TVar (EnumMap Word64 Reference)
      -> TVar (EnumSet Word64)
      -> 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 Combs -> IO (TVar (EnumMap Word64 Combs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 Combs
srcCombs
      IO
  (TVar (EnumMap Word64 MCombs)
   -> TVar (EnumMap Word64 Reference)
   -> TVar (EnumSet Word64)
   -> TVar (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 MCombs))
-> IO
     (TVar (EnumMap Word64 Reference)
      -> TVar (EnumSet Word64)
      -> 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 MCombs -> IO (TVar (EnumMap Word64 MCombs))
forall a. a -> IO (TVar a)
newTVarIO EnumMap Word64 MCombs
combs
      IO
  (TVar (EnumMap Word64 Reference)
   -> TVar (EnumSet Word64)
   -> TVar (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 (EnumSet Word64)
      -> 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 (EnumSet Word64)
   -> 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 (EnumSet Word64))
-> 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
<*> EnumSet Word64 -> IO (TVar (EnumSet Word64))
forall a. a -> IO (TVar a)
newTVarIO EnumSet Word64
cacheableCombs
      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)
  let (EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs, EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs) =
        EnumMap Word64 Combs
srcCombs
          EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 Combs)
-> EnumMap Word64 Combs
forall a b. a -> (a -> b) -> b
& Bool
-> Set ForeignFunc -> EnumMap Word64 Combs -> EnumMap Word64 Combs
sanitizeCombsOfForeignFuncs Bool
sandboxed Set ForeignFunc
sandboxedForeignFuncs
          EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx))
-> EnumMap Word64 (GCombs Val CombIx)
forall a b. a -> (a -> b) -> b
& EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx)
forall cix any.
EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
absurdCombs
          EnumMap Word64 (GCombs Val CombIx)
-> (EnumMap Word64 (GCombs Val CombIx)
    -> [(Word64, GCombs Val CombIx)])
-> [(Word64, GCombs Val CombIx)]
forall a b. a -> (a -> b) -> b
& EnumMap Word64 (GCombs Val CombIx) -> [(Word64, GCombs Val CombIx)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList
          [(Word64, GCombs Val CombIx)]
-> ([(Word64, GCombs Val CombIx)]
    -> (EnumMap Word64 (GCombs Val CombIx),
        EnumMap Word64 (GCombs Val CombIx)))
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall a b. a -> (a -> b) -> b
& ((Word64, GCombs Val CombIx)
 -> (EnumMap Word64 (GCombs Val CombIx),
     EnumMap Word64 (GCombs Val CombIx)))
-> [(Word64, GCombs Val CombIx)]
-> (EnumMap Word64 (GCombs Val CombIx),
    EnumMap Word64 (GCombs Val CombIx))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
            ( \(Word64
k, GCombs Val CombIx
v) ->
                if Word64
k Word64 -> EnumSet Word64 -> Bool
forall k. EnumKey k => k -> EnumSet k -> Bool
`member` EnumSet Word64
cacheableCombs
                  then (Word64 -> GCombs Val CombIx -> EnumMap Word64 (GCombs Val CombIx)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
k GCombs Val CombIx
v, EnumMap Word64 (GCombs Val CombIx)
forall a. Monoid a => a
mempty)
                  else (EnumMap Word64 (GCombs Val CombIx)
forall a. Monoid a => a
mempty, Word64 -> GCombs Val CombIx -> EnumMap Word64 (GCombs Val CombIx)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
k GCombs Val CombIx
v)
            )
  EnumMap Word64 (GCombs Val CombIx)
-> EnumMap Word64 (GCombs Val CombIx) -> CCache -> IO ()
preEvalTopLevelConstants EnumMap Word64 (GCombs Val CombIx)
unresolvedCacheableCombs EnumMap Word64 (GCombs Val CombIx)
unresolvedNonCacheableCombs CCache
cc
  pure CCache
cc
  where
    decom :: Val -> DecompResult Symbol
decom =
      (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term Symbol))
-> Val
-> DecompResult Symbol
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile
        (Maybe Reference -> Reference -> Maybe Reference
forall a b. a -> b -> a
const Maybe Reference
forall a. Maybe a
Nothing)
        (EnumMap Word64 Reference
-> Remapping Reference Reference
-> Remapping Reference Reference
-> Map Reference (Map Word64 (Term Symbol))
-> Word64
-> Word64
-> Maybe (Term Symbol)
backReferenceTm EnumMap Word64 Reference
crs Remapping Reference Reference
forall a. Monoid a => a
mempty Remapping Reference Reference
forall a. Monoid a => a
mempty Map Reference (Map Word64 (Term Symbol))
forall a. Monoid a => a
mempty)
    debugText :: Bool -> Val -> Tracer
debugText Bool
fancy Val
c = case Val -> DecompResult Symbol
decom Val
c of
      (Set DecompError
errs, Term Symbol
dv)
        | Set DecompError -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set DecompError
errs ->
            [Char] -> Tracer
SimpleTrace ([Char] -> Tracer) -> (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)
              (Val -> [Char]
forall a. Show a => a -> [Char]
show Val
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
    srcCombs :: EnumMap Word64 Combs
    srcCombs :: EnumMap Word64 Combs
srcCombs =
      let builtinCombs :: EnumMap Word64 Combs
builtinCombs = (Word64 -> SuperNormal Symbol -> Combs)
-> EnumMap Word64 (SuperNormal Symbol) -> EnumMap Word64 Combs
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)
-> Combs
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 Combs
builtinCombs EnumMap Word64 Combs
-> EnumMap Word64 Combs -> EnumMap Word64 Combs
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Combs
cs
    combs :: EnumMap Word64 (RCombs Val)
    combs :: EnumMap Word64 MCombs
combs =
      EnumMap Word64 Combs
srcCombs
        EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 Combs)
-> EnumMap Word64 Combs
forall a b. a -> (a -> b) -> b
& Bool
-> Set ForeignFunc -> EnumMap Word64 Combs -> EnumMap Word64 Combs
sanitizeCombsOfForeignFuncs Bool
sandboxed Set ForeignFunc
sandboxedForeignFuncs
        EnumMap Word64 Combs
-> (EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx))
-> EnumMap Word64 (GCombs Val CombIx)
forall a b. a -> (a -> b) -> b
& EnumMap Word64 Combs -> EnumMap Word64 (GCombs Val CombIx)
forall cix any.
EnumMap Word64 (EnumMap Word64 (GComb Void cix))
-> EnumMap Word64 (GCombs any cix)
absurdCombs
        EnumMap Word64 (GCombs Val CombIx)
-> (EnumMap Word64 (GCombs Val CombIx) -> EnumMap Word64 MCombs)
-> EnumMap Word64 MCombs
forall a b. a -> (a -> b) -> b
& Maybe (EnumMap Word64 MCombs)
-> EnumMap Word64 (GCombs Val CombIx) -> EnumMap Word64 MCombs
forall val.
Maybe (EnumMap Word64 (RCombs val))
-> EnumMap Word64 (GCombs val CombIx)
-> EnumMap Word64 (RCombs val)
resolveCombs Maybe (EnumMap Word64 MCombs)
forall a. Maybe a
Nothing

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

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

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

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

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

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

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

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

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

standalone :: CCache -> Word64 -> IO StoredCache
standalone :: CCache -> Word64 -> IO StoredCache
standalone CCache
cc Word64
init = TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumMap Word64 Reference)
combRefs CCache
cc) IO (EnumMap Word64 Reference)
-> (EnumMap Word64 Reference -> IO StoredCache) -> IO StoredCache
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EnumMap Word64 Reference
crs ->
  case Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
init EnumMap Word64 Reference
crs of
    Just Reference
rinit ->
      EnumMap Word64 Reference
-> EnumMap Word64 Combs
-> EnumSet Word64
-> EnumMap Word64 Reference
-> Word64
-> Word64
-> Map Reference (SuperGroup Symbol)
-> Map Reference Word64
-> Map Reference Word64
-> Map Reference (Set Reference)
-> StoredCache
buildSCache EnumMap Word64 Reference
crs
        (EnumMap Word64 Combs
 -> EnumSet Word64
 -> EnumMap Word64 Reference
 -> Word64
 -> Word64
 -> Map Reference (SuperGroup Symbol)
 -> Map Reference Word64
 -> Map Reference Word64
 -> Map Reference (Set Reference)
 -> StoredCache)
-> IO (EnumMap Word64 Combs)
-> IO
     (EnumSet Word64
      -> 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 Combs) -> IO (EnumMap Word64 Combs)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumMap Word64 Combs)
srcCombs CCache
cc)
        IO
  (EnumSet Word64
   -> EnumMap Word64 Reference
   -> Word64
   -> Word64
   -> Map Reference (SuperGroup Symbol)
   -> Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (EnumSet Word64)
-> 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 (EnumSet Word64) -> IO (EnumSet Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (EnumSet Word64)
cacheableCombs 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 (SuperGroup Symbol))
-> (Map Reference (SuperGroup Symbol)
    -> IO (Map Reference (SuperGroup Symbol)))
-> IO (Map Reference (SuperGroup Symbol))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Reference
-> Map Reference (SuperGroup Symbol)
-> IO (Map Reference (SuperGroup Symbol))
traceNeeded Reference
rinit)
        IO
  (Map Reference Word64
   -> Map Reference Word64
   -> Map Reference (Set Reference)
   -> StoredCache)
-> IO (Map Reference Word64)
-> IO
     (Map Reference Word64
      -> Map Reference (Set Reference) -> StoredCache)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (Map Reference Word64) -> IO (Map Reference Word64)
forall a. TVar a -> IO a
readTVarIO (CCache -> TVar (Map Reference Word64)
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)
    Maybe Reference
Nothing ->
      [Char] -> IO StoredCache
forall a. HasCallStack => [Char] -> IO a
die ([Char] -> IO StoredCache) -> [Char] -> IO StoredCache
forall a b. (a -> b) -> a -> b
$ [Char]
"standalone: unknown combinator: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
init