{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module Unison.Runtime.ANF
  ( minimizeCyclesOrCrash,
    pattern TVar,
    pattern TLit,
    pattern TBLit,
    pattern TApp,
    pattern TApv,
    pattern TCom,
    pattern TCon,
    pattern TKon,
    pattern TReq,
    pattern TPrm,
    pattern TFOp,
    pattern THnd,
    pattern TLet,
    pattern TLetD,
    pattern TFrc,
    pattern TLets,
    pattern TName,
    pattern TBind,
    pattern TBinds,
    pattern TShift,
    pattern TMatch,
    CompileExn (..),
    internalBug,
    Mem (..),
    Lit (..),
    Direction (..),
    SuperNormal (..),
    SuperGroup (..),
    POp (..),
    FOp,
    close,
    saturate,
    float,
    floatGroup,
    lamLift,
    lamLiftGroup,
    litRef,
    inlineAlias,
    addDefaultCases,
    ANormalF (.., AApv, ACom, ACon, AKon, AReq, APrm, AFOp),
    ANormal,
    RTag,
    CTag,
    Tag (..),
    GroupRef (..),
    Value (..),
    Cont (..),
    BLit (..),
    packTags,
    unpackTags,
    maskTags,
    ANFM,
    Branched (.., MatchDataCover),
    Func (..),
    SGEqv (..),
    equivocate,
    superNormalize,
    anfTerm,
    valueTermLinks,
    valueLinks,
    groupTermLinks,
    foldGroupLinks,
    overGroupLinks,
    traverseGroupLinks,
    normalLinks,
    prettyGroup,
    prettySuperNormal,
    prettyANF,
  )
where

import Control.Exception (throw)
import Control.Lens (snoc, unsnoc)
import Control.Monad.Reader (ReaderT (..), ask, local)
import Control.Monad.State (MonadState (..), State, gets, modify, runState)
import Data.Bifoldable (Bifoldable (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import Data.Functor.Compose (Compose (..))
import Data.List hiding (and, or)
import Data.Map qualified as Map
import Data.Primitive qualified as PA
import Data.Set qualified as Set
import Data.Text qualified as Data.Text
import GHC.Stack (CallStack, callStack)
import Unison.ABT qualified as ABT
import Unison.ABT.Normalized qualified as ABTN
import Unison.Blank (nameb)
import Unison.Builtin.Decls qualified as Ty
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import Unison.Hashing.V2.Convert (hashTermComponentsWithoutTypes)
import Unison.Pattern (SeqOp (..))
import Unison.Pattern qualified as P
import Unison.Prelude
import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId))
import Unison.Referent (Referent, pattern Con, pattern Ref)
import Unison.Symbol (Symbol)
import Unison.Term hiding (List, Ref, Text, float, fresh, resolve)
import Unison.Type qualified as Ty
import Unison.Typechecker.Components (minimize')
import Unison.Util.Bytes (Bytes)
import Unison.Util.EnumContainers as EC
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Text qualified as Util.Text
import Unison.Var (Var, typed)
import Unison.Var qualified as Var
import Prelude hiding (abs, and, or, seq)
import Prelude qualified

-- For internal errors
data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText)
  deriving (Int -> CompileExn -> ShowS
[CompileExn] -> ShowS
CompileExn -> String
(Int -> CompileExn -> ShowS)
-> (CompileExn -> String)
-> ([CompileExn] -> ShowS)
-> Show CompileExn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompileExn -> ShowS
showsPrec :: Int -> CompileExn -> ShowS
$cshow :: CompileExn -> String
show :: CompileExn -> String
$cshowList :: [CompileExn] -> ShowS
showList :: [CompileExn] -> ShowS
Show)

instance Exception CompileExn

internalBug :: (HasCallStack) => String -> a
internalBug :: forall a. HasCallStack => String -> a
internalBug = CompileExn -> a
forall a e. Exception e => e -> a
throw (CompileExn -> a) -> (String -> CompileExn) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> Pretty ColorText -> CompileExn
CE CallStack
HasCallStack => CallStack
callStack (Pretty ColorText -> CompileExn)
-> (String -> Pretty ColorText) -> String -> CompileExn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorText -> Pretty ColorText
forall s. (IsString s, ListLike s Char) => s -> Pretty s
Pretty.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

closure :: (Var v) => Map v (Set v, Set v) -> Map v (Set v)
closure :: forall v. Var v => Map v (Set v, Set v) -> Map v (Set v)
closure Map v (Set v, Set v)
m0 = Map v (Set v) -> Map v (Set v)
trace ((Set v, Set v) -> Set v
forall a b. (a, b) -> b
snd ((Set v, Set v) -> Set v) -> Map v (Set v, Set v) -> Map v (Set v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map v (Set v, Set v)
m0)
  where
    refs :: Map v (Set v)
refs = (Set v, Set v) -> Set v
forall a b. (a, b) -> a
fst ((Set v, Set v) -> Set v) -> Map v (Set v, Set v) -> Map v (Set v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map v (Set v, Set v)
m0

    expand :: Map k a -> a -> t k -> a
expand Map k a
acc a
fvs t k
rvs =
      a
fvs a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (k -> a) -> t k -> a
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\k
r -> a -> k -> Map k a -> a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault a
forall a. Monoid a => a
mempty k
r Map k a
acc) t k
rvs

    trace :: Map v (Set v) -> Map v (Set v)
trace Map v (Set v)
acc
      | Map v (Set v)
acc Map v (Set v) -> Map v (Set v) -> Bool
forall a. Eq a => a -> a -> Bool
== Map v (Set v)
acc' = Map v (Set v)
acc
      | Bool
otherwise = Map v (Set v) -> Map v (Set v)
trace Map v (Set v)
acc'
      where
        acc' :: Map v (Set v)
acc' = (Set v -> Set v -> Set v)
-> Map v (Set v) -> Map v (Set v) -> Map v (Set v)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (Map v (Set v) -> Set v -> Set v -> Set v
forall {a} {t :: * -> *} {k}.
(Foldable t, Monoid a, Ord k) =>
Map k a -> a -> t k -> a
expand Map v (Set v)
acc) Map v (Set v)
acc Map v (Set v)
refs

expandRec ::
  (Var v, Monoid a) =>
  Set v ->
  [(v, Term v a)] ->
  [(v, Term v a)]
expandRec :: forall v a.
(Var v, Monoid a) =>
Set v -> [(v, Term v a)] -> [(v, Term v a)]
expandRec Set v
keep [(v, Term v a)]
vbs = (v, [v]) -> (v, Term v a)
forall {v} {a} {vt} {at} {ap}.
(Ord v, Monoid a) =>
(v, [v]) -> (v, Term2 vt at ap v a)
mkSub ((v, [v]) -> (v, Term v a)) -> [(v, [v])] -> [(v, Term v a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, [v])]
fvl
  where
    mkSub :: (v, [v]) -> (v, Term2 vt at ap v a)
mkSub (v
v, [v]
fvs) = (v
v, Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap 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' (a -> v -> Term2 vt at ap v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
forall a. Monoid a => a
mempty v
v) (a -> v -> Term2 vt at ap v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
forall a. Monoid a => a
mempty (v -> Term2 vt at ap v a) -> [v] -> [Term2 vt at ap v a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
fvs))

    fvl :: [(v, [v])]
fvl =
      Map v [v] -> [(v, [v])]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map v [v] -> [(v, [v])])
-> (Map v (Set v, Set v) -> Map v [v])
-> Map v (Set v, Set v)
-> [(v, [v])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set v -> [v]) -> Map v (Set v) -> Map v [v]
forall a b. (a -> b) -> Map v a -> Map v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set v -> [v]
forall a. Set a -> [a]
Set.toList)
        (Map v (Set v) -> Map v [v])
-> (Map v (Set v, Set v) -> Map v (Set v))
-> Map v (Set v, Set v)
-> Map v [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map v (Set v, Set v) -> Map v (Set v)
forall v. Var v => Map v (Set v, Set v) -> Map v (Set v)
closure
        (Map v (Set v, Set v) -> [(v, [v])])
-> Map v (Set v, Set v) -> [(v, [v])]
forall a b. (a -> b) -> a -> b
$ (v -> Bool) -> Set v -> (Set v, Set v)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition (v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set v
keep)
          (Set v -> (Set v, Set v))
-> (Term v a -> Set v) -> Term v a -> (Set v, Set v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars
          (Term v a -> (Set v, Set v))
-> Map v (Term v a) -> Map v (Set v, Set v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, Term v a)] -> Map v (Term v a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(v, Term v a)]
vbs

expandSimple ::
  (Var v, Monoid a) =>
  Set v ->
  (v, Term v a) ->
  (v, Term v a)
expandSimple :: forall v a.
(Var v, Monoid a) =>
Set v -> (v, Term v a) -> (v, Term v a)
expandSimple Set v
keep (v
v, Term v a
bnd) = (v
v, Term v a -> [Term v a] -> Term 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' (a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
a v
v) [Term v a]
evs)
  where
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
bnd
    fvs :: Set v
fvs = Term v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term v a
bnd
    evs :: [Term v a]
evs = (v -> Term v a) -> [v] -> [Term v a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
a) ([v] -> [Term v a]) -> (Set v -> [v]) -> Set v -> [Term v a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set v -> [v]
forall a. Set a -> [a]
Set.toList (Set v -> [Term v a]) -> Set v -> [Term v a]
forall a b. (a -> b) -> a -> b
$ Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set v
fvs Set v
keep

abstract :: (Var v) => Set v -> Term v a -> Term v a
abstract :: forall v a. Var v => Set v -> Term v a -> Term v a
abstract Set v
keep Term v a
bnd = a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
evs Term v a
bnd
  where
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
bnd
    fvs :: Set v
fvs = Term v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term v a
bnd
    evs :: [v]
evs = Set v -> [v]
forall a. Set a -> [a]
Set.toList (Set v -> [v]) -> Set v -> [v]
forall a b. (a -> b) -> a -> b
$ Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set v
fvs Set v
keep

enclose ::
  (Var v, Monoid a) =>
  Set v ->
  (Set v -> Term v a -> Term v a) ->
  Term v a ->
  Maybe (Term v a)
enclose :: forall v a.
(Var v, Monoid a) =>
Set v
-> (Set v -> Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
enclose Set v
keep Set v -> Term v a -> Term v a
rec (LetRecNamedTop' Bool
top [(v, Term v a)]
vbs Term v a
bd) =
  Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ Bool -> [(v, a, Term v a)] -> Term v a -> Term v a
forall v a vt.
(Ord v, Monoid a) =>
Bool -> [(v, a, Term' vt v a)] -> Term' vt v a -> Term' vt v a
letRec' Bool
top [(v, a, Term v a)]
lvbs Term v a
lbd
  where
    xpnd :: [(v, Term v a)]
xpnd = Set v -> [(v, Term v a)] -> [(v, Term v a)]
forall v a.
(Var v, Monoid a) =>
Set v -> [(v, Term v a)] -> [(v, Term v a)]
expandRec Set v
keep' [(v, Term v a)]
vbs
    keep' :: Set v
keep' = Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set v
keep (Set v -> Set v)
-> ([(v, Term v a)] -> Set v) -> [(v, Term v a)] -> Set v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v)
-> ([(v, Term v a)] -> [v]) -> [(v, Term v a)] -> Set v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, Term v a) -> v) -> [(v, Term v a)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, Term v a) -> v
forall a b. (a, b) -> a
fst ([(v, Term v a)] -> Set v) -> [(v, Term v a)] -> Set v
forall a b. (a -> b) -> a -> b
$ [(v, Term v a)]
vbs
    lvbs :: [(v, a, Term v a)]
lvbs =
      [(v, Term v a)]
vbs
        [(v, Term v a)]
-> ((v, Term v a) -> (v, a, Term v a)) -> [(v, a, Term v a)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(v
v, Term v a
trm) ->
          (v
v, Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
trm, (Set v -> Term v a -> Term v a
rec Set v
keep' (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set v -> Term v a -> Term v a
forall v a. Var v => Set v -> Term v a -> Term v a
abstract Set v
keep' (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(v, Term v a)] -> Term v a -> Term 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
ABT.substs [(v, Term v a)]
xpnd) Term v a
trm)
    lbd :: Term v a
lbd = Set v -> Term v a -> Term v a
rec Set v
keep' (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(v, Term v a)] -> Term v a -> Term 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
ABT.substs [(v, Term v a)]
xpnd (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$ Term v a
bd
-- will be lifted, so keep this variable
enclose Set v
keep Set v -> Term v a -> Term v a
rec (Let1NamedTop' Bool
top v
v b :: Term v a
b@(Term v a -> Term v a
forall v a. Term v a -> Term v a
unAnn -> LamsNamed' [v]
vs Term v a
bd) Term v a
e) =
  Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a))
-> (Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [(v, Term v a)] -> Term v a -> Term v a
forall a v vt at ap.
(Semigroup a, Ord v) =>
Bool
-> [(v, Term2 vt at ap v a)]
-> Term2 vt at ap v a
-> Term2 vt at ap v a
let1' Bool
top [(v
v, Term v a
lamb)] (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set v -> Term v a -> Term v a
rec (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
keep) (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$
    v -> Term v a -> Term v a -> Term 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
ABT.subst v
v Term v a
av Term v a
e
  where
    (v
_, Term v a
av) = Set v -> (v, Term v a) -> (v, Term v a)
forall v a.
(Var v, Monoid a) =>
Set v -> (v, Term v a) -> (v, Term v a)
expandSimple Set v
keep (v
v, Term v a
b)
    keep' :: Set v
keep' = Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set v
keep (Set v -> Set v) -> Set v -> Set v
forall a b. (a -> b) -> a -> b
$ [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v]
vs
    fvs :: Set v
fvs = Term v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term v a
b
    evs :: [v]
evs = Set v -> [v]
forall a. Set a -> [a]
Set.toList (Set v -> [v]) -> Set v -> [v]
forall a b. (a -> b) -> a -> b
$ Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set v
fvs Set v
keep
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
b
    lbody :: Term v a
lbody = Set v -> Term v a -> Term v a
rec Set v
keep' Term v a
bd
    annotate :: Term v a -> Term v a
annotate Term v a
tm
      | Ann' Term v a
_ Type v a
ty <- Term v a
b = a -> Term v a -> Type v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
ann a
a Term v a
tm Type v a
ty
      | Bool
otherwise = Term v a
tm
    lamb :: Term v a
lamb = a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
evs (Term v a -> Term v a
annotate (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$ a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
vs Term v a
lbody)
enclose Set v
keep Set v -> Term v a -> Term v a
rec t :: Term v a
t@(Term v a -> Maybe ([v], Maybe (Type v a), [v], Term v a)
forall v a.
Term v a -> Maybe ([v], Maybe (Type v a), [v], Term v a)
unLamsAnnot -> Just ([v]
vs0, Maybe (Type v a)
mty, [v]
vs1, Term v a
body)) =
  Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ if [v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
evs then Term v a
lamb else Term v a -> [Term v a] -> Term 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' Term v a
lamb ([Term v a] -> Term v a) -> [Term v a] -> Term v a
forall a b. (a -> b) -> a -> b
$ (v -> Term v a) -> [v] -> [Term v a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
a) [v]
evs
  where
    -- remove shadowed variables
    keep' :: Set v
keep' = Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set v
keep (Set v -> Set v) -> Set v -> Set v
forall a b. (a -> b) -> a -> b
$ [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v]
vs0 [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
vs1)
    fvs :: Set v
fvs = Term v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term v a
t
    evs :: [v]
evs = Set v -> [v]
forall a. Set a -> [a]
Set.toList (Set v -> [v]) -> Set v -> [v]
forall a b. (a -> b) -> a -> b
$ Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set v
fvs Set v
keep
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
t
    lbody :: Term v a
lbody = Set v -> Term v a -> Term v a
rec Set v
keep' Term v a
body
    annotate :: Term v a -> Term v a
annotate Term v a
tm
      | Just Type v a
ty <- Maybe (Type v a)
mty = a -> Term v a -> Type v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
ann a
a Term v a
tm Type v a
ty
      | Bool
otherwise = Term v a
tm
    lamb :: Term v a
lamb = a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a ([v]
evs [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
vs0) (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v a -> Term v a
annotate (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
vs1 (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$ Term v a
lbody
enclose Set v
keep Set v -> Term v a -> Term v a
rec t :: Term v a
t@(Handle' Term v a
h Term v a
body)
  | Term v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured Term v a
body =
      Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a))
-> (Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Term v a -> Term v a -> Term v a
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
handle (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
t) (Set v -> Term v a -> Term v a
rec Set v
keep Term v a
h) (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ Term v a -> [Term v a] -> Term 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' Term v a
lamb [Term v a]
args
  where
    fvs :: Set v
fvs = Term v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term v a
body
    evs :: [v]
evs = Set v -> [v]
forall a. Set a -> [a]
Set.toList (Set v -> [v]) -> Set v -> [v]
forall a b. (a -> b) -> a -> b
$ Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set v
fvs Set v
keep
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
body
    lbody :: Term v a
lbody = Set v -> Term v a -> Term v a
rec Set v
keep Term v a
body
    fv :: v
fv = Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn Set v
fvs (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ Type -> v
forall v. Var v => Type -> v
typed Type
Var.Eta
    args :: [Term v a]
args
      | [v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
evs = [a -> ConstructorReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
constructor a
a (Reference -> Word64 -> ConstructorReference
forall r. r -> Word64 -> GConstructorReference r
ConstructorReference Reference
Ty.unitRef Word64
0)]
      | Bool
otherwise = a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
a (v -> Term v a) -> [v] -> [Term v a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
evs
    lamb :: Term v a
lamb
      | [v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
evs = a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v
fv] Term v a
lbody
      | Bool
otherwise = a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
evs Term v a
lbody
enclose Set v
keep Set v -> Term v a -> Term v a
rec t :: Term v a
t@(Match' Term v a
s0 [MatchCase a (Term v a)]
cs0) = Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ a -> Term v a -> [MatchCase a (Term v a)] -> Term v a
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
match a
a Term v a
s [MatchCase a (Term v a)]
cs
  where
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
t
    s :: Term v a
s = Set v -> Term v a -> Term v a
rec Set v
keep Term v a
s0
    cs :: [MatchCase a (Term v a)]
cs = a
-> Set v
-> (Set v -> Term v a -> Term v a)
-> MatchCase a (Term v a)
-> MatchCase a (Term v a)
forall v a.
(Var v, Monoid a) =>
a
-> Set v
-> (Set v -> Term v a -> Term v a)
-> MatchCase a (Term v a)
-> MatchCase a (Term v a)
encloseCase a
a Set v
keep Set v -> Term v a -> Term v a
rec (MatchCase a (Term v a) -> MatchCase a (Term v a))
-> [MatchCase a (Term v a)] -> [MatchCase a (Term v a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MatchCase a (Term v a)]
cs0
enclose Set v
_ Set v -> Term v a -> Term v a
_ Term v a
_ = Maybe (Term v a)
forall a. Maybe a
Nothing

encloseCase ::
  (Var v, Monoid a) =>
  a ->
  Set v ->
  (Set v -> Term v a -> Term v a) ->
  MatchCase a (Term v a) ->
  MatchCase a (Term v a)
encloseCase :: forall v a.
(Var v, Monoid a) =>
a
-> Set v
-> (Set v -> Term v a -> Term v a)
-> MatchCase a (Term v a)
-> MatchCase a (Term v a)
encloseCase a
a Set v
keep Set v -> Term v a -> Term v a
rec0 (MatchCase Pattern a
pats Maybe (Term v a)
guard Term v a
body) =
  Pattern a -> Maybe (Term v a) -> Term v a -> MatchCase a (Term v a)
forall loc a. Pattern loc -> Maybe a -> a -> MatchCase loc a
MatchCase Pattern a
pats (Term v a -> Term v a
rec (Term v a -> Term v a) -> Maybe (Term v a) -> Maybe (Term v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Term v a)
guard) (Term v a -> Term v a
rec Term v a
body)
  where
    rec :: Term v a -> Term v a
rec (ABT.AbsN' [v]
vs Term v a
bd) =
      [(a, v)] -> Term v a -> Term v a
forall v a (f :: * -> *).
Ord v =>
[(a, v)] -> Term f v a -> Term f v a
ABT.absChain' ((,) a
a (v -> (a, v)) -> [v] -> [(a, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
vs) (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$
        Set v -> Term v a -> Term v a
rec0 (Set v
keep Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v]
vs) Term v a
bd

newtype Prefix v x = Pfx (Map v [v]) deriving (Int -> Prefix v x -> ShowS
[Prefix v x] -> ShowS
Prefix v x -> String
(Int -> Prefix v x -> ShowS)
-> (Prefix v x -> String)
-> ([Prefix v x] -> ShowS)
-> Show (Prefix v x)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v x. Show v => Int -> Prefix v x -> ShowS
forall v x. Show v => [Prefix v x] -> ShowS
forall v x. Show v => Prefix v x -> String
$cshowsPrec :: forall v x. Show v => Int -> Prefix v x -> ShowS
showsPrec :: Int -> Prefix v x -> ShowS
$cshow :: forall v x. Show v => Prefix v x -> String
show :: Prefix v x -> String
$cshowList :: forall v x. Show v => [Prefix v x] -> ShowS
showList :: [Prefix v x] -> ShowS
Show)

instance Functor (Prefix v) where
  fmap :: forall a b. (a -> b) -> Prefix v a -> Prefix v b
fmap a -> b
_ (Pfx Map v [v]
m) = Map v [v] -> Prefix v b
forall v x. Map v [v] -> Prefix v x
Pfx Map v [v]
m

instance (Ord v) => Applicative (Prefix v) where
  pure :: forall a. a -> Prefix v a
pure a
_ = Map v [v] -> Prefix v a
forall v x. Map v [v] -> Prefix v x
Pfx Map v [v]
forall k a. Map k a
Map.empty
  Pfx Map v [v]
ml <*> :: forall a b. Prefix v (a -> b) -> Prefix v a -> Prefix v b
<*> Pfx Map v [v]
mr = Map v [v] -> Prefix v b
forall v x. Map v [v] -> Prefix v x
Pfx (Map v [v] -> Prefix v b) -> Map v [v] -> Prefix v b
forall a b. (a -> b) -> a -> b
$ ([v] -> [v] -> [v]) -> Map v [v] -> Map v [v] -> Map v [v]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [v] -> [v] -> [v]
forall v. Eq v => [v] -> [v] -> [v]
common Map v [v]
ml Map v [v]
mr

common :: (Eq v) => [v] -> [v] -> [v]
common :: forall v. Eq v => [v] -> [v] -> [v]
common (v
u : [v]
us) (v
v : [v]
vs)
  | v
u v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v = v
u v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v] -> [v] -> [v]
forall v. Eq v => [v] -> [v] -> [v]
common [v]
us [v]
vs
common [v]
_ [v]
_ = []

splitPfx :: v -> [Term v a] -> (Prefix v x, [Term v a])
splitPfx :: forall v a x. v -> [Term v a] -> (Prefix v x, [Term v a])
splitPfx v
v = ([v] -> Prefix v x)
-> ([v], [Term v a]) -> (Prefix v x, [Term v a])
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 (Map v [v] -> Prefix v x
forall v x. Map v [v] -> Prefix v x
Pfx (Map v [v] -> Prefix v x)
-> ([v] -> Map v [v]) -> [v] -> Prefix v x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> [v] -> Map v [v]
forall k a. k -> a -> Map k a
Map.singleton v
v) (([v], [Term v a]) -> (Prefix v x, [Term v a]))
-> ([Term v a] -> ([v], [Term v a]))
-> [Term v a]
-> (Prefix v x, [Term v a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term v a] -> ([v], [Term v a])
forall {f :: * -> *} {a} {a}. [Term f a a] -> ([a], [Term f a a])
split
  where
    split :: [Term f a a] -> ([a], [Term f a a])
split (Var' a
u : [Term f a a]
as) = ([a] -> [a]) -> ([a], [Term f a a]) -> ([a], [Term f a a])
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 (a
u a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], [Term f a a]) -> ([a], [Term f a a]))
-> ([a], [Term f a a]) -> ([a], [Term f a a])
forall a b. (a -> b) -> a -> b
$ [Term f a a] -> ([a], [Term f a a])
split [Term f a a]
as
    split [Term f a a]
rest = ([], [Term f a a]
rest)

-- Finds the common variable prefixes that function variables are
-- applied to, so that they can be reduced.
prefix :: (Ord v) => Term v a -> Prefix v (Term v a)
prefix :: forall v a. Ord v => Term v a -> Prefix v (Term v a)
prefix = (Term (F v a a) v a -> Maybe (Prefix v (Term (F v a a) v a)))
-> Term (F v a a) v a -> Prefix v (Term (F v a a) v a)
forall (f :: * -> *) (g :: * -> *) v a.
(Traversable f, Applicative g, Ord v) =>
(Term f v a -> Maybe (g (Term f v a)))
-> Term f v a -> g (Term f v a)
ABT.visit \case
  Apps' (Var' v
u) [Term (F v a a) v a]
as -> case v
-> [Term (F v a a) v a]
-> (Prefix v (Term (F v a a) v a), [Term (F v a a) v a])
forall v a x. v -> [Term v a] -> (Prefix v x, [Term v a])
splitPfx v
u [Term (F v a a) v a]
as of
    (Prefix v (Term (F v a a) v a)
pf, [Term (F v a a) v a]
rest) -> Prefix v (Term (F v a a) v a)
-> Maybe (Prefix v (Term (F v a a) v a))
forall a. a -> Maybe a
Just (Prefix v (Term (F v a a) v a)
 -> Maybe (Prefix v (Term (F v a a) v a)))
-> Prefix v (Term (F v a a) v a)
-> Maybe (Prefix v (Term (F v a a) v a))
forall a b. (a -> b) -> a -> b
$ (Term (F v a a) v a -> Prefix v (Term (F v a a) v a))
-> [Term (F v a a) v a] -> Prefix v [Term (F v a a) v a]
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 Term (F v a a) v a -> Prefix v (Term (F v a a) v a)
forall v a. Ord v => Term v a -> Prefix v (Term v a)
prefix [Term (F v a a) v a]
rest Prefix v [Term (F v a a) v a]
-> Prefix v (Term (F v a a) v a) -> Prefix v (Term (F v a a) v a)
forall a b. Prefix v a -> Prefix v b -> Prefix v b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Prefix v (Term (F v a a) v a)
pf
  Var' v
u -> Prefix v (Term (F v a a) v a)
-> Maybe (Prefix v (Term (F v a a) v a))
forall a. a -> Maybe a
Just (Prefix v (Term (F v a a) v a)
 -> Maybe (Prefix v (Term (F v a a) v a)))
-> (Map v [v] -> Prefix v (Term (F v a a) v a))
-> Map v [v]
-> Maybe (Prefix v (Term (F v a a) v a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map v [v] -> Prefix v (Term (F v a a) v a)
forall v x. Map v [v] -> Prefix v x
Pfx (Map v [v] -> Maybe (Prefix v (Term (F v a a) v a)))
-> Map v [v] -> Maybe (Prefix v (Term (F v a a) v a))
forall a b. (a -> b) -> a -> b
$ v -> [v] -> Map v [v]
forall k a. k -> a -> Map k a
Map.singleton v
u []
  Term (F v a a) v a
_ -> Maybe (Prefix v (Term (F v a a) v a))
forall a. Maybe a
Nothing

appPfx :: (Ord v) => Prefix v a -> v -> [v] -> [v]
appPfx :: forall v a. Ord v => Prefix v a -> v -> [v] -> [v]
appPfx (Pfx Map v [v]
m) v
v = ([v] -> [v]) -> ([v] -> [v] -> [v]) -> Maybe [v] -> [v] -> [v]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([v] -> [v] -> [v]
forall a b. a -> b -> a
const []) [v] -> [v] -> [v]
forall v. Eq v => [v] -> [v] -> [v]
common (Maybe [v] -> [v] -> [v]) -> Maybe [v] -> [v] -> [v]
forall a b. (a -> b) -> a -> b
$ v -> Map v [v] -> Maybe [v]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v [v]
m

-- Rewrites a term by dropping the first n arguments to every
-- application of `v`. This just assumes such a thing makes sense, as
-- in `beta`, where we've calculated how many arguments to drop by
-- looking at every occurrence of `v`.
dropPrefix :: (Ord v) => (Semigroup a) => v -> Int -> Term v a -> Term v a
dropPrefix :: forall v a.
(Ord v, Semigroup a) =>
v -> Int -> Term v a -> Term v a
dropPrefix v
_ Int
0 = Term v a -> Term v a
forall a. a -> a
id
dropPrefix v
v Int
n = (Term v a -> Maybe (Term v a)) -> Term v a -> Term v a
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure Term v a -> Maybe (Term v a)
rw
  where
    rw :: Term v a -> Maybe (Term v a)
rw (Apps' f :: Term v a
f@(Var' v
u) [Term v a]
as)
      | v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
u = Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> [Term v a] -> Term 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' (a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
f) v
u) (Int -> [Term v a] -> [Term v a]
forall a. Int -> [a] -> [a]
drop Int
n [Term v a]
as))
    rw Term v a
_ = Maybe (Term v a)
forall a. Maybe a
Nothing

dropPrefixes ::
  (Ord v) => (Semigroup a) => Map v Int -> Term v a -> Term v a
dropPrefixes :: forall v a.
(Ord v, Semigroup a) =>
Map v Int -> Term v a -> Term v a
dropPrefixes Map v Int
m = (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a -> Term (F v a a) v a
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure Term (F v a a) v a -> Maybe (Term (F v a a) v a)
rw
  where
    rw :: Term (F v a a) v a -> Maybe (Term (F v a a) v a)
rw (Apps' f :: Term (F v a a) v a
f@(Var' v
u) [Term (F v a a) v a]
as)
      | Just Int
n <- v -> Map v Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
u Map v Int
m =
          Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a. a -> Maybe a
Just (Term (F v a a) v a -> [Term (F v a a) v a] -> Term (F v a a) 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' (a -> v -> Term (F v a a) v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var (Term (F v a a) v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term (F v a a) v a
f) v
u) (Int -> [Term (F v a a) v a] -> [Term (F v a a) v a]
forall a. Int -> [a] -> [a]
drop Int
n [Term (F v a a) v a]
as))
    rw Term (F v a a) v a
_ = Maybe (Term (F v a a) v a)
forall a. Maybe a
Nothing

-- Performs opposite transformations to those in enclose. Named after
-- the lambda case, which is beta reduction.
beta :: (Var v) => (Monoid a) => (Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
beta :: forall v a.
(Var v, Monoid a) =>
(Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
beta Term v a -> Term v a
rec (LetRecNamedTop' Bool
top (((v, Term v a) -> (v, Term v a))
-> [(v, Term v a)] -> [(v, Term v a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Term v a -> Term v a) -> (v, Term v a) -> (v, Term v a)
forall a b. (a -> b) -> (v, a) -> (v, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term v a -> Term v a
rec) -> [(v, Term v a)]
vbs) (Term v a -> Term v a
rec -> Term v a
bd)) =
  Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ Bool -> [(v, a, Term v a)] -> Term v a -> Term v a
forall v a vt.
(Ord v, Monoid a) =>
Bool -> [(v, a, Term' vt v a)] -> Term' vt v a -> Term' vt v a
letRec' Bool
top [(v, a, Term v a)]
lvbs Term v a
lbd
  where
    -- Avoid completely reducing a lambda expression, because recursive
    -- lets must be guarded.
    args :: (a, Term2 vt at ap v a) -> (a, [v])
args (a
v, LamsNamed' [v]
vs Ann' {}) = (a
v, [v]
vs)
    args (a
v, LamsNamed' [v]
vs Term2 vt at ap v a
_) = (a
v, [v] -> [v]
forall a. HasCallStack => [a] -> [a]
init [v]
vs)
    args (a
v, Term2 vt at ap v a
_) = (a
v, [])

    Pfx Map v [v]
m0 = ((v, Term v a) -> Prefix v (Term v a))
-> [(v, Term v a)] -> Prefix v ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Term v a -> Prefix v (Term v a)
forall v a. Ord v => Term v a -> Prefix v (Term v a)
prefix (Term v a -> Prefix v (Term v a))
-> ((v, Term v a) -> Term v a)
-> (v, Term v a)
-> Prefix v (Term v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v, Term v a) -> Term v a
forall a b. (a, b) -> b
snd) [(v, Term v a)]
vbs Prefix v () -> Prefix v (Term v a) -> Prefix v (Term v a)
forall a b. Prefix v a -> Prefix v b -> Prefix v b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Term v a -> Prefix v (Term v a)
forall v a. Ord v => Term v a -> Prefix v (Term v a)
prefix Term v a
bd

    f :: [v] -> [v] -> Maybe [v]
f [v]
ls [v]
rs = case [v] -> [v] -> [v]
forall v. Eq v => [v] -> [v] -> [v]
common [v]
ls [v]
rs of
      [] -> Maybe [v]
forall a. Maybe a
Nothing
      [v]
vs -> [v] -> Maybe [v]
forall a. a -> Maybe a
Just [v]
vs

    m :: Map v Int
m = ([v] -> Int) -> Map v [v] -> Map v Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map v [v] -> Map v Int) -> Map v [v] -> Map v Int
forall a b. (a -> b) -> a -> b
$ ([v] -> [v] -> Maybe [v]) -> Map v [v] -> Map v [v] -> Map v [v]
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith [v] -> [v] -> Maybe [v]
forall {v}. Eq v => [v] -> [v] -> Maybe [v]
f ([(v, [v])] -> Map v [v]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(v, [v])] -> Map v [v]) -> [(v, [v])] -> Map v [v]
forall a b. (a -> b) -> a -> b
$ ((v, Term v a) -> (v, [v])) -> [(v, Term v a)] -> [(v, [v])]
forall a b. (a -> b) -> [a] -> [b]
map (v, Term v a) -> (v, [v])
forall {a} {vt} {at} {ap} {v} {a}.
(a, Term2 vt at ap v a) -> (a, [v])
args [(v, Term v a)]
vbs) Map v [v]
m0
    lvbs :: [(v, a, Term v a)]
lvbs =
      [(v, Term v a)]
vbs [(v, Term v a)]
-> ((v, Term v a) -> (v, a, Term v a)) -> [(v, a, Term v a)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(v
v, Term v a
b0) -> (v
v,Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
b0,) (Term v a -> (v, a, Term v a)) -> Term v a -> (v, a, Term v a)
forall a b. (a -> b) -> a -> b
$ case Term v a
b0 of
        LamsNamed' [v]
vs Term v a
b
          | Just Int
n <- v -> Map v Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v Int
m ->
              a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
b0) (Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
drop Int
n [v]
vs) (Map v Int -> Term v a -> Term v a
forall v a.
(Ord v, Semigroup a) =>
Map v Int -> Term v a -> Term v a
dropPrefixes Map v Int
m Term v a
b)
        -- shouldn't happen
        Term v a
b -> Map v Int -> Term v a -> Term v a
forall v a.
(Ord v, Semigroup a) =>
Map v Int -> Term v a -> Term v a
dropPrefixes Map v Int
m Term v a
b

    lbd :: Term v a
lbd = Map v Int -> Term v a -> Term v a
forall v a.
(Ord v, Semigroup a) =>
Map v Int -> Term v a -> Term v a
dropPrefixes Map v Int
m Term v a
bd
beta Term v a -> Term v a
rec (Let1NamedTop' Bool
top v
v l :: Term v a
l@(LamsNamed' [v]
vs Term v a
bd) (Term v a -> Term v a
rec -> Term v a
e))
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ Bool -> [(v, Term v a)] -> Term v a -> Term v a
forall a v vt at ap.
(Semigroup a, Ord v) =>
Bool
-> [(v, Term2 vt at ap v a)]
-> Term2 vt at ap v a
-> Term2 vt at ap v a
let1' Bool
top [(v
v, Term v a
lamb)] (v -> Int -> Term v a -> Term v a
forall v a.
(Ord v, Semigroup a) =>
v -> Int -> Term v a -> Term v a
dropPrefix v
v Int
n Term v a
e)
  | Bool
otherwise = Maybe (Term v a)
forall a. Maybe a
Nothing
  where
    lamb :: Term v a
lamb = a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
al (Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
drop Int
n [v]
vs) (Term v a
bd)
    al :: a
al = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
l
    -- Calculate a maximum number of arguments to drop.
    -- Enclosing doesn't create let-bound lambdas, so we
    -- should never reduce a lambda to a non-lambda, as that
    -- could affect evaluation order.
    m :: Int
m
      | Ann' Term v a
_ Type v a
_ <- Term v a
bd = [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
vs
      | Bool
otherwise = [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
m (Int -> Int) -> ([v] -> Int) -> [v] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([v] -> Int) -> [v] -> Int
forall a b. (a -> b) -> a -> b
$ Prefix v (Term v a) -> v -> [v] -> [v]
forall v a. Ord v => Prefix v a -> v -> [v] -> [v]
appPfx (Term v a -> Prefix v (Term v a)
forall v a. Ord v => Term v a -> Prefix v (Term v a)
prefix Term v a
e) v
v [v]
vs
beta Term v a -> Term v a
rec (Apps' l :: Term v a
l@(LamsNamed' [v]
vs Term v a
body) [Term v a]
as)
  | Int
n <- Int -> [v] -> [Term v a] -> Int
forall {a} {t} {f :: * -> *} {a}.
(Eq a, Num t) =>
t -> [a] -> [Term f a a] -> t
matchVars Int
0 [v]
vs [Term v a]
as,
    Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
      Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ Term v a -> [Term v a] -> Term 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' (a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
al (Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
drop Int
n [v]
vs) (Term v a -> Term v a
rec Term v a
body)) (Int -> [Term v a] -> [Term v a]
forall a. Int -> [a] -> [a]
drop Int
n [Term v a]
as)
  | Bool
otherwise = Maybe (Term v a)
forall a. Maybe a
Nothing
  where
    al :: a
al = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
l
    matchVars :: t -> [a] -> [Term f a a] -> t
matchVars !t
n (a
u : [a]
us) (Var' a
v : [Term f a a]
as) | a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v = t -> [a] -> [Term f a a] -> t
matchVars (t
1 t -> t -> t
forall a. Num a => a -> a -> a
+ t
n) [a]
us [Term f a a]
as
    matchVars t
n [a]
_ [Term f a a]
_ = t
n
beta Term v a -> Term v a
_ Term v a
_ = Maybe (Term v a)
forall a. Maybe a
Nothing

isStructured :: (Var v) => Term v a -> Bool
isStructured :: forall v a. Var v => Term v a -> Bool
isStructured (Var' v
_) = Bool
False
isStructured (Lam' Subst (F v a a) v a
_) = Bool
False
isStructured (Nat' Word64
_) = Bool
False
isStructured (Int' Int64
_) = Bool
False
isStructured (Float' Double
_) = Bool
False
isStructured (Text' Text
_) = Bool
False
isStructured (Char' Char
_) = Bool
False
isStructured (Constructor' ConstructorReference
_) = Bool
False
isStructured (Apps' Constructor' {} [Term (F v a a) v a]
args) = (Term (F v a a) v a -> Bool) -> [Term (F v a a) v a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Term (F v a a) v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured [Term (F v a a) v a]
args
isStructured (If' Term (F v a a) v a
b Term (F v a a) v a
t Term (F v a a) v a
f) =
  Term (F v a a) v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured Term (F v a a) v a
b Bool -> Bool -> Bool
|| Term (F v a a) v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured Term (F v a a) v a
t Bool -> Bool -> Bool
|| Term (F v a a) v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured Term (F v a a) v a
f
isStructured (And' Term (F v a a) v a
l Term (F v a a) v a
r) = Term (F v a a) v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured Term (F v a a) v a
l Bool -> Bool -> Bool
|| Term (F v a a) v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured Term (F v a a) v a
r
isStructured (Or' Term (F v a a) v a
l Term (F v a a) v a
r) = Term (F v a a) v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured Term (F v a a) v a
l Bool -> Bool -> Bool
|| Term (F v a a) v a -> Bool
forall v a. Var v => Term v a -> Bool
isStructured Term (F v a a) v a
r
isStructured Term (F v a a) v a
_ = Bool
True

close :: (Var v, Monoid a) => Set v -> Term v a -> Term v a
close :: forall v a. (Var v, Monoid a) => Set v -> Term v a -> Term v a
close Set v
keep Term v a
tm = (Term v a -> Maybe (Term v a)) -> Term v a -> Term v a
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure (Set v
-> (Set v -> Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
forall v a.
(Var v, Monoid a) =>
Set v
-> (Set v -> Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
enclose Set v
keep Set v -> Term v a -> Term v a
forall v a. (Var v, Monoid a) => Set v -> Term v a -> Term v a
close) Term v a
tm

-- Attempts to undo what was done in `close`. Useful for decompiling.
open :: (Var v, Monoid a) => Term v a -> Term v a
open :: forall v a. (Var v, Monoid a) => Term v a -> Term v a
open Term v a
x = (Term v a -> Maybe (Term v a)) -> Term v a -> Term v a
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure ((Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
forall v a.
(Var v, Monoid a) =>
(Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
beta Term v a -> Term v a
forall v a. (Var v, Monoid a) => Term v a -> Term v a
open) Term v a
x

type FloatM v a r = State (Set v, [(v, Term v a)], [(v, Term v a)]) r

freshFloat :: (Var v) => Set v -> v -> v
freshFloat :: forall v. Var v => Set v -> v -> v
freshFloat Set v
avoid (Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn Set v
avoid -> v
v0) =
  case v -> Type
forall v. Var v => v -> Type
Var.typeOf v
v0 of
    Var.User Text
nm
      | v
v <- Type -> v
forall v. Var v => Type -> v
typed (Text -> Type
Var.User (Text -> Type) -> Text -> Type
forall a b. (a -> b) -> a -> b
$ Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
w),
        v
v v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set v
avoid ->
          v
v
      | Bool
otherwise ->
          Set v -> v -> v
forall v. Var v => Set v -> v -> v
freshFloat (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v0 Set v
avoid) v
v0
    Type
_ -> v
v0
  where
    w :: Text
w = String -> Text
Data.Text.pack (String -> Text) -> (Word64 -> String) -> Word64 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> String
forall a. Show a => a -> String
show (Word64 -> Text) -> Word64 -> Text
forall a b. (a -> b) -> a -> b
$ v -> Word64
forall v. Var v => v -> Word64
Var.freshId v
v0

groupFloater ::
  (Var v, Monoid a) =>
  (Term v a -> FloatM v a (Term v a)) ->
  [(v, Term v a)] ->
  FloatM v a (Map v v)
groupFloater :: forall v a.
(Var v, Monoid a) =>
(Term v a -> FloatM v a (Term v a))
-> [(v, Term v a)] -> FloatM v a (Map v v)
groupFloater Term v a -> FloatM v a (Term v a)
rec [(v, Term v a)]
vbs = do
  Set v
cvs <- ((Set v, [(v, Term v a)], [(v, Term v a)]) -> Set v)
-> StateT
     (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Set v)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (\(Set v
vs, [(v, Term v a)]
_, [(v, Term v a)]
_) -> Set v
vs)
  let shadows :: [(v, v)]
shadows =
        [ (v
v, Set v -> v -> v
forall v. Var v => Set v -> v -> v
freshFloat Set v
cvs v
v)
          | (v
v, Term v a
_) <- [(v, Term v a)]
vbs,
            v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v Set v
cvs
        ]
      shadowMap :: Map v v
shadowMap = [(v, v)] -> Map v v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(v, v)]
shadows
      rn :: v -> v
rn v
v = v -> v -> Map v v -> v
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault v
v v
v Map v v
shadowMap
      shvs :: Set v
shvs = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v) -> [v] -> Set v
forall a b. (a -> b) -> a -> b
$ ((v, Term v a) -> v) -> [(v, Term v a)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v -> v
rn (v -> v) -> ((v, Term v a) -> v) -> (v, Term v a) -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v, Term v a) -> v
forall a b. (a, b) -> a
fst) [(v, Term v a)]
vbs
  ((Set v, [(v, Term v a)], [(v, Term v a)])
 -> (Set v, [(v, Term v a)], [(v, Term v a)]))
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Set v, [(v, Term v a)], [(v, Term v a)])
  -> (Set v, [(v, Term v a)], [(v, Term v a)]))
 -> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity ())
-> ((Set v, [(v, Term v a)], [(v, Term v a)])
    -> (Set v, [(v, Term v a)], [(v, Term v a)]))
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity ()
forall a b. (a -> b) -> a -> b
$ \(Set v
cvs, [(v, Term v a)]
ctx, [(v, Term v a)]
dcmp) -> (Set v
cvs Set v -> Set v -> Set v
forall a. Semigroup a => a -> a -> a
<> Set v
shvs, [(v, Term v a)]
ctx, [(v, Term v a)]
dcmp)
  [(v, Term v a)]
fvbs <- ((v, Term v a)
 -> StateT
      (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (v, Term v a))
-> [(v, Term v a)]
-> StateT
     (Set v, [(v, Term v a)], [(v, Term v a)]) Identity [(v, Term v a)]
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 (\(v
v, Term v a
b) -> (,) (v -> v
rn v
v) (Term v a -> (v, Term v a))
-> FloatM v a (Term v a)
-> StateT
     (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (v, Term v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> FloatM v a (Term v a)
rec' (Map v v -> Term v a -> Term v a
forall (f :: * -> *) v a.
(Foldable f, Functor f, Var v) =>
Map v v -> Term f v a -> Term f v a
ABT.renames Map v v
shadowMap Term v a
b)) [(v, Term v a)]
vbs
  let dvbs :: [(v, Term v a)]
dvbs = ((v, Term v a) -> (v, Term v a))
-> [(v, Term v a)] -> [(v, Term v a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(v
v, Term v a
b) -> (v -> v
rn v
v, Term v a -> Term v a
forall v a. Var v => Term v a -> Term v a
deannotate Term v a
b)) [(v, Term v a)]
vbs
  ((Set v, [(v, Term v a)], [(v, Term v a)])
 -> (Set v, [(v, Term v a)], [(v, Term v a)]))
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Set v, [(v, Term v a)], [(v, Term v a)])
  -> (Set v, [(v, Term v a)], [(v, Term v a)]))
 -> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity ())
-> ((Set v, [(v, Term v a)], [(v, Term v a)])
    -> (Set v, [(v, Term v a)], [(v, Term v a)]))
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity ()
forall a b. (a -> b) -> a -> b
$ \(Set v
vs, [(v, Term v a)]
ctx, [(v, Term v a)]
dcmp) -> (Set v
vs, [(v, Term v a)]
ctx [(v, Term v a)] -> [(v, Term v a)] -> [(v, Term v a)]
forall a. [a] -> [a] -> [a]
++ [(v, Term v a)]
fvbs, [(v, Term v a)]
dcmp [(v, Term v a)] -> [(v, Term v a)] -> [(v, Term v a)]
forall a. Semigroup a => a -> a -> a
<> [(v, Term v a)]
dvbs)
  pure Map v v
shadowMap
  where
    rec' :: Term v a -> FloatM v a (Term v a)
rec' Term v a
b
      | Just ([v]
vs0, Maybe (Type v a)
mty, [v]
vs1, Term v a
bd) <- Term v a -> Maybe ([v], Maybe (Type v a), [v], Term v a)
forall v a.
Term v a -> Maybe ([v], Maybe (Type v a), [v], Term v a)
unLamsAnnot Term v a
b =
          a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
vs0 (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term v a -> Term v a)
-> (Type v a -> Term v a -> Term v a)
-> Maybe (Type v a)
-> Term v a
-> Term v a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Term v a -> Term v a
forall a. a -> a
id ((Term v a -> Type v a -> Term v a)
-> Type v a -> Term v a -> Term v a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Term v a -> Type v a -> Term v a)
 -> Type v a -> Term v a -> Term v a)
-> (Term v a -> Type v a -> Term v a)
-> Type v a
-> Term v a
-> Term v a
forall a b. (a -> b) -> a -> b
$ a -> Term v a -> Type v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
ann a
a) Maybe (Type v a)
mty (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
vs1 (Term v a -> Term v a)
-> FloatM v a (Term v a) -> FloatM v a (Term v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> FloatM v a (Term v a)
rec Term v a
bd
      where
        a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
b
    rec' Term v a
b = Term v a -> FloatM v a (Term v a)
rec Term v a
b

letFloater ::
  (Var v, Monoid a) =>
  (Term v a -> FloatM v a (Term v a)) ->
  [(v, Term v a)] ->
  Term v a ->
  FloatM v a (Term v a)
letFloater :: forall v a.
(Var v, Monoid a) =>
(Term v a -> FloatM v a (Term v a))
-> [(v, Term v a)] -> Term v a -> FloatM v a (Term v a)
letFloater Term v a -> FloatM v a (Term v a)
rec [(v, Term v a)]
vbs Term v a
e = do
  Map v v
shadowMap <- (Term v a -> FloatM v a (Term v a))
-> [(v, Term v a)] -> FloatM v a (Map v v)
forall v a.
(Var v, Monoid a) =>
(Term v a -> FloatM v a (Term v a))
-> [(v, Term v a)] -> FloatM v a (Map v v)
groupFloater Term v a -> FloatM v a (Term v a)
rec [(v, Term v a)]
vbs
  pure $ Map v v -> Term v a -> Term v a
forall (f :: * -> *) v a.
(Foldable f, Functor f, Var v) =>
Map v v -> Term f v a -> Term f v a
ABT.renames Map v v
shadowMap Term v a
e

lamFloater ::
  (Var v, Monoid a) =>
  Bool ->
  Term v a ->
  Maybe v ->
  a ->
  [v] ->
  Term v a ->
  FloatM v a v
lamFloater :: forall v a.
(Var v, Monoid a) =>
Bool -> Term v a -> Maybe v -> a -> [v] -> Term v a -> FloatM v a v
lamFloater Bool
closed Term2 v a a v a
tm Maybe v
mv a
a [v]
vs Term2 v a a v a
bd =
  ((Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])
 -> (v, (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])))
-> StateT
     (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)]) Identity v
forall a.
((Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])
 -> (a, (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])))
-> StateT
     (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)]) Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])
  -> (v, (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])))
 -> StateT
      (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)]) Identity v)
-> ((Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])
    -> (v, (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])))
-> StateT
     (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)]) Identity v
forall a b. (a -> b) -> a -> b
$ \trip :: (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])
trip@(Set v
cvs, [(v, Term2 v a a v a)]
ctx, [(v, Term2 v a a v a)]
dcmp) -> case ((v, Term2 v a a v a) -> Bool)
-> [(v, Term2 v a a v a)] -> Maybe (v, Term2 v a a v a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (v, Term2 v a a v a) -> Bool
p [(v, Term2 v a a v a)]
ctx of
    Just (v
v, Term2 v a a v a
_) -> (v
v, (Set v, [(v, Term2 v a a v a)], [(v, Term2 v a a v a)])
trip)
    Maybe (v, Term2 v a a v a)
Nothing ->
      let v :: v
v = Set v -> v -> v
forall v. Var v => Set v -> v -> v
ABT.freshIn Set v
cvs (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ v -> Maybe v -> v
forall a. a -> Maybe a -> a
fromMaybe (Type -> v
forall v. Var v => Type -> v
typed Type
Var.Float) Maybe v
mv
       in ( v
v,
            ( v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
cvs,
              [(v, Term2 v a a v a)]
ctx [(v, Term2 v a a v a)]
-> [(v, Term2 v a a v a)] -> [(v, Term2 v a a v a)]
forall a. Semigroup a => a -> a -> a
<> [(v
v, a -> [v] -> Term2 v a a v a -> Term2 v a a v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
vs Term2 v a a v a
bd)],
              Bool
-> v
-> Term2 v a a v a
-> [(v, Term2 v a a v a)]
-> [(v, Term2 v a a v a)]
forall v a.
Bool -> v -> Term v a -> [(v, Term v a)] -> [(v, Term v a)]
floatDecomp Bool
closed v
v Term2 v a a v a
tm [(v, Term2 v a a v a)]
dcmp
            )
          )
  where
    tgt :: Term0' v v
tgt = Term2 v a a v a -> Term0' v v
forall vt at ap v a. Ord v => Term2 vt at ap v a -> Term0' vt v
unannotate (a -> [v] -> Term2 v a a v a -> Term2 v a a v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
vs Term2 v a a v a
bd)
    p :: (v, Term2 v a a v a) -> Bool
p (v
_, Term2 v a a v a
flam) = Term2 v a a v a -> Term0' v v
forall vt at ap v a. Ord v => Term2 vt at ap v a -> Term0' vt v
unannotate Term2 v a a v a
flam Term0' v v -> Term0' v v -> Bool
forall a. Eq a => a -> a -> Bool
== Term0' v v
tgt

floatDecomp ::
  Bool -> v -> Term v a -> [(v, Term v a)] -> [(v, Term v a)]
floatDecomp :: forall v a.
Bool -> v -> Term v a -> [(v, Term v a)] -> [(v, Term v a)]
floatDecomp Bool
True v
v Term v a
b [(v, Term v a)]
dcmp = (v
v, Term v a
b) (v, Term v a) -> [(v, Term v a)] -> [(v, Term v a)]
forall a. a -> [a] -> [a]
: [(v, Term v a)]
dcmp
floatDecomp Bool
False v
_ Term v a
_ [(v, Term v a)]
dcmp = [(v, Term v a)]
dcmp

floater ::
  (Var v, Monoid a) =>
  Bool ->
  (Term v a -> FloatM v a (Term v a)) ->
  Term v a ->
  Maybe (FloatM v a (Term v a))
floater :: forall v a.
(Var v, Monoid a) =>
Bool
-> (Term v a -> FloatM v a (Term v a))
-> Term v a
-> Maybe (FloatM v a (Term v a))
floater Bool
top Term v a -> FloatM v a (Term v a)
rec tm0 :: Term v a
tm0@(Ann' Term v a
tm Type v a
ty) =
  ((FloatM v a (Term v a) -> FloatM v a (Term v a))
-> Maybe (FloatM v a (Term v a)) -> Maybe (FloatM v a (Term v a))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FloatM v a (Term v a) -> FloatM v a (Term v a))
 -> Maybe (FloatM v a (Term v a)) -> Maybe (FloatM v a (Term v a)))
-> ((Term v a -> Term v a)
    -> FloatM v a (Term v a) -> FloatM v a (Term v a))
-> (Term v a -> Term v a)
-> Maybe (FloatM v a (Term v a))
-> Maybe (FloatM v a (Term v a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term v a -> Term v a)
-> FloatM v a (Term v a) -> FloatM v a (Term v a)
forall a b.
(a -> b)
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity a
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\Term v a
tm -> a -> Term v a -> Type v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
ann a
a Term v a
tm Type v a
ty) (Bool
-> (Term v a -> FloatM v a (Term v a))
-> Term v a
-> Maybe (FloatM v a (Term v a))
forall v a.
(Var v, Monoid a) =>
Bool
-> (Term v a -> FloatM v a (Term v a))
-> Term v a
-> Maybe (FloatM v a (Term v a))
floater Bool
top Term v a -> FloatM v a (Term v a)
rec Term v a
tm)
  where
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
tm0
floater Bool
top Term v a -> FloatM v a (Term v a)
rec (LetRecNamed' [(v, Term v a)]
vbs Term v a
e) =
  FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a))
forall a. a -> Maybe a
Just (FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a)))
-> FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a))
forall a b. (a -> b) -> a -> b
$
    (Term v a -> FloatM v a (Term v a))
-> [(v, Term v a)] -> Term v a -> FloatM v a (Term v a)
forall v a.
(Var v, Monoid a) =>
(Term v a -> FloatM v a (Term v a))
-> [(v, Term v a)] -> Term v a -> FloatM v a (Term v a)
letFloater Term v a -> FloatM v a (Term v a)
rec [(v, Term v a)]
vbs Term v a
e FloatM v a (Term v a)
-> (Term v a -> FloatM v a (Term v a)) -> FloatM v a (Term v a)
forall a b.
StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity a
-> (a
    -> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity b)
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      lm :: Term v a
lm@(LamsNamed' [v]
vs Term v a
bd) | Bool
top -> a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
vs (Term v a -> Term v a)
-> FloatM v a (Term v a) -> FloatM v a (Term v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> FloatM v a (Term v a)
rec Term v a
bd
        where
          a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
lm
      Term v a
tm -> Term v a -> FloatM v a (Term v a)
rec Term v a
tm
floater Bool
_ Term v a -> FloatM v a (Term v a)
rec (Let1Named' v
v Term v a
b Term v a
e)
  | Just ([v]
vs0, Maybe (Type v a)
_, [v]
vs1, Term v a
bd) <- Term v a -> Maybe ([v], Maybe (Type v a), [v], Term v a)
forall v a.
Term v a -> Maybe ([v], Maybe (Type v a), [v], Term v a)
unLamsAnnot Term v a
b =
      FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a))
forall a. a -> Maybe a
Just (FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a)))
-> FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a))
forall a b. (a -> b) -> a -> b
$
        Term v a -> FloatM v a (Term v a)
rec Term v a
bd
          FloatM v a (Term v a)
-> (Term v a
    -> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity v)
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity v
forall a b.
StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity a
-> (a
    -> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity b)
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool
-> Term v a
-> Maybe v
-> a
-> [v]
-> Term v a
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity v
forall v a.
(Var v, Monoid a) =>
Bool -> Term v a -> Maybe v -> a -> [v] -> Term v a -> FloatM v a v
lamFloater Bool
True Term v a
b (v -> Maybe v
forall a. a -> Maybe a
Just v
v) a
a ([v]
vs0 [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
vs1)
          StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity v
-> (v -> FloatM v a (Term v a)) -> FloatM v a (Term v a)
forall a b.
StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity a
-> (a
    -> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity b)
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \v
lv -> Term v a -> FloatM v a (Term v a)
rec (Term v a -> FloatM v a (Term v a))
-> Term v a -> FloatM v a (Term v a)
forall a b. (a -> b) -> a -> b
$ Map v v -> Term v a -> Term v a
forall (f :: * -> *) v a.
(Foldable f, Functor f, Var v) =>
Map v v -> Term f v a -> Term f v a
ABT.renames (v -> v -> Map v v
forall k a. k -> a -> Map k a
Map.singleton v
v v
lv) Term v a
e
  where
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
b
floater Bool
top Term v a -> FloatM v a (Term v a)
rec tm :: Term v a
tm@(LamsNamed' [v]
vs Term v a
bd)
  | Bool
top = FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a))
forall a. a -> Maybe a
Just (FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a)))
-> FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a))
forall a b. (a -> b) -> a -> b
$ a -> [v] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
a [v]
vs (Term v a -> Term v a)
-> FloatM v a (Term v a) -> FloatM v a (Term v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> FloatM v a (Term v a)
rec Term v a
bd
  | Bool
otherwise = FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a))
forall a. a -> Maybe a
Just (FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a)))
-> FloatM v a (Term v a) -> Maybe (FloatM v a (Term v a))
forall a b. (a -> b) -> a -> b
$ do
      Term v a
bd <- Term v a -> FloatM v a (Term v a)
rec Term v a
bd
      v
lv <- Bool
-> Term v a
-> Maybe v
-> a
-> [v]
-> Term v a
-> StateT (Set v, [(v, Term v a)], [(v, Term v a)]) Identity v
forall v a.
(Var v, Monoid a) =>
Bool -> Term v a -> Maybe v -> a -> [v] -> Term v a -> FloatM v a v
lamFloater Bool
True Term v a
tm Maybe v
forall a. Maybe a
Nothing a
a [v]
vs Term v a
bd
      pure $ a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
a v
lv
  where
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
tm
floater Bool
_ Term v a -> FloatM v a (Term v a)
_ Term v a
_ = Maybe (FloatM v a (Term v a))
forall a. Maybe a
Nothing

postFloat ::
  (Var v) =>
  (Monoid a) =>
  Map v Reference ->
  (Set v, [(v, Term v a)], [(v, Term v a)]) ->
  ( [(v, Term v a)],
    [(v, Id)],
    [(Reference, Term v a)],
    [(Reference, Term v a)]
  )
postFloat :: forall v a.
(Var v, Monoid a) =>
Map v Reference
-> (Set v, [(v, Term v a)], [(v, Term v a)])
-> ([(v, Term v a)], [(v, Id)], [(Reference, Term v a)],
    [(Reference, Term v a)])
postFloat Map v Reference
orig (Set v
_, [(v, Term2 v a a v a)]
bs, [(v, Term2 v a a v a)]
dcmp) =
  ( [(v, Term2 v a a v a)]
subs,
    [(v, Id)]
subvs,
    ((Id, Term2 v a a v a) -> (Reference, Term2 v a a v a))
-> [(Id, Term2 v a a v a)] -> [(Reference, Term2 v a a v a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Id -> Reference)
-> (Id, Term2 v a a v a) -> (Reference, Term2 v a a v a)
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 Id -> Reference
forall h t. Id' h -> Reference' t h
DerivedId) [(Id, Term2 v a a v a)]
tops,
    [(v, Term2 v a a v a)]
dcmp [(v, Term2 v a a v a)]
-> ((v, Term2 v a a v a) -> [(Reference, Term2 v a a v a)])
-> [(Reference, Term2 v a a v a)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(v
v, Term2 v a a v a
tm) ->
      let stm :: Term2 v a a v a
stm = Term2 v a a v a -> Term2 v a a v a
forall v a. (Var v, Monoid a) => Term v a -> Term v a
open (Term2 v a a v a -> Term2 v a a v a)
-> Term2 v a a v a -> Term2 v a a v a
forall a b. (a -> b) -> a -> b
$ [(v, Term2 v a a v a)] -> Term2 v a a v a -> Term2 v a a 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
ABT.substs [(v, Term2 v a a v a)]
dsubs Term2 v a a v a
tm
       in (Map v Reference
subm Map v Reference -> v -> Reference
forall k a. Ord k => Map k a -> k -> a
Map.! v
v, Term2 v a a v a
stm) (Reference, Term2 v a a v a)
-> [(Reference, Term2 v a a v a)] -> [(Reference, Term2 v a a v a)]
forall a. a -> [a] -> [a]
: [(Reference
r, Term2 v a a v a
stm) | Just Reference
r <- [v -> Map v Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v Reference
orig]]
  )
  where
    m :: Map v (Id, Term2 v a a v a)
m =
      ((Id, Term2 v a a v a) -> (Id, Term2 v a a v a))
-> Map v (Id, Term2 v a a v a) -> Map v (Id, Term2 v a a v a)
forall a b. (a -> b) -> Map v a -> Map v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Term2 v a a v a -> Term2 v a a v a)
-> (Id, Term2 v a a v a) -> (Id, Term2 v a a v a)
forall a b. (a -> b) -> (Id, a) -> (Id, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term2 v a a v a -> Term2 v a a v a
forall v a. Var v => Term v a -> Term v a
deannotate)
        (Map v (Id, Term2 v a a v a) -> Map v (Id, Term2 v a a v a))
-> ([(v, Term2 v a a v a)] -> Map v (Id, Term2 v a a v a))
-> [(v, Term2 v a a v a)]
-> Map v (Id, Term2 v a a v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map v (Term2 v a a v a) -> Map v (Id, Term2 v a a v a)
forall v a. Var v => Map v (Term v a) -> Map v (Id, Term v a)
hashTermComponentsWithoutTypes
        (Map v (Term2 v a a v a) -> Map v (Id, Term2 v a a v a))
-> ([(v, Term2 v a a v a)] -> Map v (Term2 v a a v a))
-> [(v, Term2 v a a v a)]
-> Map v (Id, Term2 v a a v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(v, Term2 v a a v a)] -> Map v (Term2 v a a v a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        ([(v, Term2 v a a v a)] -> Map v (Id, Term2 v a a v a))
-> [(v, Term2 v a a v a)] -> Map v (Id, Term2 v a a v a)
forall a b. (a -> b) -> a -> b
$ [(v, Term2 v a a v a)]
bs
    trips :: [(v, (Id, Term2 v a a v a))]
trips = Map v (Id, Term2 v a a v a) -> [(v, (Id, Term2 v a a v a))]
forall k a. Map k a -> [(k, a)]
Map.toList Map v (Id, Term2 v a a v a)
m
    f :: (a, (Id, Term f v a))
-> ((a, Id), (a, Term2 vt at ap v a), (Id, Term f v a))
f (a
v, (Id
id, Term f v a
tm)) = ((a
v, Id
id), (a
v, Term2 vt at ap v a
idtm), (Id
id, Term f v a
tm))
      where
        idtm :: Term2 vt at ap v a
idtm = a -> Reference -> Term2 vt at ap v a
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
ref (Term f v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term f v a
tm) (Id -> Reference
forall h t. Id' h -> Reference' t h
DerivedId Id
id)
    ([(v, Id)]
subvs, [(v, Term2 v a a v a)]
subs, [(Id, Term2 v a a v a)]
tops) = [((v, Id), (v, Term2 v a a v a), (Id, Term2 v a a v a))]
-> ([(v, Id)], [(v, Term2 v a a v a)], [(Id, Term2 v a a v a)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([((v, Id), (v, Term2 v a a v a), (Id, Term2 v a a v a))]
 -> ([(v, Id)], [(v, Term2 v a a v a)], [(Id, Term2 v a a v a)]))
-> [((v, Id), (v, Term2 v a a v a), (Id, Term2 v a a v a))]
-> ([(v, Id)], [(v, Term2 v a a v a)], [(Id, Term2 v a a v a)])
forall a b. (a -> b) -> a -> b
$ ((v, (Id, Term2 v a a v a))
 -> ((v, Id), (v, Term2 v a a v a), (Id, Term2 v a a v a)))
-> [(v, (Id, Term2 v a a v a))]
-> [((v, Id), (v, Term2 v a a v a), (Id, Term2 v a a v a))]
forall a b. (a -> b) -> [a] -> [b]
map (v, (Id, Term2 v a a v a))
-> ((v, Id), (v, Term2 v a a v a), (Id, Term2 v a a v a))
forall {v} {a} {f :: * -> *} {v} {a} {vt} {at} {ap}.
Ord v =>
(a, (Id, Term f v a))
-> ((a, Id), (a, Term2 vt at ap v a), (Id, Term f v a))
f [(v, (Id, Term2 v a a v a))]
trips
    subm :: Map v Reference
subm = (Id -> Reference) -> Map v Id -> Map v Reference
forall a b. (a -> b) -> Map v a -> Map v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> Reference
forall h t. Id' h -> Reference' t h
DerivedId ([(v, Id)] -> Map v Id
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(v, Id)]
subvs)
    dsubs :: [(v, Term2 v a a v a)]
dsubs = Map v (Term2 v a a v a) -> [(v, Term2 v a a v a)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map v (Term2 v a a v a) -> [(v, Term2 v a a v a)])
-> Map v (Term2 v a a v a) -> [(v, Term2 v a a v a)]
forall a b. (a -> b) -> a -> b
$ (Reference -> Term2 v a a v a)
-> Map v Reference -> Map v (Term2 v a a v a)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (a -> Reference -> Term2 v a a v a
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
ref a
forall a. Monoid a => a
mempty) Map v Reference
orig Map v (Term2 v a a v a)
-> Map v (Term2 v a a v a) -> Map v (Term2 v a a v a)
forall a. Semigroup a => a -> a -> a
<> [(v, Term2 v a a v a)] -> Map v (Term2 v a a v a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(v, Term2 v a a v a)]
subs

float ::
  (Var v) =>
  (Monoid a) =>
  Map v Reference ->
  Term v a ->
  (Term v a, Map Reference Reference, [(Reference, Term v a)], [(Reference, Term v a)])
float :: 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)])
float Map v Reference
orig Term v a
tm = case State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
-> (Set v, [(v, Term v a)], [(v, Term v a)])
-> (Term v a, (Set v, [(v, Term v a)], [(v, Term v a)]))
forall s a. State s a -> s -> (a, s)
runState State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
go0 (Set v
forall a. Set a
Set.empty, [], []) of
  (Term v a
bd, (Set v, [(v, Term v a)], [(v, Term v a)])
st) -> case Map v Reference
-> (Set v, [(v, Term v a)], [(v, Term v a)])
-> ([(v, Term v a)], [(v, Id)], [(Reference, Term v a)],
    [(Reference, Term v a)])
forall v a.
(Var v, Monoid a) =>
Map v Reference
-> (Set v, [(v, Term v a)], [(v, Term v a)])
-> ([(v, Term v a)], [(v, Id)], [(Reference, Term v a)],
    [(Reference, Term v a)])
postFloat Map v Reference
orig (Set v, [(v, Term v a)], [(v, Term v a)])
st of
    ([(v, Term v a)]
subs, [(v, Id)]
subvs, [(Reference, Term v a)]
tops, [(Reference, Term v a)]
dcmp) ->
      ( Bool -> [(v, a, Term v a)] -> Term v a -> Term v a
forall v a vt.
(Ord v, Monoid a) =>
Bool -> [(v, a, Term' vt v a)] -> Term' vt v a -> Term' vt v a
letRec' Bool
True [] (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(v, Term v a)] -> Term v a -> Term 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
ABT.substs [(v, Term v a)]
subs (Term v a -> Term v a)
-> (Term v a -> Term v a) -> Term v a -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v a -> Term v a
forall v a. Var v => Term v a -> Term v a
deannotate (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$ Term v a
bd,
        [(Reference, Reference)] -> Map Reference Reference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Reference, Reference)] -> Map Reference Reference)
-> ([(v, Id)] -> [(Reference, Reference)])
-> [(v, Id)]
-> Map Reference Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, Id) -> Maybe (Reference, Reference))
-> [(v, Id)] -> [(Reference, Reference)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (v, Id) -> Maybe (Reference, Reference)
f ([(v, Id)] -> Map Reference Reference)
-> [(v, Id)] -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ [(v, Id)]
subvs,
        [(Reference, Term v a)]
tops,
        [(Reference, Term v a)]
dcmp
      )
  where
    f :: (v, Id) -> Maybe (Reference, Reference)
f (v
v, Id
i) = (,Id -> Reference
forall h t. Id' h -> Reference' t h
DerivedId Id
i) (Reference -> (Reference, Reference))
-> Maybe Reference -> Maybe (Reference, Reference)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> Map v Reference -> Maybe Reference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v Reference
orig
    go0 :: State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
go0 = State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
-> Maybe
     (State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a))
-> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
forall a. a -> Maybe a -> a
fromMaybe (Term v a
-> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
go Term v a
tm) (Bool
-> (Term v a
    -> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a))
-> Term v a
-> Maybe
     (State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a))
forall v a.
(Var v, Monoid a) =>
Bool
-> (Term v a -> FloatM v a (Term v a))
-> Term v a
-> Maybe (FloatM v a (Term v a))
floater Bool
True Term v a
-> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
go Term v a
tm)
    go :: Term v a
-> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
go = (Term v a
 -> Maybe
      (State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)))
-> Term v a
-> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
forall (f :: * -> *) (g :: * -> *) v a.
(Traversable f, Applicative g, Ord v) =>
(Term f v a -> Maybe (g (Term f v a)))
-> Term f v a -> g (Term f v a)
ABT.visit ((Term v a
  -> Maybe
       (State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)))
 -> Term v a
 -> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a))
-> (Term v a
    -> Maybe
         (State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)))
-> Term v a
-> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
forall a b. (a -> b) -> a -> b
$ Bool
-> (Term v a
    -> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a))
-> Term v a
-> Maybe
     (State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a))
forall v a.
(Var v, Monoid a) =>
Bool
-> (Term v a -> FloatM v a (Term v a))
-> Term v a
-> Maybe (FloatM v a (Term v a))
floater Bool
False Term v a
-> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Term v a)
go

floatGroup ::
  (Var v) =>
  (Monoid a) =>
  Map v Reference ->
  [(v, Term v a)] ->
  ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)])
floatGroup :: forall v a.
(Var v, Monoid a) =>
Map v Reference
-> [(v, Term v a)]
-> ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)])
floatGroup Map v Reference
orig [(v, Term v a)]
grp = case State (Set v, [(v, Term v a)], [(v, Term v a)]) (Map v v)
-> (Set v, [(v, Term v a)], [(v, Term v a)])
-> (Map v v, (Set v, [(v, Term v a)], [(v, Term v a)]))
forall s a. State s a -> s -> (a, s)
runState State (Set v, [(v, Term v a)], [(v, Term v a)]) (Map v v)
go0 (Set v
forall a. Set a
Set.empty, [], []) of
  (Map v v
_, (Set v, [(v, Term v a)], [(v, Term v a)])
st) -> case Map v Reference
-> (Set v, [(v, Term v a)], [(v, Term v a)])
-> ([(v, Term v a)], [(v, Id)], [(Reference, Term v a)],
    [(Reference, Term v a)])
forall v a.
(Var v, Monoid a) =>
Map v Reference
-> (Set v, [(v, Term v a)], [(v, Term v a)])
-> ([(v, Term v a)], [(v, Id)], [(Reference, Term v a)],
    [(Reference, Term v a)])
postFloat Map v Reference
orig (Set v, [(v, Term v a)], [(v, Term v a)])
st of
    ([(v, Term v a)]
_, [(v, Id)]
subvs, [(Reference, Term v a)]
tops, [(Reference, Term v a)]
dcmp) -> ([(v, Id)]
subvs, [(Reference, Term v a)]
tops, [(Reference, Term v a)]
dcmp)
  where
    go :: Term v a
-> StateT
     (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a)
go = (Term v a
 -> Maybe
      (StateT
         (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a)))
-> Term v a
-> StateT
     (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a)
forall (f :: * -> *) (g :: * -> *) v a.
(Traversable f, Applicative g, Ord v) =>
(Term f v a -> Maybe (g (Term f v a)))
-> Term f v a -> g (Term f v a)
ABT.visit ((Term v a
  -> Maybe
       (StateT
          (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a)))
 -> Term v a
 -> StateT
      (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a))
-> (Term v a
    -> Maybe
         (StateT
            (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a)))
-> Term v a
-> StateT
     (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a)
forall a b. (a -> b) -> a -> b
$ Bool
-> (Term v a
    -> StateT
         (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a))
-> Term v a
-> Maybe
     (StateT
        (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a))
forall v a.
(Var v, Monoid a) =>
Bool
-> (Term v a -> FloatM v a (Term v a))
-> Term v a
-> Maybe (FloatM v a (Term v a))
floater Bool
False Term v a
-> StateT
     (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a)
go
    go0 :: State (Set v, [(v, Term v a)], [(v, Term v a)]) (Map v v)
go0 = (Term v a
 -> StateT
      (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a))
-> [(v, Term v a)]
-> State (Set v, [(v, Term v a)], [(v, Term v a)]) (Map v v)
forall v a.
(Var v, Monoid a) =>
(Term v a -> FloatM v a (Term v a))
-> [(v, Term v a)] -> FloatM v a (Map v v)
groupFloater Term v a
-> StateT
     (Set v, [(v, Term v a)], [(v, Term v a)]) Identity (Term v a)
go [(v, Term v a)]
grp

unAnn :: Term v a -> Term v a
unAnn :: forall v a. Term v a -> Term v a
unAnn (Ann' Term (F v a a) v a
tm Type v a
_) = Term (F v a a) v a
tm
unAnn Term (F v a a) v a
tm = Term (F v a a) v a
tm

unLamsAnnot :: Term v a -> Maybe ([v], Maybe (Ty.Type v a), [v], Term v a)
unLamsAnnot :: forall v a.
Term v a -> Maybe ([v], Maybe (Type v a), [v], Term v a)
unLamsAnnot Term v a
tm0
  | [v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
vs0, [v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
vs1 = Maybe ([v], Maybe (Type v a), [v], Term v a)
forall a. Maybe a
Nothing
  | Bool
otherwise = ([v], Maybe (Type v a), [v], Term v a)
-> Maybe ([v], Maybe (Type v a), [v], Term v a)
forall a. a -> Maybe a
Just ([v]
vs0, Maybe (Type v a)
mty, [v]
vs1, Term v a
bd)
  where
    ([v]
vs0, Term v a
bd0)
      | LamsNamed' [v]
vs Term v a
bd <- Term v a
tm0 = ([v]
vs, Term v a
bd)
      | Bool
otherwise = ([], Term v a
tm0)
    (Maybe (Type v a)
mty, Term v a
bd1)
      | Ann' Term v a
bd Type v a
ty <- Term v a
bd0 = (Type v a -> Maybe (Type v a)
forall a. a -> Maybe a
Just Type v a
ty, Term v a
bd)
      | Bool
otherwise = (Maybe (Type v a)
forall a. Maybe a
Nothing, Term v a
bd0)
    ([v]
vs1, Term v a
bd)
      | LamsNamed' [v]
vs Term v a
bd <- Term v a
bd1 = ([v]
vs, Term v a
bd)
      | Bool
otherwise = ([], Term v a
bd1)

deannotate :: (Var v) => Term v a -> Term v a
deannotate :: forall v a. Var v => Term v a -> Term v a
deannotate = (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a -> Term (F v a a) v a
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure ((Term (F v a a) v a -> Maybe (Term (F v a a) v a))
 -> Term (F v a a) v a -> Term (F v a a) v a)
-> (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a
-> Term (F v a a) v a
forall a b. (a -> b) -> a -> b
$ \case
  Ann' Term (F v a a) v a
c Type v a
_ -> Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a. a -> Maybe a
Just (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a b. (a -> b) -> a -> b
$ Term (F v a a) v a -> Term (F v a a) v a
forall v a. Var v => Term v a -> Term v a
deannotate Term (F v a a) v a
c
  Term (F v a a) v a
_ -> Maybe (Term (F v a a) v a)
forall a. Maybe a
Nothing

lamLift ::
  (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 :: 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 v Reference
orig = Map v Reference
-> Term v a
-> (Term v a, Map Reference Reference, [(Reference, Term v a)],
    [(Reference, Term v a)])
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)])
float Map v Reference
orig (Term v a
 -> (Term v a, Map Reference Reference, [(Reference, Term v a)],
     [(Reference, Term v a)]))
-> (Term v a -> Term v a)
-> Term v a
-> (Term v a, Map Reference Reference, [(Reference, Term v a)],
    [(Reference, Term v a)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set v -> Term v a -> Term v a
forall v a. (Var v, Monoid a) => Set v -> Term v a -> Term v a
close Set v
forall a. Set a
Set.empty

lamLiftGroup ::
  (Var v) =>
  (Monoid a) =>
  Map v Reference ->
  [(v, Term v a)] ->
  ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)])
lamLiftGroup :: 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 v Reference
orig [(v, Term v a)]
gr = Map v Reference
-> [(v, Term v a)]
-> ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)])
forall v a.
(Var v, Monoid a) =>
Map v Reference
-> [(v, Term v a)]
-> ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)])
floatGroup Map v Reference
orig ([(v, Term v a)]
 -> ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)]))
-> ([(v, Term v a)] -> [(v, Term v a)])
-> [(v, Term v a)]
-> ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((v, Term v a) -> (v, Term v a))
-> [(v, Term v a)] -> [(v, Term v a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((v, Term v a) -> (v, Term v a))
 -> [(v, Term v a)] -> [(v, Term v a)])
-> ((Term v a -> Term v a) -> (v, Term v a) -> (v, Term v a))
-> (Term v a -> Term v a)
-> [(v, Term v a)]
-> [(v, Term v a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term v a -> Term v a) -> (v, Term v a) -> (v, Term v a)
forall a b. (a -> b) -> (v, a) -> (v, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Set v -> Term v a -> Term v a
forall v a. (Var v, Monoid a) => Set v -> Term v a -> Term v a
close Set v
keep) ([(v, Term v a)]
 -> ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)]))
-> [(v, Term v a)]
-> ([(v, Id)], [(Reference, Term v a)], [(Reference, Term v a)])
forall a b. (a -> b) -> a -> b
$ [(v, Term v a)]
gr
  where
    keep :: Set v
keep = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v) -> [v] -> Set v
forall a b. (a -> b) -> a -> b
$ ((v, Term v a) -> v) -> [(v, Term v a)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, Term v a) -> v
forall a b. (a, b) -> a
fst [(v, Term v a)]
gr

saturate ::
  (Var v, Monoid a) =>
  Map ConstructorReference Int ->
  Term v a ->
  Term v a
saturate :: forall v a.
(Var v, Monoid a) =>
Map ConstructorReference Int -> Term v a -> Term v a
saturate Map ConstructorReference Int
dat = (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a -> Term (F v a a) v a
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure ((Term (F v a a) v a -> Maybe (Term (F v a a) v a))
 -> Term (F v a a) v a -> Term (F v a a) v a)
-> (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a
-> Term (F v a a) v a
forall a b. (a -> b) -> a -> b
$ \case
  Apps' f :: Term (F v a a) v a
f@(Constructor' ConstructorReference
r) [Term (F v a a) v a]
args -> ConstructorReference
-> Term (F v a a) v a
-> [Term (F v a a) v a]
-> Maybe (Term (F v a a) v a)
sat ConstructorReference
r Term (F v a a) v a
f [Term (F v a a) v a]
args
  Apps' f :: Term (F v a a) v a
f@(Request' ConstructorReference
r) [Term (F v a a) v a]
args -> ConstructorReference
-> Term (F v a a) v a
-> [Term (F v a a) v a]
-> Maybe (Term (F v a a) v a)
sat ConstructorReference
r Term (F v a a) v a
f [Term (F v a a) v a]
args
  f :: Term (F v a a) v a
f@(Constructor' ConstructorReference
r) -> ConstructorReference
-> Term (F v a a) v a
-> [Term (F v a a) v a]
-> Maybe (Term (F v a a) v a)
sat ConstructorReference
r Term (F v a a) v a
f []
  f :: Term (F v a a) v a
f@(Request' ConstructorReference
r) -> ConstructorReference
-> Term (F v a a) v a
-> [Term (F v a a) v a]
-> Maybe (Term (F v a a) v a)
sat ConstructorReference
r Term (F v a a) v a
f []
  Term (F v a a) v a
_ -> Maybe (Term (F v a a) v a)
forall a. Maybe a
Nothing
  where
    frsh :: Set b -> p -> (Set b, b)
frsh Set b
avoid p
_ =
      let v :: b
v = Set b -> b -> b
forall v. Var v => Set v -> v -> v
Var.freshIn Set b
avoid (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ Type -> b
forall v. Var v => Type -> v
typed Type
Var.Eta
       in (b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.insert b
v Set b
avoid, b
v)
    sat :: ConstructorReference
-> Term (F v a a) v a
-> [Term (F v a a) v a]
-> Maybe (Term (F v a a) v a)
sat ConstructorReference
r Term (F v a a) v a
f [Term (F v a a) v a]
args = case ConstructorReference -> Map ConstructorReference Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConstructorReference
r Map ConstructorReference Int
dat of
      Just Int
n
        | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n,
          [v]
vs <- (Set v, [v]) -> [v]
forall a b. (a, b) -> b
snd ((Set v, [v]) -> [v]) -> (Set v, [v]) -> [v]
forall a b. (a -> b) -> a -> b
$ (Set v -> Int -> (Set v, v)) -> Set v -> [Int] -> (Set v, [v])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Set v -> Int -> (Set v, v)
forall {b} {p}. Var b => Set b -> p -> (Set b, b)
frsh Set v
fvs [Int
1 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m],
          [Term (F v a a) v a]
nargs <- a -> v -> Term (F v a a) v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
forall a. Monoid a => a
mempty (v -> Term (F v a a) v a) -> [v] -> [Term (F v a a) v a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
vs ->
            Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a. a -> Maybe a
Just (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> ([Term (F v a a) v a] -> Term (F v a a) v a)
-> [Term (F v a a) v a]
-> Maybe (Term (F v a a) v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [v] -> Term (F v a a) v a -> Term (F v a a) v a
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns a
forall a. Monoid a => a
mempty [v]
vs (Term (F v a a) v a -> Term (F v a a) v a)
-> ([Term (F v a a) v a] -> Term (F v a a) v a)
-> [Term (F v a a) v a]
-> Term (F v a a) v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term (F v a a) v a -> [Term (F v a a) v a] -> Term (F v a a) 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' Term (F v a a) v a
f ([Term (F v a a) v a] -> Maybe (Term (F v a a) v a))
-> [Term (F v a a) v a] -> Maybe (Term (F v a a) v a)
forall a b. (a -> b) -> a -> b
$ [Term (F v a a) v a]
args' [Term (F v a a) v a]
-> [Term (F v a a) v a] -> [Term (F v a a) v a]
forall a. [a] -> [a] -> [a]
++ [Term (F v a a) v a]
nargs
        | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n,
          ([Term (F v a a) v a]
sargs, [Term (F v a a) v a]
eargs) <- Int
-> [Term (F v a a) v a]
-> ([Term (F v a a) v a], [Term (F v a a) v a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [Term (F v a a) v a]
args',
          v
sv <- Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn Set v
fvs (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ Type -> v
forall v. Var v => Type -> v
typed Type
Var.Eta ->
            Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a. a -> Maybe a
Just
              (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> (Term (F v a a) v a -> Term (F v a a) v a)
-> Term (F v a a) v a
-> Maybe (Term (F v a a) v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [(v, Term (F v a a) v a)]
-> Term (F v a a) v a
-> Term (F v a a) v a
forall a v vt at ap.
(Semigroup a, Ord v) =>
Bool
-> [(v, Term2 vt at ap v a)]
-> Term2 vt at ap v a
-> Term2 vt at ap v a
let1' Bool
False [(v
sv, Term (F v a a) v a -> [Term (F v a a) v a] -> Term (F v a a) 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' Term (F v a a) v a
f [Term (F v a a) v a]
sargs)]
              (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a b. (a -> b) -> a -> b
$ Term (F v a a) v a -> [Term (F v a a) v a] -> Term (F v a a) 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' (a -> v -> Term (F v a a) v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
forall a. Monoid a => a
mempty v
sv) [Term (F v a a) v a]
eargs
      Maybe Int
_ -> Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a. a -> Maybe a
Just (Term (F v a a) v a -> [Term (F v a a) v a] -> Term (F v a a) 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' Term (F v a a) v a
f [Term (F v a a) v a]
args')
      where
        m :: Int
m = [Term (F v a a) v a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term (F v a a) v a]
args
        fvs :: Set v
fvs = (Term (F v a a) v a -> Set v) -> [Term (F v a a) v a] -> Set v
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Term (F v a a) v a -> Set v
forall vt v a. Term' vt v a -> Set v
freeVars [Term (F v a a) v a]
args
        args' :: [Term (F v a a) v a]
args' = Map ConstructorReference Int
-> Term (F v a a) v a -> Term (F v a a) v a
forall v a.
(Var v, Monoid a) =>
Map ConstructorReference Int -> Term v a -> Term v a
saturate Map ConstructorReference Int
dat (Term (F v a a) v a -> Term (F v a a) v a)
-> [Term (F v a a) v a] -> [Term (F v a a) v a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term (F v a a) v a]
args

addDefaultCases :: (Var v) => (Monoid a) => Text -> Term v a -> Term v a
addDefaultCases :: forall v a. (Var v, Monoid a) => Text -> Term v a -> Term v a
addDefaultCases = (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a -> Term (F v a a) v a
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure ((Term (F v a a) v a -> Maybe (Term (F v a a) v a))
 -> Term (F v a a) v a -> Term (F v a a) v a)
-> (Text -> Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Text
-> Term (F v a a) v a
-> Term (F v a a) v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall v a.
(Var v, Monoid a) =>
Text -> Term v a -> Maybe (Term v a)
defaultCaseVisitor

defaultCaseVisitor ::
  (Var v) => (Monoid a) => Text -> Term v a -> Maybe (Term v a)
defaultCaseVisitor :: forall v a.
(Var v, Monoid a) =>
Text -> Term v a -> Maybe (Term v a)
defaultCaseVisitor Text
func m :: Term v a
m@(Match' Term v a
scrut [MatchCase a (Term v a)]
cases)
  | Term v a
scrut <- Text -> Term v a -> Term v a
forall v a. (Var v, Monoid a) => Text -> Term v a -> Term v a
addDefaultCases Text
func Term v a
scrut,
    [MatchCase a (Term v a)]
cases <- (Term v a -> Term v a)
-> MatchCase a (Term v a) -> MatchCase a (Term v a)
forall a b. (a -> b) -> MatchCase a a -> MatchCase a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Term v a -> Term v a
forall v a. (Var v, Monoid a) => Text -> Term v a -> Term v a
addDefaultCases Text
func) (MatchCase a (Term v a) -> MatchCase a (Term v a))
-> [MatchCase a (Term v a)] -> [MatchCase a (Term v a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MatchCase a (Term v a)]
cases =
      Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ a -> Term v a -> [MatchCase a (Term v a)] -> Term v a
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
match a
a Term v a
scrut ([MatchCase a (Term v a)]
cases [MatchCase a (Term v a)]
-> [MatchCase a (Term v a)] -> [MatchCase a (Term v a)]
forall a. [a] -> [a] -> [a]
++ [MatchCase a (Term v a)
dflt])
  where
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
m
    v :: v
v = Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn Set v
forall a. Monoid a => a
mempty (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ Type -> v
forall v. Var v => Type -> v
typed Type
Var.Blank
    txt :: Text
txt = Text
"pattern match failure in function `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
func Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
    msg :: Term v a
msg = a -> Text -> Term v a
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
text a
a Text
txt
    bu :: Term v a
bu = a -> Reference -> Term v a
forall v a vt at ap. Ord v => a -> Reference -> Term2 vt at ap v a
ref a
a (Text -> Reference
forall t h. t -> Reference' t h
Builtin Text
"bug")
    dflt :: MatchCase a (Term v a)
dflt =
      Pattern a -> Maybe (Term v a) -> Term v a -> MatchCase a (Term v a)
forall loc a. Pattern loc -> Maybe a -> a -> MatchCase loc a
MatchCase (a -> Pattern a
forall loc. loc -> Pattern loc
P.Var a
a) Maybe (Term v a)
forall a. Maybe a
Nothing
        (Term v a -> MatchCase a (Term v a))
-> (Term v a -> Term v a) -> Term v a -> MatchCase a (Term v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> v -> Term v a -> Term v a
forall v a (f :: * -> *).
Ord v =>
a -> v -> Term f v a -> Term f v a
ABT.abs' a
a v
v
        (Term v a -> MatchCase a (Term v a))
-> Term v a -> MatchCase a (Term v a)
forall a b. (a -> b) -> a -> b
$ Term v a -> [(a, Term v a)] -> Term v a
forall v vt at ap a.
Ord v =>
Term2 vt at ap v a
-> [(a, Term2 vt at ap v a)] -> Term2 vt at ap v a
apps Term v a
bu [(a
a, [Term v a] -> Term v a
forall v a vt at ap.
(Var v, Monoid a) =>
[Term2 vt at ap v a] -> Term2 vt at ap v a
Ty.tupleTerm [Term v a
msg, a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var a
a v
v])]
defaultCaseVisitor Text
_ Term v a
_ = Maybe (Term v a)
forall a. Maybe a
Nothing

inlineAlias :: (Var v) => (Monoid a) => Term v a -> Term v a
inlineAlias :: forall v a. (Var v, Monoid a) => Term v a -> Term v a
inlineAlias = (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a -> Term (F v a a) v a
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure ((Term (F v a a) v a -> Maybe (Term (F v a a) v a))
 -> Term (F v a a) v a -> Term (F v a a) v a)
-> (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a
-> Term (F v a a) v a
forall a b. (a -> b) -> a -> b
$ \case
  Let1Named' v
v b :: Term (F v a a) v a
b@(Var' v
_) Term (F v a a) v a
e -> Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a. a -> Maybe a
Just (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> (Term (F v a a) v a -> Term (F v a a) v a)
-> Term (F v a a) v a
-> Maybe (Term (F v a a) v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term (F v a a) v a -> Term (F v a a) v a
forall v a. (Var v, Monoid a) => Term v a -> Term v a
inlineAlias (Term (F v a a) v a -> Maybe (Term (F v a a) v a))
-> Term (F v a a) v a -> Maybe (Term (F v a a) v a)
forall a b. (a -> b) -> a -> b
$ v -> Term (F v a a) v a -> Term (F v a a) v a -> Term (F v a a) 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
ABT.subst v
v Term (F v a a) v a
b Term (F v a a) v a
e
  Term (F v a a) v a
_ -> Maybe (Term (F v a a) v a)
forall a. Maybe a
Nothing

minimizeCyclesOrCrash :: (Var v) => Term v a -> Term v a
minimizeCyclesOrCrash :: forall v a. Var v => Term v a -> Term v a
minimizeCyclesOrCrash Term v a
t = case Term v a -> Either (NonEmpty (v, [a])) (Term v a)
forall v vt a.
Var v =>
Term' vt v a -> Either (NonEmpty (v, [a])) (Term' vt v a)
minimize' Term v a
t of
  Right Term v a
t -> Term v a
t
  Left NonEmpty (v, [a])
e ->
    String -> Term v a
forall a. HasCallStack => String -> a
internalBug (String -> Term v a) -> String -> Term v a
forall a b. (a -> b) -> a -> b
$
      String
"tried to minimize let rec with duplicate definitions: "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ [v] -> String
forall a. Show a => a -> String
show ((v, [a]) -> v
forall a b. (a, b) -> a
fst ((v, [a]) -> v) -> [(v, [a])] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (v, [a]) -> [(v, [a])]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (v, [a])
e)

data Mem = UN | BX deriving (Mem -> Mem -> Bool
(Mem -> Mem -> Bool) -> (Mem -> Mem -> Bool) -> Eq Mem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mem -> Mem -> Bool
== :: Mem -> Mem -> Bool
$c/= :: Mem -> Mem -> Bool
/= :: Mem -> Mem -> Bool
Eq, Eq Mem
Eq Mem =>
(Mem -> Mem -> Ordering)
-> (Mem -> Mem -> Bool)
-> (Mem -> Mem -> Bool)
-> (Mem -> Mem -> Bool)
-> (Mem -> Mem -> Bool)
-> (Mem -> Mem -> Mem)
-> (Mem -> Mem -> Mem)
-> Ord Mem
Mem -> Mem -> Bool
Mem -> Mem -> Ordering
Mem -> Mem -> Mem
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 :: Mem -> Mem -> Ordering
compare :: Mem -> Mem -> Ordering
$c< :: Mem -> Mem -> Bool
< :: Mem -> Mem -> Bool
$c<= :: Mem -> Mem -> Bool
<= :: Mem -> Mem -> Bool
$c> :: Mem -> Mem -> Bool
> :: Mem -> Mem -> Bool
$c>= :: Mem -> Mem -> Bool
>= :: Mem -> Mem -> Bool
$cmax :: Mem -> Mem -> Mem
max :: Mem -> Mem -> Mem
$cmin :: Mem -> Mem -> Mem
min :: Mem -> Mem -> Mem
Ord, Int -> Mem -> ShowS
[Mem] -> ShowS
Mem -> String
(Int -> Mem -> ShowS)
-> (Mem -> String) -> ([Mem] -> ShowS) -> Show Mem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mem -> ShowS
showsPrec :: Int -> Mem -> ShowS
$cshow :: Mem -> String
show :: Mem -> String
$cshowList :: [Mem] -> ShowS
showList :: [Mem] -> ShowS
Show, Int -> Mem
Mem -> Int
Mem -> [Mem]
Mem -> Mem
Mem -> Mem -> [Mem]
Mem -> Mem -> Mem -> [Mem]
(Mem -> Mem)
-> (Mem -> Mem)
-> (Int -> Mem)
-> (Mem -> Int)
-> (Mem -> [Mem])
-> (Mem -> Mem -> [Mem])
-> (Mem -> Mem -> [Mem])
-> (Mem -> Mem -> Mem -> [Mem])
-> Enum Mem
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Mem -> Mem
succ :: Mem -> Mem
$cpred :: Mem -> Mem
pred :: Mem -> Mem
$ctoEnum :: Int -> Mem
toEnum :: Int -> Mem
$cfromEnum :: Mem -> Int
fromEnum :: Mem -> Int
$cenumFrom :: Mem -> [Mem]
enumFrom :: Mem -> [Mem]
$cenumFromThen :: Mem -> Mem -> [Mem]
enumFromThen :: Mem -> Mem -> [Mem]
$cenumFromTo :: Mem -> Mem -> [Mem]
enumFromTo :: Mem -> Mem -> [Mem]
$cenumFromThenTo :: Mem -> Mem -> Mem -> [Mem]
enumFromThenTo :: Mem -> Mem -> Mem -> [Mem]
Enum)

-- Context entries with evaluation strategy
data CTE v s
  = ST (Direction Word16) [v] [Mem] s
  | LZ v (Either Reference v) [v]
  deriving (Int -> CTE v s -> ShowS
[CTE v s] -> ShowS
CTE v s -> String
(Int -> CTE v s -> ShowS)
-> (CTE v s -> String) -> ([CTE v s] -> ShowS) -> Show (CTE v s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v s. (Show s, Show v) => Int -> CTE v s -> ShowS
forall v s. (Show s, Show v) => [CTE v s] -> ShowS
forall v s. (Show s, Show v) => CTE v s -> String
$cshowsPrec :: forall v s. (Show s, Show v) => Int -> CTE v s -> ShowS
showsPrec :: Int -> CTE v s -> ShowS
$cshow :: forall v s. (Show s, Show v) => CTE v s -> String
show :: CTE v s -> String
$cshowList :: forall v s. (Show s, Show v) => [CTE v s] -> ShowS
showList :: [CTE v s] -> ShowS
Show)

pattern ST1 :: Direction Word16 -> v -> Mem -> s -> CTE v s
pattern $mST1 :: forall {r} {v} {s}.
CTE v s
-> (Direction Word16 -> v -> Mem -> s -> r) -> ((# #) -> r) -> r
$bST1 :: forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 d v m s = ST d [v] [m] s

data ANormalF v e
  = ALet (Direction Word16) [Mem] e e
  | AName (Either Reference v) [v] e
  | ALit Lit
  | ABLit Lit -- direct boxed literal
  | AMatch v (Branched e)
  | AShift Reference e
  | AHnd [Reference] v e
  | AApp (Func v) [v]
  | AFrc v
  | AVar v
  deriving (Int -> ANormalF v e -> ShowS
[ANormalF v e] -> ShowS
ANormalF v e -> String
(Int -> ANormalF v e -> ShowS)
-> (ANormalF v e -> String)
-> ([ANormalF v e] -> ShowS)
-> Show (ANormalF v e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v e. (Show e, Show v) => Int -> ANormalF v e -> ShowS
forall v e. (Show e, Show v) => [ANormalF v e] -> ShowS
forall v e. (Show e, Show v) => ANormalF v e -> String
$cshowsPrec :: forall v e. (Show e, Show v) => Int -> ANormalF v e -> ShowS
showsPrec :: Int -> ANormalF v e -> ShowS
$cshow :: forall v e. (Show e, Show v) => ANormalF v e -> String
show :: ANormalF v e -> String
$cshowList :: forall v e. (Show e, Show v) => [ANormalF v e] -> ShowS
showList :: [ANormalF v e] -> ShowS
Show, ANormalF v e -> ANormalF v e -> Bool
(ANormalF v e -> ANormalF v e -> Bool)
-> (ANormalF v e -> ANormalF v e -> Bool) -> Eq (ANormalF v e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v e. (Eq e, Eq v) => ANormalF v e -> ANormalF v e -> Bool
$c== :: forall v e. (Eq e, Eq v) => ANormalF v e -> ANormalF v e -> Bool
== :: ANormalF v e -> ANormalF v e -> Bool
$c/= :: forall v e. (Eq e, Eq v) => ANormalF v e -> ANormalF v e -> Bool
/= :: ANormalF v e -> ANormalF v e -> Bool
Eq)

-- Types representing components that will go into the runtime tag of
-- a data type value. RTags correspond to references, while CTags
-- correspond to constructors.
newtype RTag = RTag Word64
  deriving stock (RTag -> RTag -> Bool
(RTag -> RTag -> Bool) -> (RTag -> RTag -> Bool) -> Eq RTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RTag -> RTag -> Bool
== :: RTag -> RTag -> Bool
$c/= :: RTag -> RTag -> Bool
/= :: RTag -> RTag -> Bool
Eq, Eq RTag
Eq RTag =>
(RTag -> RTag -> Ordering)
-> (RTag -> RTag -> Bool)
-> (RTag -> RTag -> Bool)
-> (RTag -> RTag -> Bool)
-> (RTag -> RTag -> Bool)
-> (RTag -> RTag -> RTag)
-> (RTag -> RTag -> RTag)
-> Ord RTag
RTag -> RTag -> Bool
RTag -> RTag -> Ordering
RTag -> RTag -> RTag
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 :: RTag -> RTag -> Ordering
compare :: RTag -> RTag -> Ordering
$c< :: RTag -> RTag -> Bool
< :: RTag -> RTag -> Bool
$c<= :: RTag -> RTag -> Bool
<= :: RTag -> RTag -> Bool
$c> :: RTag -> RTag -> Bool
> :: RTag -> RTag -> Bool
$c>= :: RTag -> RTag -> Bool
>= :: RTag -> RTag -> Bool
$cmax :: RTag -> RTag -> RTag
max :: RTag -> RTag -> RTag
$cmin :: RTag -> RTag -> RTag
min :: RTag -> RTag -> RTag
Ord, Int -> RTag -> ShowS
[RTag] -> ShowS
RTag -> String
(Int -> RTag -> ShowS)
-> (RTag -> String) -> ([RTag] -> ShowS) -> Show RTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RTag -> ShowS
showsPrec :: Int -> RTag -> ShowS
$cshow :: RTag -> String
show :: RTag -> String
$cshowList :: [RTag] -> ShowS
showList :: [RTag] -> ShowS
Show, ReadPrec [RTag]
ReadPrec RTag
Int -> ReadS RTag
ReadS [RTag]
(Int -> ReadS RTag)
-> ReadS [RTag] -> ReadPrec RTag -> ReadPrec [RTag] -> Read RTag
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RTag
readsPrec :: Int -> ReadS RTag
$creadList :: ReadS [RTag]
readList :: ReadS [RTag]
$creadPrec :: ReadPrec RTag
readPrec :: ReadPrec RTag
$creadListPrec :: ReadPrec [RTag]
readListPrec :: ReadPrec [RTag]
Read)
  deriving newtype (Int -> RTag
RTag -> Int
(RTag -> Int) -> (Int -> RTag) -> EnumKey RTag
forall k. (k -> Int) -> (Int -> k) -> EnumKey k
$ckeyToInt :: RTag -> Int
keyToInt :: RTag -> Int
$cintToKey :: Int -> RTag
intToKey :: Int -> RTag
EC.EnumKey)

newtype CTag = CTag Word16
  deriving stock (CTag -> CTag -> Bool
(CTag -> CTag -> Bool) -> (CTag -> CTag -> Bool) -> Eq CTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CTag -> CTag -> Bool
== :: CTag -> CTag -> Bool
$c/= :: CTag -> CTag -> Bool
/= :: CTag -> CTag -> Bool
Eq, Eq CTag
Eq CTag =>
(CTag -> CTag -> Ordering)
-> (CTag -> CTag -> Bool)
-> (CTag -> CTag -> Bool)
-> (CTag -> CTag -> Bool)
-> (CTag -> CTag -> Bool)
-> (CTag -> CTag -> CTag)
-> (CTag -> CTag -> CTag)
-> Ord CTag
CTag -> CTag -> Bool
CTag -> CTag -> Ordering
CTag -> CTag -> CTag
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 :: CTag -> CTag -> Ordering
compare :: CTag -> CTag -> Ordering
$c< :: CTag -> CTag -> Bool
< :: CTag -> CTag -> Bool
$c<= :: CTag -> CTag -> Bool
<= :: CTag -> CTag -> Bool
$c> :: CTag -> CTag -> Bool
> :: CTag -> CTag -> Bool
$c>= :: CTag -> CTag -> Bool
>= :: CTag -> CTag -> Bool
$cmax :: CTag -> CTag -> CTag
max :: CTag -> CTag -> CTag
$cmin :: CTag -> CTag -> CTag
min :: CTag -> CTag -> CTag
Ord, Int -> CTag -> ShowS
[CTag] -> ShowS
CTag -> String
(Int -> CTag -> ShowS)
-> (CTag -> String) -> ([CTag] -> ShowS) -> Show CTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CTag -> ShowS
showsPrec :: Int -> CTag -> ShowS
$cshow :: CTag -> String
show :: CTag -> String
$cshowList :: [CTag] -> ShowS
showList :: [CTag] -> ShowS
Show, ReadPrec [CTag]
ReadPrec CTag
Int -> ReadS CTag
ReadS [CTag]
(Int -> ReadS CTag)
-> ReadS [CTag] -> ReadPrec CTag -> ReadPrec [CTag] -> Read CTag
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CTag
readsPrec :: Int -> ReadS CTag
$creadList :: ReadS [CTag]
readList :: ReadS [CTag]
$creadPrec :: ReadPrec CTag
readPrec :: ReadPrec CTag
$creadListPrec :: ReadPrec [CTag]
readListPrec :: ReadPrec [CTag]
Read)
  deriving newtype (Int -> CTag
CTag -> Int
(CTag -> Int) -> (Int -> CTag) -> EnumKey CTag
forall k. (k -> Int) -> (Int -> k) -> EnumKey k
$ckeyToInt :: CTag -> Int
keyToInt :: CTag -> Int
$cintToKey :: Int -> CTag
intToKey :: Int -> CTag
EC.EnumKey)

class Tag t where rawTag :: t -> Word64

instance Tag RTag where rawTag :: RTag -> Word64
rawTag (RTag Word64
w) = Word64
w

instance Tag CTag where rawTag :: CTag -> Word64
rawTag (CTag Word16
w) = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w

packTags :: RTag -> CTag -> Word64
packTags :: RTag -> CTag -> Word64
packTags (RTag Word64
rt) (CTag Word16
ct) = Word64
ri Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
ci
  where
    ri :: Word64
ri = Word64
rt Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
16
    ci :: Word64
ci = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
ct

unpackTags :: Word64 -> (RTag, CTag)
unpackTags :: Word64 -> (RTag, CTag)
unpackTags Word64
w = (Word64 -> RTag
RTag (Word64 -> RTag) -> Word64 -> RTag
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16, Word16 -> CTag
CTag (Word16 -> CTag) -> (Word64 -> Word16) -> Word64 -> CTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> CTag) -> Word64 -> CTag
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xFFFF)

-- Masks a packed tag to extract just the constructor tag portion
maskTags :: Word64 -> Word64
maskTags :: Word64 -> Word64
maskTags Word64
w = Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xFFFF

ensureRTag :: (Ord n, Show n, Num n) => String -> n -> r -> r
ensureRTag :: forall n r. (Ord n, Show n, Num n) => String -> n -> r -> r
ensureRTag String
s n
n r
x
  | n
n n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0xFFFFFFFFFFFF =
      String -> r
forall a. HasCallStack => String -> a
internalBug (String -> r) -> String -> r
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"@RTag: too large: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ n -> String
forall a. Show a => a -> String
show n
n
  | Bool
otherwise = r
x

ensureCTag :: (Ord n, Show n, Num n) => String -> n -> r -> r
ensureCTag :: forall n r. (Ord n, Show n, Num n) => String -> n -> r -> r
ensureCTag String
s n
n r
x
  | n
n n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0xFFFF =
      String -> r
forall a. HasCallStack => String -> a
internalBug (String -> r) -> String -> r
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"@CTag: too large: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ n -> String
forall a. Show a => a -> String
show n
n
  | Bool
otherwise = r
x

instance Enum RTag where
  toEnum :: Int -> RTag
toEnum Int
i = String -> Int -> RTag -> RTag
forall n r. (Ord n, Show n, Num n) => String -> n -> r -> r
ensureRTag String
"toEnum" Int
i (RTag -> RTag) -> (Word64 -> RTag) -> Word64 -> RTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> RTag
RTag (Word64 -> RTag) -> Word64 -> RTag
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a. Enum a => Int -> a
toEnum Int
i
  fromEnum :: RTag -> Int
fromEnum (RTag Word64
w) = Word64 -> Int
forall a. Enum a => a -> Int
fromEnum Word64
w

instance Enum CTag where
  toEnum :: Int -> CTag
toEnum Int
i = String -> Int -> CTag -> CTag
forall n r. (Ord n, Show n, Num n) => String -> n -> r -> r
ensureCTag String
"toEnum" Int
i (CTag -> CTag) -> (Word16 -> CTag) -> Word16 -> CTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> CTag
CTag (Word16 -> CTag) -> Word16 -> CTag
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a. Enum a => Int -> a
toEnum Int
i
  fromEnum :: CTag -> Int
fromEnum (CTag Word16
w) = Word16 -> Int
forall a. Enum a => a -> Int
fromEnum Word16
w

instance Num RTag where
  fromInteger :: Integer -> RTag
fromInteger Integer
i = String -> Integer -> RTag -> RTag
forall n r. (Ord n, Show n, Num n) => String -> n -> r -> r
ensureRTag String
"fromInteger" Integer
i (RTag -> RTag) -> (Word64 -> RTag) -> Word64 -> RTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> RTag
RTag (Word64 -> RTag) -> Word64 -> RTag
forall a b. (a -> b) -> a -> b
$ Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
i
  + :: RTag -> RTag -> RTag
(+) = String -> RTag -> RTag -> RTag
forall a. HasCallStack => String -> a
internalBug String
"RTag: +"
  * :: RTag -> RTag -> RTag
(*) = String -> RTag -> RTag -> RTag
forall a. HasCallStack => String -> a
internalBug String
"RTag: *"
  abs :: RTag -> RTag
abs = String -> RTag -> RTag
forall a. HasCallStack => String -> a
internalBug String
"RTag: abs"
  signum :: RTag -> RTag
signum = String -> RTag -> RTag
forall a. HasCallStack => String -> a
internalBug String
"RTag: signum"
  negate :: RTag -> RTag
negate = String -> RTag -> RTag
forall a. HasCallStack => String -> a
internalBug String
"RTag: negate"

instance Num CTag where
  fromInteger :: Integer -> CTag
fromInteger Integer
i = String -> Integer -> CTag -> CTag
forall n r. (Ord n, Show n, Num n) => String -> n -> r -> r
ensureCTag String
"fromInteger" Integer
i (CTag -> CTag) -> (Word16 -> CTag) -> Word16 -> CTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> CTag
CTag (Word16 -> CTag) -> Word16 -> CTag
forall a b. (a -> b) -> a -> b
$ Integer -> Word16
forall a. Num a => Integer -> a
fromInteger Integer
i
  + :: CTag -> CTag -> CTag
(+) = String -> CTag -> CTag -> CTag
forall a. HasCallStack => String -> a
internalBug String
"CTag: +"
  * :: CTag -> CTag -> CTag
(*) = String -> CTag -> CTag -> CTag
forall a. HasCallStack => String -> a
internalBug String
"CTag: *"
  abs :: CTag -> CTag
abs = String -> CTag -> CTag
forall a. HasCallStack => String -> a
internalBug String
"CTag: abs"
  signum :: CTag -> CTag
signum = String -> CTag -> CTag
forall a. HasCallStack => String -> a
internalBug String
"CTag: signum"
  negate :: CTag -> CTag
negate = String -> CTag -> CTag
forall a. HasCallStack => String -> a
internalBug String
"CTag: negate"

instance Functor (ANormalF v) where
  fmap :: forall a b. (a -> b) -> ANormalF v a -> ANormalF v b
fmap a -> b
_ (AVar v
v) = v -> ANormalF v b
forall v e. v -> ANormalF v e
AVar v
v
  fmap a -> b
_ (ALit Lit
l) = Lit -> ANormalF v b
forall v e. Lit -> ANormalF v e
ALit Lit
l
  fmap a -> b
_ (ABLit Lit
l) = Lit -> ANormalF v b
forall v e. Lit -> ANormalF v e
ABLit Lit
l
  fmap a -> b
f (ALet Direction Word16
d [Mem]
m a
bn a
bo) = Direction Word16 -> [Mem] -> b -> b -> ANormalF v b
forall v e. Direction Word16 -> [Mem] -> e -> e -> ANormalF v e
ALet Direction Word16
d [Mem]
m (a -> b
f a
bn) (a -> b
f a
bo)
  fmap a -> b
f (AName Either Reference v
n [v]
as a
bo) = Either Reference v -> [v] -> b -> ANormalF v b
forall v e. Either Reference v -> [v] -> e -> ANormalF v e
AName Either Reference v
n [v]
as (b -> ANormalF v b) -> b -> ANormalF v b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
bo
  fmap a -> b
f (AMatch v
v Branched a
br) = v -> Branched b -> ANormalF v b
forall v e. v -> Branched e -> ANormalF v e
AMatch v
v (Branched b -> ANormalF v b) -> Branched b -> ANormalF v b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> Branched a -> Branched b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Branched a
br
  fmap a -> b
f (AHnd [Reference]
rs v
h a
e) = [Reference] -> v -> b -> ANormalF v b
forall v e. [Reference] -> v -> e -> ANormalF v e
AHnd [Reference]
rs v
h (b -> ANormalF v b) -> b -> ANormalF v b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
e
  fmap a -> b
f (AShift Reference
i a
e) = Reference -> b -> ANormalF v b
forall v e. Reference -> e -> ANormalF v e
AShift Reference
i (b -> ANormalF v b) -> b -> ANormalF v b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
e
  fmap a -> b
_ (AFrc v
v) = v -> ANormalF v b
forall v e. v -> ANormalF v e
AFrc v
v
  fmap a -> b
_ (AApp Func v
f [v]
args) = Func v -> [v] -> ANormalF v b
forall v e. Func v -> [v] -> ANormalF v e
AApp Func v
f [v]
args

instance Bifunctor ANormalF where
  bimap :: forall a b c d.
(a -> b) -> (c -> d) -> ANormalF a c -> ANormalF b d
bimap a -> b
f c -> d
_ (AVar a
v) = b -> ANormalF b d
forall v e. v -> ANormalF v e
AVar (a -> b
f a
v)
  bimap a -> b
_ c -> d
_ (ALit Lit
l) = Lit -> ANormalF b d
forall v e. Lit -> ANormalF v e
ALit Lit
l
  bimap a -> b
_ c -> d
_ (ABLit Lit
l) = Lit -> ANormalF b d
forall v e. Lit -> ANormalF v e
ABLit Lit
l
  bimap a -> b
_ c -> d
g (ALet Direction Word16
d [Mem]
m c
bn c
bo) = Direction Word16 -> [Mem] -> d -> d -> ANormalF b d
forall v e. Direction Word16 -> [Mem] -> e -> e -> ANormalF v e
ALet Direction Word16
d [Mem]
m (c -> d
g c
bn) (c -> d
g c
bo)
  bimap a -> b
f c -> d
g (AName Either Reference a
n [a]
as c
bo) = Either Reference b -> [b] -> d -> ANormalF b d
forall v e. Either Reference v -> [v] -> e -> ANormalF v e
AName (a -> b
f (a -> b) -> Either Reference a -> Either Reference b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Reference a
n) (a -> b
f (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as) (d -> ANormalF b d) -> d -> ANormalF b d
forall a b. (a -> b) -> a -> b
$ c -> d
g c
bo
  bimap a -> b
f c -> d
g (AMatch a
v Branched c
br) = b -> Branched d -> ANormalF b d
forall v e. v -> Branched e -> ANormalF v e
AMatch (a -> b
f a
v) (Branched d -> ANormalF b d) -> Branched d -> ANormalF b d
forall a b. (a -> b) -> a -> b
$ (c -> d) -> Branched c -> Branched d
forall a b. (a -> b) -> Branched a -> Branched b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g Branched c
br
  bimap a -> b
f c -> d
g (AHnd [Reference]
rs a
v c
e) = [Reference] -> b -> d -> ANormalF b d
forall v e. [Reference] -> v -> e -> ANormalF v e
AHnd [Reference]
rs (a -> b
f a
v) (d -> ANormalF b d) -> d -> ANormalF b d
forall a b. (a -> b) -> a -> b
$ c -> d
g c
e
  bimap a -> b
_ c -> d
g (AShift Reference
i c
e) = Reference -> d -> ANormalF b d
forall v e. Reference -> e -> ANormalF v e
AShift Reference
i (d -> ANormalF b d) -> d -> ANormalF b d
forall a b. (a -> b) -> a -> b
$ c -> d
g c
e
  bimap a -> b
f c -> d
_ (AFrc a
v) = b -> ANormalF b d
forall v e. v -> ANormalF v e
AFrc (a -> b
f a
v)
  bimap a -> b
f c -> d
_ (AApp Func a
fu [a]
args) = Func b -> [b] -> ANormalF b d
forall v e. Func v -> [v] -> ANormalF v e
AApp ((a -> b) -> Func a -> Func b
forall a b. (a -> b) -> Func a -> Func b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Func a
fu) ([b] -> ANormalF b d) -> [b] -> ANormalF b d
forall a b. (a -> b) -> a -> b
$ (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [a]
args

instance Bifoldable ANormalF where
  bifoldMap :: forall m a b. Monoid m => (a -> m) -> (b -> m) -> ANormalF a b -> m
bifoldMap a -> m
f b -> m
_ (AVar a
v) = a -> m
f a
v
  bifoldMap a -> m
_ b -> m
_ (ALit Lit
_) = m
forall a. Monoid a => a
mempty
  bifoldMap a -> m
_ b -> m
_ (ABLit Lit
_) = m
forall a. Monoid a => a
mempty
  bifoldMap a -> m
_ b -> m
g (ALet Direction Word16
_ [Mem]
_ b
b b
e) = b -> m
g b
b m -> m -> m
forall a. Semigroup a => a -> a -> a
<> b -> m
g b
e
  bifoldMap a -> m
f b -> m
g (AName Either Reference a
n [a]
as b
e) = (a -> m) -> Either Reference a -> m
forall m a. Monoid m => (a -> m) -> Either Reference a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Either Reference a
n m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> [a] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f [a]
as m -> m -> m
forall a. Semigroup a => a -> a -> a
<> b -> m
g b
e
  bifoldMap a -> m
f b -> m
g (AMatch a
v Branched b
br) = a -> m
f a
v m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (b -> m) -> Branched b -> m
forall m a. Monoid m => (a -> m) -> Branched a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap b -> m
g Branched b
br
  bifoldMap a -> m
f b -> m
g (AHnd [Reference]
_ a
h b
e) = a -> m
f a
h m -> m -> m
forall a. Semigroup a => a -> a -> a
<> b -> m
g b
e
  bifoldMap a -> m
_ b -> m
g (AShift Reference
_ b
e) = b -> m
g b
e
  bifoldMap a -> m
f b -> m
_ (AFrc a
v) = a -> m
f a
v
  bifoldMap a -> m
f b -> m
_ (AApp Func a
func [a]
args) = (a -> m) -> Func a -> m
forall m a. Monoid m => (a -> m) -> Func a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Func a
func m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> [a] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f [a]
args

instance ABTN.Align ANormalF where
  align :: forall (g :: * -> *) vl vr vs el er es.
Applicative g =>
(vl -> vr -> g vs)
-> (el -> er -> g es)
-> ANormalF vl el
-> ANormalF vr er
-> Maybe (g (ANormalF vs es))
align vl -> vr -> g vs
f el -> er -> g es
_ (AVar vl
u) (AVar vr
v) = g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ vs -> ANormalF vs es
forall v e. v -> ANormalF v e
AVar (vs -> ANormalF vs es) -> g vs -> g (ANormalF vs es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> vl -> vr -> g vs
f vl
u vr
v
  align vl -> vr -> g vs
_ el -> er -> g es
_ (ALit Lit
l) (ALit Lit
r)
    | Lit
l Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
r = g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ ANormalF vs es -> g (ANormalF vs es)
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lit -> ANormalF vs es
forall v e. Lit -> ANormalF v e
ALit Lit
l)
  align vl -> vr -> g vs
_ el -> er -> g es
_ (ABLit Lit
l) (ABLit Lit
r)
    | Lit
l Lit -> Lit -> Bool
forall a. Eq a => a -> a -> Bool
== Lit
r = g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ ANormalF vs es -> g (ANormalF vs es)
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lit -> ANormalF vs es
forall v e. Lit -> ANormalF v e
ABLit Lit
l)
  align vl -> vr -> g vs
_ el -> er -> g es
g (ALet Direction Word16
dl [Mem]
ccl el
bl el
el) (ALet Direction Word16
dr [Mem]
ccr er
br er
er)
    | Direction Word16
dl Direction Word16 -> Direction Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Direction Word16
dr,
      [Mem]
ccl [Mem] -> [Mem] -> Bool
forall a. Eq a => a -> a -> Bool
== [Mem]
ccr =
        g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ Direction Word16 -> [Mem] -> es -> es -> ANormalF vs es
forall v e. Direction Word16 -> [Mem] -> e -> e -> ANormalF v e
ALet Direction Word16
dl [Mem]
ccl (es -> es -> ANormalF vs es) -> g es -> g (es -> ANormalF vs es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> el -> er -> g es
g el
bl er
br g (es -> ANormalF vs es) -> g es -> g (ANormalF vs es)
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> el -> er -> g es
g el
el er
er
  align vl -> vr -> g vs
f el -> er -> g es
g (AName Either Reference vl
hl [vl]
asl el
el) (AName Either Reference vr
hr [vr]
asr er
er)
    | [vl] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [vl]
asl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [vr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [vr]
asr,
      Just g (Either Reference vs)
hs <- (vl -> vr -> g vs)
-> Either Reference vl
-> Either Reference vr
-> Maybe (g (Either Reference vs))
forall (f :: * -> *) l r s.
Applicative f =>
(l -> r -> f s)
-> Either Reference l
-> Either Reference r
-> Maybe (f (Either Reference s))
alignEither vl -> vr -> g vs
f Either Reference vl
hl Either Reference vr
hr =
        g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$
          Either Reference vs -> [vs] -> es -> ANormalF vs es
forall v e. Either Reference v -> [v] -> e -> ANormalF v e
AName
            (Either Reference vs -> [vs] -> es -> ANormalF vs es)
-> g (Either Reference vs) -> g ([vs] -> es -> ANormalF vs es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (Either Reference vs)
hs
            g ([vs] -> es -> ANormalF vs es)
-> g [vs] -> g (es -> ANormalF vs es)
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((vl, vr) -> g vs) -> [(vl, vr)] -> g [vs]
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 ((vl -> vr -> g vs) -> (vl, vr) -> g vs
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry vl -> vr -> g vs
f) ([vl] -> [vr] -> [(vl, vr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [vl]
asl [vr]
asr)
            g (es -> ANormalF vs es) -> g es -> g (ANormalF vs es)
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> el -> er -> g es
g el
el er
er
  align vl -> vr -> g vs
f el -> er -> g es
g (AMatch vl
vl Branched el
bsl) (AMatch vr
vr Branched er
bsr)
    | Just g (Branched es)
bss <- (el -> er -> g es)
-> Branched el -> Branched er -> Maybe (g (Branched es))
forall (f :: * -> *) el er es.
Applicative f =>
(el -> er -> f es)
-> Branched el -> Branched er -> Maybe (f (Branched es))
alignBranch el -> er -> g es
g Branched el
bsl Branched er
bsr =
        g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ vs -> Branched es -> ANormalF vs es
forall v e. v -> Branched e -> ANormalF v e
AMatch (vs -> Branched es -> ANormalF vs es)
-> g vs -> g (Branched es -> ANormalF vs es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> vl -> vr -> g vs
f vl
vl vr
vr g (Branched es -> ANormalF vs es)
-> g (Branched es) -> g (ANormalF vs es)
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> g (Branched es)
bss
  align vl -> vr -> g vs
f el -> er -> g es
g (AHnd [Reference]
rl vl
hl el
bl) (AHnd [Reference]
rr vr
hr er
br)
    | [Reference]
rl [Reference] -> [Reference] -> Bool
forall a. Eq a => a -> a -> Bool
== [Reference]
rr = g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ [Reference] -> vs -> es -> ANormalF vs es
forall v e. [Reference] -> v -> e -> ANormalF v e
AHnd [Reference]
rl (vs -> es -> ANormalF vs es) -> g vs -> g (es -> ANormalF vs es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> vl -> vr -> g vs
f vl
hl vr
hr g (es -> ANormalF vs es) -> g es -> g (ANormalF vs es)
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> el -> er -> g es
g el
bl er
br
  align vl -> vr -> g vs
_ el -> er -> g es
g (AShift Reference
rl el
bl) (AShift Reference
rr er
br)
    | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr = g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ Reference -> es -> ANormalF vs es
forall v e. Reference -> e -> ANormalF v e
AShift Reference
rl (es -> ANormalF vs es) -> g es -> g (ANormalF vs es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> el -> er -> g es
g el
bl er
br
  align vl -> vr -> g vs
f el -> er -> g es
_ (AFrc vl
u) (AFrc vr
v) = g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ vs -> ANormalF vs es
forall v e. v -> ANormalF v e
AFrc (vs -> ANormalF vs es) -> g vs -> g (ANormalF vs es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> vl -> vr -> g vs
f vl
u vr
v
  align vl -> vr -> g vs
f el -> er -> g es
_ (AApp Func vl
hl [vl]
asl) (AApp Func vr
hr [vr]
asr)
    | Just g (Func vs)
hs <- (vl -> vr -> g vs) -> Func vl -> Func vr -> Maybe (g (Func vs))
forall (f :: * -> *) vl vr vs.
Applicative f =>
(vl -> vr -> f vs) -> Func vl -> Func vr -> Maybe (f (Func vs))
alignFunc vl -> vr -> g vs
f Func vl
hl Func vr
hr,
      [vl] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [vl]
asl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [vr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [vr]
asr =
        g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a. a -> Maybe a
Just (g (ANormalF vs es) -> Maybe (g (ANormalF vs es)))
-> g (ANormalF vs es) -> Maybe (g (ANormalF vs es))
forall a b. (a -> b) -> a -> b
$ Func vs -> [vs] -> ANormalF vs es
forall v e. Func v -> [v] -> ANormalF v e
AApp (Func vs -> [vs] -> ANormalF vs es)
-> g (Func vs) -> g ([vs] -> ANormalF vs es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (Func vs)
hs g ([vs] -> ANormalF vs es) -> g [vs] -> g (ANormalF vs es)
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((vl, vr) -> g vs) -> [(vl, vr)] -> g [vs]
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 ((vl -> vr -> g vs) -> (vl, vr) -> g vs
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry vl -> vr -> g vs
f) ([vl] -> [vr] -> [(vl, vr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [vl]
asl [vr]
asr)
  align vl -> vr -> g vs
_ el -> er -> g es
_ ANormalF vl el
_ ANormalF vr er
_ = Maybe (g (ANormalF vs es))
forall a. Maybe a
Nothing

alignEither ::
  (Applicative f) =>
  (l -> r -> f s) ->
  Either Reference l ->
  Either Reference r ->
  Maybe (f (Either Reference s))
alignEither :: forall (f :: * -> *) l r s.
Applicative f =>
(l -> r -> f s)
-> Either Reference l
-> Either Reference r
-> Maybe (f (Either Reference s))
alignEither l -> r -> f s
_ (Left Reference
rl) (Left Reference
rr) | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr = f (Either Reference s) -> Maybe (f (Either Reference s))
forall a. a -> Maybe a
Just (f (Either Reference s) -> Maybe (f (Either Reference s)))
-> (Either Reference s -> f (Either Reference s))
-> Either Reference s
-> Maybe (f (Either Reference s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Reference s -> f (Either Reference s)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Reference s -> Maybe (f (Either Reference s)))
-> Either Reference s -> Maybe (f (Either Reference s))
forall a b. (a -> b) -> a -> b
$ Reference -> Either Reference s
forall a b. a -> Either a b
Left Reference
rl
alignEither l -> r -> f s
f (Right l
u) (Right r
v) = f (Either Reference s) -> Maybe (f (Either Reference s))
forall a. a -> Maybe a
Just (f (Either Reference s) -> Maybe (f (Either Reference s)))
-> f (Either Reference s) -> Maybe (f (Either Reference s))
forall a b. (a -> b) -> a -> b
$ s -> Either Reference s
forall a b. b -> Either a b
Right (s -> Either Reference s) -> f s -> f (Either Reference s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> l -> r -> f s
f l
u r
v
alignEither l -> r -> f s
_ Either Reference l
_ Either Reference r
_ = Maybe (f (Either Reference s))
forall a. Maybe a
Nothing

alignMaybe ::
  (Applicative f) =>
  (l -> r -> f s) ->
  Maybe l ->
  Maybe r ->
  Maybe (f (Maybe s))
alignMaybe :: forall (f :: * -> *) l r s.
Applicative f =>
(l -> r -> f s) -> Maybe l -> Maybe r -> Maybe (f (Maybe s))
alignMaybe l -> r -> f s
f (Just l
l) (Just r
r) = f (Maybe s) -> Maybe (f (Maybe s))
forall a. a -> Maybe a
Just (f (Maybe s) -> Maybe (f (Maybe s)))
-> f (Maybe s) -> Maybe (f (Maybe s))
forall a b. (a -> b) -> a -> b
$ s -> Maybe s
forall a. a -> Maybe a
Just (s -> Maybe s) -> f s -> f (Maybe s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> l -> r -> f s
f l
l r
r
alignMaybe l -> r -> f s
_ Maybe l
Nothing Maybe r
Nothing = f (Maybe s) -> Maybe (f (Maybe s))
forall a. a -> Maybe a
Just (Maybe s -> f (Maybe s)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe s
forall a. Maybe a
Nothing)
alignMaybe l -> r -> f s
_ Maybe l
_ Maybe r
_ = Maybe (f (Maybe s))
forall a. Maybe a
Nothing

alignFunc ::
  (Applicative f) =>
  (vl -> vr -> f vs) ->
  Func vl ->
  Func vr ->
  Maybe (f (Func vs))
alignFunc :: forall (f :: * -> *) vl vr vs.
Applicative f =>
(vl -> vr -> f vs) -> Func vl -> Func vr -> Maybe (f (Func vs))
alignFunc vl -> vr -> f vs
f (FVar vl
u) (FVar vr
v) = f (Func vs) -> Maybe (f (Func vs))
forall a. a -> Maybe a
Just (f (Func vs) -> Maybe (f (Func vs)))
-> f (Func vs) -> Maybe (f (Func vs))
forall a b. (a -> b) -> a -> b
$ vs -> Func vs
forall v. v -> Func v
FVar (vs -> Func vs) -> f vs -> f (Func vs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> vl -> vr -> f vs
f vl
u vr
v
alignFunc vl -> vr -> f vs
_ (FComb Reference
rl) (FComb Reference
rr) | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr = f (Func vs) -> Maybe (f (Func vs))
forall a. a -> Maybe a
Just (f (Func vs) -> Maybe (f (Func vs)))
-> (Func vs -> f (Func vs)) -> Func vs -> Maybe (f (Func vs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Func vs -> f (Func vs)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Func vs -> Maybe (f (Func vs))) -> Func vs -> Maybe (f (Func vs))
forall a b. (a -> b) -> a -> b
$ Reference -> Func vs
forall v. Reference -> Func v
FComb Reference
rl
alignFunc vl -> vr -> f vs
f (FCont vl
u) (FCont vr
v) = f (Func vs) -> Maybe (f (Func vs))
forall a. a -> Maybe a
Just (f (Func vs) -> Maybe (f (Func vs)))
-> f (Func vs) -> Maybe (f (Func vs))
forall a b. (a -> b) -> a -> b
$ vs -> Func vs
forall v. v -> Func v
FCont (vs -> Func vs) -> f vs -> f (Func vs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> vl -> vr -> f vs
f vl
u vr
v
alignFunc vl -> vr -> f vs
_ (FCon Reference
rl CTag
tl) (FCon Reference
rr CTag
tr)
  | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr, CTag
tl CTag -> CTag -> Bool
forall a. Eq a => a -> a -> Bool
== CTag
tr = f (Func vs) -> Maybe (f (Func vs))
forall a. a -> Maybe a
Just (f (Func vs) -> Maybe (f (Func vs)))
-> (Func vs -> f (Func vs)) -> Func vs -> Maybe (f (Func vs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Func vs -> f (Func vs)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Func vs -> Maybe (f (Func vs))) -> Func vs -> Maybe (f (Func vs))
forall a b. (a -> b) -> a -> b
$ Reference -> CTag -> Func vs
forall v. Reference -> CTag -> Func v
FCon Reference
rl CTag
tl
alignFunc vl -> vr -> f vs
_ (FReq Reference
rl CTag
tl) (FReq Reference
rr CTag
tr)
  | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr, CTag
tl CTag -> CTag -> Bool
forall a. Eq a => a -> a -> Bool
== CTag
tr = f (Func vs) -> Maybe (f (Func vs))
forall a. a -> Maybe a
Just (f (Func vs) -> Maybe (f (Func vs)))
-> (Func vs -> f (Func vs)) -> Func vs -> Maybe (f (Func vs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Func vs -> f (Func vs)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Func vs -> Maybe (f (Func vs))) -> Func vs -> Maybe (f (Func vs))
forall a b. (a -> b) -> a -> b
$ Reference -> CTag -> Func vs
forall v. Reference -> CTag -> Func v
FReq Reference
rl CTag
tl
alignFunc vl -> vr -> f vs
_ (FPrim Either POp Word64
ol) (FPrim Either POp Word64
or)
  | Either POp Word64
ol Either POp Word64 -> Either POp Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Either POp Word64
or = f (Func vs) -> Maybe (f (Func vs))
forall a. a -> Maybe a
Just (f (Func vs) -> Maybe (f (Func vs)))
-> (Func vs -> f (Func vs)) -> Func vs -> Maybe (f (Func vs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Func vs -> f (Func vs)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Func vs -> Maybe (f (Func vs))) -> Func vs -> Maybe (f (Func vs))
forall a b. (a -> b) -> a -> b
$ Either POp Word64 -> Func vs
forall v. Either POp Word64 -> Func v
FPrim Either POp Word64
ol
alignFunc vl -> vr -> f vs
_ Func vl
_ Func vr
_ = Maybe (f (Func vs))
forall a. Maybe a
Nothing

alignBranch ::
  (Applicative f) =>
  (el -> er -> f es) ->
  Branched el ->
  Branched er ->
  Maybe (f (Branched es))
alignBranch :: forall (f :: * -> *) el er es.
Applicative f =>
(el -> er -> f es)
-> Branched el -> Branched er -> Maybe (f (Branched es))
alignBranch el -> er -> f es
_ Branched el
MatchEmpty Branched er
MatchEmpty = f (Branched es) -> Maybe (f (Branched es))
forall a. a -> Maybe a
Just (f (Branched es) -> Maybe (f (Branched es)))
-> f (Branched es) -> Maybe (f (Branched es))
forall a b. (a -> b) -> a -> b
$ Branched es -> f (Branched es)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Branched es
forall e. Branched e
MatchEmpty
alignBranch el -> er -> f es
f (MatchIntegral EnumMap Word64 el
bl Maybe el
dl) (MatchIntegral EnumMap Word64 er
br Maybe er
dr)
  | EnumMap Word64 el -> EnumSet Word64
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap Word64 el
bl EnumSet Word64 -> EnumSet Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== EnumMap Word64 er -> EnumSet Word64
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap Word64 er
br,
    Just f (Maybe es)
ds <- (el -> er -> f es) -> Maybe el -> Maybe er -> Maybe (f (Maybe es))
forall (f :: * -> *) l r s.
Applicative f =>
(l -> r -> f s) -> Maybe l -> Maybe r -> Maybe (f (Maybe s))
alignMaybe el -> er -> f es
f Maybe el
dl Maybe er
dr =
      f (Branched es) -> Maybe (f (Branched es))
forall a. a -> Maybe a
Just (f (Branched es) -> Maybe (f (Branched es)))
-> f (Branched es) -> Maybe (f (Branched es))
forall a b. (a -> b) -> a -> b
$
        EnumMap Word64 es -> Maybe es -> Branched es
forall e. EnumMap Word64 e -> Maybe e -> Branched e
MatchIntegral
          (EnumMap Word64 es -> Maybe es -> Branched es)
-> f (EnumMap Word64 es) -> f (Maybe es -> Branched es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (el -> er -> f es)
-> EnumMap Word64 el -> EnumMap Word64 er -> f (EnumMap Word64 es)
forall (f :: * -> *) a b c k.
Applicative f =>
(a -> b -> f c) -> EnumMap k a -> EnumMap k b -> f (EnumMap k c)
interverse el -> er -> f es
f EnumMap Word64 el
bl EnumMap Word64 er
br
          f (Maybe es -> Branched es) -> f (Maybe es) -> f (Branched es)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (Maybe es)
ds
alignBranch el -> er -> f es
f (MatchText Map Text el
bl Maybe el
dl) (MatchText Map Text er
br Maybe er
dr)
  | Map Text el -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text el
bl Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text er -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text er
br,
    Just f (Maybe es)
ds <- (el -> er -> f es) -> Maybe el -> Maybe er -> Maybe (f (Maybe es))
forall (f :: * -> *) l r s.
Applicative f =>
(l -> r -> f s) -> Maybe l -> Maybe r -> Maybe (f (Maybe s))
alignMaybe el -> er -> f es
f Maybe el
dl Maybe er
dr =
      f (Branched es) -> Maybe (f (Branched es))
forall a. a -> Maybe a
Just (f (Branched es) -> Maybe (f (Branched es)))
-> f (Branched es) -> Maybe (f (Branched es))
forall a b. (a -> b) -> a -> b
$
        Map Text es -> Maybe es -> Branched es
forall e. Map Text e -> Maybe e -> Branched e
MatchText
          (Map Text es -> Maybe es -> Branched es)
-> f (Map Text es) -> f (Maybe es -> Branched es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f es -> f es) -> Map Text (f es) -> f (Map Text es)
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) -> Map Text a -> f (Map Text b)
traverse f es -> f es
forall a. a -> a
id ((el -> er -> f es) -> Map Text el -> Map Text er -> Map Text (f es)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith el -> er -> f es
f Map Text el
bl Map Text er
br)
          f (Maybe es -> Branched es) -> f (Maybe es) -> f (Branched es)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (Maybe es)
ds
alignBranch el -> er -> f es
f (MatchRequest Map Reference (EnumMap CTag ([Mem], el))
bl el
pl) (MatchRequest Map Reference (EnumMap CTag ([Mem], er))
br er
pr)
  | Map Reference (EnumMap CTag ([Mem], el)) -> Set Reference
forall k a. Map k a -> Set k
Map.keysSet Map Reference (EnumMap CTag ([Mem], el))
bl Set Reference -> Set Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Map Reference (EnumMap CTag ([Mem], er)) -> Set Reference
forall k a. Map k a -> Set k
Map.keysSet Map Reference (EnumMap CTag ([Mem], er))
br,
    (Reference -> Bool) -> Set Reference -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Reference -> Bool
p (Map Reference (EnumMap CTag ([Mem], el)) -> Set Reference
forall k a. Map k a -> Set k
Map.keysSet Map Reference (EnumMap CTag ([Mem], el))
bl) =
      f (Branched es) -> Maybe (f (Branched es))
forall a. a -> Maybe a
Just (f (Branched es) -> Maybe (f (Branched es)))
-> f (Branched es) -> Maybe (f (Branched es))
forall a b. (a -> b) -> a -> b
$
        Map Reference (EnumMap CTag ([Mem], es)) -> es -> Branched es
forall e.
Map Reference (EnumMap CTag ([Mem], e)) -> e -> Branched e
MatchRequest
          (Map Reference (EnumMap CTag ([Mem], es)) -> es -> Branched es)
-> f (Map Reference (EnumMap CTag ([Mem], es)))
-> f (es -> Branched es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f (EnumMap CTag ([Mem], es)) -> f (EnumMap CTag ([Mem], es)))
-> Map Reference (f (EnumMap CTag ([Mem], es)))
-> f (Map Reference (EnumMap CTag ([Mem], es)))
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) -> Map Reference a -> f (Map Reference b)
traverse f (EnumMap CTag ([Mem], es)) -> f (EnumMap CTag ([Mem], es))
forall a. a -> a
id ((EnumMap CTag ([Mem], el)
 -> EnumMap CTag ([Mem], er) -> f (EnumMap CTag ([Mem], es)))
-> Map Reference (EnumMap CTag ([Mem], el))
-> Map Reference (EnumMap CTag ([Mem], er))
-> Map Reference (f (EnumMap CTag ([Mem], es)))
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith ((([Mem], el) -> ([Mem], er) -> f ([Mem], es))
-> EnumMap CTag ([Mem], el)
-> EnumMap CTag ([Mem], er)
-> f (EnumMap CTag ([Mem], es))
forall (f :: * -> *) a b c k.
Applicative f =>
(a -> b -> f c) -> EnumMap k a -> EnumMap k b -> f (EnumMap k c)
interverse ((el -> er -> f es) -> ([Mem], el) -> ([Mem], er) -> f ([Mem], es)
forall (f :: * -> *) l r s a.
Functor f =>
(l -> r -> f s) -> (a, l) -> (a, r) -> f (a, s)
alignCCs el -> er -> f es
f)) Map Reference (EnumMap CTag ([Mem], el))
bl Map Reference (EnumMap CTag ([Mem], er))
br)
          f (es -> Branched es) -> f es -> f (Branched es)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> el -> er -> f es
f el
pl er
pr
  where
    p :: Reference -> Bool
p Reference
r = EnumMap CTag ([Mem], el) -> EnumSet CTag
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap CTag ([Mem], el)
hsl EnumSet CTag -> EnumSet CTag -> Bool
forall a. Eq a => a -> a -> Bool
== EnumMap CTag ([Mem], er) -> EnumSet CTag
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap CTag ([Mem], er)
hsr Bool -> Bool -> Bool
&& (CTag -> Bool) -> [CTag] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CTag -> Bool
q (EnumMap CTag ([Mem], el) -> [CTag]
forall k a. EnumKey k => EnumMap k a -> [k]
keys EnumMap CTag ([Mem], el)
hsl)
      where
        hsl :: EnumMap CTag ([Mem], el)
hsl = Map Reference (EnumMap CTag ([Mem], el))
bl Map Reference (EnumMap CTag ([Mem], el))
-> Reference -> EnumMap CTag ([Mem], el)
forall k a. Ord k => Map k a -> k -> a
Map.! Reference
r
        hsr :: EnumMap CTag ([Mem], er)
hsr = Map Reference (EnumMap CTag ([Mem], er))
br Map Reference (EnumMap CTag ([Mem], er))
-> Reference -> EnumMap CTag ([Mem], er)
forall k a. Ord k => Map k a -> k -> a
Map.! Reference
r
        q :: CTag -> Bool
q CTag
t = ([Mem], el) -> [Mem]
forall a b. (a, b) -> a
fst (EnumMap CTag ([Mem], el)
hsl EnumMap CTag ([Mem], el) -> CTag -> ([Mem], el)
forall k a. EnumKey k => EnumMap k a -> k -> a
! CTag
t) [Mem] -> [Mem] -> Bool
forall a. Eq a => a -> a -> Bool
== ([Mem], er) -> [Mem]
forall a b. (a, b) -> a
fst (EnumMap CTag ([Mem], er)
hsr EnumMap CTag ([Mem], er) -> CTag -> ([Mem], er)
forall k a. EnumKey k => EnumMap k a -> k -> a
! CTag
t)
alignBranch el -> er -> f es
f (MatchData Reference
rfl EnumMap CTag ([Mem], el)
bl Maybe el
dl) (MatchData Reference
rfr EnumMap CTag ([Mem], er)
br Maybe er
dr)
  | Reference
rfl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rfr,
    EnumMap CTag ([Mem], el) -> EnumSet CTag
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap CTag ([Mem], el)
bl EnumSet CTag -> EnumSet CTag -> Bool
forall a. Eq a => a -> a -> Bool
== EnumMap CTag ([Mem], er) -> EnumSet CTag
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap CTag ([Mem], er)
br,
    (CTag -> Bool) -> [CTag] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\CTag
t -> ([Mem], el) -> [Mem]
forall a b. (a, b) -> a
fst (EnumMap CTag ([Mem], el)
bl EnumMap CTag ([Mem], el) -> CTag -> ([Mem], el)
forall k a. EnumKey k => EnumMap k a -> k -> a
! CTag
t) [Mem] -> [Mem] -> Bool
forall a. Eq a => a -> a -> Bool
== ([Mem], er) -> [Mem]
forall a b. (a, b) -> a
fst (EnumMap CTag ([Mem], er)
br EnumMap CTag ([Mem], er) -> CTag -> ([Mem], er)
forall k a. EnumKey k => EnumMap k a -> k -> a
! CTag
t)) (EnumMap CTag ([Mem], el) -> [CTag]
forall k a. EnumKey k => EnumMap k a -> [k]
keys EnumMap CTag ([Mem], el)
bl),
    Just f (Maybe es)
ds <- (el -> er -> f es) -> Maybe el -> Maybe er -> Maybe (f (Maybe es))
forall (f :: * -> *) l r s.
Applicative f =>
(l -> r -> f s) -> Maybe l -> Maybe r -> Maybe (f (Maybe s))
alignMaybe el -> er -> f es
f Maybe el
dl Maybe er
dr =
      f (Branched es) -> Maybe (f (Branched es))
forall a. a -> Maybe a
Just (f (Branched es) -> Maybe (f (Branched es)))
-> f (Branched es) -> Maybe (f (Branched es))
forall a b. (a -> b) -> a -> b
$ Reference -> EnumMap CTag ([Mem], es) -> Maybe es -> Branched es
forall e.
Reference -> EnumMap CTag ([Mem], e) -> Maybe e -> Branched e
MatchData Reference
rfl (EnumMap CTag ([Mem], es) -> Maybe es -> Branched es)
-> f (EnumMap CTag ([Mem], es)) -> f (Maybe es -> Branched es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Mem], el) -> ([Mem], er) -> f ([Mem], es))
-> EnumMap CTag ([Mem], el)
-> EnumMap CTag ([Mem], er)
-> f (EnumMap CTag ([Mem], es))
forall (f :: * -> *) a b c k.
Applicative f =>
(a -> b -> f c) -> EnumMap k a -> EnumMap k b -> f (EnumMap k c)
interverse ((el -> er -> f es) -> ([Mem], el) -> ([Mem], er) -> f ([Mem], es)
forall (f :: * -> *) l r s a.
Functor f =>
(l -> r -> f s) -> (a, l) -> (a, r) -> f (a, s)
alignCCs el -> er -> f es
f) EnumMap CTag ([Mem], el)
bl EnumMap CTag ([Mem], er)
br f (Maybe es -> Branched es) -> f (Maybe es) -> f (Branched es)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (Maybe es)
ds
alignBranch el -> er -> f es
f (MatchSum EnumMap Word64 ([Mem], el)
bl) (MatchSum EnumMap Word64 ([Mem], er)
br)
  | EnumMap Word64 ([Mem], el) -> EnumSet Word64
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap Word64 ([Mem], el)
bl EnumSet Word64 -> EnumSet Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== EnumMap Word64 ([Mem], er) -> EnumSet Word64
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap Word64 ([Mem], er)
br,
    (Word64 -> Bool) -> [Word64] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Word64
w -> ([Mem], el) -> [Mem]
forall a b. (a, b) -> a
fst (EnumMap Word64 ([Mem], el)
bl EnumMap Word64 ([Mem], el) -> Word64 -> ([Mem], el)
forall k a. EnumKey k => EnumMap k a -> k -> a
! Word64
w) [Mem] -> [Mem] -> Bool
forall a. Eq a => a -> a -> Bool
== ([Mem], er) -> [Mem]
forall a b. (a, b) -> a
fst (EnumMap Word64 ([Mem], er)
br EnumMap Word64 ([Mem], er) -> Word64 -> ([Mem], er)
forall k a. EnumKey k => EnumMap k a -> k -> a
! Word64
w)) (EnumMap Word64 ([Mem], el) -> [Word64]
forall k a. EnumKey k => EnumMap k a -> [k]
keys EnumMap Word64 ([Mem], el)
bl) =
      f (Branched es) -> Maybe (f (Branched es))
forall a. a -> Maybe a
Just (f (Branched es) -> Maybe (f (Branched es)))
-> f (Branched es) -> Maybe (f (Branched es))
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 ([Mem], es) -> Branched es
forall e. EnumMap Word64 ([Mem], e) -> Branched e
MatchSum (EnumMap Word64 ([Mem], es) -> Branched es)
-> f (EnumMap Word64 ([Mem], es)) -> f (Branched es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Mem], el) -> ([Mem], er) -> f ([Mem], es))
-> EnumMap Word64 ([Mem], el)
-> EnumMap Word64 ([Mem], er)
-> f (EnumMap Word64 ([Mem], es))
forall (f :: * -> *) a b c k.
Applicative f =>
(a -> b -> f c) -> EnumMap k a -> EnumMap k b -> f (EnumMap k c)
interverse ((el -> er -> f es) -> ([Mem], el) -> ([Mem], er) -> f ([Mem], es)
forall (f :: * -> *) l r s a.
Functor f =>
(l -> r -> f s) -> (a, l) -> (a, r) -> f (a, s)
alignCCs el -> er -> f es
f) EnumMap Word64 ([Mem], el)
bl EnumMap Word64 ([Mem], er)
br
alignBranch el -> er -> f es
f (MatchNumeric Reference
rl EnumMap Word64 el
bl Maybe el
dl) (MatchNumeric Reference
rr EnumMap Word64 er
br Maybe er
dr)
  | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr,
    EnumMap Word64 el -> EnumSet Word64
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap Word64 el
bl EnumSet Word64 -> EnumSet Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== EnumMap Word64 er -> EnumSet Word64
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap Word64 er
br,
    Just f (Maybe es)
ds <- (el -> er -> f es) -> Maybe el -> Maybe er -> Maybe (f (Maybe es))
forall (f :: * -> *) l r s.
Applicative f =>
(l -> r -> f s) -> Maybe l -> Maybe r -> Maybe (f (Maybe s))
alignMaybe el -> er -> f es
f Maybe el
dl Maybe er
dr =
      f (Branched es) -> Maybe (f (Branched es))
forall a. a -> Maybe a
Just (f (Branched es) -> Maybe (f (Branched es)))
-> f (Branched es) -> Maybe (f (Branched es))
forall a b. (a -> b) -> a -> b
$
        Reference -> EnumMap Word64 es -> Maybe es -> Branched es
forall e. Reference -> EnumMap Word64 e -> Maybe e -> Branched e
MatchNumeric Reference
rl
          (EnumMap Word64 es -> Maybe es -> Branched es)
-> f (EnumMap Word64 es) -> f (Maybe es -> Branched es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (el -> er -> f es)
-> EnumMap Word64 el -> EnumMap Word64 er -> f (EnumMap Word64 es)
forall (f :: * -> *) a b c k.
Applicative f =>
(a -> b -> f c) -> EnumMap k a -> EnumMap k b -> f (EnumMap k c)
interverse el -> er -> f es
f EnumMap Word64 el
bl EnumMap Word64 er
br
          f (Maybe es -> Branched es) -> f (Maybe es) -> f (Branched es)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (Maybe es)
ds
alignBranch el -> er -> f es
_ Branched el
_ Branched er
_ = Maybe (f (Branched es))
forall a. Maybe a
Nothing

alignCCs :: (Functor f) => (l -> r -> f s) -> (a, l) -> (a, r) -> f (a, s)
alignCCs :: forall (f :: * -> *) l r s a.
Functor f =>
(l -> r -> f s) -> (a, l) -> (a, r) -> f (a, s)
alignCCs l -> r -> f s
f (a
ccs, l
l) (a
_, r
r) = (,) a
ccs (s -> (a, s)) -> f s -> f (a, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> l -> r -> f s
f l
l r
r

matchLit :: Term v a -> Maybe Lit
matchLit :: forall v a. Term v a -> Maybe Lit
matchLit (Int' Int64
i) = Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Maybe Lit) -> Lit -> Maybe Lit
forall a b. (a -> b) -> a -> b
$ Int64 -> Lit
I Int64
i
matchLit (Nat' Word64
n) = Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Maybe Lit) -> Lit -> Maybe Lit
forall a b. (a -> b) -> a -> b
$ Word64 -> Lit
N Word64
n
matchLit (Float' Double
f) = Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Maybe Lit) -> Lit -> Maybe Lit
forall a b. (a -> b) -> a -> b
$ Double -> Lit
F Double
f
matchLit (Text' Text
t) = Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Maybe Lit) -> Lit -> Maybe Lit
forall a b. (a -> b) -> a -> b
$ Text -> Lit
T (Text -> Text
Util.Text.fromText Text
t)
matchLit (Char' Char
c) = Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Maybe Lit) -> Lit -> Maybe Lit
forall a b. (a -> b) -> a -> b
$ Char -> Lit
C Char
c
matchLit Term (F v a a) v a
_ = Maybe Lit
forall a. Maybe a
Nothing

pattern TLet ::
  (ABT.Var v) =>
  Direction Word16 ->
  v ->
  Mem ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v
pattern $mTLet :: forall {r} {v}.
Var v =>
Term ANormalF v
-> (Direction Word16
    -> v -> Mem -> Term ANormalF v -> Term ANormalF v -> r)
-> ((# #) -> r)
-> r
$bTLet :: forall v.
Var v =>
Direction Word16
-> v
-> Mem
-> Term ANormalF v
-> Term ANormalF v
-> Term ANormalF v
TLet d v m bn bo = ABTN.TTm (ALet d [m] bn (ABTN.TAbs v bo))

pattern TLetD ::
  (ABT.Var v) =>
  v ->
  Mem ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v
pattern $mTLetD :: forall {r} {v}.
Var v =>
Term ANormalF v
-> (v -> Mem -> Term ANormalF v -> Term ANormalF v -> r)
-> ((# #) -> r)
-> r
$bTLetD :: forall v.
Var v =>
v -> Mem -> Term ANormalF v -> Term ANormalF v -> Term ANormalF v
TLetD v m bn bo = ABTN.TTm (ALet Direct [m] bn (ABTN.TAbs v bo))

pattern TLets ::
  (ABT.Var v) =>
  Direction Word16 ->
  [v] ->
  [Mem] ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v
pattern $mTLets :: forall {r} {v}.
Var v =>
Term ANormalF v
-> (Direction Word16
    -> [v] -> [Mem] -> Term ANormalF v -> Term ANormalF v -> r)
-> ((# #) -> r)
-> r
$bTLets :: forall v.
Var v =>
Direction Word16
-> [v]
-> [Mem]
-> Term ANormalF v
-> Term ANormalF v
-> Term ANormalF v
TLets d vs ms bn bo = ABTN.TTm (ALet d ms bn (ABTN.TAbss vs bo))

pattern TName ::
  (ABT.Var v) =>
  v ->
  Either Reference v ->
  [v] ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v
pattern $mTName :: forall {r} {v}.
Var v =>
Term ANormalF v
-> (v -> Either Reference v -> [v] -> Term ANormalF v -> r)
-> ((# #) -> r)
-> r
$bTName :: forall v.
Var v =>
v
-> Either Reference v -> [v] -> Term ANormalF v -> Term ANormalF v
TName v f as bo = ABTN.TTm (AName f as (ABTN.TAbs v bo))

pattern Lit' :: Lit -> Term v a
pattern $mLit' :: forall {r} {v} {a}. Term v a -> (Lit -> r) -> ((# #) -> r) -> r
Lit' l <- (matchLit -> Just l)

pattern TLit ::
  (ABT.Var v) =>
  Lit ->
  ABTN.Term ANormalF v
pattern $mTLit :: forall {r} {v}.
Var v =>
Term ANormalF v -> (Lit -> r) -> ((# #) -> r) -> r
$bTLit :: forall v. Var v => Lit -> Term ANormalF v
TLit l = ABTN.TTm (ALit l)

pattern TBLit ::
  (ABT.Var v) =>
  Lit ->
  ABTN.Term ANormalF v
pattern $mTBLit :: forall {r} {v}.
Var v =>
Term ANormalF v -> (Lit -> r) -> ((# #) -> r) -> r
$bTBLit :: forall v. Var v => Lit -> Term ANormalF v
TBLit l = ABTN.TTm (ABLit l)

pattern TApp ::
  (ABT.Var v) =>
  Func v ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTApp :: forall {r} {v}.
Var v =>
Term ANormalF v -> (Func v -> [v] -> r) -> ((# #) -> r) -> r
$bTApp :: forall v. Var v => Func v -> [v] -> Term ANormalF v
TApp f args = ABTN.TTm (AApp f args)

pattern AApv :: v -> [v] -> ANormalF v e
pattern $mAApv :: forall {r} {v} {e}.
ANormalF v e -> (v -> [v] -> r) -> ((# #) -> r) -> r
$bAApv :: forall v e. v -> [v] -> ANormalF v e
AApv v args = AApp (FVar v) args

pattern TApv ::
  (ABT.Var v) =>
  v ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTApv :: forall {r} {v}.
Var v =>
Term ANormalF v -> (v -> [v] -> r) -> ((# #) -> r) -> r
$bTApv :: forall v. Var v => v -> [v] -> Term ANormalF v
TApv v args = TApp (FVar v) args

pattern ACom :: Reference -> [v] -> ANormalF v e
pattern $mACom :: forall {r} {v} {e}.
ANormalF v e -> (Reference -> [v] -> r) -> ((# #) -> r) -> r
$bACom :: forall v e. Reference -> [v] -> ANormalF v e
ACom r args = AApp (FComb r) args

pattern TCom ::
  (ABT.Var v) =>
  Reference ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTCom :: forall {r} {v}.
Var v =>
Term ANormalF v -> (Reference -> [v] -> r) -> ((# #) -> r) -> r
$bTCom :: forall v. Var v => Reference -> [v] -> Term ANormalF v
TCom r args = TApp (FComb r) args

pattern ACon :: Reference -> CTag -> [v] -> ANormalF v e
pattern $mACon :: forall {r} {v} {e}.
ANormalF v e
-> (Reference -> CTag -> [v] -> r) -> ((# #) -> r) -> r
$bACon :: forall v e. Reference -> CTag -> [v] -> ANormalF v e
ACon r t args = AApp (FCon r t) args

pattern TCon ::
  (ABT.Var v) =>
  Reference ->
  CTag ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTCon :: forall {r} {v}.
Var v =>
Term ANormalF v
-> (Reference -> CTag -> [v] -> r) -> ((# #) -> r) -> r
$bTCon :: forall v. Var v => Reference -> CTag -> [v] -> Term ANormalF v
TCon r t args = TApp (FCon r t) args

pattern AKon :: v -> [v] -> ANormalF v e
pattern $mAKon :: forall {r} {v} {e}.
ANormalF v e -> (v -> [v] -> r) -> ((# #) -> r) -> r
$bAKon :: forall v e. v -> [v] -> ANormalF v e
AKon v args = AApp (FCont v) args

pattern TKon ::
  (ABT.Var v) =>
  v ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTKon :: forall {r} {v}.
Var v =>
Term ANormalF v -> (v -> [v] -> r) -> ((# #) -> r) -> r
$bTKon :: forall v. Var v => v -> [v] -> Term ANormalF v
TKon v args = TApp (FCont v) args

pattern AReq :: Reference -> CTag -> [v] -> ANormalF v e
pattern $mAReq :: forall {r} {v} {e}.
ANormalF v e
-> (Reference -> CTag -> [v] -> r) -> ((# #) -> r) -> r
$bAReq :: forall v e. Reference -> CTag -> [v] -> ANormalF v e
AReq r t args = AApp (FReq r t) args

pattern TReq ::
  (ABT.Var v) =>
  Reference ->
  CTag ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTReq :: forall {r} {v}.
Var v =>
Term ANormalF v
-> (Reference -> CTag -> [v] -> r) -> ((# #) -> r) -> r
$bTReq :: forall v. Var v => Reference -> CTag -> [v] -> Term ANormalF v
TReq r t args = TApp (FReq r t) args

pattern APrm :: POp -> [v] -> ANormalF v e
pattern $mAPrm :: forall {r} {v} {e}.
ANormalF v e -> (POp -> [v] -> r) -> ((# #) -> r) -> r
$bAPrm :: forall v e. POp -> [v] -> ANormalF v e
APrm p args = AApp (FPrim (Left p)) args

pattern TPrm ::
  (ABT.Var v) =>
  POp ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTPrm :: forall {r} {v}.
Var v =>
Term ANormalF v -> (POp -> [v] -> r) -> ((# #) -> r) -> r
$bTPrm :: forall v. Var v => POp -> [v] -> Term ANormalF v
TPrm p args = TApp (FPrim (Left p)) args

pattern AFOp :: FOp -> [v] -> ANormalF v e
pattern $mAFOp :: forall {r} {v} {e}.
ANormalF v e -> (Word64 -> [v] -> r) -> ((# #) -> r) -> r
$bAFOp :: forall v e. Word64 -> [v] -> ANormalF v e
AFOp p args = AApp (FPrim (Right p)) args

pattern TFOp ::
  (ABT.Var v) =>
  FOp ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTFOp :: forall {r} {v}.
Var v =>
Term ANormalF v -> (Word64 -> [v] -> r) -> ((# #) -> r) -> r
$bTFOp :: forall v. Var v => Word64 -> [v] -> Term ANormalF v
TFOp p args = TApp (FPrim (Right p)) args

pattern THnd ::
  (ABT.Var v) =>
  [Reference] ->
  v ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v
pattern $mTHnd :: forall {r} {v}.
Var v =>
Term ANormalF v
-> ([Reference] -> v -> Term ANormalF v -> r) -> ((# #) -> r) -> r
$bTHnd :: forall v.
Var v =>
[Reference] -> v -> Term ANormalF v -> Term ANormalF v
THnd rs h b = ABTN.TTm (AHnd rs h b)

pattern TShift ::
  (ABT.Var v) =>
  Reference ->
  v ->
  ABTN.Term ANormalF v ->
  ABTN.Term ANormalF v
pattern $mTShift :: forall {r} {v}.
Var v =>
Term ANormalF v
-> (Reference -> v -> Term ANormalF v -> r) -> ((# #) -> r) -> r
$bTShift :: forall v.
Var v =>
Reference -> v -> Term ANormalF v -> Term ANormalF v
TShift i v e = ABTN.TTm (AShift i (ABTN.TAbs v e))

pattern TMatch ::
  (ABT.Var v) =>
  v ->
  Branched (ABTN.Term ANormalF v) ->
  ABTN.Term ANormalF v
pattern $mTMatch :: forall {r} {v}.
Var v =>
Term ANormalF v
-> (v -> Branched (Term ANormalF v) -> r) -> ((# #) -> r) -> r
$bTMatch :: forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v cs = ABTN.TTm (AMatch v cs)

pattern TFrc :: (ABT.Var v) => v -> ABTN.Term ANormalF v
pattern $mTFrc :: forall {r} {v}.
Var v =>
Term ANormalF v -> (v -> r) -> ((# #) -> r) -> r
$bTFrc :: forall v. Var v => v -> Term ANormalF v
TFrc v = ABTN.TTm (AFrc v)

pattern TVar :: (ABT.Var v) => v -> ABTN.Term ANormalF v
pattern $mTVar :: forall {r} {v}.
Var v =>
Term ANormalF v -> (v -> r) -> ((# #) -> r) -> r
$bTVar :: forall v. Var v => v -> Term ANormalF v
TVar v = ABTN.TTm (AVar v)

{-# COMPLETE TLet, TName, TVar, TApp, TFrc, TLit, THnd, TShift, TMatch #-}

{-# COMPLETE
  TLet,
  TName,
  TVar,
  TFrc,
  TApv,
  TCom,
  TCon,
  TKon,
  TReq,
  TPrm,
  TFOp,
  TLit,
  THnd,
  TShift,
  TMatch
  #-}

bind :: (Var v) => Cte v -> ANormal v -> ANormal v
bind :: forall v. Var v => Cte v -> ANormal v -> ANormal v
bind (ST Direction Word16
d [v]
us [Mem]
ms ANormal v
bu) = Direction Word16
-> [v] -> [Mem] -> ANormal v -> ANormal v -> ANormal v
forall v.
Var v =>
Direction Word16
-> [v]
-> [Mem]
-> Term ANormalF v
-> Term ANormalF v
-> Term ANormalF v
TLets Direction Word16
d [v]
us [Mem]
ms ANormal v
bu
bind (LZ v
u Either Reference v
f [v]
as) = v -> Either Reference v -> [v] -> ANormal v -> ANormal v
forall v.
Var v =>
v
-> Either Reference v -> [v] -> Term ANormalF v -> Term ANormalF v
TName v
u Either Reference v
f [v]
as

unbind :: (Var v) => ANormal v -> Maybe (Cte v, ANormal v)
unbind :: forall v. Var v => ANormal v -> Maybe (Cte v, ANormal v)
unbind (TLets Direction Word16
d [v]
us [Mem]
ms Term ANormalF v
bu Term ANormalF v
bd) = (Cte v, Term ANormalF v) -> Maybe (Cte v, Term ANormalF v)
forall a. a -> Maybe a
Just (Direction Word16 -> [v] -> [Mem] -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> [v] -> [Mem] -> s -> CTE v s
ST Direction Word16
d [v]
us [Mem]
ms Term ANormalF v
bu, Term ANormalF v
bd)
unbind (TName v
u Either Reference v
f [v]
as Term ANormalF v
bd) = (Cte v, Term ANormalF v) -> Maybe (Cte v, Term ANormalF v)
forall a. a -> Maybe a
Just (v -> Either Reference v -> [v] -> Cte v
forall v s. v -> Either Reference v -> [v] -> CTE v s
LZ v
u Either Reference v
f [v]
as, Term ANormalF v
bd)
unbind Term ANormalF v
_ = Maybe (Cte v, Term ANormalF v)
forall a. Maybe a
Nothing

unbinds :: (Var v) => ANormal v -> ([Cte v], ANormal v)
unbinds :: forall v. Var v => ANormal v -> ([Cte v], ANormal v)
unbinds (TLets Direction Word16
d [v]
us [Mem]
ms Term ANormalF v
bu (Term ANormalF v -> ([Cte v], Term ANormalF v)
forall v. Var v => ANormal v -> ([Cte v], ANormal v)
unbinds -> ([Cte v]
ctx, Term ANormalF v
bd))) =
  (Direction Word16 -> [v] -> [Mem] -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> [v] -> [Mem] -> s -> CTE v s
ST Direction Word16
d [v]
us [Mem]
ms Term ANormalF v
bu Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
ctx, Term ANormalF v
bd)
unbinds (TName v
u Either Reference v
f [v]
as (Term ANormalF v -> ([Cte v], Term ANormalF v)
forall v. Var v => ANormal v -> ([Cte v], ANormal v)
unbinds -> ([Cte v]
ctx, Term ANormalF v
bd))) = (v -> Either Reference v -> [v] -> Cte v
forall v s. v -> Either Reference v -> [v] -> CTE v s
LZ v
u Either Reference v
f [v]
as Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
ctx, Term ANormalF v
bd)
unbinds Term ANormalF v
tm = ([], Term ANormalF v
tm)

pattern TBind ::
  (Var v) =>
  Cte v ->
  ANormal v ->
  ANormal v
pattern $mTBind :: forall {r} {v}.
Var v =>
ANormal v -> (Cte v -> ANormal v -> r) -> ((# #) -> r) -> r
$bTBind :: forall v. Var v => Cte v -> ANormal v -> ANormal v
TBind bn bd <-
  (unbind -> Just (bn, bd))
  where
    TBind Cte v
bn ANormal v
bd = Cte v -> ANormal v -> ANormal v
forall v. Var v => Cte v -> ANormal v -> ANormal v
bind Cte v
bn ANormal v
bd

pattern TBinds :: (Var v) => [Cte v] -> ANormal v -> ANormal v
pattern $mTBinds :: forall {r} {v}.
Var v =>
ANormal v -> ([Cte v] -> ANormal v -> r) -> ((# #) -> r) -> r
$bTBinds :: forall v. Var v => [Cte v] -> ANormal v -> ANormal v
TBinds ctx bd <-
  (unbinds -> (ctx, bd))
  where
    TBinds [Cte v]
ctx ANormal v
bd = (Cte v -> ANormal v -> ANormal v)
-> ANormal v -> [Cte v] -> ANormal v
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Cte v -> ANormal v -> ANormal v
forall v. Var v => Cte v -> ANormal v -> ANormal v
bind ANormal v
bd [Cte v]
ctx

{-# COMPLETE TBinds #-}

data SeqEnd = SLeft | SRight
  deriving (SeqEnd -> SeqEnd -> Bool
(SeqEnd -> SeqEnd -> Bool)
-> (SeqEnd -> SeqEnd -> Bool) -> Eq SeqEnd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SeqEnd -> SeqEnd -> Bool
== :: SeqEnd -> SeqEnd -> Bool
$c/= :: SeqEnd -> SeqEnd -> Bool
/= :: SeqEnd -> SeqEnd -> Bool
Eq, Eq SeqEnd
Eq SeqEnd =>
(SeqEnd -> SeqEnd -> Ordering)
-> (SeqEnd -> SeqEnd -> Bool)
-> (SeqEnd -> SeqEnd -> Bool)
-> (SeqEnd -> SeqEnd -> Bool)
-> (SeqEnd -> SeqEnd -> Bool)
-> (SeqEnd -> SeqEnd -> SeqEnd)
-> (SeqEnd -> SeqEnd -> SeqEnd)
-> Ord SeqEnd
SeqEnd -> SeqEnd -> Bool
SeqEnd -> SeqEnd -> Ordering
SeqEnd -> SeqEnd -> SeqEnd
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 :: SeqEnd -> SeqEnd -> Ordering
compare :: SeqEnd -> SeqEnd -> Ordering
$c< :: SeqEnd -> SeqEnd -> Bool
< :: SeqEnd -> SeqEnd -> Bool
$c<= :: SeqEnd -> SeqEnd -> Bool
<= :: SeqEnd -> SeqEnd -> Bool
$c> :: SeqEnd -> SeqEnd -> Bool
> :: SeqEnd -> SeqEnd -> Bool
$c>= :: SeqEnd -> SeqEnd -> Bool
>= :: SeqEnd -> SeqEnd -> Bool
$cmax :: SeqEnd -> SeqEnd -> SeqEnd
max :: SeqEnd -> SeqEnd -> SeqEnd
$cmin :: SeqEnd -> SeqEnd -> SeqEnd
min :: SeqEnd -> SeqEnd -> SeqEnd
Ord, Int -> SeqEnd
SeqEnd -> Int
SeqEnd -> [SeqEnd]
SeqEnd -> SeqEnd
SeqEnd -> SeqEnd -> [SeqEnd]
SeqEnd -> SeqEnd -> SeqEnd -> [SeqEnd]
(SeqEnd -> SeqEnd)
-> (SeqEnd -> SeqEnd)
-> (Int -> SeqEnd)
-> (SeqEnd -> Int)
-> (SeqEnd -> [SeqEnd])
-> (SeqEnd -> SeqEnd -> [SeqEnd])
-> (SeqEnd -> SeqEnd -> [SeqEnd])
-> (SeqEnd -> SeqEnd -> SeqEnd -> [SeqEnd])
-> Enum SeqEnd
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SeqEnd -> SeqEnd
succ :: SeqEnd -> SeqEnd
$cpred :: SeqEnd -> SeqEnd
pred :: SeqEnd -> SeqEnd
$ctoEnum :: Int -> SeqEnd
toEnum :: Int -> SeqEnd
$cfromEnum :: SeqEnd -> Int
fromEnum :: SeqEnd -> Int
$cenumFrom :: SeqEnd -> [SeqEnd]
enumFrom :: SeqEnd -> [SeqEnd]
$cenumFromThen :: SeqEnd -> SeqEnd -> [SeqEnd]
enumFromThen :: SeqEnd -> SeqEnd -> [SeqEnd]
$cenumFromTo :: SeqEnd -> SeqEnd -> [SeqEnd]
enumFromTo :: SeqEnd -> SeqEnd -> [SeqEnd]
$cenumFromThenTo :: SeqEnd -> SeqEnd -> SeqEnd -> [SeqEnd]
enumFromThenTo :: SeqEnd -> SeqEnd -> SeqEnd -> [SeqEnd]
Enum, Int -> SeqEnd -> ShowS
[SeqEnd] -> ShowS
SeqEnd -> String
(Int -> SeqEnd -> ShowS)
-> (SeqEnd -> String) -> ([SeqEnd] -> ShowS) -> Show SeqEnd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SeqEnd -> ShowS
showsPrec :: Int -> SeqEnd -> ShowS
$cshow :: SeqEnd -> String
show :: SeqEnd -> String
$cshowList :: [SeqEnd] -> ShowS
showList :: [SeqEnd] -> ShowS
Show)

-- Note: MatchNumeric is a new form for matching directly on boxed
-- numeric data. This leaves MatchIntegral around so that builtins can
-- continue to use it. But interchanged code can be free of unboxed
-- details.
data Branched e
  = MatchIntegral (EnumMap Word64 e) (Maybe e)
  | MatchText (Map.Map Util.Text.Text e) (Maybe e)
  | MatchRequest (Map Reference (EnumMap CTag ([Mem], e))) e
  | MatchEmpty
  | MatchData Reference (EnumMap CTag ([Mem], e)) (Maybe e)
  | MatchSum (EnumMap Word64 ([Mem], e))
  | MatchNumeric Reference (EnumMap Word64 e) (Maybe e)
  deriving (Int -> Branched e -> ShowS
[Branched e] -> ShowS
Branched e -> String
(Int -> Branched e -> ShowS)
-> (Branched e -> String)
-> ([Branched e] -> ShowS)
-> Show (Branched e)
forall e. Show e => Int -> Branched e -> ShowS
forall e. Show e => [Branched e] -> ShowS
forall e. Show e => Branched e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> Branched e -> ShowS
showsPrec :: Int -> Branched e -> ShowS
$cshow :: forall e. Show e => Branched e -> String
show :: Branched e -> String
$cshowList :: forall e. Show e => [Branched e] -> ShowS
showList :: [Branched e] -> ShowS
Show, Branched e -> Branched e -> Bool
(Branched e -> Branched e -> Bool)
-> (Branched e -> Branched e -> Bool) -> Eq (Branched e)
forall e. Eq e => Branched e -> Branched e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e. Eq e => Branched e -> Branched e -> Bool
== :: Branched e -> Branched e -> Bool
$c/= :: forall e. Eq e => Branched e -> Branched e -> Bool
/= :: Branched e -> Branched e -> Bool
Eq, (forall a b. (a -> b) -> Branched a -> Branched b)
-> (forall a b. a -> Branched b -> Branched a) -> Functor Branched
forall a b. a -> Branched b -> Branched a
forall a b. (a -> b) -> Branched a -> Branched b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Branched a -> Branched b
fmap :: forall a b. (a -> b) -> Branched a -> Branched b
$c<$ :: forall a b. a -> Branched b -> Branched a
<$ :: forall a b. a -> Branched b -> Branched a
Functor, (forall m. Monoid m => Branched m -> m)
-> (forall m a. Monoid m => (a -> m) -> Branched a -> m)
-> (forall m a. Monoid m => (a -> m) -> Branched a -> m)
-> (forall a b. (a -> b -> b) -> b -> Branched a -> b)
-> (forall a b. (a -> b -> b) -> b -> Branched a -> b)
-> (forall b a. (b -> a -> b) -> b -> Branched a -> b)
-> (forall b a. (b -> a -> b) -> b -> Branched a -> b)
-> (forall a. (a -> a -> a) -> Branched a -> a)
-> (forall a. (a -> a -> a) -> Branched a -> a)
-> (forall a. Branched a -> [a])
-> (forall a. Branched a -> Bool)
-> (forall a. Branched a -> Int)
-> (forall a. Eq a => a -> Branched a -> Bool)
-> (forall a. Ord a => Branched a -> a)
-> (forall a. Ord a => Branched a -> a)
-> (forall a. Num a => Branched a -> a)
-> (forall a. Num a => Branched a -> a)
-> Foldable Branched
forall a. Eq a => a -> Branched a -> Bool
forall a. Num a => Branched a -> a
forall a. Ord a => Branched a -> a
forall m. Monoid m => Branched m -> m
forall a. Branched a -> Bool
forall a. Branched a -> Int
forall a. Branched a -> [a]
forall a. (a -> a -> a) -> Branched a -> a
forall m a. Monoid m => (a -> m) -> Branched a -> m
forall b a. (b -> a -> b) -> b -> Branched a -> b
forall a b. (a -> b -> b) -> b -> Branched a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Branched m -> m
fold :: forall m. Monoid m => Branched m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Branched a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Branched a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Branched a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Branched a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Branched a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Branched a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Branched a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Branched a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Branched a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Branched a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Branched a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Branched a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Branched a -> a
foldr1 :: forall a. (a -> a -> a) -> Branched a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Branched a -> a
foldl1 :: forall a. (a -> a -> a) -> Branched a -> a
$ctoList :: forall a. Branched a -> [a]
toList :: forall a. Branched a -> [a]
$cnull :: forall a. Branched a -> Bool
null :: forall a. Branched a -> Bool
$clength :: forall a. Branched a -> Int
length :: forall a. Branched a -> Int
$celem :: forall a. Eq a => a -> Branched a -> Bool
elem :: forall a. Eq a => a -> Branched a -> Bool
$cmaximum :: forall a. Ord a => Branched a -> a
maximum :: forall a. Ord a => Branched a -> a
$cminimum :: forall a. Ord a => Branched a -> a
minimum :: forall a. Ord a => Branched a -> a
$csum :: forall a. Num a => Branched a -> a
sum :: forall a. Num a => Branched a -> a
$cproduct :: forall a. Num a => Branched a -> a
product :: forall a. Num a => Branched a -> a
Foldable, Functor Branched
Foldable Branched
(Functor Branched, Foldable Branched) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Branched a -> f (Branched b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Branched (f a) -> f (Branched a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Branched a -> m (Branched b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Branched (m a) -> m (Branched a))
-> Traversable Branched
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Branched (m a) -> m (Branched a)
forall (f :: * -> *) a.
Applicative f =>
Branched (f a) -> f (Branched a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Branched a -> m (Branched b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Branched a -> f (Branched b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Branched a -> f (Branched b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Branched a -> f (Branched b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Branched (f a) -> f (Branched a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Branched (f a) -> f (Branched a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Branched a -> m (Branched b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Branched a -> m (Branched b)
$csequence :: forall (m :: * -> *) a. Monad m => Branched (m a) -> m (Branched a)
sequence :: forall (m :: * -> *) a. Monad m => Branched (m a) -> m (Branched a)
Traversable)

-- Data cases expected to cover all constructors
pattern MatchDataCover :: Reference -> EnumMap CTag ([Mem], e) -> Branched e
pattern $mMatchDataCover :: forall {r} {e}.
Branched e
-> (Reference -> EnumMap CTag ([Mem], e) -> r) -> ((# #) -> r) -> r
$bMatchDataCover :: forall e. Reference -> EnumMap CTag ([Mem], e) -> Branched e
MatchDataCover r m = MatchData r m Nothing

data BranchAccum v
  = AccumEmpty
  | AccumIntegral
      Reference
      (Maybe (ANormal v))
      (EnumMap Word64 (ANormal v))
  | AccumText
      (Maybe (ANormal v))
      (Map.Map Util.Text.Text (ANormal v))
  | AccumDefault (ANormal v)
  | AccumPure (ANormal v)
  | AccumRequest
      (Map Reference (EnumMap CTag ([Mem], ANormal v)))
      (Maybe (ANormal v))
  | AccumData
      Reference
      (Maybe (ANormal v))
      (EnumMap CTag ([Mem], ANormal v))
  | AccumSeqEmpty (ANormal v)
  | AccumSeqView
      SeqEnd
      (Maybe (ANormal v)) -- empty
      (ANormal v) -- cons/snoc
  | AccumSeqSplit
      SeqEnd
      Int -- split at
      (Maybe (ANormal v)) -- default
      (ANormal v) -- split

instance Semigroup (BranchAccum v) where
  BranchAccum v
AccumEmpty <> :: BranchAccum v -> BranchAccum v -> BranchAccum v
<> BranchAccum v
r = BranchAccum v
r
  BranchAccum v
l <> BranchAccum v
AccumEmpty = BranchAccum v
l
  AccumIntegral Reference
rl Maybe (ANormal v)
dl EnumMap Word64 (ANormal v)
cl <> AccumIntegral Reference
rr Maybe (ANormal v)
dr EnumMap Word64 (ANormal v)
cr
    | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr = Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
AccumIntegral Reference
rl (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (ANormal v)
dr) (EnumMap Word64 (ANormal v) -> BranchAccum v)
-> EnumMap Word64 (ANormal v) -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ EnumMap Word64 (ANormal v)
cl EnumMap Word64 (ANormal v)
-> EnumMap Word64 (ANormal v) -> EnumMap Word64 (ANormal v)
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 (ANormal v)
cr
  AccumText Maybe (ANormal v)
dl Map Text (ANormal v)
cl <> AccumText Maybe (ANormal v)
dr Map Text (ANormal v)
cr =
    Maybe (ANormal v) -> Map Text (ANormal v) -> BranchAccum v
forall v.
Maybe (ANormal v) -> Map Text (ANormal v) -> BranchAccum v
AccumText (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (ANormal v)
dr) (Map Text (ANormal v)
cl Map Text (ANormal v)
-> Map Text (ANormal v) -> Map Text (ANormal v)
forall a. Semigroup a => a -> a -> a
<> Map Text (ANormal v)
cr)
  AccumData Reference
rl Maybe (ANormal v)
dl EnumMap CTag ([Mem], ANormal v)
cl <> AccumData Reference
rr Maybe (ANormal v)
dr EnumMap CTag ([Mem], ANormal v)
cr
    | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr = Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
AccumData Reference
rl (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (ANormal v)
dr) (EnumMap CTag ([Mem], ANormal v)
cl EnumMap CTag ([Mem], ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
forall a. Semigroup a => a -> a -> a
<> EnumMap CTag ([Mem], ANormal v)
cr)
  AccumDefault ANormal v
dl <> AccumIntegral Reference
r Maybe (ANormal v)
_ EnumMap Word64 (ANormal v)
cr =
    Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
AccumIntegral Reference
r (ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dl) EnumMap Word64 (ANormal v)
cr
  AccumDefault ANormal v
dl <> AccumText Maybe (ANormal v)
_ Map Text (ANormal v)
cr =
    Maybe (ANormal v) -> Map Text (ANormal v) -> BranchAccum v
forall v.
Maybe (ANormal v) -> Map Text (ANormal v) -> BranchAccum v
AccumText (ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dl) Map Text (ANormal v)
cr
  AccumDefault ANormal v
dl <> AccumData Reference
rr Maybe (ANormal v)
_ EnumMap CTag ([Mem], ANormal v)
cr =
    Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
AccumData Reference
rr (ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dl) EnumMap CTag ([Mem], ANormal v)
cr
  AccumIntegral Reference
r Maybe (ANormal v)
dl EnumMap Word64 (ANormal v)
cl <> AccumDefault ANormal v
dr =
    Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
AccumIntegral Reference
r (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dr) EnumMap Word64 (ANormal v)
cl
  AccumText Maybe (ANormal v)
dl Map Text (ANormal v)
cl <> AccumDefault ANormal v
dr =
    Maybe (ANormal v) -> Map Text (ANormal v) -> BranchAccum v
forall v.
Maybe (ANormal v) -> Map Text (ANormal v) -> BranchAccum v
AccumText (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dr) Map Text (ANormal v)
cl
  AccumData Reference
rl Maybe (ANormal v)
dl EnumMap CTag ([Mem], ANormal v)
cl <> AccumDefault ANormal v
dr =
    Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
AccumData Reference
rl (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dr) EnumMap CTag ([Mem], ANormal v)
cl
  l :: BranchAccum v
l@(AccumPure ANormal v
_) <> AccumPure ANormal v
_ = BranchAccum v
l
  AccumPure ANormal v
dl <> AccumRequest Map Reference (EnumMap CTag ([Mem], ANormal v))
hr Maybe (ANormal v)
_ = Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Maybe (ANormal v) -> BranchAccum v
forall v.
Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Maybe (ANormal v) -> BranchAccum v
AccumRequest Map Reference (EnumMap CTag ([Mem], ANormal v))
hr (ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dl)
  AccumRequest Map Reference (EnumMap CTag ([Mem], ANormal v))
hl Maybe (ANormal v)
dl <> AccumPure ANormal v
dr =
    Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Maybe (ANormal v) -> BranchAccum v
forall v.
Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Maybe (ANormal v) -> BranchAccum v
AccumRequest Map Reference (EnumMap CTag ([Mem], ANormal v))
hl (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dr)
  AccumRequest Map Reference (EnumMap CTag ([Mem], ANormal v))
hl Maybe (ANormal v)
dl <> AccumRequest Map Reference (EnumMap CTag ([Mem], ANormal v))
hr Maybe (ANormal v)
dr =
    Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Maybe (ANormal v) -> BranchAccum v
forall v.
Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Maybe (ANormal v) -> BranchAccum v
AccumRequest Map Reference (EnumMap CTag ([Mem], ANormal v))
hm (Maybe (ANormal v) -> BranchAccum v)
-> Maybe (ANormal v) -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (ANormal v)
dr
    where
      hm :: Map Reference (EnumMap CTag ([Mem], ANormal v))
hm = (EnumMap CTag ([Mem], ANormal v)
 -> EnumMap CTag ([Mem], ANormal v)
 -> EnumMap CTag ([Mem], ANormal v))
-> Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Map Reference (EnumMap CTag ([Mem], ANormal v))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith EnumMap CTag ([Mem], ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
forall a. Semigroup a => a -> a -> a
(<>) Map Reference (EnumMap CTag ([Mem], ANormal v))
hl Map Reference (EnumMap CTag ([Mem], ANormal v))
hr
  l :: BranchAccum v
l@(AccumSeqEmpty ANormal v
_) <> AccumSeqEmpty ANormal v
_ = BranchAccum v
l
  AccumSeqEmpty ANormal v
eml <> AccumSeqView SeqEnd
er Maybe (ANormal v)
_ ANormal v
cnr =
    SeqEnd -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v. SeqEnd -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqView SeqEnd
er (ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
eml) ANormal v
cnr
  AccumSeqView SeqEnd
el Maybe (ANormal v)
eml ANormal v
cnl <> AccumSeqEmpty ANormal v
emr =
    SeqEnd -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v. SeqEnd -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqView SeqEnd
el (Maybe (ANormal v)
eml Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
emr) ANormal v
cnl
  AccumSeqView SeqEnd
el Maybe (ANormal v)
eml ANormal v
cnl <> AccumSeqView SeqEnd
er Maybe (ANormal v)
emr ANormal v
_
    | SeqEnd
el SeqEnd -> SeqEnd -> Bool
forall a. Eq a => a -> a -> Bool
/= SeqEnd
er =
        String -> BranchAccum v
forall a. HasCallStack => String -> a
internalBug String
"AccumSeqView: trying to merge views of opposite ends"
    | Bool
otherwise = SeqEnd -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v. SeqEnd -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqView SeqEnd
el (Maybe (ANormal v)
eml Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (ANormal v)
emr) ANormal v
cnl
  AccumSeqView SeqEnd
_ Maybe (ANormal v)
_ ANormal v
_ <> AccumDefault ANormal v
_ =
    String -> BranchAccum v
forall a. HasCallStack => String -> a
internalBug String
"seq views may not have defaults"
  AccumDefault ANormal v
_ <> AccumSeqView SeqEnd
_ Maybe (ANormal v)
_ ANormal v
_ =
    String -> BranchAccum v
forall a. HasCallStack => String -> a
internalBug String
"seq views may not have defaults"
  AccumSeqSplit SeqEnd
el Int
nl Maybe (ANormal v)
dl ANormal v
bl <> AccumSeqSplit SeqEnd
er Int
nr Maybe (ANormal v)
dr ANormal v
_
    | SeqEnd
el SeqEnd -> SeqEnd -> Bool
forall a. Eq a => a -> a -> Bool
/= SeqEnd
er =
        String -> BranchAccum v
forall a. HasCallStack => String -> a
internalBug
          String
"AccumSeqSplit: trying to merge splits at opposite ends"
    | Int
nl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nr =
        String -> BranchAccum v
forall a. HasCallStack => String -> a
internalBug
          String
"AccumSeqSplit: trying to merge splits at different positions"
    | Bool
otherwise =
        SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v.
SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqSplit SeqEnd
el Int
nl (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (ANormal v)
dr) ANormal v
bl
  AccumDefault ANormal v
dl <> AccumSeqSplit SeqEnd
er Int
nr Maybe (ANormal v)
_ ANormal v
br =
    SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v.
SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqSplit SeqEnd
er Int
nr (ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dl) ANormal v
br
  AccumSeqSplit SeqEnd
el Int
nl Maybe (ANormal v)
dl ANormal v
bl <> AccumDefault ANormal v
dr =
    SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v.
SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqSplit SeqEnd
el Int
nl (Maybe (ANormal v)
dl Maybe (ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dr) ANormal v
bl
  BranchAccum v
_ <> BranchAccum v
_ = String -> BranchAccum v
forall a. HasCallStack => String -> a
internalBug (String -> BranchAccum v) -> String -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ String
"cannot merge data cases for different types"

instance Monoid (BranchAccum e) where
  mempty :: BranchAccum e
mempty = BranchAccum e
forall e. BranchAccum e
AccumEmpty

-- Foreign operation, indexed by words
type FOp = Word64

data Func v
  = -- variable
    FVar v
  | -- top-level combinator
    FComb !Reference
  | -- continuation jump
    FCont v
  | -- data constructor
    FCon !Reference !CTag
  | -- ability request
    FReq !Reference !CTag
  | -- prim op
    FPrim (Either POp FOp)
  deriving (Int -> Func v -> ShowS
[Func v] -> ShowS
Func v -> String
(Int -> Func v -> ShowS)
-> (Func v -> String) -> ([Func v] -> ShowS) -> Show (Func v)
forall v. Show v => Int -> Func v -> ShowS
forall v. Show v => [Func v] -> ShowS
forall v. Show v => Func v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> Func v -> ShowS
showsPrec :: Int -> Func v -> ShowS
$cshow :: forall v. Show v => Func v -> String
show :: Func v -> String
$cshowList :: forall v. Show v => [Func v] -> ShowS
showList :: [Func v] -> ShowS
Show, Func v -> Func v -> Bool
(Func v -> Func v -> Bool)
-> (Func v -> Func v -> Bool) -> Eq (Func v)
forall v. Eq v => Func v -> Func v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall v. Eq v => Func v -> Func v -> Bool
== :: Func v -> Func v -> Bool
$c/= :: forall v. Eq v => Func v -> Func v -> Bool
/= :: Func v -> Func v -> Bool
Eq, (forall a b. (a -> b) -> Func a -> Func b)
-> (forall a b. a -> Func b -> Func a) -> Functor Func
forall a b. a -> Func b -> Func a
forall a b. (a -> b) -> Func a -> Func b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Func a -> Func b
fmap :: forall a b. (a -> b) -> Func a -> Func b
$c<$ :: forall a b. a -> Func b -> Func a
<$ :: forall a b. a -> Func b -> Func a
Functor, (forall m. Monoid m => Func m -> m)
-> (forall m a. Monoid m => (a -> m) -> Func a -> m)
-> (forall m a. Monoid m => (a -> m) -> Func a -> m)
-> (forall a b. (a -> b -> b) -> b -> Func a -> b)
-> (forall a b. (a -> b -> b) -> b -> Func a -> b)
-> (forall b a. (b -> a -> b) -> b -> Func a -> b)
-> (forall b a. (b -> a -> b) -> b -> Func a -> b)
-> (forall a. (a -> a -> a) -> Func a -> a)
-> (forall a. (a -> a -> a) -> Func a -> a)
-> (forall a. Func a -> [a])
-> (forall a. Func a -> Bool)
-> (forall a. Func a -> Int)
-> (forall a. Eq a => a -> Func a -> Bool)
-> (forall a. Ord a => Func a -> a)
-> (forall a. Ord a => Func a -> a)
-> (forall a. Num a => Func a -> a)
-> (forall a. Num a => Func a -> a)
-> Foldable Func
forall a. Eq a => a -> Func a -> Bool
forall a. Num a => Func a -> a
forall a. Ord a => Func a -> a
forall m. Monoid m => Func m -> m
forall a. Func a -> Bool
forall a. Func a -> Int
forall a. Func a -> [a]
forall a. (a -> a -> a) -> Func a -> a
forall m a. Monoid m => (a -> m) -> Func a -> m
forall b a. (b -> a -> b) -> b -> Func a -> b
forall a b. (a -> b -> b) -> b -> Func a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Func m -> m
fold :: forall m. Monoid m => Func m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Func a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Func a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Func a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Func a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Func a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Func a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Func a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Func a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Func a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Func a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Func a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Func a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Func a -> a
foldr1 :: forall a. (a -> a -> a) -> Func a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Func a -> a
foldl1 :: forall a. (a -> a -> a) -> Func a -> a
$ctoList :: forall a. Func a -> [a]
toList :: forall a. Func a -> [a]
$cnull :: forall a. Func a -> Bool
null :: forall a. Func a -> Bool
$clength :: forall a. Func a -> Int
length :: forall a. Func a -> Int
$celem :: forall a. Eq a => a -> Func a -> Bool
elem :: forall a. Eq a => a -> Func a -> Bool
$cmaximum :: forall a. Ord a => Func a -> a
maximum :: forall a. Ord a => Func a -> a
$cminimum :: forall a. Ord a => Func a -> a
minimum :: forall a. Ord a => Func a -> a
$csum :: forall a. Num a => Func a -> a
sum :: forall a. Num a => Func a -> a
$cproduct :: forall a. Num a => Func a -> a
product :: forall a. Num a => Func a -> a
Foldable, Functor Func
Foldable Func
(Functor Func, Foldable Func) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Func a -> f (Func b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Func (f a) -> f (Func a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Func a -> m (Func b))
-> (forall (m :: * -> *) a. Monad m => Func (m a) -> m (Func a))
-> Traversable Func
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Func (m a) -> m (Func a)
forall (f :: * -> *) a. Applicative f => Func (f a) -> f (Func a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Func a -> m (Func b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Func a -> f (Func b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Func a -> f (Func b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Func a -> f (Func b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Func (f a) -> f (Func a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Func (f a) -> f (Func a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Func a -> m (Func b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Func a -> m (Func b)
$csequence :: forall (m :: * -> *) a. Monad m => Func (m a) -> m (Func a)
sequence :: forall (m :: * -> *) a. Monad m => Func (m a) -> m (Func a)
Traversable)

data Lit
  = I Int64
  | N Word64
  | F Double
  | T Util.Text.Text
  | C Char
  | LM Referent
  | LY Reference
  deriving (Int -> Lit -> ShowS
[Lit] -> ShowS
Lit -> String
(Int -> Lit -> ShowS)
-> (Lit -> String) -> ([Lit] -> ShowS) -> Show Lit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Lit -> ShowS
showsPrec :: Int -> Lit -> ShowS
$cshow :: Lit -> String
show :: Lit -> String
$cshowList :: [Lit] -> ShowS
showList :: [Lit] -> ShowS
Show, Lit -> Lit -> Bool
(Lit -> Lit -> Bool) -> (Lit -> Lit -> Bool) -> Eq Lit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Lit -> Lit -> Bool
== :: Lit -> Lit -> Bool
$c/= :: Lit -> Lit -> Bool
/= :: Lit -> Lit -> Bool
Eq)

litRef :: Lit -> Reference
litRef :: Lit -> Reference
litRef (I Int64
_) = Reference
Ty.intRef
litRef (N Word64
_) = Reference
Ty.natRef
litRef (F Double
_) = Reference
Ty.floatRef
litRef (T Text
_) = Reference
Ty.textRef
litRef (C Char
_) = Reference
Ty.charRef
litRef (LM Referent
_) = Reference
Ty.termLinkRef
litRef (LY Reference
_) = Reference
Ty.typeLinkRef

-- Note: Enum/Bounded instances should only be used for things like
-- getting a list of all ops. Using auto-generated numberings for
-- serialization, for instance, could cause observable changes to
-- formats that we want to control and version.
data POp
  = -- Int
    ADDI
  | SUBI
  | MULI
  | DIVI -- +,-,*,/
  | SGNI
  | NEGI
  | MODI -- sgn,neg,mod
  | POWI
  | SHLI
  | SHRI -- pow,shiftl,shiftr
  | INCI
  | DECI
  | LEQI
  | EQLI -- inc,dec,<=,==
  -- Nat
  | ADDN
  | SUBN
  | MULN
  | DIVN -- +,-,*,/
  | MODN
  | TZRO
  | LZRO
  | POPC -- mod,trailing/leadingZeros,popCount
  | POWN
  | SHLN
  | SHRN -- pow,shiftl,shiftr
  | ANDN
  | IORN
  | XORN
  | COMN -- and,or,xor,complement
  | INCN
  | DECN
  | LEQN
  | EQLN -- inc,dec,<=,==
  -- Float
  | ADDF
  | SUBF
  | MULF
  | DIVF -- +,-,*,/
  | MINF
  | MAXF
  | LEQF
  | EQLF -- min,max,<=,==
  | POWF
  | EXPF
  | SQRT
  | LOGF -- pow,exp,sqrt,log
  | LOGB -- logBase
  | ABSF
  | CEIL
  | FLOR
  | TRNF -- abs,ceil,floor,truncate
  | RNDF -- round
  -- Trig
  | COSF
  | ACOS
  | COSH
  | ACSH -- cos,acos,cosh,acosh
  | SINF
  | ASIN
  | SINH
  | ASNH -- sin,asin,sinh,asinh
  | TANF
  | ATAN
  | TANH
  | ATNH -- tan,atan,tanh,atanh
  | ATN2 -- atan2
  -- Text
  | CATT
  | TAKT
  | DRPT
  | SIZT -- ++,take,drop,size
  | IXOT -- indexOf
  | UCNS
  | USNC
  | EQLT
  | LEQT -- uncons,unsnoc,==,<=
  | PAKT
  | UPKT -- pack,unpack
  -- Sequence
  | CATS
  | TAKS
  | DRPS
  | SIZS -- ++,take,drop,size
  | CONS
  | SNOC
  | IDXS
  | BLDS -- cons,snoc,at,build
  | VWLS
  | VWRS
  | SPLL
  | SPLR -- viewl,viewr,splitl,splitr
  -- Bytes
  | PAKB
  | UPKB
  | TAKB
  | DRPB -- pack,unpack,take,drop
  | IXOB -- indexOf
  | IDXB
  | SIZB
  | FLTB
  | CATB -- index,size,flatten,append
  -- Conversion
  | ITOF
  | NTOF
  | ITOT
  | NTOT
  | TTOI
  | TTON
  | TTOF
  | FTOT
  | -- Concurrency
    FORK
  | -- Universal operations
    EQLU
  | CMPU
  | EROR
  | -- Code
    MISS
  | CACH
  | LKUP
  | LOAD -- isMissing,cache_,lookup,load
  | CVLD
  | SDBX -- validate, sandbox
  | VALU
  | TLTT -- value, Term.Link.toText
  -- Debug
  | PRNT
  | INFO
  | TRCE
  | DBTX
  | -- STM
    ATOM
  | TFRC -- try force
  | SDBL -- sandbox link list
  | SDBV -- sandbox check for Values
  deriving (Int -> POp -> ShowS
[POp] -> ShowS
POp -> String
(Int -> POp -> ShowS)
-> (POp -> String) -> ([POp] -> ShowS) -> Show POp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> POp -> ShowS
showsPrec :: Int -> POp -> ShowS
$cshow :: POp -> String
show :: POp -> String
$cshowList :: [POp] -> ShowS
showList :: [POp] -> ShowS
Show, POp -> POp -> Bool
(POp -> POp -> Bool) -> (POp -> POp -> Bool) -> Eq POp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: POp -> POp -> Bool
== :: POp -> POp -> Bool
$c/= :: POp -> POp -> Bool
/= :: POp -> POp -> Bool
Eq, Eq POp
Eq POp =>
(POp -> POp -> Ordering)
-> (POp -> POp -> Bool)
-> (POp -> POp -> Bool)
-> (POp -> POp -> Bool)
-> (POp -> POp -> Bool)
-> (POp -> POp -> POp)
-> (POp -> POp -> POp)
-> Ord POp
POp -> POp -> Bool
POp -> POp -> Ordering
POp -> POp -> POp
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 :: POp -> POp -> Ordering
compare :: POp -> POp -> Ordering
$c< :: POp -> POp -> Bool
< :: POp -> POp -> Bool
$c<= :: POp -> POp -> Bool
<= :: POp -> POp -> Bool
$c> :: POp -> POp -> Bool
> :: POp -> POp -> Bool
$c>= :: POp -> POp -> Bool
>= :: POp -> POp -> Bool
$cmax :: POp -> POp -> POp
max :: POp -> POp -> POp
$cmin :: POp -> POp -> POp
min :: POp -> POp -> POp
Ord, Int -> POp
POp -> Int
POp -> [POp]
POp -> POp
POp -> POp -> [POp]
POp -> POp -> POp -> [POp]
(POp -> POp)
-> (POp -> POp)
-> (Int -> POp)
-> (POp -> Int)
-> (POp -> [POp])
-> (POp -> POp -> [POp])
-> (POp -> POp -> [POp])
-> (POp -> POp -> POp -> [POp])
-> Enum POp
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: POp -> POp
succ :: POp -> POp
$cpred :: POp -> POp
pred :: POp -> POp
$ctoEnum :: Int -> POp
toEnum :: Int -> POp
$cfromEnum :: POp -> Int
fromEnum :: POp -> Int
$cenumFrom :: POp -> [POp]
enumFrom :: POp -> [POp]
$cenumFromThen :: POp -> POp -> [POp]
enumFromThen :: POp -> POp -> [POp]
$cenumFromTo :: POp -> POp -> [POp]
enumFromTo :: POp -> POp -> [POp]
$cenumFromThenTo :: POp -> POp -> POp -> [POp]
enumFromThenTo :: POp -> POp -> POp -> [POp]
Enum, POp
POp -> POp -> Bounded POp
forall a. a -> a -> Bounded a
$cminBound :: POp
minBound :: POp
$cmaxBound :: POp
maxBound :: POp
Bounded)

type ANormal = ABTN.Term ANormalF

type Cte v = CTE v (ANormal v)

type Ctx v = Directed () [Cte v]

data Direction a = Indirect a | Direct
  deriving (Direction a -> Direction a -> Bool
(Direction a -> Direction a -> Bool)
-> (Direction a -> Direction a -> Bool) -> Eq (Direction a)
forall a. Eq a => Direction a -> Direction a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Direction a -> Direction a -> Bool
== :: Direction a -> Direction a -> Bool
$c/= :: forall a. Eq a => Direction a -> Direction a -> Bool
/= :: Direction a -> Direction a -> Bool
Eq, Eq (Direction a)
Eq (Direction a) =>
(Direction a -> Direction a -> Ordering)
-> (Direction a -> Direction a -> Bool)
-> (Direction a -> Direction a -> Bool)
-> (Direction a -> Direction a -> Bool)
-> (Direction a -> Direction a -> Bool)
-> (Direction a -> Direction a -> Direction a)
-> (Direction a -> Direction a -> Direction a)
-> Ord (Direction a)
Direction a -> Direction a -> Bool
Direction a -> Direction a -> Ordering
Direction a -> Direction a -> Direction a
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
forall a. Ord a => Eq (Direction a)
forall a. Ord a => Direction a -> Direction a -> Bool
forall a. Ord a => Direction a -> Direction a -> Ordering
forall a. Ord a => Direction a -> Direction a -> Direction a
$ccompare :: forall a. Ord a => Direction a -> Direction a -> Ordering
compare :: Direction a -> Direction a -> Ordering
$c< :: forall a. Ord a => Direction a -> Direction a -> Bool
< :: Direction a -> Direction a -> Bool
$c<= :: forall a. Ord a => Direction a -> Direction a -> Bool
<= :: Direction a -> Direction a -> Bool
$c> :: forall a. Ord a => Direction a -> Direction a -> Bool
> :: Direction a -> Direction a -> Bool
$c>= :: forall a. Ord a => Direction a -> Direction a -> Bool
>= :: Direction a -> Direction a -> Bool
$cmax :: forall a. Ord a => Direction a -> Direction a -> Direction a
max :: Direction a -> Direction a -> Direction a
$cmin :: forall a. Ord a => Direction a -> Direction a -> Direction a
min :: Direction a -> Direction a -> Direction a
Ord, Int -> Direction a -> ShowS
[Direction a] -> ShowS
Direction a -> String
(Int -> Direction a -> ShowS)
-> (Direction a -> String)
-> ([Direction a] -> ShowS)
-> Show (Direction a)
forall a. Show a => Int -> Direction a -> ShowS
forall a. Show a => [Direction a] -> ShowS
forall a. Show a => Direction a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Direction a -> ShowS
showsPrec :: Int -> Direction a -> ShowS
$cshow :: forall a. Show a => Direction a -> String
show :: Direction a -> String
$cshowList :: forall a. Show a => [Direction a] -> ShowS
showList :: [Direction a] -> ShowS
Show, (forall a b. (a -> b) -> Direction a -> Direction b)
-> (forall a b. a -> Direction b -> Direction a)
-> Functor Direction
forall a b. a -> Direction b -> Direction a
forall a b. (a -> b) -> Direction a -> Direction b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Direction a -> Direction b
fmap :: forall a b. (a -> b) -> Direction a -> Direction b
$c<$ :: forall a b. a -> Direction b -> Direction a
<$ :: forall a b. a -> Direction b -> Direction a
Functor, (forall m. Monoid m => Direction m -> m)
-> (forall m a. Monoid m => (a -> m) -> Direction a -> m)
-> (forall m a. Monoid m => (a -> m) -> Direction a -> m)
-> (forall a b. (a -> b -> b) -> b -> Direction a -> b)
-> (forall a b. (a -> b -> b) -> b -> Direction a -> b)
-> (forall b a. (b -> a -> b) -> b -> Direction a -> b)
-> (forall b a. (b -> a -> b) -> b -> Direction a -> b)
-> (forall a. (a -> a -> a) -> Direction a -> a)
-> (forall a. (a -> a -> a) -> Direction a -> a)
-> (forall a. Direction a -> [a])
-> (forall a. Direction a -> Bool)
-> (forall a. Direction a -> Int)
-> (forall a. Eq a => a -> Direction a -> Bool)
-> (forall a. Ord a => Direction a -> a)
-> (forall a. Ord a => Direction a -> a)
-> (forall a. Num a => Direction a -> a)
-> (forall a. Num a => Direction a -> a)
-> Foldable Direction
forall a. Eq a => a -> Direction a -> Bool
forall a. Num a => Direction a -> a
forall a. Ord a => Direction a -> a
forall m. Monoid m => Direction m -> m
forall a. Direction a -> Bool
forall a. Direction a -> Int
forall a. Direction a -> [a]
forall a. (a -> a -> a) -> Direction a -> a
forall m a. Monoid m => (a -> m) -> Direction a -> m
forall b a. (b -> a -> b) -> b -> Direction a -> b
forall a b. (a -> b -> b) -> b -> Direction a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Direction m -> m
fold :: forall m. Monoid m => Direction m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Direction a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Direction a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Direction a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Direction a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Direction a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Direction a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Direction a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Direction a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Direction a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Direction a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Direction a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Direction a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Direction a -> a
foldr1 :: forall a. (a -> a -> a) -> Direction a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Direction a -> a
foldl1 :: forall a. (a -> a -> a) -> Direction a -> a
$ctoList :: forall a. Direction a -> [a]
toList :: forall a. Direction a -> [a]
$cnull :: forall a. Direction a -> Bool
null :: forall a. Direction a -> Bool
$clength :: forall a. Direction a -> Int
length :: forall a. Direction a -> Int
$celem :: forall a. Eq a => a -> Direction a -> Bool
elem :: forall a. Eq a => a -> Direction a -> Bool
$cmaximum :: forall a. Ord a => Direction a -> a
maximum :: forall a. Ord a => Direction a -> a
$cminimum :: forall a. Ord a => Direction a -> a
minimum :: forall a. Ord a => Direction a -> a
$csum :: forall a. Num a => Direction a -> a
sum :: forall a. Num a => Direction a -> a
$cproduct :: forall a. Num a => Direction a -> a
product :: forall a. Num a => Direction a -> a
Foldable, Functor Direction
Foldable Direction
(Functor Direction, Foldable Direction) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Direction a -> f (Direction b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Direction (f a) -> f (Direction a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Direction a -> m (Direction b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Direction (m a) -> m (Direction a))
-> Traversable Direction
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Direction (m a) -> m (Direction a)
forall (f :: * -> *) a.
Applicative f =>
Direction (f a) -> f (Direction a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Direction a -> m (Direction b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Direction a -> f (Direction b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Direction a -> f (Direction b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Direction a -> f (Direction b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Direction (f a) -> f (Direction a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Direction (f a) -> f (Direction a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Direction a -> m (Direction b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Direction a -> m (Direction b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Direction (m a) -> m (Direction a)
sequence :: forall (m :: * -> *) a.
Monad m =>
Direction (m a) -> m (Direction a)
Traversable)

directed :: (Foldable f) => f (Cte v) -> Directed () (f (Cte v))
directed :: forall (f :: * -> *) v.
Foldable f =>
f (Cte v) -> Directed () (f (Cte v))
directed f (Cte v)
x = ((Cte v -> Direction ()) -> f (Cte v) -> Direction ()
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Cte v -> Direction ()
forall {v} {s}. CTE v s -> Direction ()
f f (Cte v)
x, f (Cte v)
x)
  where
    f :: CTE v s -> Direction ()
f (ST Direction Word16
d [v]
_ [Mem]
_ s
_) = () () -> Direction Word16 -> Direction ()
forall a b. a -> Direction b -> Direction a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Direction Word16
d
    f CTE v s
_ = Direction ()
forall a. Direction a
Direct

instance (Semigroup a) => Semigroup (Direction a) where
  Indirect a
l <> :: Direction a -> Direction a -> Direction a
<> Indirect a
r = a -> Direction a
forall a. a -> Direction a
Indirect (a -> Direction a) -> a -> Direction a
forall a b. (a -> b) -> a -> b
$ a
l a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
r
  Direction a
Direct <> Direction a
r = Direction a
r
  Direction a
l <> Direction a
Direct = Direction a
l

instance (Semigroup a) => Monoid (Direction a) where
  mempty :: Direction a
mempty = Direction a
forall a. Direction a
Direct

type Directed a = (,) (Direction a)

type DNormal v = Directed () (ANormal v)

-- Should be a completely closed term
data SuperNormal v = Lambda {forall v. SuperNormal v -> [Mem]
conventions :: [Mem], forall v. SuperNormal v -> ANormal v
bound :: ANormal v}
  deriving (Int -> SuperNormal v -> ShowS
[SuperNormal v] -> ShowS
SuperNormal v -> String
(Int -> SuperNormal v -> ShowS)
-> (SuperNormal v -> String)
-> ([SuperNormal v] -> ShowS)
-> Show (SuperNormal v)
forall v. Show v => Int -> SuperNormal v -> ShowS
forall v. Show v => [SuperNormal v] -> ShowS
forall v. Show v => SuperNormal v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> SuperNormal v -> ShowS
showsPrec :: Int -> SuperNormal v -> ShowS
$cshow :: forall v. Show v => SuperNormal v -> String
show :: SuperNormal v -> String
$cshowList :: forall v. Show v => [SuperNormal v] -> ShowS
showList :: [SuperNormal v] -> ShowS
Show, SuperNormal v -> SuperNormal v -> Bool
(SuperNormal v -> SuperNormal v -> Bool)
-> (SuperNormal v -> SuperNormal v -> Bool) -> Eq (SuperNormal v)
forall v. Var v => SuperNormal v -> SuperNormal v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall v. Var v => SuperNormal v -> SuperNormal v -> Bool
== :: SuperNormal v -> SuperNormal v -> Bool
$c/= :: forall v. Var v => SuperNormal v -> SuperNormal v -> Bool
/= :: SuperNormal v -> SuperNormal v -> Bool
Eq)

data SuperGroup v = Rec
  { forall v. SuperGroup v -> [(v, SuperNormal v)]
group :: [(v, SuperNormal v)],
    forall v. SuperGroup v -> SuperNormal v
entry :: SuperNormal v
  }
  deriving (Int -> SuperGroup v -> ShowS
[SuperGroup v] -> ShowS
SuperGroup v -> String
(Int -> SuperGroup v -> ShowS)
-> (SuperGroup v -> String)
-> ([SuperGroup v] -> ShowS)
-> Show (SuperGroup v)
forall v. Show v => Int -> SuperGroup v -> ShowS
forall v. Show v => [SuperGroup v] -> ShowS
forall v. Show v => SuperGroup v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> SuperGroup v -> ShowS
showsPrec :: Int -> SuperGroup v -> ShowS
$cshow :: forall v. Show v => SuperGroup v -> String
show :: SuperGroup v -> String
$cshowList :: forall v. Show v => [SuperGroup v] -> ShowS
showList :: [SuperGroup v] -> ShowS
Show)

instance (Var v) => Eq (SuperGroup v) where
  SuperGroup v
g0 == :: SuperGroup v -> SuperGroup v -> Bool
== SuperGroup v
g1 | Left SGEqv v
_ <- SuperGroup v -> SuperGroup v -> Either (SGEqv v) ()
forall v.
Var v =>
SuperGroup v -> SuperGroup v -> Either (SGEqv v) ()
equivocate SuperGroup v
g0 SuperGroup v
g1 = Bool
False | Bool
otherwise = Bool
True

-- Failure modes for SuperGroup alpha equivalence test
data SGEqv v
  = -- mismatch number of definitions in group
    NumDefns (SuperGroup v) (SuperGroup v)
  | -- mismatched SuperNormal calling conventions
    DefnConventions (SuperNormal v) (SuperNormal v)
  | -- mismatched subterms in corresponding definition
    Subterms (ANormal v) (ANormal v)

-- Checks if two SuperGroups are equivalent up to renaming. The rest
-- of the structure must match on the nose. If the two groups are not
-- equivalent, an example of conflicting structure is returned.
equivocate ::
  (Var v) =>
  SuperGroup v ->
  SuperGroup v ->
  Either (SGEqv v) ()
equivocate :: forall v.
Var v =>
SuperGroup v -> SuperGroup v -> Either (SGEqv v) ()
equivocate g0 :: SuperGroup v
g0@(Rec [(v, SuperNormal v)]
bs0 SuperNormal v
e0) g1 :: SuperGroup v
g1@(Rec [(v, SuperNormal v)]
bs1 SuperNormal v
e1)
  | [(v, SuperNormal v)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(v, SuperNormal v)]
bs0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(v, SuperNormal v)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(v, SuperNormal v)]
bs1 =
      ((SuperNormal v, SuperNormal v) -> Either (SGEqv v) ())
-> [(SuperNormal v, SuperNormal v)] -> Either (SGEqv v) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SuperNormal v, SuperNormal v) -> Either (SGEqv v) ()
eqvSN ([SuperNormal v]
-> [SuperNormal v] -> [(SuperNormal v, SuperNormal v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SuperNormal v]
ns0 [SuperNormal v]
ns1) Either (SGEqv v) () -> Either (SGEqv v) () -> Either (SGEqv v) ()
forall a b.
Either (SGEqv v) a -> Either (SGEqv v) b -> Either (SGEqv v) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SuperNormal v, SuperNormal v) -> Either (SGEqv v) ()
eqvSN (SuperNormal v
e0, SuperNormal v
e1)
  | Bool
otherwise = SGEqv v -> Either (SGEqv v) ()
forall a b. a -> Either a b
Left (SGEqv v -> Either (SGEqv v) ()) -> SGEqv v -> Either (SGEqv v) ()
forall a b. (a -> b) -> a -> b
$ SuperGroup v -> SuperGroup v -> SGEqv v
forall v. SuperGroup v -> SuperGroup v -> SGEqv v
NumDefns SuperGroup v
g0 SuperGroup v
g1
  where
    ([v]
vs0, [SuperNormal v]
ns0) = [(v, SuperNormal v)] -> ([v], [SuperNormal v])
forall a b. [(a, b)] -> ([a], [b])
unzip [(v, SuperNormal v)]
bs0
    ([v]
vs1, [SuperNormal v]
ns1) = [(v, SuperNormal v)] -> ([v], [SuperNormal v])
forall a b. [(a, b)] -> ([a], [b])
unzip [(v, SuperNormal v)]
bs1
    vm :: Map v v
vm = [(v, v)] -> Map v v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([v] -> [v] -> [(v, v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
vs1 [v]
vs0)

    promote :: Either (ANormal v, ANormal v) b -> Either (SGEqv v) b
promote (Left (ANormal v
l, ANormal v
r)) = SGEqv v -> Either (SGEqv v) b
forall a b. a -> Either a b
Left (SGEqv v -> Either (SGEqv v) b) -> SGEqv v -> Either (SGEqv v) b
forall a b. (a -> b) -> a -> b
$ ANormal v -> ANormal v -> SGEqv v
forall v. ANormal v -> ANormal v -> SGEqv v
Subterms ANormal v
l ANormal v
r
    promote (Right b
v) = b -> Either (SGEqv v) b
forall a b. b -> Either a b
Right b
v

    eqvSN :: (SuperNormal v, SuperNormal v) -> Either (SGEqv v) ()
eqvSN (Lambda [Mem]
ccs0 ANormal v
e0, Lambda [Mem]
ccs1 ANormal v
e1)
      | [Mem]
ccs0 [Mem] -> [Mem] -> Bool
forall a. Eq a => a -> a -> Bool
== [Mem]
ccs1 = Either (ANormal v, ANormal v) () -> Either (SGEqv v) ()
forall {v} {b}.
Either (ANormal v, ANormal v) b -> Either (SGEqv v) b
promote (Either (ANormal v, ANormal v) () -> Either (SGEqv v) ())
-> Either (ANormal v, ANormal v) () -> Either (SGEqv v) ()
forall a b. (a -> b) -> a -> b
$ Map v v
-> ANormal v -> ANormal v -> Either (ANormal v, ANormal v) ()
forall (f :: * -> * -> *) v.
(Align f, Var v) =>
Map v v -> Term f v -> Term f v -> Either (Term f v, Term f v) ()
ABTN.alpha Map v v
vm ANormal v
e0 ANormal v
e1
    eqvSN (SuperNormal v
n0, SuperNormal v
n1) = SGEqv v -> Either (SGEqv v) ()
forall a b. a -> Either a b
Left (SGEqv v -> Either (SGEqv v) ()) -> SGEqv v -> Either (SGEqv v) ()
forall a b. (a -> b) -> a -> b
$ SuperNormal v -> SuperNormal v -> SGEqv v
forall v. SuperNormal v -> SuperNormal v -> SGEqv v
DefnConventions SuperNormal v
n0 SuperNormal v
n1

type ANFM v =
  ReaderT
    (Set v)
    (State (Word64, Word16, [(v, SuperNormal v)]))

type ANFD v = Compose (ANFM v) (Directed ())

data GroupRef = GR Reference Word64
  deriving (Int -> GroupRef -> ShowS
[GroupRef] -> ShowS
GroupRef -> String
(Int -> GroupRef -> ShowS)
-> (GroupRef -> String) -> ([GroupRef] -> ShowS) -> Show GroupRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GroupRef -> ShowS
showsPrec :: Int -> GroupRef -> ShowS
$cshow :: GroupRef -> String
show :: GroupRef -> String
$cshowList :: [GroupRef] -> ShowS
showList :: [GroupRef] -> ShowS
Show)

data Value
  = Partial GroupRef [Word64] [Value]
  | Data Reference Word64 [Word64] [Value]
  | Cont [Word64] [Value] Cont
  | BLit BLit
  deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show)

data Cont
  = KE
  | Mark Word64 Word64 [Reference] (Map Reference Value) Cont
  | Push Word64 Word64 Word64 Word64 GroupRef Cont
  deriving (Int -> Cont -> ShowS
[Cont] -> ShowS
Cont -> String
(Int -> Cont -> ShowS)
-> (Cont -> String) -> ([Cont] -> ShowS) -> Show Cont
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cont -> ShowS
showsPrec :: Int -> Cont -> ShowS
$cshow :: Cont -> String
show :: Cont -> String
$cshowList :: [Cont] -> ShowS
showList :: [Cont] -> ShowS
Show)

data BLit
  = Text Util.Text.Text
  | List (Seq Value)
  | TmLink Referent
  | TyLink Reference
  | Bytes Bytes
  | Quote Value
  | Code (SuperGroup Symbol)
  | BArr PA.ByteArray
  | Pos Word64
  | Neg Word64
  | Char Char
  | Float Double
  | Arr (PA.Array Value)
  deriving (Int -> BLit -> ShowS
[BLit] -> ShowS
BLit -> String
(Int -> BLit -> ShowS)
-> (BLit -> String) -> ([BLit] -> ShowS) -> Show BLit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BLit -> ShowS
showsPrec :: Int -> BLit -> ShowS
$cshow :: BLit -> String
show :: BLit -> String
$cshowList :: [BLit] -> ShowS
showList :: [BLit] -> ShowS
Show)

groupVars :: ANFM v (Set v)
groupVars :: forall v. ANFM v (Set v)
groupVars = ReaderT
  (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) (Set v)
forall r (m :: * -> *). MonadReader r m => m r
ask

bindLocal :: (Ord v) => [v] -> ANFM v r -> ANFM v r
bindLocal :: forall v r. Ord v => [v] -> ANFM v r -> ANFM v r
bindLocal [v]
vs = (Set v -> Set v)
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) r
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) r
forall a.
(Set v -> Set v)
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v]
vs)

freshANF :: (Var v) => Word64 -> v
freshANF :: forall v. Var v => Word64 -> v
freshANF Word64
fr = Word64 -> v -> v
forall v. Var v => Word64 -> v -> v
Var.freshenId Word64
fr (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ Type -> v
forall v. Var v => Type -> v
typed Type
Var.ANFBlank

fresh :: (Var v) => ANFM v v
fresh :: forall v. Var v => ANFM v v
fresh = ((Word64, Word16, [(v, SuperNormal v)])
 -> (v, (Word64, Word16, [(v, SuperNormal v)])))
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) v
forall a.
((Word64, Word16, [(v, SuperNormal v)])
 -> (a, (Word64, Word16, [(v, SuperNormal v)])))
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((Word64, Word16, [(v, SuperNormal v)])
  -> (v, (Word64, Word16, [(v, SuperNormal v)])))
 -> ReaderT
      (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) v)
-> ((Word64, Word16, [(v, SuperNormal v)])
    -> (v, (Word64, Word16, [(v, SuperNormal v)])))
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) v
forall a b. (a -> b) -> a -> b
$ \(Word64
fr, Word16
bnd, [(v, SuperNormal v)]
cs) -> (Word64 -> v
forall v. Var v => Word64 -> v
freshANF Word64
fr, (Word64
fr Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1, Word16
bnd, [(v, SuperNormal v)]
cs))

contextualize :: (Var v) => DNormal v -> ANFM v (Ctx v, v)
contextualize :: forall v. Var v => DNormal v -> ANFM v (Ctx v, v)
contextualize (Direction ()
_, TVar v
cv) = do
  Set v
gvs <- ANFM v (Set v)
forall v. ANFM v (Set v)
groupVars
  if v
cv v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set v
gvs
    then (Ctx v, v) -> ANFM v (Ctx v, v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [], v
cv)
    else do
      v
bv <- ANFM v v
forall v. Var v => ANFM v v
fresh
      Direction Word16
d <- Word16 -> Direction Word16
forall a. a -> Direction a
Indirect (Word16 -> Direction Word16)
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
forall v. ANFM v Word16
binder
      pure ([Cte v] -> Ctx v
forall (f :: * -> *) v.
Foldable f =>
f (Cte v) -> Directed () (f (Cte v))
directed [Direction Word16 -> v -> Mem -> ANormal v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d v
bv Mem
BX (ANormal v -> Cte v) -> ANormal v -> Cte v
forall a b. (a -> b) -> a -> b
$ v -> [v] -> ANormal v
forall v. Var v => v -> [v] -> Term ANormalF v
TApv v
cv []], v
bv)
contextualize (Direction ()
d0, ANormal v
tm) = do
  v
fv <- ANFM v v
forall v. Var v => ANFM v v
fresh
  Direction Word16
d <- Direction ()
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction Word16)
forall a v. Direction a -> ANFM v (Direction Word16)
bindDirection Direction ()
d0
  pure ((Direction ()
d0, [Direction Word16 -> v -> Mem -> ANormal v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d v
fv Mem
BX ANormal v
tm]), v
fv)

binder :: ANFM v Word16
binder :: forall v. ANFM v Word16
binder = ((Word64, Word16, [(v, SuperNormal v)])
 -> (Word16, (Word64, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
forall a.
((Word64, Word16, [(v, SuperNormal v)])
 -> (a, (Word64, Word16, [(v, SuperNormal v)])))
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((Word64, Word16, [(v, SuperNormal v)])
  -> (Word16, (Word64, Word16, [(v, SuperNormal v)])))
 -> ReaderT
      (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16)
-> ((Word64, Word16, [(v, SuperNormal v)])
    -> (Word16, (Word64, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
forall a b. (a -> b) -> a -> b
$ \(Word64
fr, Word16
bnd, [(v, SuperNormal v)]
cs) -> (Word16
bnd, (Word64
fr, Word16
bnd Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
1, [(v, SuperNormal v)]
cs))

bindDirection :: Direction a -> ANFM v (Direction Word16)
bindDirection :: forall a v. Direction a -> ANFM v (Direction Word16)
bindDirection = (a
 -> ReaderT
      (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16)
-> Direction a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction Word16)
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) -> Direction a -> f (Direction b)
traverse (ReaderT
  (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
-> a
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
forall a b. a -> b -> a
const ReaderT
  (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
forall v. ANFM v Word16
binder)

record :: (Var v) => (v, SuperNormal v) -> ANFM v ()
record :: forall v. Var v => (v, SuperNormal v) -> ANFM v ()
record (v, SuperNormal v)
p = ((Word64, Word16, [(v, SuperNormal v)])
 -> (Word64, Word16, [(v, SuperNormal v)]))
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Word64, Word16, [(v, SuperNormal v)])
  -> (Word64, Word16, [(v, SuperNormal v)]))
 -> ReaderT
      (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) ())
-> ((Word64, Word16, [(v, SuperNormal v)])
    -> (Word64, Word16, [(v, SuperNormal v)]))
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) ()
forall a b. (a -> b) -> a -> b
$ \(Word64
fr, Word16
bnd, [(v, SuperNormal v)]
to) -> (Word64
fr, Word16
bnd, (v, SuperNormal v)
p (v, SuperNormal v) -> [(v, SuperNormal v)] -> [(v, SuperNormal v)]
forall a. a -> [a] -> [a]
: [(v, SuperNormal v)]
to)

superNormalize :: (Var v) => Term v a -> SuperGroup v
superNormalize :: forall v a. Var v => Term v a -> SuperGroup v
superNormalize Term v a
tm = [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
forall v. [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
Rec [(v, SuperNormal v)]
l SuperNormal v
c
  where
    ([(v, Term v a)]
bs, Term v a
e)
      | LetRecNamed' [(v, Term v a)]
bs Term v a
e <- Term v a
tm = ([(v, Term v a)]
bs, Term v a
e)
      | Bool
otherwise = ([], Term v a
tm)
    grp :: Set v
grp = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v) -> [v] -> Set v
forall a b. (a -> b) -> a -> b
$ (v, Term v a) -> v
forall a b. (a, b) -> a
fst ((v, Term v a) -> v) -> [(v, Term v a)] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, Term v a)]
bs
    comp :: ReaderT
  (Set v)
  (State (Word64, Word16, [(v, SuperNormal v)]))
  (SuperNormal v)
comp = ((v, Term v a)
 -> ReaderT
      (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) ())
-> [(v, Term v a)]
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (v, Term v a)
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) ()
forall v a. Var v => (v, Term v a) -> ANFM v ()
superBinding [(v, Term v a)]
bs ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) ()
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (SuperNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (SuperNormal v)
forall a b.
ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (SuperNormal v)
forall v a. Var v => Term v a -> ANFM v (SuperNormal v)
toSuperNormal Term v a
e
    subc :: State (Word64, Word16, [(v, SuperNormal v)]) (SuperNormal v)
subc = ReaderT
  (Set v)
  (State (Word64, Word16, [(v, SuperNormal v)]))
  (SuperNormal v)
-> Set v
-> State (Word64, Word16, [(v, SuperNormal v)]) (SuperNormal v)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  (Set v)
  (State (Word64, Word16, [(v, SuperNormal v)]))
  (SuperNormal v)
comp Set v
grp
    (SuperNormal v
c, (Word64
_, Word16
_, [(v, SuperNormal v)]
l)) = State (Word64, Word16, [(v, SuperNormal v)]) (SuperNormal v)
-> (Word64, Word16, [(v, SuperNormal v)])
-> (SuperNormal v, (Word64, Word16, [(v, SuperNormal v)]))
forall s a. State s a -> s -> (a, s)
runState State (Word64, Word16, [(v, SuperNormal v)]) (SuperNormal v)
subc (Word64
0, Word16
1, [])

superBinding :: (Var v) => (v, Term v a) -> ANFM v ()
superBinding :: forall v a. Var v => (v, Term v a) -> ANFM v ()
superBinding (v
v, Term v a
tm) = do
  SuperNormal v
nf <- Term v a -> ANFM v (SuperNormal v)
forall v a. Var v => Term v a -> ANFM v (SuperNormal v)
toSuperNormal Term v a
tm
  ((Word64, Word16, [(v, SuperNormal v)])
 -> (Word64, Word16, [(v, SuperNormal v)]))
-> ANFM v ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Word64, Word16, [(v, SuperNormal v)])
  -> (Word64, Word16, [(v, SuperNormal v)]))
 -> ANFM v ())
-> ((Word64, Word16, [(v, SuperNormal v)])
    -> (Word64, Word16, [(v, SuperNormal v)]))
-> ANFM v ()
forall a b. (a -> b) -> a -> b
$ \(Word64
cvs, Word16
bnd, [(v, SuperNormal v)]
ctx) -> (Word64
cvs, Word16
bnd, (v
v, SuperNormal v
nf) (v, SuperNormal v) -> [(v, SuperNormal v)] -> [(v, SuperNormal v)]
forall a. a -> [a] -> [a]
: [(v, SuperNormal v)]
ctx)

toSuperNormal :: (Var v) => Term v a -> ANFM v (SuperNormal v)
toSuperNormal :: forall v a. Var v => Term v a -> ANFM v (SuperNormal v)
toSuperNormal Term v a
tm = do
  Set v
grp <- ANFM v (Set v)
forall v. ANFM v (Set v)
groupVars
  if Bool -> Bool
not (Bool -> Bool) -> (Set v -> Bool) -> Set v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set v -> Bool
forall a. Set a -> Bool
Set.null (Set v -> Bool) -> (Set v -> Set v) -> Set v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set v
grp) (Set v -> Bool) -> Set v -> Bool
forall a b. (a -> b) -> a -> b
$ Term v a -> Set v
forall vt v a. Term' vt v a -> Set v
freeVars Term v a
tm
    then String -> ANFM v (SuperNormal v)
forall a. HasCallStack => String -> a
internalBug (String -> ANFM v (SuperNormal v))
-> String -> ANFM v (SuperNormal v)
forall a b. (a -> b) -> a -> b
$ String
"free variables in supercombinator: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term v a -> String
forall a. Show a => a -> String
show Term v a
tm
    else
      [Mem] -> ANormal v -> SuperNormal v
forall v. [Mem] -> ANormal v -> SuperNormal v
Lambda (Mem
BX Mem -> [v] -> [Mem]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [v]
vs) (ANormal v -> SuperNormal v)
-> ((Direction (), ANormal v) -> ANormal v)
-> (Direction (), ANormal v)
-> SuperNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> ANormal v -> ANormal v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
vs (ANormal v -> ANormal v)
-> ((Direction (), ANormal v) -> ANormal v)
-> (Direction (), ANormal v)
-> ANormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Direction (), ANormal v) -> ANormal v
forall a b. (a, b) -> b
snd
        ((Direction (), ANormal v) -> SuperNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction (), ANormal v)
-> ANFM v (SuperNormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction (), ANormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction (), ANormal v)
forall v r. Ord v => [v] -> ANFM v r -> ANFM v r
bindLocal [v]
vs (Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction (), ANormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
body)
  where
    ([v]
vs, Term v a
body) = ([v], Term v a) -> Maybe ([v], Term v a) -> ([v], Term v a)
forall a. a -> Maybe a -> a
fromMaybe ([], Term v a
tm) (Maybe ([v], Term v a) -> ([v], Term v a))
-> Maybe ([v], Term v a) -> ([v], Term v a)
forall a b. (a -> b) -> a -> b
$ Term v a -> Maybe ([v], Term v a)
forall vt at ap v a.
Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a)
unLams' Term v a
tm

anfTerm :: (Var v) => Term v a -> ANFM v (DNormal v)
anfTerm :: forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
tm = ((Direction (), [Cte v]), (Direction (), ANormal v))
-> (Direction (), ANormal v)
forall {v} {a}.
Var v =>
((a, [Cte v]), (Direction (), ANormal v))
-> (Direction (), ANormal v)
f (((Direction (), [Cte v]), (Direction (), ANormal v))
 -> (Direction (), ANormal v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     ((Direction (), [Cte v]), (Direction (), ANormal v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction (), ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     ((Direction (), [Cte v]), (Direction (), ANormal v))
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
tm
  where
    -- f = uncurry (liftA2 TBinds)
    f :: ((a, [Cte v]), (Direction (), ANormal v))
-> (Direction (), ANormal v)
f ((a
_, []), (Direction (), ANormal v)
dtm) = (Direction (), ANormal v)
dtm
    f ((a
_, [Cte v]
cx), (Direction ()
_, ANormal v
tm)) = (() -> Direction ()
forall a. a -> Direction a
Indirect (), [Cte v] -> ANormal v -> ANormal v
forall v. Var v => [Cte v] -> ANormal v -> ANormal v
TBinds [Cte v]
cx ANormal v
tm)

floatableCtx :: (Var v) => Ctx v -> Bool
floatableCtx :: forall v. Var v => Ctx v -> Bool
floatableCtx = (CTE v (Term ANormalF v) -> Bool)
-> [CTE v (Term ANormalF v)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CTE v (Term ANormalF v) -> Bool
forall {v} {v}. Var v => CTE v (Term ANormalF v) -> Bool
p ([CTE v (Term ANormalF v)] -> Bool)
-> (Ctx v -> [CTE v (Term ANormalF v)]) -> Ctx v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx v -> [CTE v (Term ANormalF v)]
forall a b. (a, b) -> b
snd
  where
    p :: CTE v (Term ANormalF v) -> Bool
p (LZ v
_ Either Reference v
_ [v]
_) = Bool
True
    p (ST Direction Word16
_ [v]
_ [Mem]
_ Term ANormalF v
tm) = Term ANormalF v -> Bool
forall {v}. Var v => Term ANormalF v -> Bool
q Term ANormalF v
tm
    q :: Term ANormalF v -> Bool
q (TLit Lit
_) = Bool
True
    q (TVar v
_) = Bool
True
    q (TCon Reference
_ CTag
_ [v]
_) = Bool
True
    q Term ANormalF v
_ = Bool
False

anfHandled :: (Var v) => Term v a -> ANFM v (Ctx v, DNormal v)
anfHandled :: forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfHandled Term v a
body =
  Term v a -> ANFM v (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
body ANFM v (Ctx v, DNormal v)
-> ((Ctx v, DNormal v) -> ANFM v (Ctx v, DNormal v))
-> ANFM v (Ctx v, DNormal v)
forall a b.
ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
-> (a
    -> ReaderT
         (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b)
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Ctx v
ctx, (Direction ()
_, t :: ANormal v
t@TCon {})) ->
      ANFM v v
forall v. Var v => ANFM v v
fresh ANFM v v -> (v -> (Ctx v, DNormal v)) -> ANFM v (Ctx v, DNormal v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \v
v ->
        (Ctx v
ctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Direction Word16 -> v -> Mem -> ANormal v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
forall a. Direction a
Direct v
v Mem
BX ANormal v
t], ANormal v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ANormal v -> DNormal v) -> ANormal v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v -> ANormal v
forall v. Var v => v -> Term ANormalF v
TVar v
v)
    (Ctx v
ctx, (Direction ()
_, t :: ANormal v
t@(TLit Lit
l))) ->
      ANFM v v
forall v. Var v => ANFM v v
fresh ANFM v v -> (v -> (Ctx v, DNormal v)) -> ANFM v (Ctx v, DNormal v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \v
v ->
        (Ctx v
ctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Direction Word16 -> v -> Mem -> ANormal v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
forall a. Direction a
Direct v
v Mem
cc ANormal v
t], ANormal v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ANormal v -> DNormal v) -> ANormal v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v -> ANormal v
forall v. Var v => v -> Term ANormalF v
TVar v
v)
      where
        cc :: Mem
cc = case Lit
l of T {} -> Mem
BX; LM {} -> Mem
BX; LY {} -> Mem
BX; Lit
_ -> Mem
UN
    (Ctx v, DNormal v)
p -> (Ctx v, DNormal v) -> ANFM v (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v, DNormal v)
p

fls, tru :: (Var v) => ANormal v
fls :: forall v. Var v => ANormal v
fls = Reference -> CTag -> [v] -> Term ANormalF v
forall v. Var v => Reference -> CTag -> [v] -> Term ANormalF v
TCon Reference
Ty.booleanRef CTag
0 []
tru :: forall v. Var v => ANormal v
tru = Reference -> CTag -> [v] -> Term ANormalF v
forall v. Var v => Reference -> CTag -> [v] -> Term ANormalF v
TCon Reference
Ty.booleanRef CTag
1 []

-- Helper function for renaming a variable arising from a
--   let v = u
-- binding during ANF translation. Renames a variable in a
-- context, and returns an indication of whether the varible
-- was shadowed by one of the context bindings.
renameCtx :: (Var v) => v -> v -> Ctx v -> (Ctx v, Bool)
renameCtx :: forall v. Var v => v -> v -> Ctx v -> (Ctx v, Bool)
renameCtx v
v v
u (Direction ()
d, [Cte v]
ctx) | ([Cte v]
ctx, Bool
b) <- [Cte v] -> [Cte v] -> ([Cte v], Bool)
rn [] [Cte v]
ctx = ((Direction ()
d, [Cte v]
ctx), Bool
b)
  where
    swap :: v -> v
swap v
w
      | v
w v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v = v
u
      | Bool
otherwise = v
w

    rn :: [Cte v] -> [Cte v] -> ([Cte v], Bool)
rn [Cte v]
acc [] = ([Cte v] -> [Cte v]
forall a. [a] -> [a]
reverse [Cte v]
acc, Bool
False)
    rn [Cte v]
acc (ST Direction Word16
d [v]
vs [Mem]
ccs Term ANormalF v
b : [Cte v]
es)
      | (v -> Bool) -> [v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v) [v]
vs = ([Cte v] -> [Cte v]
forall a. [a] -> [a]
reverse [Cte v]
acc [Cte v] -> [Cte v] -> [Cte v]
forall a. [a] -> [a] -> [a]
++ Cte v
e Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
es, Bool
True)
      | Bool
otherwise = [Cte v] -> [Cte v] -> ([Cte v], Bool)
rn (Cte v
e Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
acc) [Cte v]
es
      where
        e :: Cte v
e = Direction Word16 -> [v] -> [Mem] -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> [v] -> [Mem] -> s -> CTE v s
ST Direction Word16
d [v]
vs [Mem]
ccs (Term ANormalF v -> Cte v) -> Term ANormalF v -> Cte v
forall a b. (a -> b) -> a -> b
$ v -> v -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *).
(Var v, Ord v, Bifunctor f, Bifoldable f) =>
v -> v -> Term f v -> Term f v
ABTN.rename v
v v
u Term ANormalF v
b
    rn [Cte v]
acc (LZ v
w Either Reference v
f [v]
as : [Cte v]
es)
      | v
w v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v = ([Cte v] -> [Cte v]
forall a. [a] -> [a]
reverse [Cte v]
acc [Cte v] -> [Cte v] -> [Cte v]
forall a. [a] -> [a] -> [a]
++ Cte v
e Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
es, Bool
True)
      | Bool
otherwise = [Cte v] -> [Cte v] -> ([Cte v], Bool)
rn (Cte v
e Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
acc) [Cte v]
es
      where
        e :: Cte v
e = v -> Either Reference v -> [v] -> Cte v
forall v s. v -> Either Reference v -> [v] -> CTE v s
LZ v
w (v -> v
swap (v -> v) -> Either Reference v -> Either Reference v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Reference v
f) (v -> v
swap (v -> v) -> [v] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
as)

anfBlock :: (Var v) => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock :: forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock (Var' v
v) = (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v -> Term ANormalF v
forall v. Var v => v -> Term ANormalF v
TVar v
v)
anfBlock (If' Term v a
c Term v a
t Term v a
f) = do
  (Ctx v
cctx, DNormal v
cc) <- Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
c
  (Direction ()
df, Term ANormalF v
cf) <- Term v a -> ANFM v (DNormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
f
  (Direction ()
dt, Term ANormalF v
ct) <- Term v a -> ANFM v (DNormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
t
  (Ctx v
cx, v
v) <- DNormal v -> ANFM v (Ctx v, v)
forall v. Var v => DNormal v -> ANFM v (Ctx v, v)
contextualize DNormal v
cc
  let cases :: Branched (Term ANormalF v)
cases =
        Reference
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Maybe (Term ANormalF v)
-> Branched (Term ANormalF v)
forall e.
Reference -> EnumMap CTag ([Mem], e) -> Maybe e -> Branched e
MatchData
          (Text -> Reference
forall t h. t -> Reference' t h
Builtin (Text -> Reference) -> Text -> Reference
forall a b. (a -> b) -> a -> b
$ String -> Text
Data.Text.pack String
"Boolean")
          (CTag
-> ([Mem], Term ANormalF v)
-> EnumMap CTag ([Mem], Term ANormalF v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton CTag
0 ([], Term ANormalF v
cf))
          (Term ANormalF v -> Maybe (Term ANormalF v)
forall a. a -> Maybe a
Just Term ANormalF v
ct)
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
cctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx, (() -> Direction ()
forall a. a -> Direction a
Indirect () Direction () -> Direction () -> Direction ()
forall a. Semigroup a => a -> a -> a
<> Direction ()
df Direction () -> Direction () -> Direction ()
forall a. Semigroup a => a -> a -> a
<> Direction ()
dt, v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
v Branched (Term ANormalF v)
cases))
anfBlock (And' Term v a
l Term v a
r) = do
  (Ctx v
lctx, v
vl) <- Term v a -> ANFM v (Ctx v, v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, v)
anfArg Term v a
l
  (Direction ()
d, Term ANormalF v
tmr) <- Term v a -> ANFM v (DNormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
r
  let tree :: Term ANormalF v
tree =
        v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
vl (Branched (Term ANormalF v) -> Term ANormalF v)
-> (EnumMap CTag ([Mem], Term ANormalF v)
    -> Branched (Term ANormalF v))
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Term ANormalF v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Branched (Term ANormalF v)
forall e. Reference -> EnumMap CTag ([Mem], e) -> Branched e
MatchDataCover Reference
Ty.booleanRef (EnumMap CTag ([Mem], Term ANormalF v) -> Term ANormalF v)
-> EnumMap CTag ([Mem], Term ANormalF v) -> Term ANormalF v
forall a b. (a -> b) -> a -> b
$
          [(CTag, ([Mem], Term ANormalF v))]
-> EnumMap CTag ([Mem], Term ANormalF v)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList
            [ (CTag
0, ([], Term ANormalF v
forall v. Var v => ANormal v
fls)),
              (CTag
1, ([], Term ANormalF v
tmr))
            ]
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
lctx, (() -> Direction ()
forall a. a -> Direction a
Indirect () Direction () -> Direction () -> Direction ()
forall a. Semigroup a => a -> a -> a
<> Direction ()
d, Term ANormalF v
tree))
anfBlock (Or' Term v a
l Term v a
r) = do
  (Ctx v
lctx, v
vl) <- Term v a -> ANFM v (Ctx v, v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, v)
anfArg Term v a
l
  (Direction ()
d, Term ANormalF v
tmr) <- Term v a -> ANFM v (DNormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
r
  let tree :: Term ANormalF v
tree =
        v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
vl (Branched (Term ANormalF v) -> Term ANormalF v)
-> (EnumMap CTag ([Mem], Term ANormalF v)
    -> Branched (Term ANormalF v))
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Term ANormalF v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Branched (Term ANormalF v)
forall e. Reference -> EnumMap CTag ([Mem], e) -> Branched e
MatchDataCover Reference
Ty.booleanRef (EnumMap CTag ([Mem], Term ANormalF v) -> Term ANormalF v)
-> EnumMap CTag ([Mem], Term ANormalF v) -> Term ANormalF v
forall a b. (a -> b) -> a -> b
$
          [(CTag, ([Mem], Term ANormalF v))]
-> EnumMap CTag ([Mem], Term ANormalF v)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList
            [ (CTag
1, ([], Term ANormalF v
forall v. Var v => ANormal v
tru)),
              (CTag
0, ([], Term ANormalF v
tmr))
            ]
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
lctx, (() -> Direction ()
forall a. a -> Direction a
Indirect () Direction () -> Direction () -> Direction ()
forall a. Semigroup a => a -> a -> a
<> Direction ()
d, Term ANormalF v
tree))
anfBlock (Handle' Term v a
h Term v a
body) =
  Term v a -> ANFM v (Ctx v, v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, v)
anfArg Term v a
h ANFM v (Ctx v, v)
-> ((Ctx v, v)
    -> ReaderT
         (Set v)
         (State (Word64, Word16, [(v, SuperNormal v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
-> (a
    -> ReaderT
         (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b)
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ctx v
hctx, v
vh) ->
    Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfHandled Term v a
body ReaderT
  (Set v)
  (State (Word64, Word16, [(v, SuperNormal v)]))
  (Ctx v, DNormal v)
-> ((Ctx v, DNormal v)
    -> ReaderT
         (Set v)
         (State (Word64, Word16, [(v, SuperNormal v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
-> (a
    -> ReaderT
         (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b)
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Ctx v
ctx, (Direction ()
_, TCom Reference
f [v]
as)) | Ctx v -> Bool
forall v. Var v => Ctx v -> Bool
floatableCtx Ctx v
ctx -> do
        v
v <- ANFM v v
forall v. Var v => ANFM v v
fresh
        pure
          ( Ctx v
hctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
ctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [v -> Either Reference v -> [v] -> Cte v
forall v s. v -> Either Reference v -> [v] -> CTE v s
LZ v
v (Reference -> Either Reference v
forall a b. a -> Either a b
Left Reference
f) [v]
as],
            (() -> Direction ()
forall a. a -> Direction a
Indirect (), Func v -> [v] -> Term ANormalF v
forall v. Var v => Func v -> [v] -> Term ANormalF v
TApp (v -> Func v
forall v. v -> Func v
FVar v
vh) [v
v])
          )
      (Ctx v
ctx, (Direction ()
_, TApv v
f [v]
as)) | Ctx v -> Bool
forall v. Var v => Ctx v -> Bool
floatableCtx Ctx v
ctx -> do
        v
v <- ANFM v v
forall v. Var v => ANFM v v
fresh
        pure
          ( Ctx v
hctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
ctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [v -> Either Reference v -> [v] -> Cte v
forall v s. v -> Either Reference v -> [v] -> CTE v s
LZ v
v (v -> Either Reference v
forall a b. b -> Either a b
Right v
f) [v]
as],
            (() -> Direction ()
forall a. a -> Direction a
Indirect (), Func v -> [v] -> Term ANormalF v
forall v. Var v => Func v -> [v] -> Term ANormalF v
TApp (v -> Func v
forall v. v -> Func v
FVar v
vh) [v
v])
          )
      (Ctx v
ctx, (Direction ()
_, TVar v
v)) | Ctx v -> Bool
forall v. Var v => Ctx v -> Bool
floatableCtx Ctx v
ctx -> do
        (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
hctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
ctx, (() -> Direction ()
forall a. a -> Direction a
Indirect (), Func v -> [v] -> Term ANormalF v
forall v. Var v => Func v -> [v] -> Term ANormalF v
TApp (v -> Func v
forall v. v -> Func v
FVar v
vh) [v
v]))
      p :: (Ctx v, DNormal v)
p@(Ctx v
_, DNormal v
_) ->
        String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug (String
 -> ReaderT
      (Set v)
      (State (Word64, Word16, [(v, SuperNormal v)]))
      (Ctx v, DNormal v))
-> String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b. (a -> b) -> a -> b
$ String
"handle body should be a simple call: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Ctx v, DNormal v) -> String
forall a. Show a => a -> String
show (Ctx v, DNormal v)
p
anfBlock (Match' Term v a
scrut [MatchCase a (Term v a)]
cas) = do
  (Ctx v
sctx, DNormal v
sc) <- Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
scrut
  (Ctx v
cx, v
v) <- DNormal v -> ANFM v (Ctx v, v)
forall v. Var v => DNormal v -> ANFM v (Ctx v, v)
contextualize DNormal v
sc
  (Direction ()
d, BranchAccum v
brn) <- v
-> [MatchCase a (Term v a)] -> ANFM v (Direction (), BranchAccum v)
forall v p a.
Var v =>
v
-> [MatchCase p (Term v a)] -> ANFM v (Directed () (BranchAccum v))
anfCases v
v [MatchCase a (Term v a)]
cas
  (DNormal v -> DNormal v)
-> (Ctx v, DNormal v) -> (Ctx v, DNormal v)
forall a b. (a -> b) -> (Ctx v, a) -> (Ctx v, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Direction () -> Direction ()) -> DNormal v -> DNormal v
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 ((() -> Direction ()
forall a. a -> Direction a
Indirect () Direction () -> Direction () -> Direction ()
forall a. Semigroup a => a -> a -> a
<> Direction ()
d) Direction () -> Direction () -> Direction ()
forall a. Semigroup a => a -> a -> a
<>)) ((Ctx v, DNormal v) -> (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case BranchAccum v
brn of
    AccumDefault (TBinds ([Cte v] -> Ctx v
forall (f :: * -> *) v.
Foldable f =>
f (Cte v) -> Directed () (f (Cte v))
directed -> Ctx v
dctx) Term ANormalF v
df) -> do
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
dctx, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term ANormalF v
df)
    AccumRequest Map Reference (EnumMap CTag ([Mem], Term ANormalF v))
_ Maybe (Term ANormalF v)
Nothing ->
      String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug String
"anfBlock: AccumRequest without default"
    AccumPure (ABTN.TAbss [v]
us Term ANormalF v
bd)
      | [v
u] <- [v]
us,
        TBinds ([Cte v] -> Ctx v
forall (f :: * -> *) v.
Foldable f =>
f (Cte v) -> Directed () (f (Cte v))
directed -> Ctx v
bx) Term ANormalF v
bd <- Term ANormalF v
bd ->
          case Ctx v
cx of
            (Direction ()
_, []) -> do
              Direction Word16
d0 <- Word16 -> Direction Word16
forall a. a -> Direction a
Indirect (Word16 -> Direction Word16)
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
forall v. ANFM v Word16
binder
              pure (Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d0 v
u Mem
BX (v -> Term ANormalF v
forall v. Var v => v -> Term ANormalF v
TFrc v
v)] Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
bx, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term ANormalF v
bd)
            (Direction ()
d0, [ST1 Direction Word16
d1 v
_ Mem
BX Term ANormalF v
tm]) ->
              (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> (Direction ()
d0, [Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d1 v
u Mem
BX Term ANormalF v
tm]) Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
bx, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term ANormalF v
bd)
            Ctx v
_ -> String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug String
"anfBlock|AccumPure: impossible"
      | Bool
otherwise -> String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug String
"pure handler with too many variables"
    AccumRequest Map Reference (EnumMap CTag ([Mem], Term ANormalF v))
abr (Just Term ANormalF v
df) -> do
      (v
r, [v]
vs) <- do
        v
r <- ANFM v v
forall v. Var v => ANFM v v
fresh
        v
v <- ANFM v v
forall v. Var v => ANFM v v
fresh
        Set v
gvs <- ANFM v (Set v)
forall v. ANFM v (Set v)
groupVars
        let hfb :: Term ANormalF v
hfb = v -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *). Var v => v -> Term f v -> Term f v
ABTN.TAbs v
v (Term ANormalF v -> Term ANormalF v)
-> (Branched (Term ANormalF v) -> Term ANormalF v)
-> Branched (Term ANormalF v)
-> Term ANormalF v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
v (Branched (Term ANormalF v) -> Term ANormalF v)
-> Branched (Term ANormalF v) -> Term ANormalF v
forall a b. (a -> b) -> a -> b
$ Map Reference (EnumMap CTag ([Mem], Term ANormalF v))
-> Term ANormalF v -> Branched (Term ANormalF v)
forall e.
Map Reference (EnumMap CTag ([Mem], e)) -> e -> Branched e
MatchRequest Map Reference (EnumMap CTag ([Mem], Term ANormalF v))
abr Term ANormalF v
df
            hfvs :: [v]
hfvs = Set v -> [v]
forall a. Set a -> [a]
Set.toList (Set v -> [v]) -> Set v -> [v]
forall a b. (a -> b) -> a -> b
$ Term ANormalF v -> Set v
forall (f :: * -> * -> *) v. Term f v -> Set v
ABTN.freeVars Term ANormalF v
hfb Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set v
gvs
        (v, SuperNormal v) -> ANFM v ()
forall v. Var v => (v, SuperNormal v) -> ANFM v ()
record (v
r, [Mem] -> Term ANormalF v -> SuperNormal v
forall v. [Mem] -> ANormal v -> SuperNormal v
Lambda (Mem
BX Mem -> [v] -> [Mem]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [v]
hfvs [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v
v]) (Term ANormalF v -> SuperNormal v)
-> (Term ANormalF v -> Term ANormalF v)
-> Term ANormalF v
-> SuperNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
hfvs (Term ANormalF v -> SuperNormal v)
-> Term ANormalF v -> SuperNormal v
forall a b. (a -> b) -> a -> b
$ Term ANormalF v
hfb)
        pure (v
r, [v]
hfvs)
      v
hv <- ANFM v v
forall v. Var v => ANFM v v
fresh
      let (Direction ()
d, Term ANormalF v
msc)
            | (Direction ()
d, [ST1 Direction Word16
_ v
_ Mem
BX Term ANormalF v
tm]) <- Ctx v
cx = (Direction ()
d, Term ANormalF v
tm)
            | (Direction ()
_, [ST Direction Word16
_ [v]
_ [Mem]
_ Term ANormalF v
_]) <- Ctx v
cx =
                String -> DNormal v
forall a. HasCallStack => String -> a
internalBug String
"anfBlock: impossible"
            | Bool
otherwise = (() -> Direction ()
forall a. a -> Direction a
Indirect (), v -> Term ANormalF v
forall v. Var v => v -> Term ANormalF v
TFrc v
v)
      pure
        ( Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [v -> Either Reference v -> [v] -> Cte v
forall v s. v -> Either Reference v -> [v] -> CTE v s
LZ v
hv (v -> Either Reference v
forall a b. b -> Either a b
Right v
r) [v]
vs],
          (Direction ()
d, [Reference] -> v -> Term ANormalF v -> Term ANormalF v
forall v.
Var v =>
[Reference] -> v -> Term ANormalF v -> Term ANormalF v
THnd (Map Reference (EnumMap CTag ([Mem], Term ANormalF v))
-> [Reference]
forall k a. Map k a -> [k]
Map.keys Map Reference (EnumMap CTag ([Mem], Term ANormalF v))
abr) v
hv Term ANormalF v
msc)
        )
    AccumText Maybe (Term ANormalF v)
df Map Text (Term ANormalF v)
cs ->
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v)
-> (Branched (Term ANormalF v) -> Term ANormalF v)
-> Branched (Term ANormalF v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
v (Branched (Term ANormalF v) -> DNormal v)
-> Branched (Term ANormalF v) -> DNormal v
forall a b. (a -> b) -> a -> b
$ Map Text (Term ANormalF v)
-> Maybe (Term ANormalF v) -> Branched (Term ANormalF v)
forall e. Map Text e -> Maybe e -> Branched e
MatchText Map Text (Term ANormalF v)
cs Maybe (Term ANormalF v)
df)
    AccumIntegral Reference
r Maybe (Term ANormalF v)
df EnumMap Word64 (Term ANormalF v)
cs ->
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
v (Branched (Term ANormalF v) -> Term ANormalF v)
-> Branched (Term ANormalF v) -> Term ANormalF v
forall a b. (a -> b) -> a -> b
$ Reference
-> EnumMap Word64 (Term ANormalF v)
-> Maybe (Term ANormalF v)
-> Branched (Term ANormalF v)
forall e. Reference -> EnumMap Word64 e -> Maybe e -> Branched e
MatchNumeric Reference
r EnumMap Word64 (Term ANormalF v)
cs Maybe (Term ANormalF v)
df)
    AccumData Reference
r Maybe (Term ANormalF v)
df EnumMap CTag ([Mem], Term ANormalF v)
cs ->
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v)
-> (Branched (Term ANormalF v) -> Term ANormalF v)
-> Branched (Term ANormalF v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
v (Branched (Term ANormalF v) -> DNormal v)
-> Branched (Term ANormalF v) -> DNormal v
forall a b. (a -> b) -> a -> b
$ Reference
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Maybe (Term ANormalF v)
-> Branched (Term ANormalF v)
forall e.
Reference -> EnumMap CTag ([Mem], e) -> Maybe e -> Branched e
MatchData Reference
r EnumMap CTag ([Mem], Term ANormalF v)
cs Maybe (Term ANormalF v)
df)
    AccumSeqEmpty Term ANormalF v
_ ->
      String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug String
"anfBlock: non-exhaustive AccumSeqEmpty"
    AccumSeqView SeqEnd
en (Just Term ANormalF v
em) Term ANormalF v
bd -> do
      v
r <- ANFM v v
forall v. Var v => ANFM v v
fresh
      let op :: Reference
op
            | SeqEnd
SLeft <- SeqEnd
en = Text -> Reference
forall t h. t -> Reference' t h
Builtin Text
"List.viewl"
            | Bool
otherwise = Text -> Reference
forall t h. t -> Reference' t h
Builtin Text
"List.viewr"
      Word16
b <- ReaderT
  (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
forall v. ANFM v Word16
binder
      pure
        ( Ctx v
sctx
            Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx
            Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> (() -> Direction ()
forall a. a -> Direction a
Indirect (), [Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 (Word16 -> Direction Word16
forall a. a -> Direction a
Indirect Word16
b) v
r Mem
BX (Reference -> [v] -> Term ANormalF v
forall v. Var v => Reference -> [v] -> Term ANormalF v
TCom Reference
op [v
v])]),
          Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v)
-> (Branched (Term ANormalF v) -> Term ANormalF v)
-> Branched (Term ANormalF v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
r (Branched (Term ANormalF v) -> DNormal v)
-> Branched (Term ANormalF v) -> DNormal v
forall a b. (a -> b) -> a -> b
$
            Reference
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Branched (Term ANormalF v)
forall e. Reference -> EnumMap CTag ([Mem], e) -> Branched e
MatchDataCover
              Reference
Ty.seqViewRef
              ( [(CTag, ([Mem], Term ANormalF v))]
-> EnumMap CTag ([Mem], Term ANormalF v)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList
                  [ (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
Ty.seqViewEmpty, ([], Term ANormalF v
em)),
                    (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
Ty.seqViewElem, ([Mem
BX, Mem
BX], Term ANormalF v
bd))
                  ]
              )
        )
    AccumSeqView {} ->
      String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug String
"anfBlock: non-exhaustive AccumSeqView"
    AccumSeqSplit SeqEnd
en Int
n Maybe (Term ANormalF v)
mdf Term ANormalF v
bd -> do
      v
i <- ANFM v v
forall v. Var v => ANFM v v
fresh
      v
r <- ANFM v v
forall v. Var v => ANFM v v
fresh
      v
s <- ANFM v v
forall v. Var v => ANFM v v
fresh
      Word16
b <- ReaderT
  (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) Word16
forall v. ANFM v Word16
binder
      let split :: Cte v
split = Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 (Word16 -> Direction Word16
forall a. a -> Direction a
Indirect Word16
b) v
r Mem
BX (Reference -> [v] -> Term ANormalF v
forall v. Var v => Reference -> [v] -> Term ANormalF v
TCom Reference
op [v
i, v
v])
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall (f :: * -> *) v.
Foldable f =>
f (Cte v) -> Directed () (f (Cte v))
directed [v -> Cte v
lit v
i, Cte v
split],
          Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v)
-> (EnumMap CTag ([Mem], Term ANormalF v) -> Term ANormalF v)
-> EnumMap CTag ([Mem], Term ANormalF v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
r (Branched (Term ANormalF v) -> Term ANormalF v)
-> (EnumMap CTag ([Mem], Term ANormalF v)
    -> Branched (Term ANormalF v))
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Term ANormalF v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference
-> EnumMap CTag ([Mem], Term ANormalF v)
-> Branched (Term ANormalF v)
forall e. Reference -> EnumMap CTag ([Mem], e) -> Branched e
MatchDataCover Reference
Ty.seqViewRef (EnumMap CTag ([Mem], Term ANormalF v) -> DNormal v)
-> EnumMap CTag ([Mem], Term ANormalF v) -> DNormal v
forall a b. (a -> b) -> a -> b
$
            [(CTag, ([Mem], Term ANormalF v))]
-> EnumMap CTag ([Mem], Term ANormalF v)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList
              [ (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
Ty.seqViewEmpty, ([], v -> Term ANormalF v
df v
s)),
                (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
Ty.seqViewElem, ([Mem
BX, Mem
BX], Term ANormalF v
bd))
              ]
        )
      where
        op :: Reference
op
          | SeqEnd
SLeft <- SeqEnd
en = Text -> Reference
forall t h. t -> Reference' t h
Builtin Text
"List.splitLeft"
          | Bool
otherwise = Text -> Reference
forall t h. t -> Reference' t h
Builtin Text
"List.splitRight"
        lit :: v -> Cte v
lit v
i = Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
forall a. Direction a
Direct v
i Mem
BX (Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TBLit (Lit -> Term ANormalF v)
-> (Word64 -> Lit) -> Word64 -> Term ANormalF v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Lit
N (Word64 -> Term ANormalF v) -> Word64 -> Term ANormalF v
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
        df :: v -> Term ANormalF v
df v
n =
          Term ANormalF v -> Maybe (Term ANormalF v) -> Term ANormalF v
forall a. a -> Maybe a -> a
fromMaybe
            ( Direction Word16
-> v
-> Mem
-> Term ANormalF v
-> Term ANormalF v
-> Term ANormalF v
forall v.
Var v =>
Direction Word16
-> v
-> Mem
-> Term ANormalF v
-> Term ANormalF v
-> Term ANormalF v
TLet Direction Word16
forall a. Direction a
Direct v
n Mem
BX (Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TLit (Text -> Lit
T Text
"pattern match failure")) (Term ANormalF v -> Term ANormalF v)
-> Term ANormalF v -> Term ANormalF v
forall a b. (a -> b) -> a -> b
$
                POp -> [v] -> Term ANormalF v
forall v. Var v => POp -> [v] -> Term ANormalF v
TPrm POp
EROR [v
n, v
v]
            )
            Maybe (Term ANormalF v)
mdf
    BranchAccum v
AccumEmpty -> (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v -> Branched (Term ANormalF v) -> Term ANormalF v
forall v.
Var v =>
v -> Branched (Term ANormalF v) -> Term ANormalF v
TMatch v
v Branched (Term ANormalF v)
forall e. Branched e
MatchEmpty)
anfBlock (Let1Named' v
v Term v a
b Term v a
e) =
  Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
b ReaderT
  (Set v)
  (State (Word64, Word16, [(v, SuperNormal v)]))
  (Ctx v, DNormal v)
-> ((Ctx v, DNormal v)
    -> ReaderT
         (Set v)
         (State (Word64, Word16, [(v, SuperNormal v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
-> (a
    -> ReaderT
         (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b)
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Ctx v
bctx, (Direction ()
Direct, TVar v
u)) -> do
      (Ctx v
ectx, DNormal v
ce) <- Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
e
      (Ctx v
ectx, Bool
shaded) <- (Ctx v, Bool)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, Bool)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Ctx v, Bool)
 -> ReaderT
      (Set v)
      (State (Word64, Word16, [(v, SuperNormal v)]))
      (Ctx v, Bool))
-> (Ctx v, Bool)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, Bool)
forall a b. (a -> b) -> a -> b
$ v -> v -> Ctx v -> (Ctx v, Bool)
forall v. Var v => v -> v -> Ctx v -> (Ctx v, Bool)
renameCtx v
v v
u Ctx v
ectx
      DNormal v
ce <- DNormal v -> ANFM v (DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNormal v -> ANFM v (DNormal v))
-> DNormal v -> ANFM v (DNormal v)
forall a b. (a -> b) -> a -> b
$ if Bool
shaded then DNormal v
ce else v -> v -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *).
(Var v, Ord v, Bifunctor f, Bifoldable f) =>
v -> v -> Term f v -> Term f v
ABTN.rename v
v v
u (Term ANormalF v -> Term ANormalF v) -> DNormal v -> DNormal v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DNormal v
ce
      pure (Ctx v
bctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
ectx, DNormal v
ce)
    (Ctx v
bctx, (Direction ()
d0, Term ANormalF v
cb)) -> [v]
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v r. Ord v => [v] -> ANFM v r -> ANFM v r
bindLocal [v
v] (ReaderT
   (Set v)
   (State (Word64, Word16, [(v, SuperNormal v)]))
   (Ctx v, DNormal v)
 -> ReaderT
      (Set v)
      (State (Word64, Word16, [(v, SuperNormal v)]))
      (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b. (a -> b) -> a -> b
$ do
      (Ctx v
ectx, DNormal v
ce) <- Term v a
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
e
      Direction Word16
d <- Direction ()
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction Word16)
forall a v. Direction a -> ANFM v (Direction Word16)
bindDirection Direction ()
d0
      let octx :: Ctx v
octx = Ctx v
bctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall (f :: * -> *) v.
Foldable f =>
f (Cte v) -> Directed () (f (Cte v))
directed [Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d v
v Mem
BX Term ANormalF v
cb] Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
ectx
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
octx, DNormal v
ce)
anfBlock (Apps' (Blank' Blank a
b) [Term v a]
args) = do
  v
nm <- ANFM v v
forall v. Var v => ANFM v v
fresh
  (Ctx v
actx, [v]
cas) <- [Term v a] -> ANFM v (Ctx v, [v])
forall v a. Var v => [Term v a] -> ANFM v (Ctx v, [v])
anfArgs [Term v a]
args
  pure
    ( Ctx v
actx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> [Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
forall a. Direction a
Direct v
nm Mem
BX (Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TLit (Text -> Lit
T Text
msg))],
      Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ POp -> [v] -> Term ANormalF v
forall v. Var v => POp -> [v] -> Term ANormalF v
TPrm POp
EROR (v
nm v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
cas)
    )
  where
    msg :: Text
msg = String -> Text
Util.Text.pack (String -> Text)
-> (Maybe String -> String) -> Maybe String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"blank expression" (Maybe String -> Text) -> Maybe String -> Text
forall a b. (a -> b) -> a -> b
$ Blank a -> Maybe String
forall loc. Blank loc -> Maybe String
nameb Blank a
b
anfBlock (Apps' Term v a
f [Term v a]
args) = do
  (Ctx v
fctx, (Direction ()
d, Func v
cf)) <- Term v a -> ANFM v (Ctx v, Directed () (Func v))
forall v a.
Var v =>
Term v a -> ANFM v (Ctx v, Directed () (Func v))
anfFunc Term v a
f
  (Ctx v
actx, [v]
cas) <- [Term v a] -> ANFM v (Ctx v, [v])
forall v a. Var v => [Term v a] -> ANFM v (Ctx v, [v])
anfArgs [Term v a]
args
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
fctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
actx, (Direction ()
d, Func v -> [v] -> Term ANormalF v
forall v. Var v => Func v -> [v] -> Term ANormalF v
TApp Func v
cf [v]
cas))
anfBlock (Constructor' (ConstructorReference Reference
r Word64
t)) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ Reference -> CTag -> [v] -> Term ANormalF v
forall v. Var v => Reference -> CTag -> [v] -> Term ANormalF v
TCon Reference
r (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t) [])
anfBlock (Request' (ConstructorReference Reference
r Word64
t)) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, (() -> Direction ()
forall a. a -> Direction a
Indirect (), Reference -> CTag -> [v] -> Term ANormalF v
forall v. Var v => Reference -> CTag -> [v] -> Term ANormalF v
TReq Reference
r (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t) []))
anfBlock (Boolean' Bool
b) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ Reference -> CTag -> [v] -> Term ANormalF v
forall v. Var v => Reference -> CTag -> [v] -> Term ANormalF v
TCon Reference
Ty.booleanRef (if Bool
b then CTag
1 else CTag
0) [])
anfBlock (Lit' l :: Lit
l@(T Text
_)) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TLit Lit
l)
anfBlock (Lit' Lit
l) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TBLit Lit
l)
anfBlock (Ref' Reference
r) = (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, (() -> Direction ()
forall a. a -> Direction a
Indirect (), Reference -> [v] -> Term ANormalF v
forall v. Var v => Reference -> [v] -> Term ANormalF v
TCom Reference
r []))
anfBlock (Blank' Blank a
b) = do
  v
nm <- ANFM v v
forall v. Var v => ANFM v v
fresh
  v
ev <- ANFM v v
forall v. Var v => ANFM v v
fresh
  pure
    ( [Cte v] -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
forall a. Direction a
Direct v
nm Mem
BX (Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TLit (Text -> Lit
T Text
name)),
          Direction Word16 -> v -> Mem -> Term ANormalF v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
forall a. Direction a
Direct v
ev Mem
BX (Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TLit (Text -> Lit
T (Text -> Lit) -> Text -> Lit
forall a b. (a -> b) -> a -> b
$ String -> Text
Util.Text.pack String
msg))
        ],
      Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v) -> Term ANormalF v -> DNormal v
forall a b. (a -> b) -> a -> b
$ POp -> [v] -> Term ANormalF v
forall v. Var v => POp -> [v] -> Term ANormalF v
TPrm POp
EROR [v
nm, v
ev]
    )
  where
    name :: Text
name = Text
"blank expression"
    msg :: String
msg = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"blank expression" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Blank a -> Maybe String
forall loc. Blank loc -> Maybe String
nameb Blank a
b
anfBlock (TermLink' Referent
r) = (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v)
-> (Lit -> Term ANormalF v) -> Lit -> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TLit (Lit -> DNormal v) -> Lit -> DNormal v
forall a b. (a -> b) -> a -> b
$ Referent -> Lit
LM Referent
r)
anfBlock (TypeLink' Reference
r) = (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v)
-> (Lit -> Term ANormalF v) -> Lit -> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Term ANormalF v
forall v. Var v => Lit -> Term ANormalF v
TLit (Lit -> DNormal v) -> Lit -> DNormal v
forall a b. (a -> b) -> a -> b
$ Reference -> Lit
LY Reference
r)
anfBlock (List' Seq (Term v a)
as) = ([v] -> DNormal v) -> (Ctx v, [v]) -> (Ctx v, DNormal v)
forall a b. (a -> b) -> (Ctx v, a) -> (Ctx v, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term ANormalF v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v -> DNormal v)
-> ([v] -> Term ANormalF v) -> [v] -> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POp -> [v] -> Term ANormalF v
forall v. Var v => POp -> [v] -> Term ANormalF v
TPrm POp
BLDS) ((Ctx v, [v]) -> (Ctx v, DNormal v))
-> ANFM v (Ctx v, [v])
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term v a] -> ANFM v (Ctx v, [v])
forall v a. Var v => [Term v a] -> ANFM v (Ctx v, [v])
anfArgs [Term v a]
tms
  where
    tms :: [Term v a]
tms = Seq (Term v a) -> [Term v a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term v a)
as
anfBlock Term v a
t = String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug (String
 -> ReaderT
      (Set v)
      (State (Word64, Word16, [(v, SuperNormal v)]))
      (Ctx v, DNormal v))
-> String
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b. (a -> b) -> a -> b
$ String
"anf: unhandled term: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term v a -> String
forall a. Show a => a -> String
show Term v a
t

-- Note: this assumes that patterns have already been translated
-- to a state in which every case matches a single layer of data,
-- with no guards, and no variables ignored. This is not checked
-- completely.
anfInitCase ::
  (Var v) =>
  v ->
  MatchCase p (Term v a) ->
  ANFD v (BranchAccum v)
anfInitCase :: forall v p a.
Var v =>
v -> MatchCase p (Term v a) -> ANFD v (BranchAccum v)
anfInitCase v
u (MatchCase Pattern p
p Maybe (Term v a)
guard (ABT.AbsN' [v]
vs Term v a
bd))
  | Just Term v a
_ <- Maybe (Term v a)
guard = String -> ANFD v (BranchAccum v)
forall a. HasCallStack => String -> a
internalBug String
"anfInitCase: unexpected guard"
  | P.Unbound p
_ <- Pattern p
p,
    [] <- [v]
vs =
      ANormal v -> BranchAccum v
forall v. ANormal v -> BranchAccum v
AccumDefault (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
  | P.Var p
_ <- Pattern p
p,
    [v
v] <- [v]
vs =
      ANormal v -> BranchAccum v
forall v. ANormal v -> BranchAccum v
AccumDefault (ANormal v -> BranchAccum v)
-> (ANormal v -> ANormal v) -> ANormal v -> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> v -> ANormal v -> ANormal v
forall v (f :: * -> * -> *).
(Var v, Ord v, Bifunctor f, Bifoldable f) =>
v -> v -> Term f v -> Term f v
ABTN.rename v
v v
u (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
  | P.Var p
_ <- Pattern p
p =
      String -> ANFD v (BranchAccum v)
forall a. HasCallStack => String -> a
internalBug (String -> ANFD v (BranchAccum v))
-> String -> ANFD v (BranchAccum v)
forall a b. (a -> b) -> a -> b
$ String
"vars: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
vs)
  | P.Int p
_ (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Word64
i) <- Pattern p
p =
      Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
AccumIntegral Reference
Ty.intRef Maybe (ANormal v)
forall a. Maybe a
Nothing (EnumMap Word64 (ANormal v) -> BranchAccum v)
-> (ANormal v -> EnumMap Word64 (ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ANormal v -> EnumMap Word64 (ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
i (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
  | P.Nat p
_ Word64
i <- Pattern p
p =
      Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
AccumIntegral Reference
Ty.natRef Maybe (ANormal v)
forall a. Maybe a
Nothing (EnumMap Word64 (ANormal v) -> BranchAccum v)
-> (ANormal v -> EnumMap Word64 (ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ANormal v -> EnumMap Word64 (ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
i (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
  | P.Char p
_ Char
c <- Pattern p
p,
    Word64
w <- Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c =
      Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v) -> EnumMap Word64 (ANormal v) -> BranchAccum v
AccumIntegral Reference
Ty.charRef Maybe (ANormal v)
forall a. Maybe a
Nothing (EnumMap Word64 (ANormal v) -> BranchAccum v)
-> (ANormal v -> EnumMap Word64 (ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ANormal v -> EnumMap Word64 (ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton Word64
w (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
  | P.Boolean p
_ Bool
b <- Pattern p
p,
    CTag
t <- if Bool
b then CTag
1 else CTag
0 =
      Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
AccumData Reference
Ty.booleanRef Maybe (ANormal v)
forall a. Maybe a
Nothing
        (EnumMap CTag ([Mem], ANormal v) -> BranchAccum v)
-> (ANormal v -> EnumMap CTag ([Mem], ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag -> ([Mem], ANormal v) -> EnumMap CTag ([Mem], ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton CTag
t
        (([Mem], ANormal v) -> EnumMap CTag ([Mem], ANormal v))
-> (ANormal v -> ([Mem], ANormal v))
-> ANormal v
-> EnumMap CTag ([Mem], ANormal v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([],)
        (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
  | P.Text p
_ Text
t <- Pattern p
p,
    [] <- [v]
vs =
      Maybe (ANormal v) -> Map Text (ANormal v) -> BranchAccum v
forall v.
Maybe (ANormal v) -> Map Text (ANormal v) -> BranchAccum v
AccumText Maybe (ANormal v)
forall a. Maybe a
Nothing (Map Text (ANormal v) -> BranchAccum v)
-> (ANormal v -> Map Text (ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ANormal v -> Map Text (ANormal v)
forall k a. k -> a -> Map k a
Map.singleton (Text -> Text
Util.Text.fromText Text
t) (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
  | P.Constructor p
_ (ConstructorReference Reference
r Word64
t) [Pattern p]
ps <- Pattern p
p = do
      (,)
        ([v] -> ANormal v -> ([v], ANormal v))
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v) ((,) (Direction ())) (ANormal v -> ([v], ANormal v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern p] -> [v] -> Compose (ANFM v) ((,) (Direction ())) [v]
forall v p. Var v => [Pattern p] -> [v] -> ANFD v [v]
expandBindings [Pattern p]
ps [v]
vs
        Compose
  (ANFM v) ((,) (Direction ())) (ANormal v -> ([v], ANormal v))
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) ([v], ANormal v)
forall a b.
Compose (ANFM v) ((,) (Direction ())) (a -> b)
-> Compose (ANFM v) ((,) (Direction ())) a
-> Compose (ANFM v) ((,) (Direction ())) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
        Compose (ANFM v) ((,) (Direction ())) ([v], ANormal v)
-> (([v], ANormal v) -> BranchAccum v) -> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([v]
us, ANormal v
bd) ->
          Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap CTag ([Mem], ANormal v)
-> BranchAccum v
AccumData Reference
r Maybe (ANormal v)
forall a. Maybe a
Nothing (EnumMap CTag ([Mem], ANormal v) -> BranchAccum v)
-> (ANormal v -> EnumMap CTag ([Mem], ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag -> ([Mem], ANormal v) -> EnumMap CTag ([Mem], ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t) (([Mem], ANormal v) -> EnumMap CTag ([Mem], ANormal v))
-> (ANormal v -> ([Mem], ANormal v))
-> ANormal v
-> EnumMap CTag ([Mem], ANormal v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Mem
BX Mem -> [v] -> [Mem]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [v]
us,) (ANormal v -> BranchAccum v) -> ANormal v -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ [v] -> ANormal v -> ANormal v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
us ANormal v
bd
  | P.EffectPure p
_ Pattern p
q <- Pattern p
p =
      (,)
        ([v] -> ANormal v -> ([v], ANormal v))
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v) ((,) (Direction ())) (ANormal v -> ([v], ANormal v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern p] -> [v] -> Compose (ANFM v) ((,) (Direction ())) [v]
forall v p. Var v => [Pattern p] -> [v] -> ANFD v [v]
expandBindings [Pattern p
q] [v]
vs
        Compose
  (ANFM v) ((,) (Direction ())) (ANormal v -> ([v], ANormal v))
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) ([v], ANormal v)
forall a b.
Compose (ANFM v) ((,) (Direction ())) (a -> b)
-> Compose (ANFM v) ((,) (Direction ())) a
-> Compose (ANFM v) ((,) (Direction ())) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
        Compose (ANFM v) ((,) (Direction ())) ([v], ANormal v)
-> (([v], ANormal v) -> BranchAccum v) -> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([v]
us, ANormal v
bd) -> ANormal v -> BranchAccum v
forall v. ANormal v -> BranchAccum v
AccumPure (ANormal v -> BranchAccum v) -> ANormal v -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ [v] -> ANormal v -> ANormal v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
us ANormal v
bd
  | P.EffectBind p
_ (ConstructorReference Reference
r Word64
t) [Pattern p]
ps Pattern p
pk <- Pattern p
p = do
      (,,)
        ([v] -> v -> ANormal v -> ([v], v, ANormal v))
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (v -> ANormal v -> ([v], v, ANormal v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern p] -> [v] -> Compose (ANFM v) ((,) (Direction ())) [v]
forall v p. Var v => [Pattern p] -> [v] -> ANFD v [v]
expandBindings ([Pattern p] -> Pattern p -> [Pattern p]
forall s a. Snoc s s a a => s -> a -> s
snoc [Pattern p]
ps Pattern p
pk) [v]
vs
        Compose
  (ANFM v)
  ((,) (Direction ()))
  (v -> ANormal v -> ([v], v, ANormal v))
-> Compose (ANFM v) ((,) (Direction ())) v
-> Compose
     (ANFM v) ((,) (Direction ())) (ANormal v -> ([v], v, ANormal v))
forall a b.
Compose (ANFM v) ((,) (Direction ())) (a -> b)
-> Compose (ANFM v) ((,) (Direction ())) a
-> Compose (ANFM v) ((,) (Direction ())) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ANFM v (Directed () v) -> Compose (ANFM v) ((,) (Direction ())) v
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (v -> Directed () v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> Directed () v) -> ANFM v v -> ANFM v (Directed () v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ANFM v v
forall v. Var v => ANFM v v
fresh)
        Compose
  (ANFM v) ((,) (Direction ())) (ANormal v -> ([v], v, ANormal v))
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) ([v], v, ANormal v)
forall a b.
Compose (ANFM v) ((,) (Direction ())) (a -> b)
-> Compose (ANFM v) ((,) (Direction ())) a
-> Compose (ANFM v) ((,) (Direction ())) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
        Compose (ANFM v) ((,) (Direction ())) ([v], v, ANormal v)
-> (([v], v, ANormal v) -> BranchAccum v) -> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([v]
exp, v
kf, ANormal v
bd) ->
          let ([v]
us, v
uk) =
                ([v], v) -> (([v], v) -> ([v], v)) -> Maybe ([v], v) -> ([v], v)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ([v], v)
forall a. HasCallStack => String -> a
internalBug String
"anfInitCase: unsnoc impossible") ([v], v) -> ([v], v)
forall a. a -> a
id (Maybe ([v], v) -> ([v], v)) -> Maybe ([v], v) -> ([v], v)
forall a b. (a -> b) -> a -> b
$
                  [v] -> Maybe ([v], v)
forall s a. Snoc s s a a => s -> Maybe (s, a)
unsnoc [v]
exp
              jn :: Reference' Text h
jn = Text -> Reference' Text h
forall t h. t -> Reference' t h
Builtin Text
"jumpCont"
           in (Map Reference (EnumMap CTag ([Mem], ANormal v))
 -> Maybe (ANormal v) -> BranchAccum v)
-> Maybe (ANormal v)
-> Map Reference (EnumMap CTag ([Mem], ANormal v))
-> BranchAccum v
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Maybe (ANormal v) -> BranchAccum v
forall v.
Map Reference (EnumMap CTag ([Mem], ANormal v))
-> Maybe (ANormal v) -> BranchAccum v
AccumRequest Maybe (ANormal v)
forall a. Maybe a
Nothing
                (Map Reference (EnumMap CTag ([Mem], ANormal v)) -> BranchAccum v)
-> (ANormal v -> Map Reference (EnumMap CTag ([Mem], ANormal v)))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference
-> EnumMap CTag ([Mem], ANormal v)
-> Map Reference (EnumMap CTag ([Mem], ANormal v))
forall k a. k -> a -> Map k a
Map.singleton Reference
r
                (EnumMap CTag ([Mem], ANormal v)
 -> Map Reference (EnumMap CTag ([Mem], ANormal v)))
-> (ANormal v -> EnumMap CTag ([Mem], ANormal v))
-> ANormal v
-> Map Reference (EnumMap CTag ([Mem], ANormal v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag -> ([Mem], ANormal v) -> EnumMap CTag ([Mem], ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton (Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t)
                (([Mem], ANormal v) -> EnumMap CTag ([Mem], ANormal v))
-> (ANormal v -> ([Mem], ANormal v))
-> ANormal v
-> EnumMap CTag ([Mem], ANormal v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Mem
BX Mem -> [v] -> [Mem]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [v]
us,)
                (ANormal v -> ([Mem], ANormal v))
-> (ANormal v -> ANormal v) -> ANormal v -> ([Mem], ANormal v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> ANormal v -> ANormal v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
us
                (ANormal v -> ANormal v)
-> (ANormal v -> ANormal v) -> ANormal v -> ANormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> v -> ANormal v -> ANormal v
forall v.
Var v =>
Reference -> v -> Term ANormalF v -> Term ANormalF v
TShift Reference
r v
kf
                (ANormal v -> BranchAccum v) -> ANormal v -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ v -> Either Reference v -> [v] -> ANormal v -> ANormal v
forall v.
Var v =>
v
-> Either Reference v -> [v] -> Term ANormalF v -> Term ANormalF v
TName v
uk (Reference -> Either Reference v
forall a b. a -> Either a b
Left Reference
forall {h}. Reference' Text h
jn) [v
kf] ANormal v
bd
  | P.SequenceLiteral p
_ [] <- Pattern p
p =
      ANormal v -> BranchAccum v
forall v. ANormal v -> BranchAccum v
AccumSeqEmpty (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd
  | P.SequenceOp p
_ Pattern p
l SeqOp
op Pattern p
r <- Pattern p
p,
    SeqOp
Concat <- SeqOp
op,
    P.SequenceLiteral p
p [Pattern p]
ll <- Pattern p
l = do
      SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v.
SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqSplit SeqEnd
SLeft ([Pattern p] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern p]
ll) Maybe (ANormal v)
forall a. Maybe a
Nothing
        (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([v] -> ANormal v -> ANormal v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss ([v] -> ANormal v -> ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v -> ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern p] -> [v] -> Compose (ANFM v) ((,) (Direction ())) [v]
forall v p. Var v => [Pattern p] -> [v] -> ANFD v [v]
expandBindings [p -> Pattern p
forall loc. loc -> Pattern loc
P.Var p
p, Pattern p
r] [v]
vs Compose (ANFM v) ((,) (Direction ())) (ANormal v -> ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
forall a b.
Compose (ANFM v) ((,) (Direction ())) (a -> b)
-> Compose (ANFM v) ((,) (Direction ())) a
-> Compose (ANFM v) ((,) (Direction ())) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd)
  | P.SequenceOp p
_ Pattern p
l SeqOp
op Pattern p
r <- Pattern p
p,
    SeqOp
Concat <- SeqOp
op,
    P.SequenceLiteral p
p [Pattern p]
rl <- Pattern p
r =
      SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v.
SeqEnd -> Int -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqSplit SeqEnd
SLeft ([Pattern p] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern p]
rl) Maybe (ANormal v)
forall a. Maybe a
Nothing
        (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([v] -> ANormal v -> ANormal v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss ([v] -> ANormal v -> ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v -> ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern p] -> [v] -> Compose (ANFM v) ((,) (Direction ())) [v]
forall v p. Var v => [Pattern p] -> [v] -> ANFD v [v]
expandBindings [Pattern p
l, p -> Pattern p
forall loc. loc -> Pattern loc
P.Var p
p] [v]
vs Compose (ANFM v) ((,) (Direction ())) (ANormal v -> ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
forall a b.
Compose (ANFM v) ((,) (Direction ())) (a -> b)
-> Compose (ANFM v) ((,) (Direction ())) a
-> Compose (ANFM v) ((,) (Direction ())) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd)
  | P.SequenceOp p
_ Pattern p
l SeqOp
op Pattern p
r <- Pattern p
p,
    SeqEnd
dir <- case SeqOp
op of SeqOp
Cons -> SeqEnd
SLeft; SeqOp
_ -> SeqEnd
SRight =
      SeqEnd -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
forall v. SeqEnd -> Maybe (ANormal v) -> ANormal v -> BranchAccum v
AccumSeqView SeqEnd
dir Maybe (ANormal v)
forall a. Maybe a
Nothing
        (ANormal v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([v] -> ANormal v -> ANormal v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss ([v] -> ANormal v -> ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v -> ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern p] -> [v] -> Compose (ANFM v) ((,) (Direction ())) [v]
forall v p. Var v => [Pattern p] -> [v] -> ANFD v [v]
expandBindings [Pattern p
l, Pattern p
r] [v]
vs Compose (ANFM v) ((,) (Direction ())) (ANormal v -> ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
forall a b.
Compose (ANFM v) ((,) (Direction ())) (a -> b)
-> Compose (ANFM v) ((,) (Direction ())) a
-> Compose (ANFM v) ((,) (Direction ())) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
bd)
  where
    anfBody :: Term v a -> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
anfBody Term v a
tm = ReaderT
  (Set v)
  (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
  (Direction (), ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ReaderT
   (Set v)
   (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
   (Direction (), ANormal v)
 -> Compose (ANFM v) ((,) (Direction ())) (ANormal v))
-> (ReaderT
      (Set v)
      (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
      (Direction (), ANormal v)
    -> ReaderT
         (Set v)
         (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
         (Direction (), ANormal v))
-> ReaderT
     (Set v)
     (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
     (Direction (), ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v]
-> ReaderT
     (Set v)
     (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
     (Direction (), ANormal v)
-> ReaderT
     (Set v)
     (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
     (Direction (), ANormal v)
forall v r. Ord v => [v] -> ANFM v r -> ANFM v r
bindLocal [v]
vs (ReaderT
   (Set v)
   (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
   (Direction (), ANormal v)
 -> Compose (ANFM v) ((,) (Direction ())) (ANormal v))
-> ReaderT
     (Set v)
     (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
     (Direction (), ANormal v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal v)
forall a b. (a -> b) -> a -> b
$ Term v a
-> ReaderT
     (Set v)
     (StateT (Word64, Word16, [(v, SuperNormal v)]) Identity)
     (Direction (), ANormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
tm
anfInitCase v
_ (MatchCase Pattern p
p Maybe (Term v a)
_ Term v a
_) =
  String -> ANFD v (BranchAccum v)
forall a. HasCallStack => String -> a
internalBug (String -> ANFD v (BranchAccum v))
-> String -> ANFD v (BranchAccum v)
forall a b. (a -> b) -> a -> b
$ String
"anfInitCase: unexpected pattern: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Pattern p -> String
forall a. Show a => a -> String
show Pattern p
p

valueTermLinks :: Value -> [Reference]
valueTermLinks :: Value -> [Reference]
valueTermLinks = Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList (Set Reference -> [Reference])
-> (Value -> Set Reference) -> Value -> [Reference]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Reference -> Set Reference) -> Value -> Set Reference
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> Set Reference
forall {a}. Bool -> a -> Set a
f
  where
    f :: Bool -> a -> Set a
f Bool
False a
r = a -> Set a
forall a. a -> Set a
Set.singleton a
r
    f Bool
_ a
_ = Set a
forall a. Set a
Set.empty

valueLinks :: (Monoid a) => (Bool -> Reference -> a) -> Value -> a
valueLinks :: forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> a
f (Partial (GR Reference
cr Word64
_) [Word64]
_ [Value]
bs) =
  Bool -> Reference -> a
f Bool
False Reference
cr a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Value -> a) -> [Value] -> a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Bool -> Reference -> a) -> Value -> a
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> a
f) [Value]
bs
valueLinks Bool -> Reference -> a
f (Data Reference
dr Word64
_ [Word64]
_ [Value]
bs) =
  Bool -> Reference -> a
f Bool
True Reference
dr a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Value -> a) -> [Value] -> a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Bool -> Reference -> a) -> Value -> a
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> a
f) [Value]
bs
valueLinks Bool -> Reference -> a
f (Cont [Word64]
_ [Value]
bs Cont
k) =
  (Value -> a) -> [Value] -> a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Bool -> Reference -> a) -> Value -> a
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> a
f) [Value]
bs a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Bool -> Reference -> a) -> Cont -> a
forall a. Monoid a => (Bool -> Reference -> a) -> Cont -> a
contLinks Bool -> Reference -> a
f Cont
k
valueLinks Bool -> Reference -> a
f (BLit BLit
l) = (Bool -> Reference -> a) -> BLit -> a
forall a. Monoid a => (Bool -> Reference -> a) -> BLit -> a
blitLinks Bool -> Reference -> a
f BLit
l

contLinks :: (Monoid a) => (Bool -> Reference -> a) -> Cont -> a
contLinks :: forall a. Monoid a => (Bool -> Reference -> a) -> Cont -> a
contLinks Bool -> Reference -> a
f (Push Word64
_ Word64
_ Word64
_ Word64
_ (GR Reference
cr Word64
_) Cont
k) =
  Bool -> Reference -> a
f Bool
False Reference
cr a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Bool -> Reference -> a) -> Cont -> a
forall a. Monoid a => (Bool -> Reference -> a) -> Cont -> a
contLinks Bool -> Reference -> a
f Cont
k
contLinks Bool -> Reference -> a
f (Mark Word64
_ Word64
_ [Reference]
ps Map Reference Value
de Cont
k) =
  (Reference -> a) -> [Reference] -> a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Bool -> Reference -> a
f Bool
True) [Reference]
ps
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Reference -> Value -> a) -> Map Reference Value -> a
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\Reference
k Value
c -> Bool -> Reference -> a
f Bool
True Reference
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Bool -> Reference -> a) -> Value -> a
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> a
f Value
c) Map Reference Value
de
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Bool -> Reference -> a) -> Cont -> a
forall a. Monoid a => (Bool -> Reference -> a) -> Cont -> a
contLinks Bool -> Reference -> a
f Cont
k
contLinks Bool -> Reference -> a
_ Cont
KE = a
forall a. Monoid a => a
mempty

blitLinks :: (Monoid a) => (Bool -> Reference -> a) -> BLit -> a
blitLinks :: forall a. Monoid a => (Bool -> Reference -> a) -> BLit -> a
blitLinks Bool -> Reference -> a
f (List Seq Value
s) = (Value -> a) -> Seq Value -> a
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Bool -> Reference -> a) -> Value -> a
forall a. Monoid a => (Bool -> Reference -> a) -> Value -> a
valueLinks Bool -> Reference -> a
f) Seq Value
s
blitLinks Bool -> Reference -> a
_ BLit
_ = a
forall a. Monoid a => a
mempty

groupTermLinks :: (Var v) => SuperGroup v -> [Reference]
groupTermLinks :: forall v. Var v => SuperGroup v -> [Reference]
groupTermLinks = Set Reference -> [Reference]
forall a. Set a -> [a]
Set.toList (Set Reference -> [Reference])
-> (SuperGroup v -> Set Reference) -> SuperGroup v -> [Reference]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Reference -> Set Reference)
-> SuperGroup v -> Set Reference
forall r v.
(Monoid r, Var v) =>
(Bool -> Reference -> r) -> SuperGroup v -> r
foldGroupLinks Bool -> Reference -> Set Reference
forall {a}. Bool -> a -> Set a
f
  where
    f :: Bool -> a -> Set a
f Bool
False a
r = a -> Set a
forall a. a -> Set a
Set.singleton a
r
    f Bool
_ a
_ = Set a
forall a. Set a
Set.empty

overGroupLinks ::
  (Var v) =>
  (Bool -> Reference -> Reference) ->
  SuperGroup v ->
  SuperGroup v
overGroupLinks :: forall v.
Var v =>
(Bool -> Reference -> Reference) -> SuperGroup v -> SuperGroup v
overGroupLinks Bool -> Reference -> Reference
f =
  Identity (SuperGroup v) -> SuperGroup v
forall a. Identity a -> a
runIdentity (Identity (SuperGroup v) -> SuperGroup v)
-> (SuperGroup v -> Identity (SuperGroup v))
-> SuperGroup v
-> SuperGroup v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Reference -> Identity Reference)
-> SuperGroup v -> Identity (SuperGroup v)
forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference)
-> SuperGroup v -> f (SuperGroup v)
traverseGroupLinks (\Bool
b -> Reference -> Identity Reference
forall a. a -> Identity a
Identity (Reference -> Identity Reference)
-> (Reference -> Reference) -> Reference -> Identity Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Reference -> Reference
f Bool
b)

traverseGroupLinks ::
  (Applicative f, Var v) =>
  (Bool -> Reference -> f Reference) ->
  SuperGroup v ->
  f (SuperGroup v)
traverseGroupLinks :: forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference)
-> SuperGroup v -> f (SuperGroup v)
traverseGroupLinks Bool -> Reference -> f Reference
f (Rec [(v, SuperNormal v)]
bs SuperNormal v
e) =
  [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
forall v. [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
Rec ([(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v)
-> f [(v, SuperNormal v)] -> f (SuperNormal v -> SuperGroup v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((v, SuperNormal v) -> f (v, SuperNormal v))
-> [(v, SuperNormal v)] -> f [(v, SuperNormal 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 (((v, SuperNormal v) -> f (v, SuperNormal v))
 -> [(v, SuperNormal v)] -> f [(v, SuperNormal v)])
-> ((SuperNormal v -> f (SuperNormal v))
    -> (v, SuperNormal v) -> f (v, SuperNormal v))
-> (SuperNormal v -> f (SuperNormal v))
-> [(v, SuperNormal v)]
-> f [(v, SuperNormal v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuperNormal v -> f (SuperNormal v))
-> (v, SuperNormal v) -> f (v, SuperNormal 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) -> (v, a) -> f (v, b)
traverse) ((Bool -> Reference -> f Reference)
-> SuperNormal v -> f (SuperNormal v)
forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference)
-> SuperNormal v -> f (SuperNormal v)
normalLinks Bool -> Reference -> f Reference
f) [(v, SuperNormal v)]
bs f (SuperNormal v -> SuperGroup v)
-> f (SuperNormal v) -> f (SuperGroup v)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Bool -> Reference -> f Reference)
-> SuperNormal v -> f (SuperNormal v)
forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference)
-> SuperNormal v -> f (SuperNormal v)
normalLinks Bool -> Reference -> f Reference
f SuperNormal v
e

foldGroupLinks ::
  (Monoid r, Var v) =>
  (Bool -> Reference -> r) ->
  SuperGroup v ->
  r
foldGroupLinks :: forall r v.
(Monoid r, Var v) =>
(Bool -> Reference -> r) -> SuperGroup v -> r
foldGroupLinks Bool -> Reference -> r
f = Const r (SuperGroup v) -> r
forall {k} a (b :: k). Const a b -> a
getConst (Const r (SuperGroup v) -> r)
-> (SuperGroup v -> Const r (SuperGroup v)) -> SuperGroup v -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Reference -> Const r Reference)
-> SuperGroup v -> Const r (SuperGroup v)
forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference)
-> SuperGroup v -> f (SuperGroup v)
traverseGroupLinks (\Bool
b -> r -> Const r Reference
forall {k} a (b :: k). a -> Const a b
Const (r -> Const r Reference)
-> (Reference -> r) -> Reference -> Const r Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Reference -> r
f Bool
b)

normalLinks ::
  (Applicative f, Var v) =>
  (Bool -> Reference -> f Reference) ->
  SuperNormal v ->
  f (SuperNormal v)
normalLinks :: forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference)
-> SuperNormal v -> f (SuperNormal v)
normalLinks Bool -> Reference -> f Reference
f (Lambda [Mem]
ccs ANormal v
e) = [Mem] -> ANormal v -> SuperNormal v
forall v. [Mem] -> ANormal v -> SuperNormal v
Lambda [Mem]
ccs (ANormal v -> SuperNormal v) -> f (ANormal v) -> f (SuperNormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Reference -> f Reference) -> ANormal v -> f (ANormal v)
forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference) -> ANormal v -> f (ANormal v)
anfLinks Bool -> Reference -> f Reference
f ANormal v
e

anfLinks ::
  (Applicative f, Var v) =>
  (Bool -> Reference -> f Reference) ->
  ANormal v ->
  f (ANormal v)
anfLinks :: forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference) -> ANormal v -> f (ANormal v)
anfLinks Bool -> Reference -> f Reference
f (ABTN.Term Set v
_ (ABTN.Abs v
v Term ANormalF v
e)) =
  v -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *). Var v => v -> Term f v -> Term f v
ABTN.TAbs v
v (Term ANormalF v -> Term ANormalF v)
-> f (Term ANormalF v) -> f (Term ANormalF v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Reference -> f Reference)
-> Term ANormalF v -> f (Term ANormalF v)
forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference) -> ANormal v -> f (ANormal v)
anfLinks Bool -> Reference -> f Reference
f Term ANormalF v
e
anfLinks Bool -> Reference -> f Reference
f (ABTN.Term Set v
_ (ABTN.Tm ANormalF v (Term ANormalF v)
e)) =
  ANormalF v (Term ANormalF v) -> Term ANormalF v
forall v (f :: * -> * -> *).
(Var v, Bifoldable f) =>
f v (Term f v) -> Term f v
ABTN.TTm (ANormalF v (Term ANormalF v) -> Term ANormalF v)
-> f (ANormalF v (Term ANormalF v)) -> f (Term ANormalF v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Reference -> f Reference)
-> (Term ANormalF v -> f (Term ANormalF v))
-> ANormalF v (Term ANormalF v)
-> f (ANormalF v (Term ANormalF v))
forall (f :: * -> *) e v.
Applicative f =>
(Bool -> Reference -> f Reference)
-> (e -> f e) -> ANormalF v e -> f (ANormalF v e)
anfFLinks Bool -> Reference -> f Reference
f ((Bool -> Reference -> f Reference)
-> Term ANormalF v -> f (Term ANormalF v)
forall (f :: * -> *) v.
(Applicative f, Var v) =>
(Bool -> Reference -> f Reference) -> ANormal v -> f (ANormal v)
anfLinks Bool -> Reference -> f Reference
f) ANormalF v (Term ANormalF v)
e

anfFLinks ::
  (Applicative f) =>
  (Bool -> Reference -> f Reference) ->
  (e -> f e) ->
  ANormalF v e ->
  f (ANormalF v e)
anfFLinks :: forall (f :: * -> *) e v.
Applicative f =>
(Bool -> Reference -> f Reference)
-> (e -> f e) -> ANormalF v e -> f (ANormalF v e)
anfFLinks Bool -> Reference -> f Reference
_ e -> f e
g (ALet Direction Word16
d [Mem]
ccs e
b e
e) = Direction Word16 -> [Mem] -> e -> e -> ANormalF v e
forall v e. Direction Word16 -> [Mem] -> e -> e -> ANormalF v e
ALet Direction Word16
d [Mem]
ccs (e -> e -> ANormalF v e) -> f e -> f (e -> ANormalF v e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> f e
g e
b f (e -> ANormalF v e) -> f e -> f (ANormalF v e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> e -> f e
g e
e
anfFLinks Bool -> Reference -> f Reference
f e -> f e
g (AName Either Reference v
er [v]
vs e
e) =
  (Either Reference v -> [v] -> e -> ANormalF v e)
-> [v] -> Either Reference v -> e -> ANormalF v e
forall a b c. (a -> b -> c) -> b -> a -> c
flip Either Reference v -> [v] -> e -> ANormalF v e
forall v e. Either Reference v -> [v] -> e -> ANormalF v e
AName [v]
vs (Either Reference v -> e -> ANormalF v e)
-> f (Either Reference v) -> f (e -> ANormalF v e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Reference -> f Reference)
-> (v -> f v) -> Either Reference v -> f (Either Reference v)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (Bool -> Reference -> f Reference
f Bool
False) v -> f v
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Reference v
er f (e -> ANormalF v e) -> f e -> f (ANormalF v e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> e -> f e
g e
e
anfFLinks Bool -> Reference -> f Reference
f e -> f e
g (AMatch v
v Branched e
bs) =
  v -> Branched e -> ANormalF v e
forall v e. v -> Branched e -> ANormalF v e
AMatch v
v (Branched e -> ANormalF v e) -> f (Branched e) -> f (ANormalF v e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Reference -> f Reference)
-> (e -> f e) -> Branched e -> f (Branched e)
forall (f :: * -> *) e.
Applicative f =>
(Reference -> f Reference)
-> (e -> f e) -> Branched e -> f (Branched e)
branchLinks (Bool -> Reference -> f Reference
f Bool
True) e -> f e
g Branched e
bs
anfFLinks Bool -> Reference -> f Reference
f e -> f e
g (AShift Reference
r e
e) =
  Reference -> e -> ANormalF v e
forall v e. Reference -> e -> ANormalF v e
AShift (Reference -> e -> ANormalF v e)
-> f Reference -> f (e -> ANormalF v e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Reference -> f Reference
f Bool
True Reference
r f (e -> ANormalF v e) -> f e -> f (ANormalF v e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> e -> f e
g e
e
anfFLinks Bool -> Reference -> f Reference
f e -> f e
g (AHnd [Reference]
rs v
v e
e) =
  ([Reference] -> v -> e -> ANormalF v e)
-> v -> [Reference] -> e -> ANormalF v e
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Reference] -> v -> e -> ANormalF v e
forall v e. [Reference] -> v -> e -> ANormalF v e
AHnd v
v ([Reference] -> e -> ANormalF v e)
-> f [Reference] -> f (e -> ANormalF v e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Reference -> f Reference) -> [Reference] -> f [Reference]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Bool -> Reference -> f Reference
f Bool
True) [Reference]
rs f (e -> ANormalF v e) -> f e -> f (ANormalF v e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> e -> f e
g e
e
anfFLinks Bool -> Reference -> f Reference
f e -> f e
_ (AApp Func v
fu [v]
vs) = (Func v -> [v] -> ANormalF v e) -> [v] -> Func v -> ANormalF v e
forall a b c. (a -> b -> c) -> b -> a -> c
flip Func v -> [v] -> ANormalF v e
forall v e. Func v -> [v] -> ANormalF v e
AApp [v]
vs (Func v -> ANormalF v e) -> f (Func v) -> f (ANormalF v e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Reference -> f Reference) -> Func v -> f (Func v)
forall (f :: * -> *) v.
Applicative f =>
(Bool -> Reference -> f Reference) -> Func v -> f (Func v)
funcLinks Bool -> Reference -> f Reference
f Func v
fu
anfFLinks Bool -> Reference -> f Reference
f e -> f e
_ (ALit Lit
l) = Lit -> ANormalF v e
forall v e. Lit -> ANormalF v e
ALit (Lit -> ANormalF v e) -> f Lit -> f (ANormalF v e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Reference -> f Reference) -> Lit -> f Lit
forall (f :: * -> *).
Applicative f =>
(Bool -> Reference -> f Reference) -> Lit -> f Lit
litLinks Bool -> Reference -> f Reference
f Lit
l
anfFLinks Bool -> Reference -> f Reference
_ e -> f e
_ ANormalF v e
v = ANormalF v e -> f (ANormalF v e)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ANormalF v e
v

litLinks ::
  (Applicative f) =>
  (Bool -> Reference -> f Reference) ->
  Lit ->
  f Lit
litLinks :: forall (f :: * -> *).
Applicative f =>
(Bool -> Reference -> f Reference) -> Lit -> f Lit
litLinks Bool -> Reference -> f Reference
f (LY Reference
r) = Reference -> Lit
LY (Reference -> Lit) -> f Reference -> f Lit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Reference -> f Reference
f Bool
True Reference
r
litLinks Bool -> Reference -> f Reference
f (LM (Con (ConstructorReference Reference
r Word64
i) ConstructorType
t)) =
  Referent -> Lit
LM (Referent -> Lit) -> (Reference -> Referent) -> Reference -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstructorReference -> ConstructorType -> Referent)
-> ConstructorType -> ConstructorReference -> Referent
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConstructorReference -> ConstructorType -> Referent
Con ConstructorType
t (ConstructorReference -> Referent)
-> (Reference -> ConstructorReference) -> Reference -> Referent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> Word64 -> ConstructorReference)
-> Word64 -> Reference -> ConstructorReference
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> Word64 -> ConstructorReference
forall r. r -> Word64 -> GConstructorReference r
ConstructorReference Word64
i (Reference -> Lit) -> f Reference -> f Lit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Reference -> f Reference
f Bool
True Reference
r
litLinks Bool -> Reference -> f Reference
f (LM (Ref Reference
r)) = Referent -> Lit
LM (Referent -> Lit) -> (Reference -> Referent) -> Reference -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent
Ref (Reference -> Lit) -> f Reference -> f Lit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Reference -> f Reference
f Bool
False Reference
r
litLinks Bool -> Reference -> f Reference
_ Lit
v = Lit -> f Lit
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lit
v

branchLinks ::
  (Applicative f) =>
  (Reference -> f Reference) ->
  (e -> f e) ->
  Branched e ->
  f (Branched e)
branchLinks :: forall (f :: * -> *) e.
Applicative f =>
(Reference -> f Reference)
-> (e -> f e) -> Branched e -> f (Branched e)
branchLinks Reference -> f Reference
f e -> f e
g (MatchRequest Map Reference (EnumMap CTag ([Mem], e))
m e
e) =
  Map Reference (EnumMap CTag ([Mem], e)) -> e -> Branched e
forall e.
Map Reference (EnumMap CTag ([Mem], e)) -> e -> Branched e
MatchRequest (Map Reference (EnumMap CTag ([Mem], e)) -> e -> Branched e)
-> ([(Reference, EnumMap CTag ([Mem], e))]
    -> Map Reference (EnumMap CTag ([Mem], e)))
-> [(Reference, EnumMap CTag ([Mem], e))]
-> e
-> Branched e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Reference, EnumMap CTag ([Mem], e))]
-> Map Reference (EnumMap CTag ([Mem], e))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    ([(Reference, EnumMap CTag ([Mem], e))] -> e -> Branched e)
-> f [(Reference, EnumMap CTag ([Mem], e))] -> f (e -> Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Reference, EnumMap CTag ([Mem], e))
 -> f (Reference, EnumMap CTag ([Mem], e)))
-> [(Reference, EnumMap CTag ([Mem], e))]
-> f [(Reference, EnumMap CTag ([Mem], e))]
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 -> f Reference)
-> (EnumMap CTag ([Mem], e) -> f (EnumMap CTag ([Mem], e)))
-> (Reference, EnumMap CTag ([Mem], e))
-> f (Reference, EnumMap CTag ([Mem], e))
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Reference -> f Reference
f ((EnumMap CTag ([Mem], e) -> f (EnumMap CTag ([Mem], e)))
 -> (Reference, EnumMap CTag ([Mem], e))
 -> f (Reference, EnumMap CTag ([Mem], e)))
-> (EnumMap CTag ([Mem], e) -> f (EnumMap CTag ([Mem], e)))
-> (Reference, EnumMap CTag ([Mem], e))
-> f (Reference, EnumMap CTag ([Mem], e))
forall a b. (a -> b) -> a -> b
$ ((([Mem], e) -> f ([Mem], e))
-> EnumMap CTag ([Mem], e) -> f (EnumMap CTag ([Mem], e))
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) -> EnumMap CTag a -> f (EnumMap CTag b)
traverse ((([Mem], e) -> f ([Mem], e))
 -> EnumMap CTag ([Mem], e) -> f (EnumMap CTag ([Mem], e)))
-> ((e -> f e) -> ([Mem], e) -> f ([Mem], e))
-> (e -> f e)
-> EnumMap CTag ([Mem], e)
-> f (EnumMap CTag ([Mem], e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> f e) -> ([Mem], e) -> f ([Mem], e)
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) -> ([Mem], a) -> f ([Mem], b)
traverse) e -> f e
g) (Map Reference (EnumMap CTag ([Mem], e))
-> [(Reference, EnumMap CTag ([Mem], e))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Reference (EnumMap CTag ([Mem], e))
m)
    f (e -> Branched e) -> f e -> f (Branched e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> e -> f e
g e
e
branchLinks Reference -> f Reference
f e -> f e
g (MatchData Reference
r EnumMap CTag ([Mem], e)
m Maybe e
e) =
  Reference -> EnumMap CTag ([Mem], e) -> Maybe e -> Branched e
forall e.
Reference -> EnumMap CTag ([Mem], e) -> Maybe e -> Branched e
MatchData (Reference -> EnumMap CTag ([Mem], e) -> Maybe e -> Branched e)
-> f Reference
-> f (EnumMap CTag ([Mem], e) -> Maybe e -> Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> f Reference
f Reference
r f (EnumMap CTag ([Mem], e) -> Maybe e -> Branched e)
-> f (EnumMap CTag ([Mem], e)) -> f (Maybe e -> Branched e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((([Mem], e) -> f ([Mem], e))
-> EnumMap CTag ([Mem], e) -> f (EnumMap CTag ([Mem], e))
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) -> EnumMap CTag a -> f (EnumMap CTag b)
traverse ((([Mem], e) -> f ([Mem], e))
 -> EnumMap CTag ([Mem], e) -> f (EnumMap CTag ([Mem], e)))
-> ((e -> f e) -> ([Mem], e) -> f ([Mem], e))
-> (e -> f e)
-> EnumMap CTag ([Mem], e)
-> f (EnumMap CTag ([Mem], e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> f e) -> ([Mem], e) -> f ([Mem], e)
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) -> ([Mem], a) -> f ([Mem], b)
traverse) e -> f e
g EnumMap CTag ([Mem], e)
m f (Maybe e -> Branched e) -> f (Maybe e) -> f (Branched e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (e -> f e) -> Maybe e -> f (Maybe e)
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) -> Maybe a -> f (Maybe b)
traverse e -> f e
g Maybe e
e
branchLinks Reference -> f Reference
_ e -> f e
g (MatchText Map Text e
m Maybe e
e) =
  Map Text e -> Maybe e -> Branched e
forall e. Map Text e -> Maybe e -> Branched e
MatchText (Map Text e -> Maybe e -> Branched e)
-> f (Map Text e) -> f (Maybe e -> Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e -> f e) -> Map Text e -> f (Map Text e)
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) -> Map Text a -> f (Map Text b)
traverse e -> f e
g Map Text e
m f (Maybe e -> Branched e) -> f (Maybe e) -> f (Branched e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (e -> f e) -> Maybe e -> f (Maybe e)
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) -> Maybe a -> f (Maybe b)
traverse e -> f e
g Maybe e
e
branchLinks Reference -> f Reference
_ e -> f e
g (MatchIntegral EnumMap Word64 e
m Maybe e
e) =
  EnumMap Word64 e -> Maybe e -> Branched e
forall e. EnumMap Word64 e -> Maybe e -> Branched e
MatchIntegral (EnumMap Word64 e -> Maybe e -> Branched e)
-> f (EnumMap Word64 e) -> f (Maybe e -> Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e -> f e) -> EnumMap Word64 e -> f (EnumMap Word64 e)
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse e -> f e
g EnumMap Word64 e
m f (Maybe e -> Branched e) -> f (Maybe e) -> f (Branched e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (e -> f e) -> Maybe e -> f (Maybe e)
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) -> Maybe a -> f (Maybe b)
traverse e -> f e
g Maybe e
e
branchLinks Reference -> f Reference
_ e -> f e
g (MatchNumeric Reference
r EnumMap Word64 e
m Maybe e
e) =
  Reference -> EnumMap Word64 e -> Maybe e -> Branched e
forall e. Reference -> EnumMap Word64 e -> Maybe e -> Branched e
MatchNumeric Reference
r (EnumMap Word64 e -> Maybe e -> Branched e)
-> f (EnumMap Word64 e) -> f (Maybe e -> Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e -> f e) -> EnumMap Word64 e -> f (EnumMap Word64 e)
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse e -> f e
g EnumMap Word64 e
m f (Maybe e -> Branched e) -> f (Maybe e) -> f (Branched e)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (e -> f e) -> Maybe e -> f (Maybe e)
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) -> Maybe a -> f (Maybe b)
traverse e -> f e
g Maybe e
e
branchLinks Reference -> f Reference
_ e -> f e
g (MatchSum EnumMap Word64 ([Mem], e)
m) =
  EnumMap Word64 ([Mem], e) -> Branched e
forall e. EnumMap Word64 ([Mem], e) -> Branched e
MatchSum (EnumMap Word64 ([Mem], e) -> Branched e)
-> f (EnumMap Word64 ([Mem], e)) -> f (Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((([Mem], e) -> f ([Mem], e))
-> EnumMap Word64 ([Mem], e) -> f (EnumMap Word64 ([Mem], e))
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) -> EnumMap Word64 a -> f (EnumMap Word64 b)
traverse ((([Mem], e) -> f ([Mem], e))
 -> EnumMap Word64 ([Mem], e) -> f (EnumMap Word64 ([Mem], e)))
-> ((e -> f e) -> ([Mem], e) -> f ([Mem], e))
-> (e -> f e)
-> EnumMap Word64 ([Mem], e)
-> f (EnumMap Word64 ([Mem], e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> f e) -> ([Mem], e) -> f ([Mem], e)
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) -> ([Mem], a) -> f ([Mem], b)
traverse) e -> f e
g EnumMap Word64 ([Mem], e)
m
branchLinks Reference -> f Reference
_ e -> f e
_ Branched e
MatchEmpty = Branched e -> f (Branched e)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Branched e
forall e. Branched e
MatchEmpty

funcLinks ::
  (Applicative f) =>
  (Bool -> Reference -> f Reference) ->
  Func v ->
  f (Func v)
funcLinks :: forall (f :: * -> *) v.
Applicative f =>
(Bool -> Reference -> f Reference) -> Func v -> f (Func v)
funcLinks Bool -> Reference -> f Reference
f (FComb Reference
r) = Reference -> Func v
forall v. Reference -> Func v
FComb (Reference -> Func v) -> f Reference -> f (Func v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Reference -> f Reference
f Bool
False Reference
r
funcLinks Bool -> Reference -> f Reference
f (FCon Reference
r CTag
t) = (Reference -> CTag -> Func v) -> CTag -> Reference -> Func v
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> CTag -> Func v
forall v. Reference -> CTag -> Func v
FCon CTag
t (Reference -> Func v) -> f Reference -> f (Func v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Reference -> f Reference
f Bool
True Reference
r
funcLinks Bool -> Reference -> f Reference
f (FReq Reference
r CTag
t) = (Reference -> CTag -> Func v) -> CTag -> Reference -> Func v
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> CTag -> Func v
forall v. Reference -> CTag -> Func v
FReq CTag
t (Reference -> Func v) -> f Reference -> f (Func v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Reference -> f Reference
f Bool
True Reference
r
funcLinks Bool -> Reference -> f Reference
_ Func v
ff = Func v -> f (Func v)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Func v
ff

expandBindings' ::
  (Var v) =>
  Word64 ->
  [P.Pattern p] ->
  [v] ->
  Either String (Word64, [v])
expandBindings' :: forall v p.
Var v =>
Word64 -> [Pattern p] -> [v] -> Either String (Word64, [v])
expandBindings' Word64
fr [] [] = (Word64, [v]) -> Either String (Word64, [v])
forall a b. b -> Either a b
Right (Word64
fr, [])
expandBindings' Word64
fr (P.Unbound p
_ : [Pattern p]
ps) [v]
vs =
  ([v] -> [v]) -> (Word64, [v]) -> (Word64, [v])
forall a b. (a -> b) -> (Word64, a) -> (Word64, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v
u v -> [v] -> [v]
forall a. a -> [a] -> [a]
:) ((Word64, [v]) -> (Word64, [v]))
-> Either String (Word64, [v]) -> Either String (Word64, [v])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> [Pattern p] -> [v] -> Either String (Word64, [v])
forall v p.
Var v =>
Word64 -> [Pattern p] -> [v] -> Either String (Word64, [v])
expandBindings' (Word64
fr Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) [Pattern p]
ps [v]
vs
  where
    u :: v
u = Word64 -> v
forall v. Var v => Word64 -> v
freshANF Word64
fr
expandBindings' Word64
fr (P.Var p
_ : [Pattern p]
ps) (v
v : [v]
vs) =
  ([v] -> [v]) -> (Word64, [v]) -> (Word64, [v])
forall a b. (a -> b) -> (Word64, a) -> (Word64, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v
v v -> [v] -> [v]
forall a. a -> [a] -> [a]
:) ((Word64, [v]) -> (Word64, [v]))
-> Either String (Word64, [v]) -> Either String (Word64, [v])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> [Pattern p] -> [v] -> Either String (Word64, [v])
forall v p.
Var v =>
Word64 -> [Pattern p] -> [v] -> Either String (Word64, [v])
expandBindings' Word64
fr [Pattern p]
ps [v]
vs
expandBindings' Word64
_ [] (v
_ : [v]
_) =
  String -> Either String (Word64, [v])
forall a b. a -> Either a b
Left String
"expandBindings': more bindings than expected"
expandBindings' Word64
_ (Pattern p
_ : [Pattern p]
_) [] =
  String -> Either String (Word64, [v])
forall a b. a -> Either a b
Left String
"expandBindings': more patterns than expected"
expandBindings' Word64
_ [Pattern p]
_ [v]
_ =
  String -> Either String (Word64, [v])
forall a b. a -> Either a b
Left (String -> Either String (Word64, [v]))
-> String -> Either String (Word64, [v])
forall a b. (a -> b) -> a -> b
$ String
"expandBindings': unexpected pattern"

expandBindings :: (Var v) => [P.Pattern p] -> [v] -> ANFD v [v]
expandBindings :: forall v p. Var v => [Pattern p] -> [v] -> ANFD v [v]
expandBindings [Pattern p]
ps [v]
vs =
  ANFM v (Directed () [v])
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     [v]
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ANFM v (Directed () [v])
 -> Compose
      (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
      ((,) (Direction ()))
      [v])
-> (((Word64, Word16, [(v, SuperNormal v)])
     -> (Directed () [v], (Word64, Word16, [(v, SuperNormal v)])))
    -> ANFM v (Directed () [v]))
-> ((Word64, Word16, [(v, SuperNormal v)])
    -> (Directed () [v], (Word64, Word16, [(v, SuperNormal v)])))
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word64, Word16, [(v, SuperNormal v)])
 -> (Directed () [v], (Word64, Word16, [(v, SuperNormal v)])))
-> ANFM v (Directed () [v])
forall a.
((Word64, Word16, [(v, SuperNormal v)])
 -> (a, (Word64, Word16, [(v, SuperNormal v)])))
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((Word64, Word16, [(v, SuperNormal v)])
  -> (Directed () [v], (Word64, Word16, [(v, SuperNormal v)])))
 -> Compose
      (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
      ((,) (Direction ()))
      [v])
-> ((Word64, Word16, [(v, SuperNormal v)])
    -> (Directed () [v], (Word64, Word16, [(v, SuperNormal v)])))
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     [v]
forall a b. (a -> b) -> a -> b
$ \(Word64
fr, Word16
bnd, [(v, SuperNormal v)]
co) -> case Word64 -> [Pattern p] -> [v] -> Either String (Word64, [v])
forall v p.
Var v =>
Word64 -> [Pattern p] -> [v] -> Either String (Word64, [v])
expandBindings' Word64
fr [Pattern p]
ps [v]
vs of
    Left String
err -> String -> (Directed () [v], (Word64, Word16, [(v, SuperNormal v)]))
forall a. HasCallStack => String -> a
internalBug (String
 -> (Directed () [v], (Word64, Word16, [(v, SuperNormal v)])))
-> String
-> (Directed () [v], (Word64, Word16, [(v, SuperNormal v)]))
forall a b. (a -> b) -> a -> b
$ String
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Pattern p], [v]) -> String
forall a. Show a => a -> String
show ([Pattern p]
ps, [v]
vs)
    Right (Word64
fr, [v]
l) -> ([v] -> Directed () [v]
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [v]
l, (Word64
fr, Word16
bnd, [(v, SuperNormal v)]
co))

anfCases ::
  (Var v) =>
  v ->
  [MatchCase p (Term v a)] ->
  ANFM v (Directed () (BranchAccum v))
anfCases :: forall v p a.
Var v =>
v
-> [MatchCase p (Term v a)] -> ANFM v (Directed () (BranchAccum v))
anfCases v
u = Compose
  (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
  ((,) (Direction ()))
  (BranchAccum v)
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction (), BranchAccum v)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose
   (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
   ((,) (Direction ()))
   (BranchAccum v)
 -> ReaderT
      (Set v)
      (State (Word64, Word16, [(v, SuperNormal v)]))
      (Direction (), BranchAccum v))
-> ([MatchCase p (Term v a)]
    -> Compose
         (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
         ((,) (Direction ()))
         (BranchAccum v))
-> [MatchCase p (Term v a)]
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Direction (), BranchAccum v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([BranchAccum v] -> BranchAccum v)
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     [BranchAccum v]
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     (BranchAccum v)
forall a b.
(a -> b)
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     a
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [BranchAccum v] -> BranchAccum v
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Compose
   (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
   ((,) (Direction ()))
   [BranchAccum v]
 -> Compose
      (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
      ((,) (Direction ()))
      (BranchAccum v))
-> ([MatchCase p (Term v a)]
    -> Compose
         (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
         ((,) (Direction ()))
         [BranchAccum v])
-> [MatchCase p (Term v a)]
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     (BranchAccum v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MatchCase p (Term v a)
 -> Compose
      (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
      ((,) (Direction ()))
      (BranchAccum v))
-> [MatchCase p (Term v a)]
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     [BranchAccum 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 (v
-> MatchCase p (Term v a)
-> Compose
     (ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     (BranchAccum v)
forall v p a.
Var v =>
v -> MatchCase p (Term v a) -> ANFD v (BranchAccum v)
anfInitCase v
u)

anfFunc :: (Var v) => Term v a -> ANFM v (Ctx v, Directed () (Func v))
anfFunc :: forall v a.
Var v =>
Term v a -> ANFM v (Ctx v, Directed () (Func v))
anfFunc (Var' v
v) = (Ctx v, Directed () (Func v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, (() -> Direction ()
forall a. a -> Direction a
Indirect (), v -> Func v
forall v. v -> Func v
FVar v
v))
anfFunc (Ref' Reference
r) = (Ctx v, Directed () (Func v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, (() -> Direction ()
forall a. a -> Direction a
Indirect (), Reference -> Func v
forall v. Reference -> Func v
FComb Reference
r))
anfFunc (Constructor' (ConstructorReference Reference
r Word64
t)) = (Ctx v, Directed () (Func v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, (Direction ()
forall a. Direction a
Direct, Reference -> CTag -> Func v
forall v. Reference -> CTag -> Func v
FCon Reference
r (CTag -> Func v) -> CTag -> Func v
forall a b. (a -> b) -> a -> b
$ Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t))
anfFunc (Request' (ConstructorReference Reference
r Word64
t)) = (Ctx v, Directed () (Func v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, (() -> Direction ()
forall a. a -> Direction a
Indirect (), Reference -> CTag -> Func v
forall v. Reference -> CTag -> Func v
FReq Reference
r (CTag -> Func v) -> CTag -> Func v
forall a b. (a -> b) -> a -> b
$ Word64 -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t))
anfFunc Term (F v a a) v a
tm = do
  (Ctx v
fctx, DNormal v
ctm) <- Term (F v a a) v a -> ANFM v (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term (F v a a) v a
tm
  (Ctx v
cx, v
v) <- DNormal v -> ANFM v (Ctx v, v)
forall v. Var v => DNormal v -> ANFM v (Ctx v, v)
contextualize DNormal v
ctm
  (Ctx v, Directed () (Func v))
-> ReaderT
     (Set v)
     (State (Word64, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
fctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx, (() -> Direction ()
forall a. a -> Direction a
Indirect (), v -> Func v
forall v. v -> Func v
FVar v
v))

anfArg :: (Var v) => Term v a -> ANFM v (Ctx v, v)
anfArg :: forall v a. Var v => Term v a -> ANFM v (Ctx v, v)
anfArg Term v a
tm = do
  (Ctx v
ctx, DNormal v
ctm) <- Term v a -> ANFM v (Ctx v, DNormal v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
tm
  (Ctx v
cx, v
v) <- DNormal v -> ANFM v (Ctx v, v)
forall v. Var v => DNormal v -> ANFM v (Ctx v, v)
contextualize DNormal v
ctm
  (Ctx v, v) -> ANFM v (Ctx v, v)
forall a.
a
-> ReaderT (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
ctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
cx, v
v)

anfArgs :: (Var v) => [Term v a] -> ANFM v (Ctx v, [v])
anfArgs :: forall v a. Var v => [Term v a] -> ANFM v (Ctx v, [v])
anfArgs [Term v a]
tms = ([Ctx v] -> Ctx v) -> ([Ctx v], [v]) -> (Ctx v, [v])
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 [Ctx v] -> Ctx v
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (([Ctx v], [v]) -> (Ctx v, [v]))
-> ([(Ctx v, v)] -> ([Ctx v], [v])) -> [(Ctx v, v)] -> (Ctx v, [v])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Ctx v, v)] -> ([Ctx v], [v])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Ctx v, v)] -> (Ctx v, [v]))
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) [(Ctx v, v)]
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) (Ctx v, [v])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term v a
 -> ReaderT
      (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) (Ctx v, v))
-> [Term v a]
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) [(Ctx v, 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 Term v a
-> ReaderT
     (Set v) (State (Word64, Word16, [(v, SuperNormal v)])) (Ctx v, v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, v)
anfArg [Term v a]
tms

indent :: Int -> ShowS
indent :: Int -> ShowS
indent Int
ind = String -> ShowS
showString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' ')

prettyGroup :: (Var v) => String -> SuperGroup v -> ShowS
prettyGroup :: forall v. Var v => String -> SuperGroup v -> ShowS
prettyGroup String
s (Rec [(v, SuperNormal v)]
grp SuperNormal v
ent) =
  String -> ShowS
showString (String
"let rec[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]\n")
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, SuperNormal v) -> ShowS -> ShowS)
-> ShowS -> [(v, SuperNormal v)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (v, SuperNormal v) -> ShowS -> ShowS
forall {v} {v} {a}.
(Var v, Var v) =>
(v, SuperNormal v) -> (a -> String) -> a -> String
f ShowS
forall a. a -> a
id [(v, SuperNormal v)]
grp
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"entry"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SuperNormal v -> ShowS
forall v. Var v => Int -> SuperNormal v -> ShowS
prettySuperNormal Int
1 SuperNormal v
ent
  where
    f :: (v, SuperNormal v) -> (a -> String) -> a -> String
f (v
v, SuperNormal v
sn) a -> String
r =
      Int -> ShowS
indent Int
1
        ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v
        ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SuperNormal v -> ShowS
forall v. Var v => Int -> SuperNormal v -> ShowS
prettySuperNormal Int
2 SuperNormal v
sn
        ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n"
        ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
r

pvar :: (Var v) => v -> ShowS
pvar :: forall v. Var v => v -> ShowS
pvar v
v = String -> ShowS
showString (String -> ShowS) -> (Text -> String) -> Text -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Data.Text.unpack (Text -> ShowS) -> Text -> ShowS
forall a b. (a -> b) -> a -> b
$ v -> Text
forall v. Var v => v -> Text
Var.name v
v

prettyVars :: (Var v) => [v] -> ShowS
prettyVars :: forall v. Var v => [v] -> ShowS
prettyVars =
  (v -> ShowS -> ShowS) -> ShowS -> [v] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\v
v ShowS
r -> String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r) ShowS
forall a. a -> a
id

prettyLVars :: (Var v) => [Mem] -> [v] -> ShowS
prettyLVars :: forall v. Var v => [Mem] -> [v] -> ShowS
prettyLVars [] [] = String -> ShowS
showString String
" "
prettyLVars (Mem
c : [Mem]
cs) (v
v : [v]
vs) =
  String -> ShowS
showString String
" "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True (v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
":" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mem -> ShowS
forall a. Show a => a -> ShowS
shows Mem
c)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Mem] -> [v] -> ShowS
forall v. Var v => [Mem] -> [v] -> ShowS
prettyLVars [Mem]
cs [v]
vs
prettyLVars [] (v
_ : [v]
_) = String -> ShowS
forall a. HasCallStack => String -> a
internalBug String
"more variables than conventions"
prettyLVars (Mem
_ : [Mem]
_) [] = String -> ShowS
forall a. HasCallStack => String -> a
internalBug String
"more conventions than variables"

prettyRBind :: (Var v) => [v] -> ShowS
prettyRBind :: forall v. Var v => [v] -> ShowS
prettyRBind [] = String -> ShowS
showString String
"()"
prettyRBind [v
v] = v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v
prettyRBind (v
v : [v]
vs) =
  Bool -> ShowS -> ShowS
showParen Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> ShowS -> ShowS) -> ShowS -> [v] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\v
v ShowS
r -> v -> ShowS
forall a. Show a => a -> ShowS
shows v
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"," ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r) ShowS
forall a. a -> a
id [v]
vs

prettySuperNormal :: (Var v) => Int -> SuperNormal v -> ShowS
prettySuperNormal :: forall v. Var v => Int -> SuperNormal v -> ShowS
prettySuperNormal Int
ind (Lambda [Mem]
ccs (ABTN.TAbss [v]
vs Term ANormalF v
tm)) =
  [Mem] -> [v] -> ShowS
forall v. Var v => [Mem] -> [v] -> ShowS
prettyLVars [Mem]
ccs [v]
vs
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"="
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int -> Term ANormalF v -> ShowS
forall v. Var v => Bool -> Int -> ANormal v -> ShowS
prettyANF Bool
False (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Term ANormalF v
tm

reqSpace :: (Var v) => Bool -> ANormal v -> Bool
reqSpace :: forall v. Var v => Bool -> ANormal v -> Bool
reqSpace Bool
_ TLets {} = Bool
True
reqSpace Bool
_ TName {} = Bool
True
reqSpace Bool
b Term ANormalF v
_ = Bool
b

prettyANF :: (Var v) => Bool -> Int -> ANormal v -> ShowS
prettyANF :: forall v. Var v => Bool -> Int -> ANormal v -> ShowS
prettyANF Bool
m Int
ind ANormal v
tm =
  Bool -> Int -> ShowS
prettySpace (Bool -> ANormal v -> Bool
forall v. Var v => Bool -> ANormal v -> Bool
reqSpace Bool
m ANormal v
tm) Int
ind ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case ANormal v
tm of
    TLets Direction Word16
_ [v]
vs [Mem]
_ ANormal v
bn ANormal v
bo ->
      [v] -> ShowS
forall v. Var v => [v] -> ShowS
prettyRBind [v]
vs
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ="
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int -> ANormal v -> ShowS
forall v. Var v => Bool -> Int -> ANormal v -> ShowS
prettyANF Bool
False (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ANormal v
bn
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int -> ANormal v -> ShowS
forall v. Var v => Bool -> Int -> ANormal v -> ShowS
prettyANF Bool
True Int
ind ANormal v
bo
    TName v
v Either Reference v
f [v]
vs ANormal v
bo ->
      [v] -> ShowS
forall v. Var v => [v] -> ShowS
prettyRBind [v
v]
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" := "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Reference v -> ShowS
forall v. Var v => Either Reference v -> ShowS
prettyLZF Either Reference v
f
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> ShowS
forall v. Var v => [v] -> ShowS
prettyVars [v]
vs
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int -> ANormal v -> ShowS
forall v. Var v => Bool -> Int -> ANormal v -> ShowS
prettyANF Bool
True Int
ind ANormal v
bo
    TLit Lit
l -> Lit -> ShowS
forall a. Show a => a -> ShowS
shows Lit
l
    TFrc v
v -> String -> ShowS
showString String
"!" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v
    TVar v
v -> v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v
    TApp Func v
f [v]
vs -> Func v -> ShowS
forall v. Var v => Func v -> ShowS
prettyFunc Func v
f ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> ShowS
forall v. Var v => [v] -> ShowS
prettyVars [v]
vs
    TMatch v
v Branched (ANormal v)
bs ->
      String -> ShowS
showString String
"match "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" with"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Branched (ANormal v) -> ShowS
forall v. Var v => Int -> Branched (ANormal v) -> ShowS
prettyBranches (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Branched (ANormal v)
bs
    TShift Reference
r v
v ANormal v
bo ->
      String -> ShowS
showString String
"shift["
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> ShowS
forall a. Show a => a -> ShowS
shows Reference
r
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"]"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> ShowS
forall v. Var v => [v] -> ShowS
prettyVars [v
v]
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"."
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int -> ANormal v -> ShowS
forall v. Var v => Bool -> Int -> ANormal v -> ShowS
prettyANF Bool
False (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ANormal v
bo
    THnd [Reference]
rs v
v ANormal v
bo ->
      String -> ShowS
showString String
"handle"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reference] -> ShowS
prettyRefs [Reference]
rs
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int -> ANormal v -> ShowS
forall v. Var v => Bool -> Int -> ANormal v -> ShowS
prettyANF Bool
False (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ANormal v
bo
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" with "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v
    ANormal v
_ -> ANormal v -> ShowS
forall a. Show a => a -> ShowS
shows ANormal v
tm

prettySpace :: Bool -> Int -> ShowS
prettySpace :: Bool -> Int -> ShowS
prettySpace Bool
False Int
_ = String -> ShowS
showString String
" "
prettySpace Bool
True Int
ind = String -> ShowS
showString String
"\n" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
ind

prettyLZF :: (Var v) => Either Reference v -> ShowS
prettyLZF :: forall v. Var v => Either Reference v -> ShowS
prettyLZF (Left Reference
w) = String -> ShowS
showString String
"ENV(" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> ShowS
forall a. Show a => a -> ShowS
shows Reference
w ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
") "
prettyLZF (Right v
v) = v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "

prettyRefs :: [Reference] -> ShowS
prettyRefs :: [Reference] -> ShowS
prettyRefs [] = String -> ShowS
showString String
"{}"
prettyRefs (Reference
r : [Reference]
rs) =
  String -> ShowS
showString String
"{"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> ShowS
forall a. Show a => a -> ShowS
shows Reference
r
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> ShowS -> ShowS) -> ShowS -> [Reference] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Reference
t ShowS
r -> Reference -> ShowS
forall a. Show a => a -> ShowS
shows Reference
t ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"," ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r) ShowS
forall a. a -> a
id [Reference]
rs
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"

prettyFunc :: (Var v) => Func v -> ShowS
prettyFunc :: forall v. Var v => Func v -> ShowS
prettyFunc (FVar v
v) = v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
prettyFunc (FCont v
v) = v -> ShowS
forall v. Var v => v -> ShowS
pvar v
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
prettyFunc (FComb Reference
w) = String -> ShowS
showString String
"ENV(" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> ShowS
forall a. Show a => a -> ShowS
shows Reference
w ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"
prettyFunc (FCon Reference
r CTag
t) =
  String -> ShowS
showString String
"CON("
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> ShowS
forall a. Show a => a -> ShowS
shows Reference
r
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
","
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag -> ShowS
forall a. Show a => a -> ShowS
shows CTag
t
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"
prettyFunc (FReq Reference
r CTag
t) =
  String -> ShowS
showString String
"REQ("
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> ShowS
forall a. Show a => a -> ShowS
shows Reference
r
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
","
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag -> ShowS
forall a. Show a => a -> ShowS
shows CTag
t
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"
prettyFunc (FPrim Either POp Word64
op) = (POp -> ShowS) -> (Word64 -> ShowS) -> Either POp Word64 -> ShowS
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either POp -> ShowS
forall a. Show a => a -> ShowS
shows Word64 -> ShowS
forall a. Show a => a -> ShowS
shows Either POp Word64
op ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "

prettyBranches :: (Var v) => Int -> Branched (ANormal v) -> ShowS
prettyBranches :: forall v. Var v => Int -> Branched (ANormal v) -> ShowS
prettyBranches Int
ind Branched (ANormal v)
bs = case Branched (ANormal v)
bs of
  Branched (ANormal v)
MatchEmpty -> String -> ShowS
showString String
"{}"
  MatchIntegral EnumMap Word64 (ANormal v)
bs Maybe (ANormal v)
df ->
    ShowS -> (ANormal v -> ShowS) -> Maybe (ANormal v) -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id (\ANormal v
e -> Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (String -> ShowS
showString String
"_") ANormal v
e ShowS
forall a. a -> a
id) Maybe (ANormal v)
df
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word64, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(Word64, ANormal v)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Word64 -> ANormal v -> ShowS -> ShowS)
-> (Word64, ANormal v) -> ShowS -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Word64 -> ANormal v -> ShowS -> ShowS)
 -> (Word64, ANormal v) -> ShowS -> ShowS)
-> (Word64 -> ANormal v -> ShowS -> ShowS)
-> (Word64, ANormal v)
-> ShowS
-> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (ShowS -> ANormal v -> ShowS -> ShowS)
-> (Word64 -> ShowS) -> Word64 -> ANormal v -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows) ShowS
forall a. a -> a
id (EnumMap Word64 (ANormal v) -> [(Word64, ANormal v)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap Word64 (ANormal v)
bs)
  MatchText Map Text (ANormal v)
bs Maybe (ANormal v)
df ->
    ShowS -> (ANormal v -> ShowS) -> Maybe (ANormal v) -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id (\ANormal v
e -> Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (String -> ShowS
showString String
"_") ANormal v
e ShowS
forall a. a -> a
id) Maybe (ANormal v)
df
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(Text, ANormal v)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Text -> ANormal v -> ShowS -> ShowS)
-> (Text, ANormal v) -> ShowS -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Text -> ANormal v -> ShowS -> ShowS)
 -> (Text, ANormal v) -> ShowS -> ShowS)
-> (Text -> ANormal v -> ShowS -> ShowS)
-> (Text, ANormal v)
-> ShowS
-> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (ShowS -> ANormal v -> ShowS -> ShowS)
-> (Text -> ShowS) -> Text -> ANormal v -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ShowS
forall a. Show a => a -> ShowS
shows) ShowS
forall a. a -> a
id (Map Text (ANormal v) -> [(Text, ANormal v)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (ANormal v)
bs)
  MatchData Reference
_ EnumMap CTag ([Mem], ANormal v)
bs Maybe (ANormal v)
df ->
    ShowS -> (ANormal v -> ShowS) -> Maybe (ANormal v) -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id (\ANormal v
e -> Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (String -> ShowS
showString String
"_") ANormal v
e ShowS
forall a. a -> a
id) Maybe (ANormal v)
df
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CTag, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(CTag, ANormal v)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        ((CTag -> ANormal v -> ShowS -> ShowS)
-> (CTag, ANormal v) -> ShowS -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((CTag -> ANormal v -> ShowS -> ShowS)
 -> (CTag, ANormal v) -> ShowS -> ShowS)
-> (CTag -> ANormal v -> ShowS -> ShowS)
-> (CTag, ANormal v)
-> ShowS
-> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (ShowS -> ANormal v -> ShowS -> ShowS)
-> (CTag -> ShowS) -> CTag -> ANormal v -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag -> ShowS
forall a. Show a => a -> ShowS
shows)
        ShowS
forall a. a -> a
id
        (EnumMap CTag (ANormal v) -> [(CTag, ANormal v)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList (EnumMap CTag (ANormal v) -> [(CTag, ANormal v)])
-> EnumMap CTag (ANormal v) -> [(CTag, ANormal v)]
forall a b. (a -> b) -> a -> b
$ ([Mem], ANormal v) -> ANormal v
forall a b. (a, b) -> b
snd (([Mem], ANormal v) -> ANormal v)
-> EnumMap CTag ([Mem], ANormal v) -> EnumMap CTag (ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap CTag ([Mem], ANormal v)
bs)
  MatchRequest Map Reference (EnumMap CTag ([Mem], ANormal v))
bs ANormal v
df ->
    ((Reference, EnumMap CTag ([Mem], ANormal v)) -> ShowS -> ShowS)
-> ShowS -> [(Reference, EnumMap CTag ([Mem], ANormal v))] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      ( \(Reference
r, EnumMap CTag ([Mem], ANormal v)
m) ShowS
s ->
          ((CTag, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(CTag, ANormal v)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
            (\(CTag
c, ANormal v
e) -> Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (Reference -> CTag -> ShowS
forall {a} {a}. (Show a, Show a) => a -> a -> ShowS
prettyReq Reference
r CTag
c) ANormal v
e)
            ShowS
s
            (EnumMap CTag (ANormal v) -> [(CTag, ANormal v)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList (EnumMap CTag (ANormal v) -> [(CTag, ANormal v)])
-> EnumMap CTag (ANormal v) -> [(CTag, ANormal v)]
forall a b. (a -> b) -> a -> b
$ ([Mem], ANormal v) -> ANormal v
forall a b. (a, b) -> b
snd (([Mem], ANormal v) -> ANormal v)
-> EnumMap CTag ([Mem], ANormal v) -> EnumMap CTag (ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap CTag ([Mem], ANormal v)
m)
      )
      (Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (Int -> Int -> ShowS
forall {a} {a}. (Show a, Show a) => a -> a -> ShowS
prettyReq (Int
0 :: Int) (Int
0 :: Int)) ANormal v
df ShowS
forall a. a -> a
id)
      (Map Reference (EnumMap CTag ([Mem], ANormal v))
-> [(Reference, EnumMap CTag ([Mem], ANormal v))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Reference (EnumMap CTag ([Mem], ANormal v))
bs)
  MatchSum EnumMap Word64 ([Mem], ANormal v)
bs ->
    ((Word64, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(Word64, ANormal v)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      ((Word64 -> ANormal v -> ShowS -> ShowS)
-> (Word64, ANormal v) -> ShowS -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Word64 -> ANormal v -> ShowS -> ShowS)
 -> (Word64, ANormal v) -> ShowS -> ShowS)
-> (Word64 -> ANormal v -> ShowS -> ShowS)
-> (Word64, ANormal v)
-> ShowS
-> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (ShowS -> ANormal v -> ShowS -> ShowS)
-> (Word64 -> ShowS) -> Word64 -> ANormal v -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows)
      ShowS
forall a. a -> a
id
      (EnumMap Word64 (ANormal v) -> [(Word64, ANormal v)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList (EnumMap Word64 (ANormal v) -> [(Word64, ANormal v)])
-> EnumMap Word64 (ANormal v) -> [(Word64, ANormal v)]
forall a b. (a -> b) -> a -> b
$ ([Mem], ANormal v) -> ANormal v
forall a b. (a, b) -> b
snd (([Mem], ANormal v) -> ANormal v)
-> EnumMap Word64 ([Mem], ANormal v) -> EnumMap Word64 (ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap Word64 ([Mem], ANormal v)
bs)
  MatchNumeric Reference
_ EnumMap Word64 (ANormal v)
bs Maybe (ANormal v)
df ->
    ShowS -> (ANormal v -> ShowS) -> Maybe (ANormal v) -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id (\ANormal v
e -> Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (String -> ShowS
showString String
"_") ANormal v
e ShowS
forall a. a -> a
id) Maybe (ANormal v)
df
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word64, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(Word64, ANormal v)] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Word64 -> ANormal v -> ShowS -> ShowS)
-> (Word64, ANormal v) -> ShowS -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Word64 -> ANormal v -> ShowS -> ShowS)
 -> (Word64, ANormal v) -> ShowS -> ShowS)
-> (Word64 -> ANormal v -> ShowS -> ShowS)
-> (Word64, ANormal v)
-> ShowS
-> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS -> ANormal v -> ShowS -> ShowS
forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind (ShowS -> ANormal v -> ShowS -> ShowS)
-> (Word64 -> ShowS) -> Word64 -> ANormal v -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Show a => a -> ShowS
shows) ShowS
forall a. a -> a
id (EnumMap Word64 (ANormal v) -> [(Word64, ANormal v)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap Word64 (ANormal v)
bs)
      -- _ -> error "prettyBranches: todo"
  where
    -- prettyReq :: Reference -> CTag -> ShowS
    prettyReq :: a -> a -> ShowS
prettyReq a
r a
c =
      String -> ShowS
showString String
"REQ("
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
r
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
","
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
c
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"

prettyCase :: (Var v) => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase :: forall v. Var v => Int -> ShowS -> ANormal v -> ShowS -> ShowS
prettyCase Int
ind ShowS
sc (ABTN.TAbss [v]
vs Term ANormalF v
e) ShowS
r =
  String -> ShowS
showString String
"\n"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
ind
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sc
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> ShowS
forall v. Var v => [v] -> ShowS
prettyVars [v]
vs
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ->"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int -> Term ANormalF v -> ShowS
forall v. Var v => Bool -> Int -> ANormal v -> ShowS
prettyANF Bool
False (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Term ANormalF v
e
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
r