{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Unison.Runtime.Decompile
  ( decompile,
    DecompResult,
    DecompError (..),
    renderDecompError,
  )
where

import Data.Set (singleton)
import Unison.ABT (substs)
import Unison.Codebase.Runtime (Error)
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.Prelude
import Unison.Reference (Reference, pattern Builtin)
import Unison.Referent (pattern Ref)
import Unison.Runtime.ANF (maskTags)
import Unison.Runtime.Array
  ( Array,
    ByteArray,
    byteArrayToList,
  )
import Unison.Runtime.Foreign
  ( Foreign (..),
    HashAlgorithm (..),
    maybeUnwrapBuiltin,
    maybeUnwrapForeign,
  )
import Unison.Runtime.IOSource (iarrayFromListRef, ibarrayFromBytesRef)
import Unison.Runtime.MCode (CombIx (..))
import Unison.Runtime.Stack
  ( Closure (..),
    USeq,
    UnboxedTypeTag (..),
    Val (..),
    pattern DataC,
    pattern PApV,
  )
import Unison.Syntax.NamePrinter (prettyReference)
import Unison.Term
  ( Term,
    app,
    apps',
    boolean,
    builtin,
    char,
    constructor,
    float,
    int,
    list,
    list',
    nat,
    ref,
    termLink,
    text,
    typeLink,
    pattern LamNamed',
  )
import Unison.Term qualified as Term
import Unison.Type
  ( anyRef,
    booleanRef,
    iarrayRef,
    ibytearrayRef,
    listRef,
    termLinkRef,
    typeLinkRef,
  )
import Unison.Util.Bytes qualified as By
import Unison.Util.Pretty (indentN, lines, lit, shown, syntaxToColor, wrap)
import Unison.Util.Text qualified as Text
import Unison.Var (Var)
import Prelude hiding (lines)

con :: (Var v) => Reference -> Word64 -> Term v ()
con :: forall v. Var v => Reference -> Word64 -> Term v ()
con Reference
rf Word64
ct = () -> ConstructorReference -> Term2 v () () v ()
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
constructor () (Reference -> Word64 -> ConstructorReference
forall r. r -> Word64 -> GConstructorReference r
ConstructorReference Reference
rf (Word64 -> ConstructorReference) -> Word64 -> ConstructorReference
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ct)

bug :: (Var v) => Text -> Term v ()
bug :: forall v. Var v => Text -> Term v ()
bug Text
msg = ()
-> Term2 v () () v () -> Term2 v () () v () -> Term2 v () () v ()
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
app () (() -> Text -> Term2 v () () v ()
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
builtin () Text
"bug") (() -> Text -> Term2 v () () v ()
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
text () Text
msg)

err :: DecompError -> a -> (Set DecompError, a)
err :: forall a. DecompError -> a -> (Set DecompError, a)
err DecompError
err a
x = (DecompError -> Set DecompError
forall a. a -> Set a
singleton DecompError
err, a
x)

data DecompError
  = BadBool !Word64
  | BadUnboxed !UnboxedTypeTag
  | BadForeign !Reference
  | BadData !Reference
  | BadPAp !Reference
  | UnkComb !Reference
  | UnkLocal !Reference !Word64
  | Cont
  | Exn
  deriving (DecompError -> DecompError -> Bool
(DecompError -> DecompError -> Bool)
-> (DecompError -> DecompError -> Bool) -> Eq DecompError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecompError -> DecompError -> Bool
== :: DecompError -> DecompError -> Bool
$c/= :: DecompError -> DecompError -> Bool
/= :: DecompError -> DecompError -> Bool
Eq, Eq DecompError
Eq DecompError =>
(DecompError -> DecompError -> Ordering)
-> (DecompError -> DecompError -> Bool)
-> (DecompError -> DecompError -> Bool)
-> (DecompError -> DecompError -> Bool)
-> (DecompError -> DecompError -> Bool)
-> (DecompError -> DecompError -> DecompError)
-> (DecompError -> DecompError -> DecompError)
-> Ord DecompError
DecompError -> DecompError -> Bool
DecompError -> DecompError -> Ordering
DecompError -> DecompError -> DecompError
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DecompError -> DecompError -> Ordering
compare :: DecompError -> DecompError -> Ordering
$c< :: DecompError -> DecompError -> Bool
< :: DecompError -> DecompError -> Bool
$c<= :: DecompError -> DecompError -> Bool
<= :: DecompError -> DecompError -> Bool
$c> :: DecompError -> DecompError -> Bool
> :: DecompError -> DecompError -> Bool
$c>= :: DecompError -> DecompError -> Bool
>= :: DecompError -> DecompError -> Bool
$cmax :: DecompError -> DecompError -> DecompError
max :: DecompError -> DecompError -> DecompError
$cmin :: DecompError -> DecompError -> DecompError
min :: DecompError -> DecompError -> DecompError
Ord)

type DecompResult v = (Set DecompError, Term v ())

prf :: Reference -> Error
prf :: Reference -> Pretty ColorText
prf = Pretty (SyntaxText' Reference) -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
syntaxToColor (Pretty (SyntaxText' Reference) -> Pretty ColorText)
-> (Reference -> Pretty (SyntaxText' Reference))
-> Reference
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Reference -> Pretty (SyntaxText' Reference)
prettyReference Int
10

printUnboxedTypeTag :: UnboxedTypeTag -> Error
printUnboxedTypeTag :: UnboxedTypeTag -> Pretty ColorText
printUnboxedTypeTag = UnboxedTypeTag -> Pretty ColorText
forall a s. (Show a, IsString s) => a -> Pretty s
shown

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

decompile ::
  forall v.
  (Var v) =>
  (Reference -> Maybe Reference) ->
  (Word64 -> Word64 -> Maybe (Term v ())) ->
  Val ->
  DecompResult v
decompile :: forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms = \case
  CharVal Char
c -> Term v () -> DecompResult v
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Char -> Term v ()
forall v a vt at ap. Ord v => a -> Char -> Term2 vt at ap v a
char () Char
c)
  NatVal Word64
n -> Term v () -> DecompResult v
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Word64 -> Term v ()
forall v a vt at ap. Ord v => a -> Word64 -> Term2 vt at ap v a
nat () Word64
n)
  IntVal Int
i -> Term v () -> DecompResult v
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Int64 -> Term v ()
forall v a vt at ap. Ord v => a -> Int64 -> Term2 vt at ap v a
int () (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
  DoubleVal Double
f -> Term v () -> DecompResult v
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Double -> Term v ()
forall v a vt at ap. Ord v => a -> Double -> Term2 vt at ap v a
float () Double
f)
  Val Int
i (UnboxedTypeTag UnboxedTypeTag
tt) ->
    DecompError -> Term v () -> DecompResult v
forall a. DecompError -> a -> (Set DecompError, a)
err (UnboxedTypeTag -> DecompError
BadUnboxed UnboxedTypeTag
tt) (Term v () -> DecompResult v)
-> (Word64 -> Term v ()) -> Word64 -> DecompResult v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Word64 -> Term v ()
forall v a vt at ap. Ord v => a -> Word64 -> Term2 vt at ap v a
nat () (Word64 -> DecompResult v) -> Word64 -> DecompResult v
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Int
i
  Val Int
_u Closure
clos -> case Closure
clos of
    DataC Reference
rf (PackedTag -> Word64
maskTags -> Word64
ct) []
      | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
booleanRef -> Word64 -> DecompResult v
forall v. Var v => Word64 -> DecompResult v
tag2bool Word64
ct
    (DataC Reference
rf PackedTag
_ [Val
b])
      | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
anyRef ->
          () -> Term v () -> Term v () -> Term v ()
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
app () (() -> Text -> Term v ()
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
builtin () Text
"Any.Any") (Term v () -> Term v ()) -> DecompResult v -> DecompResult v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms Val
b
    (DataC Reference
rf (PackedTag -> Word64
maskTags -> Word64
ct) [Val]
vs) ->
      Term v () -> [Term v ()] -> Term v ()
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
apps' (Reference -> Word64 -> Term v ()
forall v. Var v => Reference -> Word64 -> Term v ()
con Reference
rf Word64
ct) ([Term v ()] -> Term v ())
-> (Set DecompError, [Term v ()]) -> DecompResult v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> DecompResult v) -> [Val] -> (Set DecompError, [Term v ()])
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 -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms) [Val]
vs
    (PApV (CIx Reference
rf Word64
rt Word64
k) RCombInfo Val
_ [Val]
vs)
      | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Reference
forall t h. t -> Reference' t h
Builtin Text
"jumpCont" ->
          DecompError -> Term v () -> DecompResult v
forall a. DecompError -> a -> (Set DecompError, a)
err DecompError
Cont (Term v () -> DecompResult v) -> Term v () -> DecompResult v
forall a b. (a -> b) -> a -> b
$ Text -> Term v ()
forall v. Var v => Text -> Term v ()
bug Text
"<Continuation>"
      | Builtin Text
nm <- Reference
rf ->
          Term v () -> [Term v ()] -> Term v ()
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
apps' (() -> Text -> Term v ()
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
builtin () Text
nm) ([Term v ()] -> Term v ())
-> (Set DecompError, [Term v ()]) -> DecompResult v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> DecompResult v) -> [Val] -> (Set DecompError, [Term v ()])
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 -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms) [Val]
vs
      | Just Term v ()
t <- Word64 -> Word64 -> Maybe (Term v ())
topTerms Word64
rt Word64
k ->
          Term v () -> Term v ()
forall v. Var v => Term0 v -> Term0 v
Term.etaReduceEtaVars (Term v () -> Term v ())
-> ([Term v ()] -> Term v ()) -> [Term v ()] -> Term v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v () -> [Term v ()] -> Term v ()
forall v. Var v => Term v () -> [Term v ()] -> Term v ()
substitute Term v ()
t
            ([Term v ()] -> Term v ())
-> (Set DecompError, [Term v ()]) -> DecompResult v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> DecompResult v) -> [Val] -> (Set DecompError, [Term v ()])
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 -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms) [Val]
vs
      | Word64
k Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0,
        Just Term v ()
_ <- Word64 -> Word64 -> Maybe (Term v ())
topTerms Word64
rt Word64
0 ->
          DecompError -> Term v () -> DecompResult v
forall a. DecompError -> a -> (Set DecompError, a)
err (Reference -> Word64 -> DecompError
UnkLocal Reference
rf Word64
k) (Term v () -> DecompResult v) -> Term v () -> DecompResult v
forall a b. (a -> b) -> a -> b
$ Text -> Term v ()
forall v. Var v => Text -> Term v ()
bug Text
"<Unknown>"
      | Bool
otherwise -> DecompError -> Term v () -> DecompResult v
forall a. DecompError -> a -> (Set DecompError, a)
err (Reference -> DecompError
UnkComb Reference
rf) (Term v () -> DecompResult v) -> Term v () -> DecompResult v
forall a b. (a -> b) -> a -> b
$ () -> Reference -> Term v ()
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
ref () Reference
rf
    (PAp (CIx Reference
rf Word64
_ Word64
_) RCombInfo Val
_ Seg
_) ->
      DecompError -> Term v () -> DecompResult v
forall a. DecompError -> a -> (Set DecompError, a)
err (Reference -> DecompError
BadPAp Reference
rf) (Term v () -> DecompResult v) -> Term v () -> DecompResult v
forall a b. (a -> b) -> a -> b
$ Text -> Term v ()
forall v. Var v => Text -> Term v ()
bug Text
"<Unknown>"
    Closure
BlackHole -> DecompError -> Term v () -> DecompResult v
forall a. DecompError -> a -> (Set DecompError, a)
err DecompError
Exn (Term v () -> DecompResult v) -> Term v () -> DecompResult v
forall a b. (a -> b) -> a -> b
$ Text -> Term v ()
forall v. Var v => Text -> Term v ()
bug Text
"<Exception>"
    (Captured {}) -> DecompError -> Term v () -> DecompResult v
forall a. DecompError -> a -> (Set DecompError, a)
err DecompError
Cont (Term v () -> DecompResult v) -> Term v () -> DecompResult v
forall a b. (a -> b) -> a -> b
$ Text -> Term v ()
forall v. Var v => Text -> Term v ()
bug Text
"<Continuation>"
    (Foreign Foreign
f) ->
      (Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ()))
-> Foreign
-> DecompResult v
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ()))
-> Foreign
-> DecompResult v
decompileForeign Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms Foreign
f

tag2bool :: (Var v) => Word64 -> DecompResult v
tag2bool :: forall v. Var v => Word64 -> DecompResult v
tag2bool Word64
0 = Term v () -> (Set DecompError, Term v ())
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Bool -> Term v ()
forall v a vt at ap. Ord v => a -> Bool -> Term2 vt at ap v a
boolean () Bool
False)
tag2bool Word64
1 = Term v () -> (Set DecompError, Term v ())
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Bool -> Term v ()
forall v a vt at ap. Ord v => a -> Bool -> Term2 vt at ap v a
boolean () Bool
True)
tag2bool Word64
n = DecompError -> Term v () -> (Set DecompError, Term v ())
forall a. DecompError -> a -> (Set DecompError, a)
err (Word64 -> DecompError
BadBool Word64
n) (Term v () -> (Set DecompError, Term v ()))
-> Term v () -> (Set DecompError, Term v ())
forall a b. (a -> b) -> a -> b
$ Reference -> Word64 -> Term v ()
forall v. Var v => Reference -> Word64 -> Term v ()
con Reference
booleanRef Word64
n

substitute :: (Var v) => Term v () -> [Term v ()] -> Term v ()
substitute :: forall v. Var v => Term v () -> [Term v ()] -> Term v ()
substitute = [(v, Term (F v () ()) v ())]
-> Term (F v () ()) v ()
-> [Term (F v () ()) v ()]
-> Term (F v () ()) v ()
forall {v} {a} {typeVar} {typeAnn} {patternAnn}.
(Var v, Semigroup a) =>
[(v, Term (F typeVar typeAnn patternAnn) v a)]
-> Term (F typeVar typeAnn patternAnn) v a
-> [Term (F typeVar typeAnn patternAnn) v a]
-> Term (F typeVar typeAnn patternAnn) v a
align []
  where
    align :: [(v, Term (F typeVar typeAnn patternAnn) v a)]
-> Term (F typeVar typeAnn patternAnn) v a
-> [Term (F typeVar typeAnn patternAnn) v a]
-> Term (F typeVar typeAnn patternAnn) v a
align [(v, Term (F typeVar typeAnn patternAnn) v a)]
vts (LamNamed' v
v Term (F typeVar typeAnn patternAnn) v a
bd) (Term (F typeVar typeAnn patternAnn) v a
t : [Term (F typeVar typeAnn patternAnn) v a]
ts) = [(v, Term (F typeVar typeAnn patternAnn) v a)]
-> Term (F typeVar typeAnn patternAnn) v a
-> [Term (F typeVar typeAnn patternAnn) v a]
-> Term (F typeVar typeAnn patternAnn) v a
align ((v
v, Term (F typeVar typeAnn patternAnn) v a
t) (v, Term (F typeVar typeAnn patternAnn) v a)
-> [(v, Term (F typeVar typeAnn patternAnn) v a)]
-> [(v, Term (F typeVar typeAnn patternAnn) v a)]
forall a. a -> [a] -> [a]
: [(v, Term (F typeVar typeAnn patternAnn) v a)]
vts) Term (F typeVar typeAnn patternAnn) v a
bd [Term (F typeVar typeAnn patternAnn) v a]
ts
    align [(v, Term (F typeVar typeAnn patternAnn) v a)]
vts Term (F typeVar typeAnn patternAnn) v a
tm [] = [(v, Term (F typeVar typeAnn patternAnn) v a)]
-> Term (F typeVar typeAnn patternAnn) v a
-> Term (F typeVar typeAnn patternAnn) v a
forall (f :: * -> *) v a.
(Foldable f, Functor f, Var v) =>
[(v, Term f v a)] -> Term f v a -> Term f v a
substs [(v, Term (F typeVar typeAnn patternAnn) v a)]
vts Term (F typeVar typeAnn patternAnn) v a
tm
    -- this should not happen
    align [(v, Term (F typeVar typeAnn patternAnn) v a)]
vts Term (F typeVar typeAnn patternAnn) v a
tm [Term (F typeVar typeAnn patternAnn) v a]
ts = Term (F typeVar typeAnn patternAnn) v a
-> [Term (F typeVar typeAnn patternAnn) v a]
-> Term (F typeVar typeAnn patternAnn) v a
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
apps' ([(v, Term (F typeVar typeAnn patternAnn) v a)]
-> Term (F typeVar typeAnn patternAnn) v a
-> Term (F typeVar typeAnn patternAnn) v a
forall (f :: * -> *) v a.
(Foldable f, Functor f, Var v) =>
[(v, Term f v a)] -> Term f v a -> Term f v a
substs [(v, Term (F typeVar typeAnn patternAnn) v a)]
vts Term (F typeVar typeAnn patternAnn) v a
tm) [Term (F typeVar typeAnn patternAnn) v a]
ts

decompileForeign ::
  (Var v) =>
  (Reference -> Maybe Reference) ->
  (Word64 -> Word64 -> Maybe (Term v ())) ->
  Foreign ->
  DecompResult v
decompileForeign :: forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ()))
-> Foreign
-> DecompResult v
decompileForeign Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms Foreign
f
  | Just Text
t <- Foreign -> Maybe Text
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f = Term v () -> (Set DecompError, Term v ())
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v () -> (Set DecompError, Term v ()))
-> Term v () -> (Set DecompError, Term v ())
forall a b. (a -> b) -> a -> b
$ () -> Text -> Term v ()
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
text () (Text -> Text
Text.toText Text
t)
  | Just Bytes
b <- Foreign -> Maybe Bytes
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f = Term v () -> (Set DecompError, Term v ())
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v () -> (Set DecompError, Term v ()))
-> Term v () -> (Set DecompError, Term v ())
forall a b. (a -> b) -> a -> b
$ Bytes -> Term v ()
forall v. Var v => Bytes -> Term v ()
decompileBytes Bytes
b
  | Just HashAlgorithm
h <- Foreign -> Maybe HashAlgorithm
forall f. BuiltinForeign f => Foreign -> Maybe f
maybeUnwrapBuiltin Foreign
f = Term v () -> (Set DecompError, Term v ())
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v () -> (Set DecompError, Term v ()))
-> Term v () -> (Set DecompError, Term v ())
forall a b. (a -> b) -> a -> b
$ HashAlgorithm -> Term v ()
forall v. Var v => HashAlgorithm -> Term v ()
decompileHashAlgorithm HashAlgorithm
h
  | Just Referent
l <- Reference -> Foreign -> Maybe Referent
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
termLinkRef Foreign
f =
      Term v () -> (Set DecompError, Term v ())
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v () -> (Set DecompError, Term v ()))
-> (Referent -> Term v ())
-> Referent
-> (Set DecompError, Term v ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Referent -> Term v ()
forall v a vt at ap. Ord v => a -> Referent -> Term2 vt at ap v a
termLink () (Referent -> (Set DecompError, Term v ()))
-> Referent -> (Set DecompError, Term v ())
forall a b. (a -> b) -> a -> b
$ case Referent
l of
        Ref Reference
r -> Referent -> (Reference -> Referent) -> Maybe Reference -> Referent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Referent
l Reference -> Referent
Ref (Maybe Reference -> Referent) -> Maybe Reference -> Referent
forall a b. (a -> b) -> a -> b
$ Reference -> Maybe Reference
backref Reference
r
        Referent
_ -> Referent
l
  | Just Reference
l <- Reference -> Foreign -> Maybe Reference
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
typeLinkRef Foreign
f =
      Term v () -> (Set DecompError, Term v ())
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v () -> (Set DecompError, Term v ()))
-> Term v () -> (Set DecompError, Term v ())
forall a b. (a -> b) -> a -> b
$ () -> Reference -> Term v ()
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
typeLink () Reference
l
  | Just (Array Val
a :: Array Val) <- Reference -> Foreign -> Maybe (Array Val)
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
iarrayRef Foreign
f =
      () -> Term v () -> Term v () -> Term v ()
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
app () (() -> Reference -> Term v ()
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
ref () Reference
iarrayFromListRef) (Term v () -> Term v ())
-> ([Term v ()] -> Term v ()) -> [Term v ()] -> Term v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> [Term v ()] -> Term v ()
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
list ()
        ([Term v ()] -> Term v ())
-> (Set DecompError, [Term v ()]) -> (Set DecompError, Term v ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> (Set DecompError, Term v ()))
-> [Val] -> (Set DecompError, [Term v ()])
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 -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ()))
-> Val
-> (Set DecompError, Term v ())
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms) (Array Val -> [Val]
forall a. Array a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array Val
a)
  | Just (ByteArray
a :: ByteArray) <- Reference -> Foreign -> Maybe ByteArray
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
ibytearrayRef Foreign
f =
      Term v () -> (Set DecompError, Term v ())
forall a. a -> (Set DecompError, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v () -> (Set DecompError, Term v ()))
-> Term v () -> (Set DecompError, Term v ())
forall a b. (a -> b) -> a -> b
$
        () -> Term v () -> Term v () -> Term v ()
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
app
          ()
          (() -> Reference -> Term v ()
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
ref () Reference
ibarrayFromBytesRef)
          (Bytes -> Term v ()
forall v. Var v => Bytes -> Term v ()
decompileBytes (Bytes -> Term v ()) -> ([Word8] -> Bytes) -> [Word8] -> Term v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Bytes
By.fromWord8s ([Word8] -> Term v ()) -> [Word8] -> Term v ()
forall a b. (a -> b) -> a -> b
$ ByteArray -> [Word8]
byteArrayToList ByteArray
a)
  | Just USeq
s <- Foreign -> Maybe USeq
unwrapSeq Foreign
f =
      () -> Seq (Term v ()) -> Term v ()
forall v a vt at ap.
Ord v =>
a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a
list' () (Seq (Term v ()) -> Term v ())
-> (Set DecompError, Seq (Term v ()))
-> (Set DecompError, Term v ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> (Set DecompError, Term v ()))
-> USeq -> (Set DecompError, Seq (Term v ()))
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) -> Seq a -> f (Seq b)
traverse ((Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ()))
-> Val
-> (Set DecompError, Term v ())
forall v.
Var v =>
(Reference -> Maybe Reference)
-> (Word64 -> Word64 -> Maybe (Term v ())) -> Val -> DecompResult v
decompile Reference -> Maybe Reference
backref Word64 -> Word64 -> Maybe (Term v ())
topTerms) USeq
s
decompileForeign Reference -> Maybe Reference
_ Word64 -> Word64 -> Maybe (Term v ())
_ (Wrap Reference
r e
_) =
  DecompError -> Term v () -> (Set DecompError, Term v ())
forall a. DecompError -> a -> (Set DecompError, a)
err (Reference -> DecompError
BadForeign Reference
r) (Term v () -> (Set DecompError, Term v ()))
-> Term v () -> (Set DecompError, Term v ())
forall a b. (a -> b) -> a -> b
$ Text -> Term v ()
forall v. Var v => Text -> Term v ()
bug Text
text
  where
    text :: Text
text
      | Builtin Text
name <- Reference
r = Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
      | Bool
otherwise = Text
"<Foreign>"

decompileBytes :: (Var v) => By.Bytes -> Term v ()
decompileBytes :: forall v. Var v => Bytes -> Term v ()
decompileBytes =
  ()
-> Term2 v () () v () -> Term2 v () () v () -> Term2 v () () v ()
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
app () (() -> Text -> Term2 v () () v ()
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
builtin () (Text -> Term2 v () () v ()) -> Text -> Term2 v () () v ()
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString String
"Bytes.fromList")
    (Term2 v () () v () -> Term2 v () () v ())
-> (Bytes -> Term2 v () () v ()) -> Bytes -> Term2 v () () v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> [Term2 v () () v ()] -> Term2 v () () v ()
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
list ()
    ([Term2 v () () v ()] -> Term2 v () () v ())
-> (Bytes -> [Term2 v () () v ()]) -> Bytes -> Term2 v () () v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Term2 v () () v ()) -> [Word8] -> [Term2 v () () v ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Word64 -> Term2 v () () v ()
forall v a vt at ap. Ord v => a -> Word64 -> Term2 vt at ap v a
nat () (Word64 -> Term2 v () () v ())
-> (Word8 -> Word64) -> Word8 -> Term2 v () () v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
    ([Word8] -> [Term2 v () () v ()])
-> (Bytes -> [Word8]) -> Bytes -> [Term2 v () () v ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> [Word8]
By.toWord8s

decompileHashAlgorithm :: (Var v) => HashAlgorithm -> Term v ()
decompileHashAlgorithm :: forall v. Var v => HashAlgorithm -> Term v ()
decompileHashAlgorithm (HashAlgorithm Reference
r a
_) = () -> Reference -> Term2 v () () v ()
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
ref () Reference
r

unwrapSeq :: Foreign -> Maybe USeq
unwrapSeq :: Foreign -> Maybe USeq
unwrapSeq = Reference -> Foreign -> Maybe USeq
forall a. Reference -> Foreign -> Maybe a
maybeUnwrapForeign Reference
listRef