{-# 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 UFalse,
    pattern UTrue,
    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 (..),
    Cacheability (..),
    Direction (..),
    SuperNormal (..),
    arity,
    SuperGroup (..),
    arities,
    POp (..),
    close,
    saturate,
    float,
    floatGroup,
    lamLift,
    lamLiftGroup,
    litRef,
    inlineAlias,
    addDefaultCases,
    ANormalF (.., AApv, ACom, ACon, AKon, AReq, APrm, AFOp),
    ANormal,
    RTag,
    CTag,
    PackedTag (..),
    Tag (..),
    GroupRef (..),
    Code (..),
    ValList,
    Value (..),
    Cont (..),
    BLit (..),
    packTags,
    unpackTags,
    maskTags,
    ANFM,
    Branched (.., MatchDataCover),
    Func (..),
    SGEqv (..),
    equivocate,
    superNormalize,
    anfTerm,
    codeGroup,
    valueTermLinks,
    valueLinks,
    groupTermLinks,
    buildInlineMap,
    inline,
    foldGroup,
    foldGroupLinks,
    overGroup,
    overGroupLinks,
    traverseGroup,
    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.Functor.Compose (Compose (..))
import Data.List hiding (and, or)
import Data.Map qualified as Map
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.Runtime.Array qualified as PA
import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..))
import Unison.Runtime.TypeTags (CTag (..), PackedTag (..), RTag (..), Tag (..), maskTags, packTags, unpackTags)
import Unison.Symbol (Symbol)
import Unison.Term hiding (List, Ref, Text, arity, 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)

-- 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 -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference Reference
Ty.unitRef ConstructorId
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' ConstructorId
_) = 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)
-> (ConstructorId -> String) -> ConstructorId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> String
forall a. Show a => a -> String
show (ConstructorId -> Text) -> ConstructorId -> Text
forall a b. (a -> b) -> a -> b
$ v -> ConstructorId
forall v. Var v => v -> ConstructorId
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

-- Performs inlining on a supergroup using the inlining information
-- in the map. The map can be created from typical SuperGroup data
-- using the `buildInlineMap` function.
inline ::
  (Var v) =>
  Map Reference (Int, ANormal v) ->
  SuperGroup v ->
  SuperGroup v
inline :: forall v.
Var v =>
Map Reference (Int, ANormal v) -> SuperGroup v -> SuperGroup v
inline Map Reference (Int, ANormal v)
inls (Rec [(v, SuperNormal v)]
bs SuperNormal v
entry) = [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
forall v. [(v, SuperNormal v)] -> SuperNormal v -> SuperGroup v
Rec ((SuperNormal v -> SuperNormal v)
-> (v, SuperNormal v) -> (v, SuperNormal v)
forall a b. (a -> b) -> (v, a) -> (v, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SuperNormal v -> SuperNormal v
go0 ((v, SuperNormal v) -> (v, SuperNormal v))
-> [(v, SuperNormal v)] -> [(v, SuperNormal v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, SuperNormal v)]
bs) (SuperNormal v -> SuperNormal v
go0 SuperNormal v
entry)
  where
    go0 :: SuperNormal v -> SuperNormal v
go0 (Lambda [Mem]
ccs ANormal v
body) = [Mem] -> ANormal v -> SuperNormal v
forall v. [Mem] -> ANormal v -> SuperNormal v
Lambda [Mem]
ccs (ANormal v -> SuperNormal v) -> ANormal v -> SuperNormal v
forall a b. (a -> b) -> a -> b
$ Int -> ANormal v -> ANormal v
go (Int
30 :: Int) ANormal v
body
    -- Note: number argument bails out in recursive inlining cases
    go :: Int -> ANormal v -> ANormal v
go Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ANormal v -> ANormal v
forall a. a -> a
id
    go Int
n = (ANormal v -> Maybe (ANormal v)) -> ANormal v -> ANormal v
forall (f :: * -> * -> *) v.
(Bifoldable f, Traversable (f v), Var v) =>
(Term f v -> Maybe (Term f v)) -> Term f v -> Term f v
ABTN.visitPure \case
      TApp (FComb Reference
r) [v]
args
        | Just (Int
arity, ANormal v
expr) <- Reference
-> Map Reference (Int, ANormal v) -> Maybe (Int, ANormal v)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Reference
r Map Reference (Int, ANormal v)
inls ->
            Int -> ANormal v -> ANormal v
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (ANormal v -> ANormal v) -> Maybe (ANormal v) -> Maybe (ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ANormal v -> [v] -> Int -> Maybe (ANormal v)
forall {v}.
Var v =>
Term ANormalF v -> [v] -> Int -> Maybe (Term ANormalF v)
tweak ANormal v
expr [v]
args Int
arity
      ANormal v
_ -> Maybe (ANormal v)
forall a. Maybe a
Nothing

    tweak :: Term ANormalF v -> [v] -> Int -> Maybe (Term ANormalF v)
tweak (ABTN.TAbss [v]
vs Term ANormalF v
body) [v]
args Int
arity
      -- exactly saturated
      | [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity,
        Map v v
rn <- [(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]
vs [v]
args) =
          Term ANormalF v -> Maybe (Term ANormalF v)
forall a. a -> Maybe a
Just (Term ANormalF v -> Maybe (Term ANormalF v))
-> Term ANormalF v -> Maybe (Term ANormalF v)
forall a b. (a -> b) -> a -> b
$ Map v v -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *).
(Var v, Ord v, Bifunctor f, Bifoldable f) =>
Map v v -> Term f v -> Term f v
ABTN.renames Map v v
rn Term ANormalF v
body
      -- oversaturated, only makes sense if body is a call
      | [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
arity,
        ([v]
pre, [v]
post) <- Int -> [v] -> ([v], [v])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
arity [v]
args,
        Map v v
rn <- [(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]
vs [v]
pre),
        TApp Func v
f [v]
pre <- Map v v -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *).
(Var v, Ord v, Bifunctor f, Bifoldable f) =>
Map v v -> Term f v -> Term f v
ABTN.renames Map v v
rn Term ANormalF v
body =
          Term ANormalF v -> Maybe (Term ANormalF v)
forall a. a -> Maybe a
Just (Term ANormalF v -> Maybe (Term ANormalF v))
-> Term ANormalF v -> Maybe (Term ANormalF v)
forall a b. (a -> b) -> a -> b
$ Func v -> [v] -> Term ANormalF v
forall v. Var v => Func v -> [v] -> Term ANormalF v
TApp Func v
f ([v]
pre [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
post)
      | Bool
otherwise = Maybe (Term ANormalF v)
forall a. Maybe a
Nothing

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

-- All variables, both bound and free occurring in a CTE. This is
-- useful for avoiding both free and bound variables when
-- freshening.
cteVars :: (Ord v) => Cte v -> Set v
cteVars :: forall v. Ord v => Cte v -> Set v
cteVars (ST Direction Word16
_ [v]
vs [Mem]
_ ANormal v
e) = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v]
vs Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` ANormal v -> Set v
forall (f :: * -> * -> *) v. Term f v -> Set v
ABTN.freeVars ANormal v
e
cteVars (LZ v
v Either Reference v
r [v]
as) = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ((Reference -> [v] -> [v])
-> (v -> [v] -> [v]) -> Either Reference v -> [v] -> [v]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([v] -> [v]) -> Reference -> [v] -> [v]
forall a b. a -> b -> a
const [v] -> [v]
forall a. a -> a
id) (:) Either Reference v
r ([v] -> [v]) -> [v] -> [v]
forall a b. (a -> b) -> a -> b
$ v
v v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
as)

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, (forall a b. (a -> b) -> ANormalF v a -> ANormalF v b)
-> (forall a b. a -> ANormalF v b -> ANormalF v a)
-> Functor (ANormalF v)
forall a b. a -> ANormalF v b -> ANormalF v a
forall a b. (a -> b) -> ANormalF v a -> ANormalF v b
forall v a b. a -> ANormalF v b -> ANormalF v a
forall v a b. (a -> b) -> ANormalF v a -> ANormalF v b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall v a b. (a -> b) -> ANormalF v a -> ANormalF v b
fmap :: forall a b. (a -> b) -> ANormalF v a -> ANormalF v b
$c<$ :: forall v a b. a -> ANormalF v b -> ANormalF v a
<$ :: forall a b. a -> ANormalF v b -> ANormalF v a
Functor, (forall m. Monoid m => ANormalF v m -> m)
-> (forall m a. Monoid m => (a -> m) -> ANormalF v a -> m)
-> (forall m a. Monoid m => (a -> m) -> ANormalF v a -> m)
-> (forall a b. (a -> b -> b) -> b -> ANormalF v a -> b)
-> (forall a b. (a -> b -> b) -> b -> ANormalF v a -> b)
-> (forall b a. (b -> a -> b) -> b -> ANormalF v a -> b)
-> (forall b a. (b -> a -> b) -> b -> ANormalF v a -> b)
-> (forall a. (a -> a -> a) -> ANormalF v a -> a)
-> (forall a. (a -> a -> a) -> ANormalF v a -> a)
-> (forall a. ANormalF v a -> [a])
-> (forall a. ANormalF v a -> Bool)
-> (forall a. ANormalF v a -> Int)
-> (forall a. Eq a => a -> ANormalF v a -> Bool)
-> (forall a. Ord a => ANormalF v a -> a)
-> (forall a. Ord a => ANormalF v a -> a)
-> (forall a. Num a => ANormalF v a -> a)
-> (forall a. Num a => ANormalF v a -> a)
-> Foldable (ANormalF v)
forall a. Eq a => a -> ANormalF v a -> Bool
forall a. Num a => ANormalF v a -> a
forall a. Ord a => ANormalF v a -> a
forall m. Monoid m => ANormalF v m -> m
forall a. ANormalF v a -> Bool
forall a. ANormalF v a -> Int
forall a. ANormalF v a -> [a]
forall a. (a -> a -> a) -> ANormalF v a -> a
forall v a. Eq a => a -> ANormalF v a -> Bool
forall v a. Num a => ANormalF v a -> a
forall v a. Ord a => ANormalF v a -> a
forall m a. Monoid m => (a -> m) -> ANormalF v a -> m
forall v m. Monoid m => ANormalF v m -> m
forall v a. ANormalF v a -> Bool
forall v a. ANormalF v a -> Int
forall v a. ANormalF v a -> [a]
forall b a. (b -> a -> b) -> b -> ANormalF v a -> b
forall a b. (a -> b -> b) -> b -> ANormalF v a -> b
forall v a. (a -> a -> a) -> ANormalF v a -> a
forall v m a. Monoid m => (a -> m) -> ANormalF v a -> m
forall v b a. (b -> a -> b) -> b -> ANormalF v a -> b
forall v a b. (a -> b -> b) -> b -> ANormalF v 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 v m. Monoid m => ANormalF v m -> m
fold :: forall m. Monoid m => ANormalF v m -> m
$cfoldMap :: forall v m a. Monoid m => (a -> m) -> ANormalF v a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ANormalF v a -> m
$cfoldMap' :: forall v m a. Monoid m => (a -> m) -> ANormalF v a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> ANormalF v a -> m
$cfoldr :: forall v a b. (a -> b -> b) -> b -> ANormalF v a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ANormalF v a -> b
$cfoldr' :: forall v a b. (a -> b -> b) -> b -> ANormalF v a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ANormalF v a -> b
$cfoldl :: forall v b a. (b -> a -> b) -> b -> ANormalF v a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ANormalF v a -> b
$cfoldl' :: forall v b a. (b -> a -> b) -> b -> ANormalF v a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> ANormalF v a -> b
$cfoldr1 :: forall v a. (a -> a -> a) -> ANormalF v a -> a
foldr1 :: forall a. (a -> a -> a) -> ANormalF v a -> a
$cfoldl1 :: forall v a. (a -> a -> a) -> ANormalF v a -> a
foldl1 :: forall a. (a -> a -> a) -> ANormalF v a -> a
$ctoList :: forall v a. ANormalF v a -> [a]
toList :: forall a. ANormalF v a -> [a]
$cnull :: forall v a. ANormalF v a -> Bool
null :: forall a. ANormalF v a -> Bool
$clength :: forall v a. ANormalF v a -> Int
length :: forall a. ANormalF v a -> Int
$celem :: forall v a. Eq a => a -> ANormalF v a -> Bool
elem :: forall a. Eq a => a -> ANormalF v a -> Bool
$cmaximum :: forall v a. Ord a => ANormalF v a -> a
maximum :: forall a. Ord a => ANormalF v a -> a
$cminimum :: forall v a. Ord a => ANormalF v a -> a
minimum :: forall a. Ord a => ANormalF v a -> a
$csum :: forall v a. Num a => ANormalF v a -> a
sum :: forall a. Num a => ANormalF v a -> a
$cproduct :: forall v a. Num a => ANormalF v a -> a
product :: forall a. Num a => ANormalF v a -> a
Foldable, Functor (ANormalF v)
Foldable (ANormalF v)
(Functor (ANormalF v), Foldable (ANormalF v)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> ANormalF v a -> f (ANormalF v b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ANormalF v (f a) -> f (ANormalF v a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ANormalF v a -> m (ANormalF v b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ANormalF v (m a) -> m (ANormalF v a))
-> Traversable (ANormalF v)
forall v. Functor (ANormalF v)
forall v. Foldable (ANormalF v)
forall v (m :: * -> *) a.
Monad m =>
ANormalF v (m a) -> m (ANormalF v a)
forall v (f :: * -> *) a.
Applicative f =>
ANormalF v (f a) -> f (ANormalF v a)
forall v (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ANormalF v a -> m (ANormalF v b)
forall v (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ANormalF v a -> f (ANormalF v b)
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 =>
ANormalF v (m a) -> m (ANormalF v a)
forall (f :: * -> *) a.
Applicative f =>
ANormalF v (f a) -> f (ANormalF v a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ANormalF v a -> m (ANormalF v b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ANormalF v a -> f (ANormalF v b)
$ctraverse :: forall v (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ANormalF v a -> f (ANormalF v b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ANormalF v a -> f (ANormalF v b)
$csequenceA :: forall v (f :: * -> *) a.
Applicative f =>
ANormalF v (f a) -> f (ANormalF v a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ANormalF v (f a) -> f (ANormalF v a)
$cmapM :: forall v (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ANormalF v a -> m (ANormalF v b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ANormalF v a -> m (ANormalF v b)
$csequence :: forall v (m :: * -> *) a.
Monad m =>
ANormalF v (m a) -> m (ANormalF v a)
sequence :: forall (m :: * -> *) a.
Monad m =>
ANormalF v (m a) -> m (ANormalF v a)
Traversable)

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 ForeignFunc
ol) (FPrim Either POp ForeignFunc
or)
  | Either POp ForeignFunc
ol Either POp ForeignFunc -> Either POp ForeignFunc -> Bool
forall a. Eq a => a -> a -> Bool
== Either POp ForeignFunc
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 ForeignFunc -> Func vs
forall v. Either POp ForeignFunc -> Func v
FPrim Either POp ForeignFunc
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 ConstructorId el
bl Maybe el
dl) (MatchIntegral EnumMap ConstructorId er
br Maybe er
dr)
  | EnumMap ConstructorId el -> EnumSet ConstructorId
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap ConstructorId el
bl EnumSet ConstructorId -> EnumSet ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== EnumMap ConstructorId er -> EnumSet ConstructorId
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap ConstructorId 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 ConstructorId es -> Maybe es -> Branched es
forall e. EnumMap ConstructorId e -> Maybe e -> Branched e
MatchIntegral
          (EnumMap ConstructorId es -> Maybe es -> Branched es)
-> f (EnumMap ConstructorId es) -> f (Maybe es -> Branched es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (el -> er -> f es)
-> EnumMap ConstructorId el
-> EnumMap ConstructorId er
-> f (EnumMap ConstructorId 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 ConstructorId el
bl EnumMap ConstructorId 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 ConstructorId ([Mem], el)
bl) (MatchSum EnumMap ConstructorId ([Mem], er)
br)
  | EnumMap ConstructorId ([Mem], el) -> EnumSet ConstructorId
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap ConstructorId ([Mem], el)
bl EnumSet ConstructorId -> EnumSet ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== EnumMap ConstructorId ([Mem], er) -> EnumSet ConstructorId
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap ConstructorId ([Mem], er)
br,
    (ConstructorId -> Bool) -> [ConstructorId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ConstructorId
w -> ([Mem], el) -> [Mem]
forall a b. (a, b) -> a
fst (EnumMap ConstructorId ([Mem], el)
bl EnumMap ConstructorId ([Mem], el) -> ConstructorId -> ([Mem], el)
forall k a. EnumKey k => EnumMap k a -> k -> a
! ConstructorId
w) [Mem] -> [Mem] -> Bool
forall a. Eq a => a -> a -> Bool
== ([Mem], er) -> [Mem]
forall a b. (a, b) -> a
fst (EnumMap ConstructorId ([Mem], er)
br EnumMap ConstructorId ([Mem], er) -> ConstructorId -> ([Mem], er)
forall k a. EnumKey k => EnumMap k a -> k -> a
! ConstructorId
w)) (EnumMap ConstructorId ([Mem], el) -> [ConstructorId]
forall k a. EnumKey k => EnumMap k a -> [k]
keys EnumMap ConstructorId ([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 ConstructorId ([Mem], es) -> Branched es
forall e. EnumMap ConstructorId ([Mem], e) -> Branched e
MatchSum (EnumMap ConstructorId ([Mem], es) -> Branched es)
-> f (EnumMap ConstructorId ([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 ConstructorId ([Mem], el)
-> EnumMap ConstructorId ([Mem], er)
-> f (EnumMap ConstructorId ([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 ConstructorId ([Mem], el)
bl EnumMap ConstructorId ([Mem], er)
br
alignBranch el -> er -> f es
f (MatchNumeric Reference
rl EnumMap ConstructorId el
bl Maybe el
dl) (MatchNumeric Reference
rr EnumMap ConstructorId er
br Maybe er
dr)
  | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr,
    EnumMap ConstructorId el -> EnumSet ConstructorId
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap ConstructorId el
bl EnumSet ConstructorId -> EnumSet ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== EnumMap ConstructorId er -> EnumSet ConstructorId
forall k a. EnumKey k => EnumMap k a -> EnumSet k
keysSet EnumMap ConstructorId 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 ConstructorId es -> Maybe es -> Branched es
forall e.
Reference -> EnumMap ConstructorId e -> Maybe e -> Branched e
MatchNumeric Reference
rl
          (EnumMap ConstructorId es -> Maybe es -> Branched es)
-> f (EnumMap ConstructorId es) -> f (Maybe es -> Branched es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (el -> er -> f es)
-> EnumMap ConstructorId el
-> EnumMap ConstructorId er
-> f (EnumMap ConstructorId 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 ConstructorId el
bl EnumMap ConstructorId 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' ConstructorId
n) = Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Lit -> Maybe Lit) -> Lit -> Maybe Lit
forall a b. (a -> b) -> a -> b
$ ConstructorId -> Lit
N ConstructorId
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 :: ForeignFunc -> [v] -> ANormalF v e
pattern $mAFOp :: forall {r} {v} {e}.
ANormalF v e -> (ForeignFunc -> [v] -> r) -> ((# #) -> r) -> r
$bAFOp :: forall v e. ForeignFunc -> [v] -> ANormalF v e
AFOp p args = AApp (FPrim (Right p)) args

pattern TFOp ::
  (ABT.Var v) =>
  ForeignFunc ->
  [v] ->
  ABTN.Term ANormalF v
pattern $mTFOp :: forall {r} {v}.
Var v =>
Term ANormalF v -> (ForeignFunc -> [v] -> r) -> ((# #) -> r) -> r
$bTFOp :: forall v. Var v => ForeignFunc -> [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 ConstructorId (ANormal v)
cl <> AccumIntegral Reference
rr Maybe (ANormal v)
dr EnumMap ConstructorId (ANormal v)
cr
    | Reference
rl Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
rr = Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (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 ConstructorId (ANormal v) -> BranchAccum v)
-> EnumMap ConstructorId (ANormal v) -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ EnumMap ConstructorId (ANormal v)
cl EnumMap ConstructorId (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> EnumMap ConstructorId (ANormal v)
forall a. Semigroup a => a -> a -> a
<> EnumMap ConstructorId (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 ConstructorId (ANormal v)
cr =
    Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
AccumIntegral Reference
r (ANormal v -> Maybe (ANormal v)
forall a. a -> Maybe a
Just ANormal v
dl) EnumMap ConstructorId (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 ConstructorId (ANormal v)
cl <> AccumDefault ANormal v
dr =
    Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (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 ConstructorId (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

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 ForeignFunc)
  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 -- Term Link
  | LY Reference -- Type Link
  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 ConstructorId
_) = 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 -- sgn
  | NEGI -- neg
  | MODI -- mod
  | POWI -- pow
  | SHLI -- shiftl
  | SHRI -- shiftr
  | ANDI -- and
  | IORI -- or
  | XORI -- xor
  | COMI -- complement
  | INCI -- inc
  | DECI -- dec
  | LEQI -- <=
  | LESI -- <
  | EQLI -- ==
  | NEQI -- !=
  | TRNC -- truncate0
  -- Nat
  | ADDN -- +
  | SUBN -- -
  | DRPN -- drop
  | MULN
  | DIVN -- /
  | MODN -- mod
  | TZRO -- trailingZeros
  | LZRO -- leadingZeros
  | POPC -- popCount
  | POWN -- pow
  | SHLN -- shiftl
  | SHRN -- shiftr
  | ANDN -- and
  | IORN -- or
  | XORN -- xor
  | COMN -- complement
  | INCN -- inc
  | DECN -- dec
  | LEQN -- <=
  | LESN -- <
  | EQLN -- ==
  | NEQN -- !=
  -- Float
  | ADDF -- +
  | SUBF -- -
  | MULF
  | DIVF -- /
  | MINF -- min
  | MAXF -- max
  | LEQF -- <=
  | LESF -- <
  | EQLF -- ==
  | NEQF -- !=
  | POWF -- pow
  | EXPF -- exp
  | SQRT -- sqrt
  | LOGF -- log
  | LOGB -- logBase
  | ABSF -- abs
  | CEIL -- ceil
  | FLOR -- floor
  | TRNF -- truncate
  | RNDF -- round
  -- Trig
  | COSF -- cos
  | ACOS -- acos
  | COSH -- cosh
  | ACSH -- acosh
  | SINF -- sin
  | ASIN -- asin
  | SINH -- sinh
  | ASNH -- asinh
  | TANF -- tan
  | ATAN -- atan
  | TANH -- tanh
  | ATNH -- atanh
  | ATN2 -- atan2
  -- Text
  | CATT -- ++
  | TAKT -- take
  | DRPT -- drop
  | SIZT -- size
  | IXOT -- indexOf
  | UCNS -- uncons
  | USNC -- unsnoc
  | EQLT -- ==
  | LEQT -- <=
  | PAKT -- pack
  | UPKT -- unpack
  -- Sequence
  | CATS -- ++
  | TAKS -- take
  | DRPS -- drop
  | SIZS -- size
  | CONS -- cons
  | SNOC -- snoc
  | IDXS -- at
  | BLDS -- build
  | VWLS -- viewl
  | VWRS -- viewr
  | SPLL -- splitl
  | SPLR -- splitr
  -- Bytes
  | PAKB -- pack
  | UPKB -- unpack
  | TAKB -- take
  | DRPB -- drop
  | IXOB -- indexOf
  | IDXB -- index
  | SIZB -- size
  | FLTB -- flatten
  | CATB -- append
  -- Conversion
  | ITOF -- intToFloat
  | NTOF -- natToFloat
  | ITOT -- intToText
  | NTOT -- natToText
  | TTOI -- textToInt
  | TTON -- textToNat
  | TTOF -- textToFloat
  | FTOT -- floatToText
  | CAST -- runtime type cast for unboxed values.
  | -- Concurrency
    FORK -- fork
  | -- Universal operations
    EQLU -- ==
  | CMPU -- compare
  | LEQU -- <=
  | LESU -- <
  | EROR -- error
  | -- Code
    MISS -- isMissing
  | CACH -- cache_
  | LKUP -- lookup
  | LOAD -- load
  | CVLD -- validate
  | SDBX -- sandbox
  | VALU -- value
  | TLTT -- Term.Link.toText
  -- Debug
  | PRNT -- print
  | INFO -- info
  | TRCE -- trace
  | DBTX -- debugText
  | -- STM
    ATOM -- atomically
  | TFRC -- try force
  | SDBL -- sandbox link list
  | SDBV -- sandbox check for Values
  -- Refs
  | REFN -- Ref.new
  | REFR -- Ref.read
  | REFW -- Ref.write
  | RCAS -- Ref.cas
  | RRFC -- Ref.readForCas
  | TIKR -- Ref.Ticket.read
  -- Bools
  | NOTB -- not
  | ANDB -- and
  | IORB -- or
  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)

-- | Whether the evaluation of a given definition is cacheable or not.
-- i.e. it's a top-level pure value.
data Cacheability = Cacheable | Uncacheable
  deriving stock (Cacheability -> Cacheability -> Bool
(Cacheability -> Cacheability -> Bool)
-> (Cacheability -> Cacheability -> Bool) -> Eq Cacheability
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cacheability -> Cacheability -> Bool
== :: Cacheability -> Cacheability -> Bool
$c/= :: Cacheability -> Cacheability -> Bool
/= :: Cacheability -> Cacheability -> Bool
Eq, Int -> Cacheability -> ShowS
[Cacheability] -> ShowS
Cacheability -> String
(Int -> Cacheability -> ShowS)
-> (Cacheability -> String)
-> ([Cacheability] -> ShowS)
-> Show Cacheability
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cacheability -> ShowS
showsPrec :: Int -> Cacheability -> ShowS
$cshow :: Cacheability -> String
show :: Cacheability -> String
$cshowList :: [Cacheability] -> ShowS
showList :: [Cacheability] -> 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)

-- Yields the number of arguments directly accepted by a combinator.
arity :: SuperNormal v -> Int
arity :: forall v. SuperNormal v -> Int
arity (Lambda [Mem]
ccs ANormal v
_) = [Mem] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Mem]
ccs

-- Yields the numbers of arguments directly accepted by the
-- combinators in a group. The main entry is the first element, and
-- local bindings follow in their original order.
arities :: SuperGroup v -> [Int]
arities :: forall v. SuperGroup v -> [Int]
arities (Rec [(v, SuperNormal v)]
bs SuperNormal v
e) = SuperNormal v -> Int
forall v. SuperNormal v -> Int
arity SuperNormal v
e Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((v, SuperNormal v) -> Int) -> [(v, SuperNormal v)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SuperNormal v -> Int
forall v. SuperNormal v -> Int
arity (SuperNormal v -> Int)
-> ((v, SuperNormal v) -> SuperNormal v)
-> (v, SuperNormal v)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v, SuperNormal v) -> SuperNormal v
forall a b. (a, b) -> b
snd) [(v, SuperNormal v)]
bs

-- Checks the body of a SuperGroup makes it eligible for inlining.
-- See below for the discussion.
isInlinable :: (Var v) => Reference -> ANormal v -> Bool
isInlinable :: forall v. Var v => Reference -> ANormal v -> Bool
isInlinable Reference
r (TApp (FComb Reference
s) [v]
_) = Reference
r Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
/= Reference
s
isInlinable Reference
_ TApp {} = Bool
True
isInlinable Reference
_ TBLit {} = Bool
True
isInlinable Reference
_ TVar {} = Bool
True
isInlinable Reference
_ Term ANormalF v
_ = Bool
False

-- Checks a SuperGroup makes it eligible to be inlined.
-- Unfortunately we need to be quite conservative about this.
--
-- The heuristic implemented below is as follows:
--
--   1. There are no local bindings, so only the 'entry point'
--      matters.
--   2. The entry point body is just a single expression, that is,
--      an application, variable or literal.
--
-- The first condition ensures that there isn't any need to jump
-- into a non-entrypoint from outside a group. These should be rare
-- anyway, because the local bindings are no longer used for
-- (unison-level) local function definitions (those are lifted
-- out). The second condition ensures that inlining the body should
-- have no effect on the runtime stack of of the function we're
-- inlining into, because the combinator is just a wrapper around
-- the simple expression.
--
-- Fortunately, it should be possible to make _most_ builtins have
-- this form, so that their instructions can be inlined directly
-- into the call sites when saturated.
--
-- The result of this function is the information necessary to
-- inline the combinator—an arity and the body expression with
-- bound variables. This should allow checking if the call is
-- saturated and make it possible to locally substitute for an
-- inlined expression.
--
-- The `Reference` argument allows us to check if the body is a
-- direct recursive call to the same function, which would result
-- in infinite inlining. This isn't the only such scenario, but
-- it's one we can opportunistically rule out.
inlineInfo :: (Var v) => Reference -> SuperGroup v -> Maybe (Int, ANormal v)
inlineInfo :: forall v.
Var v =>
Reference -> SuperGroup v -> Maybe (Int, ANormal v)
inlineInfo Reference
r (Rec [] (Lambda [Mem]
ccs body :: ANormal v
body@(ABTN.TAbss [v]
_ ANormal v
e)))
  | Reference -> ANormal v -> Bool
forall v. Var v => Reference -> ANormal v -> Bool
isInlinable Reference
r ANormal v
e = (Int, ANormal v) -> Maybe (Int, ANormal v)
forall a. a -> Maybe a
Just ([Mem] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Mem]
ccs, ANormal v
body)
inlineInfo Reference
_ SuperGroup v
_ = Maybe (Int, ANormal v)
forall a. Maybe a
Nothing

-- Builds inlining information from a collection of SuperGroups.
-- They are all tested for inlinability, and the result map
-- contains only the information for groups that are able to be
-- inlined.
buildInlineMap ::
  (Var v) =>
  Map Reference (SuperGroup v) ->
  Map Reference (Int, ANormal v)
buildInlineMap :: forall v.
Var v =>
Map Reference (SuperGroup v) -> Map Reference (Int, ANormal v)
buildInlineMap =
  Identity (Map Reference (Int, ANormal v))
-> Map Reference (Int, ANormal v)
forall a. Identity a -> a
runIdentity
    (Identity (Map Reference (Int, ANormal v))
 -> Map Reference (Int, ANormal v))
-> (Map Reference (SuperGroup v)
    -> Identity (Map Reference (Int, ANormal v)))
-> Map Reference (SuperGroup v)
-> Map Reference (Int, ANormal v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> SuperGroup v -> Identity (Maybe (Int, ANormal v)))
-> Map Reference (SuperGroup v)
-> Identity (Map Reference (Int, ANormal v))
forall (f :: * -> *) k a b.
Applicative f =>
(k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)
Map.traverseMaybeWithKey (\Reference
r SuperGroup v
g -> Maybe (Int, ANormal v) -> Identity (Maybe (Int, ANormal v))
forall a. a -> Identity a
Identity (Maybe (Int, ANormal v) -> Identity (Maybe (Int, ANormal v)))
-> Maybe (Int, ANormal v) -> Identity (Maybe (Int, ANormal v))
forall a b. (a -> b) -> a -> b
$ Reference -> SuperGroup v -> Maybe (Int, ANormal v)
forall v.
Var v =>
Reference -> SuperGroup v -> Maybe (Int, ANormal v)
inlineInfo Reference
r SuperGroup v
g)

-- 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, GroupRef -> GroupRef -> Bool
(GroupRef -> GroupRef -> Bool)
-> (GroupRef -> GroupRef -> Bool) -> Eq GroupRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GroupRef -> GroupRef -> Bool
== :: GroupRef -> GroupRef -> Bool
$c/= :: GroupRef -> GroupRef -> Bool
/= :: GroupRef -> GroupRef -> Bool
Eq)

-- | A list of either unboxed or boxed values.
-- Each slot is one of unboxed or boxed but not both.
type ValList = [Value]

data Value
  = Partial GroupRef ValList
  | Data Reference Word64 ValList
  | Cont ValList 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, Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq)

-- Since we can now track cacheability of supergroups, this type
-- pairs the two together. This is the type that should be used
-- as the representation of unison Code values rather than the
-- previous `SuperGroup Symbol`.
data Code = CodeRep (SuperGroup Symbol) Cacheability
  deriving (Int -> Code -> ShowS
[Code] -> ShowS
Code -> String
(Int -> Code -> ShowS)
-> (Code -> String) -> ([Code] -> ShowS) -> Show Code
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Code -> ShowS
showsPrec :: Int -> Code -> ShowS
$cshow :: Code -> String
show :: Code -> String
$cshowList :: [Code] -> ShowS
showList :: [Code] -> ShowS
Show)

codeGroup :: Code -> SuperGroup Symbol
codeGroup :: Code -> SuperGroup Symbol
codeGroup (CodeRep SuperGroup Symbol
sg Cacheability
_) = SuperGroup Symbol
sg

instance Eq Code where
  CodeRep SuperGroup Symbol
sg1 Cacheability
_ == :: Code -> Code -> Bool
== CodeRep SuperGroup Symbol
sg2 Cacheability
_ = SuperGroup Symbol
sg1 SuperGroup Symbol -> SuperGroup Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== SuperGroup Symbol
sg2

overGroup :: (SuperGroup Symbol -> SuperGroup Symbol) -> Code -> Code
overGroup :: (SuperGroup Symbol -> SuperGroup Symbol) -> Code -> Code
overGroup SuperGroup Symbol -> SuperGroup Symbol
f (CodeRep SuperGroup Symbol
sg Cacheability
ch) = SuperGroup Symbol -> Cacheability -> Code
CodeRep (SuperGroup Symbol -> SuperGroup Symbol
f SuperGroup Symbol
sg) Cacheability
ch

foldGroup :: (Monoid m) => (SuperGroup Symbol -> m) -> Code -> m
foldGroup :: forall m. Monoid m => (SuperGroup Symbol -> m) -> Code -> m
foldGroup SuperGroup Symbol -> m
f (CodeRep SuperGroup Symbol
sg Cacheability
_) = SuperGroup Symbol -> m
f SuperGroup Symbol
sg

traverseGroup ::
  (Applicative f) =>
  (SuperGroup Symbol -> f (SuperGroup Symbol)) ->
  Code ->
  f Code
traverseGroup :: forall (f :: * -> *).
Applicative f =>
(SuperGroup Symbol -> f (SuperGroup Symbol)) -> Code -> f Code
traverseGroup SuperGroup Symbol -> f (SuperGroup Symbol)
f (CodeRep SuperGroup Symbol
sg Cacheability
ch) = (SuperGroup Symbol -> Cacheability -> Code)
-> Cacheability -> SuperGroup Symbol -> Code
forall a b c. (a -> b -> c) -> b -> a -> c
flip SuperGroup Symbol -> Cacheability -> Code
CodeRep Cacheability
ch (SuperGroup Symbol -> Code) -> f (SuperGroup Symbol) -> f Code
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SuperGroup Symbol -> f (SuperGroup Symbol)
f SuperGroup Symbol
sg

data Cont
  = KE
  | Mark
      Word64 -- pending args
      [Reference]
      (Map Reference Value)
      Cont
  | Push
      Word64 -- Frame size
      Word64 -- Pending args
      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, Cont -> Cont -> Bool
(Cont -> Cont -> Bool) -> (Cont -> Cont -> Bool) -> Eq Cont
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cont -> Cont -> Bool
== :: Cont -> Cont -> Bool
$c/= :: Cont -> Cont -> Bool
/= :: Cont -> Cont -> Bool
Eq)

data BLit
  = Text Util.Text.Text
  | List (Seq Value)
  | TmLink Referent
  | TyLink Reference
  | Bytes Bytes
  | Quote Value
  | Code Code
  | BArr PA.ByteArray
  | Arr (PA.Array Value)
  | -- Despite the following being in the Boxed Literal type, they all represent unboxed values
    Pos Word64
  | Neg Word64
  | Char Char
  | Float Double
  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, BLit -> BLit -> Bool
(BLit -> BLit -> Bool) -> (BLit -> BLit -> Bool) -> Eq BLit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BLit -> BLit -> Bool
== :: BLit -> BLit -> Bool
$c/= :: BLit -> BLit -> Bool
/= :: BLit -> BLit -> Bool
Eq)

groupVars :: ANFM v (Set v)
groupVars :: forall v. ANFM v (Set v)
groupVars = ReaderT
  (Set v)
  (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)])) r
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) r
forall a.
(Set v -> Set v)
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
-> ReaderT
     (Set v) (State (ConstructorId, 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 => ConstructorId -> v
freshANF ConstructorId
fr = ConstructorId -> v -> v
forall v. Var v => ConstructorId -> v -> v
Var.freshenId ConstructorId
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 = ((ConstructorId, Word16, [(v, SuperNormal v)])
 -> (v, (ConstructorId, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) v
forall a.
((ConstructorId, Word16, [(v, SuperNormal v)])
 -> (a, (ConstructorId, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((ConstructorId, Word16, [(v, SuperNormal v)])
  -> (v, (ConstructorId, Word16, [(v, SuperNormal v)])))
 -> ReaderT
      (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) v)
-> ((ConstructorId, Word16, [(v, SuperNormal v)])
    -> (v, (ConstructorId, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) v
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
fr, Word16
bnd, [(v, SuperNormal v)]
cs) -> (ConstructorId -> v
forall v. Var v => ConstructorId -> v
freshANF ConstructorId
fr, (ConstructorId
fr ConstructorId -> ConstructorId -> ConstructorId
forall a. Num a => a -> a -> a
+ ConstructorId
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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     Word16
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Direction Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Set v)
  (State (ConstructorId, 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 (ConstructorId, 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 = ((ConstructorId, Word16, [(v, SuperNormal v)])
 -> (Word16, (ConstructorId, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     Word16
forall a.
((ConstructorId, Word16, [(v, SuperNormal v)])
 -> (a, (ConstructorId, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((ConstructorId, Word16, [(v, SuperNormal v)])
  -> (Word16, (ConstructorId, Word16, [(v, SuperNormal v)])))
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal v)]))
      Word16)
-> ((ConstructorId, Word16, [(v, SuperNormal v)])
    -> (Word16, (ConstructorId, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     Word16
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
fr, Word16
bnd, [(v, SuperNormal v)]
cs) -> (Word16
bnd, (ConstructorId
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 (ConstructorId, Word16, [(v, SuperNormal v)]))
      Word16)
-> Direction a
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
  Word16
-> a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     Word16
forall a b. a -> b -> a
const ReaderT
  (Set v)
  (State (ConstructorId, 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 = ((ConstructorId, Word16, [(v, SuperNormal v)])
 -> (ConstructorId, Word16, [(v, SuperNormal v)]))
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((ConstructorId, Word16, [(v, SuperNormal v)])
  -> (ConstructorId, Word16, [(v, SuperNormal v)]))
 -> ReaderT
      (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) ())
-> ((ConstructorId, Word16, [(v, SuperNormal v)])
    -> (ConstructorId, Word16, [(v, SuperNormal v)]))
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) ()
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
fr, Word16
bnd, [(v, SuperNormal v)]
to) -> (ConstructorId
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 (ConstructorId, Word16, [(v, SuperNormal v)]))
  (SuperNormal v)
comp = ((v, Term v a)
 -> ReaderT
      (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) ())
-> [(v, Term v a)]
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)])) ()
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (SuperNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (SuperNormal v)
forall a b.
ReaderT
  (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) b
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]) (SuperNormal v)
subc = ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal v)]))
  (SuperNormal v)
-> Set v
-> State
     (ConstructorId, Word16, [(v, SuperNormal v)]) (SuperNormal v)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal v)]))
  (SuperNormal v)
comp Set v
grp
    (SuperNormal v
c, (ConstructorId
_, Word16
_, [(v, SuperNormal v)]
l)) = State (ConstructorId, Word16, [(v, SuperNormal v)]) (SuperNormal v)
-> (ConstructorId, Word16, [(v, SuperNormal v)])
-> (SuperNormal v, (ConstructorId, Word16, [(v, SuperNormal v)]))
forall s a. State s a -> s -> (a, s)
runState State (ConstructorId, Word16, [(v, SuperNormal v)]) (SuperNormal v)
subc (ConstructorId
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
  ((ConstructorId, Word16, [(v, SuperNormal v)])
 -> (ConstructorId, Word16, [(v, SuperNormal v)]))
-> ANFM v ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((ConstructorId, Word16, [(v, SuperNormal v)])
  -> (ConstructorId, Word16, [(v, SuperNormal v)]))
 -> ANFM v ())
-> ((ConstructorId, Word16, [(v, SuperNormal v)])
    -> (ConstructorId, Word16, [(v, SuperNormal v)]))
-> ANFM v ()
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
cvs, Word16
bnd, [(v, SuperNormal v)]
ctx) -> (ConstructorId
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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Direction (), ANormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     ((Direction (), [Cte v]), (Direction (), ANormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     ((Direction (), [Cte v]), (Direction (), ANormal v))
forall v a. (Ord v, 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. (Ord v, 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 (ConstructorId, Word16, [(v, SuperNormal v)])) a
-> (a
    -> ReaderT
         (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) b)
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v, DNormal v)
p

pattern $mUFalse :: forall {r} {v}.
Var v =>
Term ANormalF v -> ((# #) -> r) -> ((# #) -> r) -> r
$bUFalse :: forall {v}. Var v => Term ANormalF v
UFalse <- TCon ((== Ty.booleanRef) -> True) 0 []
  where
    UFalse = Reference -> CTag -> [v] -> Term ANormalF v
forall v. Var v => Reference -> CTag -> [v] -> Term ANormalF v
TCon Reference
Ty.booleanRef CTag
0 []

pattern $mUTrue :: forall {r} {v}.
Var v =>
Term ANormalF v -> ((# #) -> r) -> ((# #) -> r) -> r
$bUTrue :: forall {v}. Var v => Term ANormalF v
UTrue <- TCon ((== Ty.booleanRef) -> True) 1 []
  where
    UTrue = 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.
--
-- Note: this assumes that `u` is not bound by any of the context
-- entries, as no effort is made to rename them to avoid capturing
-- `u`.
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) <- v -> v -> [Cte v] -> ([Cte v], Bool)
forall v. Var v => v -> v -> [Cte v] -> ([Cte v], Bool)
renameCtes v
v v
u [Cte v]
ctx = ((Direction ()
d, [Cte v]
ctx), Bool
b)

-- As above, but without the Direction.
renameCtes :: (Var v) => v -> v -> [Cte v] -> ([Cte v], Bool)
renameCtes :: forall v. Var v => v -> v -> [Cte v] -> ([Cte v], Bool)
renameCtes v
v v
u = [CTE v (Term ANormalF v)]
-> [CTE v (Term ANormalF v)] -> ([CTE v (Term ANormalF v)], Bool)
rn []
  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 (Term ANormalF v)]
-> [CTE v (Term ANormalF v)] -> ([CTE v (Term ANormalF v)], Bool)
rn [CTE v (Term ANormalF v)]
acc [] = ([CTE v (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. [a] -> [a]
reverse [CTE v (Term ANormalF v)]
acc, Bool
False)
    rn [CTE v (Term ANormalF v)]
acc (ST Direction Word16
d [v]
vs [Mem]
ccs Term ANormalF v
b : [CTE v (Term ANormalF 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 (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. [a] -> [a]
reverse [CTE v (Term ANormalF v)]
acc [CTE v (Term ANormalF v)]
-> [CTE v (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. [a] -> [a] -> [a]
++ CTE v (Term ANormalF v)
e CTE v (Term ANormalF v)
-> [CTE v (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. a -> [a] -> [a]
: [CTE v (Term ANormalF v)]
es, Bool
True)
      | Bool
otherwise = [CTE v (Term ANormalF v)]
-> [CTE v (Term ANormalF v)] -> ([CTE v (Term ANormalF v)], Bool)
rn (CTE v (Term ANormalF v)
e CTE v (Term ANormalF v)
-> [CTE v (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. a -> [a] -> [a]
: [CTE v (Term ANormalF v)]
acc) [CTE v (Term ANormalF v)]
es
      where
        e :: CTE v (Term ANormalF v)
e = Direction Word16
-> [v] -> [Mem] -> Term ANormalF v -> CTE v (Term ANormalF 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))
-> Term ANormalF v -> CTE v (Term ANormalF 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 (Term ANormalF v)]
acc (LZ v
w Either Reference v
f [v]
as : [CTE v (Term ANormalF v)]
es)
      | v
w v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v = ([CTE v (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. [a] -> [a]
reverse [CTE v (Term ANormalF v)]
acc [CTE v (Term ANormalF v)]
-> [CTE v (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. [a] -> [a] -> [a]
++ CTE v (Term ANormalF v)
e CTE v (Term ANormalF v)
-> [CTE v (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. a -> [a] -> [a]
: [CTE v (Term ANormalF v)]
es, Bool
True)
      | Bool
otherwise = [CTE v (Term ANormalF v)]
-> [CTE v (Term ANormalF v)] -> ([CTE v (Term ANormalF v)], Bool)
rn (CTE v (Term ANormalF v)
e CTE v (Term ANormalF v)
-> [CTE v (Term ANormalF v)] -> [CTE v (Term ANormalF v)]
forall a. a -> [a] -> [a]
: [CTE v (Term ANormalF v)]
acc) [CTE v (Term ANormalF v)]
es
      where
        e :: CTE v (Term ANormalF v)
e = v -> Either Reference v -> [v] -> CTE v (Term ANormalF 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)

-- Simultaneously renames variables in a list of context entries.
--
-- Assumes that the variables being renamed to are not bound by the
-- context entries, so that it is unnecessary to rename them.
renamesCtes :: (Var v) => Map v v -> [Cte v] -> [Cte v]
renamesCtes :: forall v. Var v => Map v v -> [Cte v] -> [Cte v]
renamesCtes Map v v
rn = (Cte v -> Cte v) -> [Cte v] -> [Cte v]
forall a b. (a -> b) -> [a] -> [b]
map Cte v -> Cte v
f
  where
    swap :: v -> v
swap v
w
      | Just v
u <- v -> Map v v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
w Map v v
rn = v
u
      | Bool
otherwise = v
w

    f :: Cte v -> Cte v
f (ST Direction Word16
d [v]
vs [Mem]
ccs Term ANormalF v
b) = 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 (Map v v -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *).
(Var v, Ord v, Bifunctor f, Bifoldable f) =>
Map v v -> Term f v -> Term f v
ABTN.renames Map v v
rn Term ANormalF v
b)
    f (LZ v
v Either Reference v
r [v]
as) = v -> Either Reference v -> [v] -> Cte v
forall v s. v -> Either Reference v -> [v] -> CTE v s
LZ v
v ((v -> v) -> Either Reference v -> Either Reference v
forall b c a. (b -> c) -> Either a b -> Either a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second v -> v
swap Either Reference v
r) ((v -> v) -> [v] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map v -> v
swap [v]
as)

-- Calculates the free variables occurring in a context. This
-- consists of the free variables in the expressions being bound,
-- but with previously bound variables subtracted.
freeVarsCtx :: (Ord v) => Ctx v -> Set v
freeVarsCtx :: forall v. Ord v => Ctx v -> Set v
freeVarsCtx = [Cte v] -> Set v
forall v. Ord v => [Cte v] -> Set v
freeVarsCte ([Cte v] -> Set v) -> (Ctx v -> [Cte v]) -> Ctx v -> Set v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx v -> [Cte v]
forall a b. (a, b) -> b
snd

freeVarsCte :: (Ord v) => [Cte v] -> Set v
freeVarsCte :: forall v. Ord v => [Cte v] -> Set v
freeVarsCte = (Cte v -> Set v -> Set v) -> Set v -> [Cte v] -> Set 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 -> Set v -> Set v
forall {a} {f :: * -> * -> *}.
Ord a =>
CTE a (Term f a) -> Set a -> Set a
m Set v
forall a. Set a
Set.empty
  where
    m :: CTE a (Term f a) -> Set a -> Set a
m (ST Direction Word16
_ [a]
vs [Mem]
_ Term f a
bn) Set a
rest =
      Term f a -> Set a
forall (f :: * -> * -> *) v. Term f v -> Set v
ABTN.freeVars Term f a
bn Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (Set a
rest Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
vs)
    m (LZ a
v Either Reference a
r [a]
as) Set a
rest =
      [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ((Reference -> [a] -> [a])
-> (a -> [a] -> [a]) -> Either Reference a -> [a] -> [a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([a] -> [a]) -> Reference -> [a] -> [a]
forall a b. a -> b -> a
const [a] -> [a]
forall a. a -> a
id) (:) Either Reference a
r [a]
as)
        Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.delete a
v Set a
rest

-- Conditionally freshens a list of variables. The predicate
-- argument selects which variables to freshen, and the set is a set
-- of variables to avoid for freshness. The process ensures that the
-- result is mutually fresh, and returns a new set of variables to
-- avoid, which includes the freshened variables.
--
-- Presumably any variables selected by the predicate should be
-- included in the set, but the set may contain additional variables
-- to avoid, when freshening.
freshens :: (Var v) => (v -> Bool) -> Set v -> [v] -> (Set v, [v])
freshens :: forall v. Var v => (v -> Bool) -> Set v -> [v] -> (Set v, [v])
freshens v -> Bool
p Set v
avoid0 [v]
vs =
  (Set v -> v -> (Set v, v)) -> Set v -> [v] -> (Set v, [v])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Set v -> v -> (Set v, v)
f (Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set v
avoid0 ([v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v]
vs)) [v]
vs
  where
    f :: Set v -> v -> (Set v, v)
f Set v
avoid v
v
      | v -> Bool
p v
v, v
u <- Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn Set v
avoid v
v = (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
u Set v
avoid, v
u)
      | Bool
otherwise = (Set v
avoid, v
v)

-- Freshens the variable bindings in a context to avoid a set of
-- variables. Returns the renaming necessary for anything that was
-- bound in the freshened context.
--
-- Note: this only freshens if it's necessary to avoid variables in
-- the _original_ set. We need to keep track of other variables to
-- avoid when making up new names for those, but it it isn't
-- necessary to freshen variables to remove shadowing _within_ the
-- context, since it is presumably already correctly formed.
freshenCtx :: (Var v) => Set v -> Ctx v -> (Map v v, Ctx v)
freshenCtx :: forall v. Var v => Set v -> Ctx v -> (Map v v, Ctx v)
freshenCtx Set v
avoid0 (Direction ()
d, [Cte v]
ctx) =
  case Set v -> Map v v -> [Cte v] -> [Cte v] -> (Map v v, [Cte v])
go Set v
lavoid Map v v
forall k a. Map k a
Map.empty [] ([Cte v] -> (Map v v, [Cte v])) -> [Cte v] -> (Map v v, [Cte v])
forall a b. (a -> b) -> a -> b
$ [Cte v] -> [Cte v]
forall a. [a] -> [a]
reverse [Cte v]
ctx of
    (Map v v
rn, [Cte v]
ctx) -> (Map v v
rn, (Direction ()
d, [Cte v]
ctx))
  where
    -- precalculate all variable occurrences in the context to just
    -- completely avoid those as well.
    lavoid :: Set v
lavoid =
      (Set v -> Cte v -> Set v) -> Set v -> [Cte v] -> Set v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Cte v -> Set v -> Set v) -> Set v -> Cte v -> Set v
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Cte v -> Set v -> Set v) -> Set v -> Cte v -> Set v)
-> (Cte v -> Set v -> Set v) -> Set v -> Cte v -> Set 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.union (Set v -> Set v -> Set v)
-> (Cte v -> Set v) -> Cte v -> Set v -> Set v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cte v -> Set v
forall v. Ord v => Cte v -> Set v
cteVars) Set v
avoid0 [Cte v]
ctx

    go :: Set v -> Map v v -> [Cte v] -> [Cte v] -> (Map v v, [Cte v])
go Set v
_ Map v v
rns [Cte v]
fresh [] = (Map v v
rns, [Cte v]
fresh)
    go Set v
avoid Map v v
rns [Cte v]
fresh (Cte v
bn : [Cte v]
bns) = case Cte v
bn of
      LZ v
v Either Reference v
r [v]
as
        | v
v v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set v
avoid0,
          v
u <- Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn Set v
avoid v
v,
          ([Cte v]
fresh, Bool
_) <- v -> v -> [Cte v] -> ([Cte v], Bool)
forall v. Var v => v -> v -> [Cte v] -> ([Cte v], Bool)
renameCtes v
v v
u [Cte v]
fresh,
          Set v
avoid <- v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
u Set v
avoid,
          Map v v
rns <- (Maybe v -> Maybe v) -> v -> Map v v -> Map v v
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> (Maybe v -> v) -> Maybe v -> Maybe v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Maybe v -> v
forall a. a -> Maybe a -> a
fromMaybe v
u) v
v Map v v
rns ->
            Set v -> Map v v -> [Cte v] -> [Cte v] -> (Map v v, [Cte v])
go Set v
avoid Map v v
rns (v -> Either Reference v -> [v] -> Cte v
forall v s. v -> Either Reference v -> [v] -> CTE v s
LZ v
u Either Reference v
r [v]
as Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
fresh) [Cte v]
bns
      ST Direction Word16
d [v]
vs [Mem]
ccs ANormal v
expr
        | (Set v
avoid, [v]
us) <- (v -> Bool) -> Set v -> [v] -> (Set v, [v])
forall v. Var v => (v -> Bool) -> Set v -> [v] -> (Set v, [v])
freshens (v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set v
avoid0) Set v
avoid [v]
vs,
          Map v v
rn <- [(v, v)] -> Map v v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((v, v) -> Bool) -> [(v, v)] -> [(v, v)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((v -> v -> Bool) -> (v, v) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry v -> v -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) ([(v, v)] -> [(v, v)]) -> [(v, v)] -> [(v, v)]
forall a b. (a -> b) -> a -> b
$ [v] -> [v] -> [(v, v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [v]
vs [v]
us),
          Bool -> Bool
not (Map v v -> Bool
forall k a. Map k a -> Bool
Map.null Map v v
rn),
          [Cte v]
fresh <- Map v v -> [Cte v] -> [Cte v]
forall v. Var v => Map v v -> [Cte v] -> [Cte v]
renamesCtes Map v v
rn [Cte v]
fresh,
          -- Note: rns union left-biased, so inner contexts take
          -- priority.
          Map v v
rns <- Map v v -> Map v v -> Map v v
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map v v
rns Map v v
rn ->
            Set v -> Map v v -> [Cte v] -> [Cte v] -> (Map v v, [Cte v])
go Set v
avoid Map v v
rns (Direction Word16 -> [v] -> [Mem] -> ANormal v -> Cte v
forall v s. Direction Word16 -> [v] -> [Mem] -> s -> CTE v s
ST Direction Word16
d [v]
us [Mem]
ccs ANormal v
expr Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
fresh) [Cte v]
bns
      Cte v
_ -> Set v -> Map v v -> [Cte v] -> [Cte v] -> (Map v v, [Cte v])
go Set v
avoid Map v v
rns (Cte v
bn Cte v -> [Cte v] -> [Cte v]
forall a. a -> [a] -> [a]
: [Cte v]
fresh) [Cte v]
bns

anfBlock :: (Ord v, Var v) => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock :: forall v a. (Ord v, Var v) => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock (Var' v
v) = (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. (Ord v, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 => Term ANormalF v
UFalse)),
              (CTag
1, ([], Term ANormalF v
tmr))
            ]
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 => Term ANormalF v
UTrue)),
              (CTag
0, ([], Term ANormalF v
tmr))
            ]
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT
  (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
-> (a
    -> ReaderT
         (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) b)
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
  (Ctx v, DNormal v)
-> ((Ctx v, DNormal v)
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT
  (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
-> (a
    -> ReaderT
         (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) b)
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug (String
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal v)]))
      (Ctx v, DNormal v))
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. (Ord v, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     Word16
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Direction Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Set v)
  (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 ConstructorId (Term ANormalF v)
cs ->
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 ConstructorId (Term ANormalF v)
-> Maybe (Term ANormalF v)
-> Branched (Term ANormalF v)
forall e.
Reference -> EnumMap ConstructorId e -> Maybe e -> Branched e
MatchNumeric Reference
r EnumMap ConstructorId (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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, 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
                  [ (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
Ty.seqViewEmpty, ([], Term ANormalF v
em)),
                    (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
Ty.seqViewElem, ([Mem
BX, Mem
BX], Term ANormalF v
bd))
                  ]
              )
        )
    AccumSeqView {} ->
      String
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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
              [ (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
Ty.seqViewEmpty, ([], v -> Term ANormalF v
df v
s)),
                (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
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)
-> (ConstructorId -> Lit) -> ConstructorId -> Term ANormalF v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> Lit
N (ConstructorId -> Term ANormalF v)
-> ConstructorId -> Term ANormalF v
forall a b. (a -> b) -> a -> b
$ Int -> ConstructorId
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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. (Ord v, Var v) => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
b ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal v)]))
  (Ctx v, DNormal v)
-> ((Ctx v, DNormal v)
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT
  (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
-> (a
    -> ReaderT
         (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) b)
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. (Ord v, Var v) => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
e
      (Map v v
brn, Ctx v
bctx) <- Ctx v
-> Ctx v
-> DNormal v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Map v v, Ctx v)
forall {f :: * -> *} {v} {a} {f :: * -> * -> *}.
(Applicative f, Var v) =>
Ctx v -> Ctx v -> (a, Term f v) -> f (Map v v, Ctx v)
fixupBctx Ctx v
bctx Ctx v
ectx DNormal v
ce
      v
u <- v -> ANFM v v
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> ANFM v v) -> v -> ANFM v v
forall a b. (a -> b) -> a -> b
$ v -> v -> Map v v -> v
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault v
u v
u Map v v
brn
      (Ctx v
ectx, Bool
shaded) <- (Ctx v, Bool)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, Bool)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Ctx v, Bool)
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal v)]))
      (Ctx v, Bool))
-> (Ctx v, Bool)
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
   (Ctx v, DNormal v)
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal v)]))
      (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall v a. (Ord v, Var v) => Term v a -> ANFM v (Ctx v, DNormal v)
anfBlock Term v a
e
      Direction Word16
d <- Direction ()
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Direction Word16)
forall a v. Direction a -> ANFM v (Direction Word16)
bindDirection Direction ()
d0
      (Map v v
brn, Ctx v
bctx) <- Ctx v
-> Ctx v
-> DNormal v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Map v v, Ctx v)
forall {f :: * -> *} {v} {a} {f :: * -> * -> *}.
(Applicative f, Var v) =>
Ctx v -> Ctx v -> (a, Term f v) -> f (Map v v, Ctx v)
fixupBctx Ctx v
bctx Ctx v
ectx DNormal v
ce
      Term ANormalF v
cb <- Term ANormalF v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Term ANormalF v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term ANormalF v
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal v)]))
      (Term ANormalF v))
-> Term ANormalF v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Term ANormalF v)
forall a b. (a -> b) -> a -> b
$ Map v v -> Term ANormalF v -> Term ANormalF v
forall v (f :: * -> * -> *).
(Var v, Ord v, Bifunctor f, Bifoldable f) =>
Map v v -> Term f v -> Term f v
ABTN.renames Map v v
brn Term ANormalF v
cb
      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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
octx, DNormal v
ce)
  where
    fixupBctx :: Ctx v -> Ctx v -> (a, Term f v) -> f (Map v v, Ctx v)
fixupBctx Ctx v
bctx Ctx v
ectx (a
_, Term f v
ce) =
      (Map v v, Ctx v) -> f (Map v v, Ctx v)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map v v, Ctx v) -> f (Map v v, Ctx v))
-> (Map v v, Ctx v) -> f (Map v v, Ctx v)
forall a b. (a -> b) -> a -> b
$ Set v -> Ctx v -> (Map v v, Ctx v)
forall v. Var v => Set v -> Ctx v -> (Map v v, Ctx v)
freshenCtx (Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set v
ecfvs Set v
efvs) Ctx v
bctx
      where
        ecfvs :: Set v
ecfvs = Ctx v -> Set v
forall v. Ord v => Ctx v -> Set v
freeVarsCtx Ctx v
ectx
        efvs :: Set v
efvs = Term f v -> Set v
forall (f :: * -> * -> *) v. Term f v -> Set v
ABTN.freeVars Term f 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 ConstructorId
t)) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
t) [])
anfBlock (Request' (ConstructorReference Reference
r ConstructorId
t)) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
t) []))
anfBlock (Boolean' Bool
b) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => String -> a
internalBug (String
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal v)]))
      (Ctx v, DNormal v))
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 -> ConstructorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> ConstructorId
i) <- Pattern p
p =
      Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
AccumIntegral Reference
Ty.intRef Maybe (ANormal v)
forall a. Maybe a
Nothing (EnumMap ConstructorId (ANormal v) -> BranchAccum v)
-> (ANormal v -> EnumMap ConstructorId (ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> ANormal v -> EnumMap ConstructorId (ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton ConstructorId
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
_ ConstructorId
i <- Pattern p
p =
      Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
AccumIntegral Reference
Ty.natRef Maybe (ANormal v)
forall a. Maybe a
Nothing (EnumMap ConstructorId (ANormal v) -> BranchAccum v)
-> (ANormal v -> EnumMap ConstructorId (ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> ANormal v -> EnumMap ConstructorId (ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton ConstructorId
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,
    ConstructorId
w <- Int -> ConstructorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> ConstructorId) -> Int -> ConstructorId
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c =
      Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
forall v.
Reference
-> Maybe (ANormal v)
-> EnumMap ConstructorId (ANormal v)
-> BranchAccum v
AccumIntegral Reference
Ty.charRef Maybe (ANormal v)
forall a. Maybe a
Nothing (EnumMap ConstructorId (ANormal v) -> BranchAccum v)
-> (ANormal v -> EnumMap ConstructorId (ANormal v))
-> ANormal v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> ANormal v -> EnumMap ConstructorId (ANormal v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton ConstructorId
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 ConstructorId
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 (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
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 ConstructorId
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 (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]) Identity)
   (Direction (), ANormal v)
 -> Compose (ANFM v) ((,) (Direction ())) (ANormal v))
-> (ReaderT
      (Set v)
      (StateT (ConstructorId, Word16, [(v, SuperNormal v)]) Identity)
      (Direction (), ANormal v)
    -> ReaderT
         (Set v)
         (StateT (ConstructorId, Word16, [(v, SuperNormal v)]) Identity)
         (Direction (), ANormal v))
-> ReaderT
     (Set v)
     (StateT (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]) Identity)
     (Direction (), ANormal v)
-> ReaderT
     (Set v)
     (StateT (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]) Identity)
   (Direction (), ANormal v)
 -> Compose (ANFM v) ((,) (Direction ())) (ANormal v))
-> ReaderT
     (Set v)
     (StateT (ConstructorId, 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 (ConstructorId, 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 ConstructorId
_) [Value]
vs) =
  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]
vs
valueLinks Bool -> Reference -> a
f (Data Reference
dr ConstructorId
_ [Value]
vs) =
  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]
vs
valueLinks Bool -> Reference -> a
f (Cont [Value]
vs 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]
vs 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 ConstructorId
_ ConstructorId
_ (GR Reference
cr ConstructorId
_) 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 ConstructorId
_ [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 ConstructorId
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 -> ConstructorId -> ConstructorReference)
-> ConstructorId -> Reference -> ConstructorReference
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference ConstructorId
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 ConstructorId e
m Maybe e
e) =
  EnumMap ConstructorId e -> Maybe e -> Branched e
forall e. EnumMap ConstructorId e -> Maybe e -> Branched e
MatchIntegral (EnumMap ConstructorId e -> Maybe e -> Branched e)
-> f (EnumMap ConstructorId e) -> f (Maybe e -> Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e -> f e)
-> EnumMap ConstructorId e -> f (EnumMap ConstructorId 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 ConstructorId a -> f (EnumMap ConstructorId b)
traverse e -> f e
g EnumMap ConstructorId 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 ConstructorId e
m Maybe e
e) =
  Reference -> EnumMap ConstructorId e -> Maybe e -> Branched e
forall e.
Reference -> EnumMap ConstructorId e -> Maybe e -> Branched e
MatchNumeric Reference
r (EnumMap ConstructorId e -> Maybe e -> Branched e)
-> f (EnumMap ConstructorId e) -> f (Maybe e -> Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e -> f e)
-> EnumMap ConstructorId e -> f (EnumMap ConstructorId 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 ConstructorId a -> f (EnumMap ConstructorId b)
traverse e -> f e
g EnumMap ConstructorId 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 ConstructorId ([Mem], e)
m) =
  EnumMap ConstructorId ([Mem], e) -> Branched e
forall e. EnumMap ConstructorId ([Mem], e) -> Branched e
MatchSum (EnumMap ConstructorId ([Mem], e) -> Branched e)
-> f (EnumMap ConstructorId ([Mem], e)) -> f (Branched e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((([Mem], e) -> f ([Mem], e))
-> EnumMap ConstructorId ([Mem], e)
-> f (EnumMap ConstructorId ([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 ConstructorId a -> f (EnumMap ConstructorId b)
traverse ((([Mem], e) -> f ([Mem], e))
 -> EnumMap ConstructorId ([Mem], e)
 -> f (EnumMap ConstructorId ([Mem], e)))
-> ((e -> f e) -> ([Mem], e) -> f ([Mem], e))
-> (e -> f e)
-> EnumMap ConstructorId ([Mem], e)
-> f (EnumMap ConstructorId ([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 ConstructorId ([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 =>
ConstructorId
-> [Pattern p] -> [v] -> Either String (ConstructorId, [v])
expandBindings' ConstructorId
fr [] [] = (ConstructorId, [v]) -> Either String (ConstructorId, [v])
forall a b. b -> Either a b
Right (ConstructorId
fr, [])
expandBindings' ConstructorId
fr (P.Unbound p
_ : [Pattern p]
ps) [v]
vs =
  ([v] -> [v]) -> (ConstructorId, [v]) -> (ConstructorId, [v])
forall a b. (a -> b) -> (ConstructorId, a) -> (ConstructorId, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v
u v -> [v] -> [v]
forall a. a -> [a] -> [a]
:) ((ConstructorId, [v]) -> (ConstructorId, [v]))
-> Either String (ConstructorId, [v])
-> Either String (ConstructorId, [v])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorId
-> [Pattern p] -> [v] -> Either String (ConstructorId, [v])
forall v p.
Var v =>
ConstructorId
-> [Pattern p] -> [v] -> Either String (ConstructorId, [v])
expandBindings' (ConstructorId
fr ConstructorId -> ConstructorId -> ConstructorId
forall a. Num a => a -> a -> a
+ ConstructorId
1) [Pattern p]
ps [v]
vs
  where
    u :: v
u = ConstructorId -> v
forall v. Var v => ConstructorId -> v
freshANF ConstructorId
fr
expandBindings' ConstructorId
fr (P.Var p
_ : [Pattern p]
ps) (v
v : [v]
vs) =
  ([v] -> [v]) -> (ConstructorId, [v]) -> (ConstructorId, [v])
forall a b. (a -> b) -> (ConstructorId, a) -> (ConstructorId, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v
v v -> [v] -> [v]
forall a. a -> [a] -> [a]
:) ((ConstructorId, [v]) -> (ConstructorId, [v]))
-> Either String (ConstructorId, [v])
-> Either String (ConstructorId, [v])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorId
-> [Pattern p] -> [v] -> Either String (ConstructorId, [v])
forall v p.
Var v =>
ConstructorId
-> [Pattern p] -> [v] -> Either String (ConstructorId, [v])
expandBindings' ConstructorId
fr [Pattern p]
ps [v]
vs
expandBindings' ConstructorId
_ [] (v
_ : [v]
_) =
  String -> Either String (ConstructorId, [v])
forall a b. a -> Either a b
Left String
"expandBindings': more bindings than expected"
expandBindings' ConstructorId
_ (Pattern p
_ : [Pattern p]
_) [] =
  String -> Either String (ConstructorId, [v])
forall a b. a -> Either a b
Left String
"expandBindings': more patterns than expected"
expandBindings' ConstructorId
_ [Pattern p]
_ [v]
_ =
  String -> Either String (ConstructorId, [v])
forall a b. a -> Either a b
Left (String -> Either String (ConstructorId, [v]))
-> String -> Either String (ConstructorId, [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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)])))
      ((,) (Direction ()))
      [v])
-> (((ConstructorId, Word16, [(v, SuperNormal v)])
     -> (Directed () [v],
         (ConstructorId, Word16, [(v, SuperNormal v)])))
    -> ANFM v (Directed () [v]))
-> ((ConstructorId, Word16, [(v, SuperNormal v)])
    -> (Directed () [v],
        (ConstructorId, Word16, [(v, SuperNormal v)])))
-> Compose
     (ReaderT
        (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConstructorId, Word16, [(v, SuperNormal v)])
 -> (Directed () [v],
     (ConstructorId, Word16, [(v, SuperNormal v)])))
-> ANFM v (Directed () [v])
forall a.
((ConstructorId, Word16, [(v, SuperNormal v)])
 -> (a, (ConstructorId, Word16, [(v, SuperNormal v)])))
-> ReaderT
     (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])) a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((ConstructorId, Word16, [(v, SuperNormal v)])
  -> (Directed () [v],
      (ConstructorId, Word16, [(v, SuperNormal v)])))
 -> Compose
      (ReaderT
         (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])))
      ((,) (Direction ()))
      [v])
-> ((ConstructorId, Word16, [(v, SuperNormal v)])
    -> (Directed () [v],
        (ConstructorId, Word16, [(v, SuperNormal v)])))
-> Compose
     (ReaderT
        (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     [v]
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
fr, Word16
bnd, [(v, SuperNormal v)]
co) -> case ConstructorId
-> [Pattern p] -> [v] -> Either String (ConstructorId, [v])
forall v p.
Var v =>
ConstructorId
-> [Pattern p] -> [v] -> Either String (ConstructorId, [v])
expandBindings' ConstructorId
fr [Pattern p]
ps [v]
vs of
    Left String
err -> String
-> (Directed () [v], (ConstructorId, Word16, [(v, SuperNormal v)]))
forall a. HasCallStack => String -> a
internalBug (String
 -> (Directed () [v],
     (ConstructorId, Word16, [(v, SuperNormal v)])))
-> String
-> (Directed () [v], (ConstructorId, 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 (ConstructorId
fr, [v]
l) -> ([v] -> Directed () [v]
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [v]
l, (ConstructorId
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 (ConstructorId, Word16, [(v, SuperNormal v)])))
  ((,) (Direction ()))
  (BranchAccum v)
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)])))
   ((,) (Direction ()))
   (BranchAccum v)
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal v)]))
      (Direction (), BranchAccum v))
-> ([MatchCase p (Term v a)]
    -> Compose
         (ReaderT
            (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])))
         ((,) (Direction ()))
         (BranchAccum v))
-> [MatchCase p (Term v a)]
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     [BranchAccum v]
-> Compose
     (ReaderT
        (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     (BranchAccum v)
forall a b.
(a -> b)
-> Compose
     (ReaderT
        (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])))
     ((,) (Direction ()))
     a
-> Compose
     (ReaderT
        (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)])))
   ((,) (Direction ()))
   [BranchAccum v]
 -> Compose
      (ReaderT
         (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])))
      ((,) (Direction ()))
      (BranchAccum v))
-> ([MatchCase p (Term v a)]
    -> Compose
         (ReaderT
            (Set v) (State (ConstructorId, Word16, [(v, SuperNormal v)])))
         ((,) (Direction ()))
         [BranchAccum v])
-> [MatchCase p (Term v a)]
-> Compose
     (ReaderT
        (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)])))
      ((,) (Direction ()))
      (BranchAccum v))
-> [MatchCase p (Term v a)]
-> Compose
     (ReaderT
        (Set v) (State (ConstructorId, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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 ConstructorId
t)) = (Ctx v, Directed () (Func v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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
$ ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
t))
anfFunc (Request' (ConstructorReference Reference
r ConstructorId
t)) = (Ctx v, Directed () (Func v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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
$ ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
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. (Ord v, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     (Ctx v, Directed () (Func v))
forall a.
a
-> ReaderT
     (Set v) (State (ConstructorId, 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. (Ord v, 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 (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
     [(Ctx v, v)]
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, Word16, [(v, SuperNormal v)]))
      (Ctx v, v))
-> [Term v a]
-> ReaderT
     (Set v)
     (State (ConstructorId, 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 (ConstructorId, 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 ForeignFunc
op) = (POp -> ShowS)
-> (ForeignFunc -> ShowS) -> Either POp ForeignFunc -> ShowS
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either POp -> ShowS
forall a. Show a => a -> ShowS
shows ForeignFunc -> ShowS
forall a. Show a => a -> ShowS
shows Either POp ForeignFunc
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 ConstructorId (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
. ((ConstructorId, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(ConstructorId, 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 ((ConstructorId -> ANormal v -> ShowS -> ShowS)
-> (ConstructorId, ANormal v) -> ShowS -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((ConstructorId -> ANormal v -> ShowS -> ShowS)
 -> (ConstructorId, ANormal v) -> ShowS -> ShowS)
-> (ConstructorId -> ANormal v -> ShowS -> ShowS)
-> (ConstructorId, 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)
-> (ConstructorId -> ShowS)
-> ConstructorId
-> ANormal v
-> ShowS
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> ShowS
forall a. Show a => a -> ShowS
shows) ShowS
forall a. a -> a
id (EnumMap ConstructorId (ANormal v) -> [(ConstructorId, ANormal v)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap ConstructorId (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 ConstructorId ([Mem], ANormal v)
bs ->
    ((ConstructorId, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(ConstructorId, 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
      ((ConstructorId -> ANormal v -> ShowS -> ShowS)
-> (ConstructorId, ANormal v) -> ShowS -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((ConstructorId -> ANormal v -> ShowS -> ShowS)
 -> (ConstructorId, ANormal v) -> ShowS -> ShowS)
-> (ConstructorId -> ANormal v -> ShowS -> ShowS)
-> (ConstructorId, 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)
-> (ConstructorId -> ShowS)
-> ConstructorId
-> ANormal v
-> ShowS
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> ShowS
forall a. Show a => a -> ShowS
shows)
      ShowS
forall a. a -> a
id
      (EnumMap ConstructorId (ANormal v) -> [(ConstructorId, ANormal v)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList (EnumMap ConstructorId (ANormal v) -> [(ConstructorId, ANormal v)])
-> EnumMap ConstructorId (ANormal v)
-> [(ConstructorId, 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 ConstructorId ([Mem], ANormal v)
-> EnumMap ConstructorId (ANormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumMap ConstructorId ([Mem], ANormal v)
bs)
  MatchNumeric Reference
_ EnumMap ConstructorId (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
. ((ConstructorId, ANormal v) -> ShowS -> ShowS)
-> ShowS -> [(ConstructorId, 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 ((ConstructorId -> ANormal v -> ShowS -> ShowS)
-> (ConstructorId, ANormal v) -> ShowS -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((ConstructorId -> ANormal v -> ShowS -> ShowS)
 -> (ConstructorId, ANormal v) -> ShowS -> ShowS)
-> (ConstructorId -> ANormal v -> ShowS -> ShowS)
-> (ConstructorId, 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)
-> (ConstructorId -> ShowS)
-> ConstructorId
-> ANormal v
-> ShowS
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> ShowS
forall a. Show a => a -> ShowS
shows) ShowS
forall a. a -> a
id (EnumMap ConstructorId (ANormal v) -> [(ConstructorId, ANormal v)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
mapToList EnumMap ConstructorId (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