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

-- | Compiling Unison terms to ANF: closure conversion, lambda lifting
-- and the translation itself. The ANF it produces, and everything the
-- runtime does with it, is in "Unison.Runtime.ANF".
module Unison.Runtime.ANF.Convert
  ( minimizeCyclesOrCrash,
    FloatName (..),
    prettyFloatName,
    close,
    saturate,
    float,
    floatGroup,
    lamLift,
    lamLiftGroup,
    inlineAlias,
    addDefaultCases,
    superNormalize,
    anfTerm,
  )
where

import Control.Lens (snoc, unsnoc)
import Control.Monad.Reader (ReaderT (..), ask, local)
import Control.Monad.State (MonadState (..), State, gets, modify, runState)
import Data.Functor.Compose (Compose (..))
import Data.List hiding (and, or, unsnoc, unzip)
import Data.Map qualified as Map
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.Text qualified as Data.Text
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.PrettyPrintEnv (PrettyPrintEnv, termName)
import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId))
import Unison.ReferentPrime qualified as Rfn
import Unison.Runtime.ANF
import Unison.Runtime.InternalError (internalBug)
import Unison.Syntax.NamePrinter (prettyHashQualified)
import Unison.Term hiding (Char, Float, List, Record, Ref, Text, arity, float, fresh, record, resolve)
import Unison.Type qualified as Ty
import Unison.Typechecker.Components (minimize')
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, unzip)

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)
-- No lambda. Won't be floated, might shadow variable in `keep`.
enclose Set v
keep Set v -> Term v a -> Term v a
rec (Let1NamedTop' Bool
top v
v Term v a
bn 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, 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, Set v -> Term v a -> Term v a
rec Set v
keep Term v a
bn)]
      (Set v -> Term v a -> Term v a
rec (v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.delete v
v Set v
keep) Term v a
bd)
enclose Set v
keep Set v -> Term v a -> Term v a
rec t :: Term v a
t@(LamsAnnot [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
    lamb :: Term v a
lamb = a -> [v] -> Maybe (Type v a) -> [v] -> Term v a -> Term v a
forall v a.
Var v =>
a -> [v] -> Maybe (Type v a) -> [v] -> Term v a -> Term v a
lamsAnnot a
a ([v]
evs [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
vs0) Maybe (Type v a)
mty [v]
vs1 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 (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
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' {}) = Bool
False
isStructured (Lam' {}) = Bool
False
isStructured (Nat' {}) = Bool
False
isStructured (Int' {}) = Bool
False
isStructured (Float' {}) = Bool
False
isStructured (Text' {}) = Bool
False
isStructured (Char' {}) = Bool
False
isStructured (Constructor' {}) = 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

data FloatSeg v = FSRef Reference | FSText Text | FSVar v

data FloatName v = FloatName [FloatSeg v]

extendName :: FloatSeg v -> FloatName v -> FloatName v
extendName :: forall v. FloatSeg v -> FloatName v -> FloatName v
extendName FloatSeg v
s (FloatName [FloatSeg v]
ss) = [FloatSeg v] -> FloatName v
forall v. [FloatSeg v] -> FloatName v
FloatName ([FloatSeg v] -> FloatName v) -> [FloatSeg v] -> FloatName v
forall a b. (a -> b) -> a -> b
$ FloatSeg v
s FloatSeg v -> [FloatSeg v] -> [FloatSeg v]
forall a. a -> [a] -> [a]
: [FloatSeg v]
ss

prettyFloatName ::
  (Var v) => PrettyPrintEnv -> FloatName v -> Pretty.Pretty Pretty.ColorText
prettyFloatName :: forall v.
Var v =>
PrettyPrintEnv -> FloatName v -> Pretty ColorText
prettyFloatName PrettyPrintEnv
ppe (FloatName [FloatSeg v]
ts) =
  Pretty ColorText -> [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
Pretty.sep Pretty ColorText
"$" ([Pretty ColorText] -> Pretty ColorText)
-> ([FloatSeg v] -> [Pretty ColorText])
-> [FloatSeg v]
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FloatSeg v -> Pretty ColorText)
-> [FloatSeg v] -> [Pretty ColorText]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FloatSeg v -> Pretty ColorText
prettySeg ([FloatSeg v] -> Pretty ColorText)
-> [FloatSeg v] -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ [FloatSeg v] -> [FloatSeg v]
forall a. [a] -> [a]
reverse [FloatSeg v]
ts
  where
    prettySeg :: FloatSeg v -> Pretty ColorText
prettySeg (FSText Text
tx) = Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
Pretty.text Text
tx
    prettySeg (FSVar v
v) = Text -> Pretty ColorText
forall s. IsString s => Text -> Pretty s
Pretty.text (Text -> Pretty ColorText) -> Text -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ v -> Text
forall v. Var v => v -> Text
Var.name v
v
    prettySeg (FSRef TypeReference
r) =
      Pretty (SyntaxText' TypeReference) -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
Pretty.syntaxToColor
        (Pretty (SyntaxText' TypeReference) -> Pretty ColorText)
-> (Referent -> Pretty (SyntaxText' TypeReference))
-> Referent
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashQualified Name -> Pretty (SyntaxText' TypeReference)
prettyHashQualified
        (HashQualified Name -> Pretty (SyntaxText' TypeReference))
-> (Referent -> HashQualified Name)
-> Referent
-> Pretty (SyntaxText' TypeReference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv -> Referent -> HashQualified Name
termName PrettyPrintEnv
ppe
        (Referent -> Pretty ColorText) -> Referent -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ TypeReference -> Referent
forall r. r -> Referent' r
Rfn.Ref' TypeReference
r

data FloatState v a = FS
  { forall v a. FloatState v a -> Int
lambdas :: Int,
    forall v a. FloatState v a -> FloatName v
path :: FloatName v,
    forall v a. FloatState v a -> Set v
ctxVars :: Set v,
    forall v a. FloatState v a -> [(v, Term v a)]
floated :: [(v, Term v a)],
    forall v a. FloatState v a -> [(v, FloatName v)]
floatNames :: [(v, FloatName v)],
    forall v a. FloatState v a -> [(v, Term v a)]
decomp :: [(v, Term v a)]
  }

emptyState :: FloatState v a
emptyState :: forall v a. FloatState v a
emptyState = Int
-> FloatName v
-> Set v
-> [(v, Term v a)]
-> [(v, FloatName v)]
-> [(v, Term v a)]
-> FloatState v a
forall v a.
Int
-> FloatName v
-> Set v
-> [(v, Term v a)]
-> [(v, FloatName v)]
-> [(v, Term v a)]
-> FloatState v a
FS Int
0 ([FloatSeg v] -> FloatName v
forall v. [FloatSeg v] -> FloatName v
FloatName []) Set v
forall a. Set a
Set.empty [] [] []

type FloatM v a r = State (FloatState v a) r

addVars :: (Ord v) => Set v -> FloatM v a ()
addVars :: forall v a. Ord v => Set v -> FloatM v a ()
addVars Set v
new = (FloatState v a -> FloatState v a)
-> StateT (FloatState v a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \FloatState v a
st -> FloatState v a
st {ctxVars = new <> ctxVars st}

inLocal :: FloatSeg v -> FloatM v a r -> FloatM v a r
inLocal :: forall v a r. FloatSeg v -> FloatM v a r -> FloatM v a r
inLocal FloatSeg v
nm FloatM v a r
act = do
  FloatState v a
st <- StateT (FloatState v a) Identity (FloatState v a)
forall s (m :: * -> *). MonadState s m => m s
get
  FloatState v a -> StateT (FloatState v a) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (FloatState v a -> StateT (FloatState v a) Identity ())
-> FloatState v a -> StateT (FloatState v a) Identity ()
forall a b. (a -> b) -> a -> b
$
    FloatState v a
st
      { path = extendName nm $ path st,
        lambdas = 0
      }
  r
r <- FloatM v a r
act
  (FloatState v a -> FloatState v a)
-> StateT (FloatState v a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \FloatState v a
st' -> FloatState v a
st' {path = path st, lambdas = lambdas st}
  pure r
r

inLocalLam :: FloatM v a r -> FloatM v a r
inLocalLam :: forall v a r. FloatM v a r -> FloatM v a r
inLocalLam FloatM v a r
act = do
  Int
n <- (FloatState v a -> Int) -> StateT (FloatState v a) Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FloatState v a -> Int
forall v a. FloatState v a -> Int
lambdas
  FloatSeg v -> FloatM v a r -> FloatM v a r
forall v a r. FloatSeg v -> FloatM v a r -> FloatM v a r
inLocal (Text -> FloatSeg v
forall v. Text -> FloatSeg v
FSText (Text -> FloatSeg v) -> Text -> FloatSeg v
forall a b. (a -> b) -> a -> b
$ Text
"Lambda" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Data.Text.pack (Int -> String
forall a. Show a => a -> String
show Int
n)) FloatM v a r
act

addFloated ::
  [(v, FloatSeg v, Term v a)] -> [(v, Term v a)] -> FloatM v a ()
addFloated :: forall v a.
[(v, FloatSeg v, Term v a)] -> [(v, Term v a)] -> FloatM v a ()
addFloated [(v, FloatSeg v, Term v a)]
fln [(v, Term v a)]
dc = (FloatState v a -> FloatState v a)
-> StateT (FloatState v a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \FloatState v a
st ->
  let fl :: [(v, Term v a)]
fl = [(v, FloatSeg v, Term v a)]
fln [(v, FloatSeg v, Term v a)]
-> ((v, FloatSeg v, Term v a) -> (v, Term v a)) -> [(v, Term v a)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(v
v, FloatSeg v
_, Term v a
tm) -> (v
v, Term v a
tm)
      fn :: [(v, FloatName v)]
fn = [(v, FloatSeg v, Term v a)]
fln [(v, FloatSeg v, Term v a)]
-> ((v, FloatSeg v, Term v a) -> (v, FloatName v))
-> [(v, FloatName v)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(v
v, FloatSeg v
n, Term v a
_) -> (v
v, FloatSeg v -> FloatName v -> FloatName v
forall v. FloatSeg v -> FloatName v -> FloatName v
extendName FloatSeg v
n (FloatName v -> FloatName v) -> FloatName v -> FloatName v
forall a b. (a -> b) -> a -> b
$ FloatState v a -> FloatName v
forall v a. FloatState v a -> FloatName v
path FloatState v a
st)
   in FloatState v a
st
        { floated = fl <> floated st,
          floatNames = fn <> floatNames st,
          decomp = dc <> decomp st
        }

nameLambda :: (Var v) => Maybe v -> FloatM v a Text
nameLambda :: forall v a. Var v => Maybe v -> FloatM v a Text
nameLambda (Just v
v) = Text -> StateT (FloatState v a) Identity Text
forall a. a -> StateT (FloatState v a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> StateT (FloatState v a) Identity Text)
-> Text -> StateT (FloatState v a) Identity Text
forall a b. (a -> b) -> a -> b
$ v -> Text
forall v. Var v => v -> Text
Var.name v
v
nameLambda Maybe v
Nothing = (FloatState v a -> (Text, FloatState v a))
-> StateT (FloatState v a) Identity Text
forall a.
(FloatState v a -> (a, FloatState v a))
-> StateT (FloatState v a) Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state \FloatState v a
st ->
  let n :: Int
n = FloatState v a -> Int
forall v a. FloatState v a -> Int
lambdas FloatState v a
st
   in (Text
"Lambda" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Data.Text.pack (Int -> String
forall a. Show a => a -> String
show Int
n), FloatState v a
st {lambdas = n + 1})

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 <- (FloatState v a -> Set v)
-> StateT (FloatState v a) Identity (Set v)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FloatState v a -> Set v
forall v a. FloatState v a -> Set v
ctxVars
  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
      h :: (v, Term v a)
-> StateT (FloatState v a) Identity (v, FloatSeg v, Term v a)
h (v
v, Term v a
b) =
        (v -> v
rn v
v,FloatSeg v
nm,) (Term v a -> (v, FloatSeg v, Term v a))
-> FloatM v a (Term v a)
-> StateT (FloatState v a) Identity (v, FloatSeg v, Term v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FloatSeg v -> FloatM v a (Term v a) -> FloatM v a (Term v a)
forall v a r. FloatSeg v -> FloatM v a r -> FloatM v a r
inLocal FloatSeg v
nm (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))
        where
          nm :: FloatSeg v
nm = v -> FloatSeg v
forall v. v -> FloatSeg v
FSVar v
v
  Set v -> StateT (FloatState v a) Identity ()
forall v a. Ord v => Set v -> FloatM v a ()
addVars Set v
shvs
  [(v, FloatSeg v, Term v a)]
fvnbs <- ((v, Term v a)
 -> StateT (FloatState v a) Identity (v, FloatSeg v, Term v a))
-> [(v, Term v a)]
-> StateT (FloatState v a) Identity [(v, FloatSeg 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, Term v a)
-> StateT (FloatState v a) Identity (v, FloatSeg v, Term v a)
h [(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
  [(v, FloatSeg v, Term v a)]
-> [(v, Term v a)] -> StateT (FloatState v a) Identity ()
forall v a.
[(v, FloatSeg v, Term v a)] -> [(v, Term v a)] -> FloatM v a ()
addFloated [(v, FloatSeg v, Term v a)]
fvnbs [(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
      | LamsAnnot [v]
vs0 Maybe (Type v a)
mty [v]
vs1 Term v a
bd <- Term v a
b =
          a -> [v] -> Maybe (Type v a) -> [v] -> Term v a -> Term v a
forall v a.
Var v =>
a -> [v] -> Maybe (Type v a) -> [v] -> Term v a -> Term v a
lamsAnnot a
a [v]
vs0 Maybe (Type v a)
mty [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)] -> StateT (FloatState v a) Identity (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 Term v a
tm Maybe v
mv a
a [v]
vs Term v a
bd =
  StateT (FloatState v a) Identity (FloatState v a)
forall s (m :: * -> *). MonadState s m => m s
get StateT (FloatState v a) Identity (FloatState v a)
-> (FloatState v a -> StateT (FloatState v a) Identity v)
-> StateT (FloatState v a) Identity v
forall a b.
StateT (FloatState v a) Identity a
-> (a -> StateT (FloatState v a) Identity b)
-> StateT (FloatState v a) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FS {Set v
ctxVars :: forall v a. FloatState v a -> Set v
ctxVars :: Set v
ctxVars, [(v, Term v a)]
floated :: forall v a. FloatState v a -> [(v, Term v a)]
floated :: [(v, Term v a)]
floated} ->
    case ((v, Term v a) -> Bool) -> [(v, Term v a)] -> Maybe (v, Term v a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (v, Term v a) -> Bool
p [(v, Term v a)]
floated of
      Just (v
v, Term v a
_) -> v -> StateT (FloatState v a) Identity v
forall a. a -> StateT (FloatState v a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v
      Maybe (v, Term v a)
Nothing -> do
        let v :: v
v = Set v -> v -> v
forall v. Var v => Set v -> v -> v
ABT.freshIn Set v
ctxVars (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
        Text
nm <- Maybe v -> StateT (FloatState v a) Identity Text
forall v a. Var v => Maybe v -> FloatM v a Text
nameLambda Maybe v
mv
        Set v -> StateT (FloatState v a) Identity ()
forall v a. Ord v => Set v -> FloatM v a ()
addVars (Set v -> StateT (FloatState v a) Identity ())
-> Set v -> StateT (FloatState v a) Identity ()
forall a b. (a -> b) -> a -> b
$ v -> Set v
forall a. a -> Set a
Set.singleton v
v
        [(v, FloatSeg v, Term v a)]
-> [(v, Term v a)] -> StateT (FloatState v a) Identity ()
forall v a.
[(v, FloatSeg v, Term v a)] -> [(v, Term v a)] -> FloatM v a ()
addFloated
          [(v
v, Text -> FloatSeg v
forall v. Text -> FloatSeg v
FSText Text
nm, 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
bd)]
          (Bool -> v -> Term v a -> [(v, Term v a)]
forall v a. Bool -> v -> Term v a -> [(v, Term v a)]
floatDecomp Bool
closed v
v Term v a
tm)
        pure v
v
  where
    tgt :: Term0' v v
tgt = Term 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] -> 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
bd)
    p :: (v, Term v a) -> Bool
p (v
_, Term v a
flam) = Term v a -> Term0' v v
forall vt at ap v a. Ord v => Term2 vt at ap v a -> Term0' vt v
unannotate Term 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)]
floatDecomp :: forall v a. Bool -> v -> Term v a -> [(v, Term v a)]
floatDecomp Bool
True v
v Term v a
b = [(v
v, Term v a
b)]
floatDecomp Bool
False v
_ Term v a
_ = []

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 (FloatState v a) Identity a
-> StateT (FloatState 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 (FloatState v a) Identity a
-> (a -> StateT (FloatState v a) Identity b)
-> StateT (FloatState 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)
  | LamsAnnot [v]
vs0 Maybe (Type v a)
_ [v]
vs1 Term v a
bd <- 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 (FloatState v a) Identity v)
-> StateT (FloatState v a) Identity v
forall a b.
StateT (FloatState v a) Identity a
-> (a -> StateT (FloatState v a) Identity b)
-> StateT (FloatState 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 (FloatState 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 (FloatState v a) Identity v
-> (v -> FloatM v a (Term v a)) -> FloatM v a (Term v a)
forall a b.
StateT (FloatState v a) Identity a
-> (a -> StateT (FloatState v a) Identity b)
-> StateT (FloatState 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@(LamsAnnot [v]
vs0 Maybe (Type v a)
mty [v]
vs1 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] -> Maybe (Type v a) -> [v] -> Term v a -> Term v a
forall v a.
Var v =>
a -> [v] -> Maybe (Type v a) -> [v] -> Term v a -> Term v a
lamsAnnot a
a [v]
vs0 Maybe (Type v a)
mty [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
<$> FloatM v a (Term v a) -> FloatM v a (Term v a)
forall v a r. FloatM v a r -> FloatM v a r
inLocalLam (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 <- FloatM v a (Term v a) -> FloatM v a (Term v a)
forall v a r. FloatM v a r -> FloatM v a r
inLocalLam (FloatM v a (Term v a) -> FloatM v a (Term v a))
-> FloatM v a (Term v a) -> 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
      v
lv <- Bool
-> Term v a
-> Maybe v
-> a
-> [v]
-> Term v a
-> StateT (FloatState 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]
vs0 [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
vs1) 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 ->
  FloatState v a ->
  ( [(v, Term v a)],
    [(v, Id)],
    [(Reference, FloatName v)],
    [(Reference, Term v a)],
    [(Reference, Term v a)]
  )
postFloat :: forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> FloatState v a
-> ([(v, Term v a)], [(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
postFloat Map v TypeReference
orig (FS {[(v, FloatName v)]
floatNames :: forall v a. FloatState v a -> [(v, FloatName v)]
floatNames :: [(v, FloatName v)]
floatNames, [(v, Term2 v a a v a)]
floated :: forall v a. FloatState v a -> [(v, Term v a)]
floated :: [(v, Term2 v a a v a)]
floated, [(v, Term2 v a a v a)]
decomp :: forall v a. FloatState v a -> [(v, Term v a)]
decomp :: [(v, Term2 v a a v a)]
decomp}) =
  ( [(v, Term2 v a a v a)]
subs,
    [(v, Id)]
subvs,
    (Maybe (TypeReference, FloatName v)
 -> Maybe (TypeReference, FloatName v))
-> [Maybe (TypeReference, FloatName v)]
-> [(TypeReference, FloatName v)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe (((TypeReference, FloatName v) -> (TypeReference, FloatName v))
-> Maybe (TypeReference, FloatName v)
-> Maybe (TypeReference, FloatName v)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((TypeReference, FloatName v) -> (TypeReference, FloatName v))
 -> Maybe (TypeReference, FloatName v)
 -> Maybe (TypeReference, FloatName v))
-> ((TypeReference, FloatName v) -> (TypeReference, FloatName v))
-> Maybe (TypeReference, FloatName v)
-> Maybe (TypeReference, FloatName v)
forall a b. (a -> b) -> a -> b
$ (FloatName v -> FloatName v)
-> (TypeReference, FloatName v) -> (TypeReference, FloatName v)
forall a b. (a -> b) -> (TypeReference, a) -> (TypeReference, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FloatName v -> FloatName v
originals) [Maybe (TypeReference, FloatName v)]
nms,
    [(TypeReference, Term2 v a a v a)]
tops,
    [(v, Term2 v a a v a)]
decomp [(v, Term2 v a a v a)]
-> ((v, Term2 v a a v a) -> [(TypeReference, Term2 v a a v a)])
-> [(TypeReference, 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 TypeReference
subm Map v TypeReference -> v -> TypeReference
forall k a. Ord k => Map k a -> k -> a
Map.! v
v, Term2 v a a v a
stm) (TypeReference, Term2 v a a v a)
-> [(TypeReference, Term2 v a a v a)]
-> [(TypeReference, Term2 v a a v a)]
forall a. a -> [a] -> [a]
: [(TypeReference
r, Term2 v a a v a
stm) | Just TypeReference
r <- [v -> Map v TypeReference -> Maybe TypeReference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v TypeReference
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
. ([HashingWarning], Map v (Id, Term2 v a a v a))
-> Map v (Id, Term2 v a a v a)
forall a b. (a, b) -> b
snd {- we ignore the hashing warnings in the runtime; they're not relevant -}
        (([HashingWarning], 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)]
    -> ([HashingWarning], 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)
-> ([HashingWarning], Map v (Id, Term2 v a a v a))
forall v a.
Var v =>
Map v (Term v a) -> ([HashingWarning], Map v (Id, Term v a))
hashTermComponentsWithoutTypes
        (Map v (Term2 v a a v a)
 -> ([HashingWarning], 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)]
-> ([HashingWarning], 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)]
floated
    vname :: Map v (FloatName v)
vname = [(v, FloatName v)] -> Map v (FloatName v)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(v, FloatName v)]
floatNames
    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 :: (v, (Id, Term2 v a a v a))
-> ((v, Id), Maybe (TypeReference, FloatName v),
    (v, Term2 v a a v a), (TypeReference, Term2 v a a v a))
f (v
v, (Id
id, Term2 v a a v a
tm)) =
      ((v
v, Id
id), (TypeReference
rf,) (FloatName v -> (TypeReference, FloatName v))
-> Maybe (FloatName v) -> Maybe (TypeReference, FloatName v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> Map v (FloatName v) -> Maybe (FloatName v)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v (FloatName v)
vname, (v
v, Term2 v a a v a
idtm), (TypeReference
rf, Term2 v a a v a
tm))
      where
        rf :: TypeReference
rf = Id -> TypeReference
forall h t. Id' h -> Reference' t h
DerivedId Id
id
        idtm :: Term2 v a a v a
idtm = a -> TypeReference -> Term2 v a a v a
forall v a vt at ap.
Ord v =>
a -> TypeReference -> Term2 vt at ap v a
ref (Term2 v a a v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term2 v a a v a
tm) TypeReference
rf
    unzip4 :: [(a, a, a, a)] -> ([a], [a], [a], [a])
unzip4 [] = ([], [], [], [])
    unzip4 ((a
a, a
b, a
c, a
d) : ([(a, a, a, a)] -> ([a], [a], [a], [a])
unzip4 -> ~([a]
as, [a]
bs, [a]
cs, [a]
ds))) =
      (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as, a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
bs, a
c a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
cs, a
d a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ds)
    ([(v, Id)]
subvs, [Maybe (TypeReference, FloatName v)]
nms, [(v, Term2 v a a v a)]
subs, [(TypeReference, Term2 v a a v a)]
tops) = [((v, Id), Maybe (TypeReference, FloatName v),
  (v, Term2 v a a v a), (TypeReference, Term2 v a a v a))]
-> ([(v, Id)], [Maybe (TypeReference, FloatName v)],
    [(v, Term2 v a a v a)], [(TypeReference, Term2 v a a v a)])
forall {a} {a} {a} {a}. [(a, a, a, a)] -> ([a], [a], [a], [a])
unzip4 ([((v, Id), Maybe (TypeReference, FloatName v),
   (v, Term2 v a a v a), (TypeReference, Term2 v a a v a))]
 -> ([(v, Id)], [Maybe (TypeReference, FloatName v)],
     [(v, Term2 v a a v a)], [(TypeReference, Term2 v a a v a)]))
-> [((v, Id), Maybe (TypeReference, FloatName v),
     (v, Term2 v a a v a), (TypeReference, Term2 v a a v a))]
-> ([(v, Id)], [Maybe (TypeReference, FloatName v)],
    [(v, Term2 v a a v a)], [(TypeReference, Term2 v a a v a)])
forall a b. (a -> b) -> a -> b
$ ((v, (Id, Term2 v a a v a))
 -> ((v, Id), Maybe (TypeReference, FloatName v),
     (v, Term2 v a a v a), (TypeReference, Term2 v a a v a)))
-> [(v, (Id, Term2 v a a v a))]
-> [((v, Id), Maybe (TypeReference, FloatName v),
     (v, Term2 v a a v a), (TypeReference, Term2 v a a v a))]
forall a b. (a -> b) -> [a] -> [b]
map (v, (Id, Term2 v a a v a))
-> ((v, Id), Maybe (TypeReference, FloatName v),
    (v, Term2 v a a v a), (TypeReference, Term2 v a a v a))
f [(v, (Id, Term2 v a a v a))]
trips
    subm :: Map v TypeReference
subm = (Id -> TypeReference) -> Map v Id -> Map v TypeReference
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 -> TypeReference
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
$ (TypeReference -> Term2 v a a v a)
-> Map v TypeReference -> Map v (Term2 v a a v a)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (a -> TypeReference -> Term2 v a a v a
forall v a vt at ap.
Ord v =>
a -> TypeReference -> Term2 vt at ap v a
ref a
forall a. Monoid a => a
mempty) Map v TypeReference
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

    originals :: FloatName v -> FloatName v
originals (FloatName [FloatSeg v]
ss) =
      [FloatSeg v] -> FloatName v
forall v. [FloatSeg v] -> FloatName v
FloatName ([FloatSeg v] -> FloatName v) -> [FloatSeg v] -> FloatName v
forall a b. (a -> b) -> a -> b
$
        [FloatSeg v]
ss [FloatSeg v] -> (FloatSeg v -> FloatSeg v) -> [FloatSeg v]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          FSVar v
v
            | Just TypeReference
r <- v -> Map v TypeReference -> Maybe TypeReference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v TypeReference
orig -> TypeReference -> FloatSeg v
forall v. TypeReference -> FloatSeg v
FSRef TypeReference
r
          FloatSeg v
seg -> FloatSeg v
seg

float ::
  (Var v) =>
  (Monoid a) =>
  Map v Reference ->
  Term v a ->
  ( Term v a,
    Map Reference Reference,
    Map Reference (FloatName v),
    [(Reference, Term v a)],
    [(Reference, Term v a)]
  )
float :: forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> Term v a
-> (Term v a, Map TypeReference TypeReference,
    Map TypeReference (FloatName v), [(TypeReference, Term v a)],
    [(TypeReference, Term v a)])
float Map v TypeReference
orig Term v a
tm = case State (FloatState v a) (Term v a)
-> FloatState v a -> (Term v a, FloatState v a)
forall s a. State s a -> s -> (a, s)
runState State (FloatState v a) (Term v a)
go0 FloatState v a
forall v a. FloatState v a
emptyState of
  (Term v a
bd, FloatState v a
st) -> case Map v TypeReference
-> FloatState v a
-> ([(v, Term v a)], [(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> FloatState v a
-> ([(v, Term v a)], [(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
postFloat Map v TypeReference
orig FloatState v a
st of
    ([(v, Term v a)]
subs, [(v, Id)]
subvs, [(TypeReference, FloatName v)]
fnames, [(TypeReference, Term v a)]
tops, [(TypeReference, 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,
        [(TypeReference, TypeReference)] -> Map TypeReference TypeReference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TypeReference, TypeReference)]
 -> Map TypeReference TypeReference)
-> ([(v, Id)] -> [(TypeReference, TypeReference)])
-> [(v, Id)]
-> Map TypeReference TypeReference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, Id) -> Maybe (TypeReference, TypeReference))
-> [(v, Id)] -> [(TypeReference, TypeReference)]
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 (TypeReference, TypeReference)
f ([(v, Id)] -> Map TypeReference TypeReference)
-> [(v, Id)] -> Map TypeReference TypeReference
forall a b. (a -> b) -> a -> b
$ [(v, Id)]
subvs,
        [(TypeReference, FloatName v)] -> Map TypeReference (FloatName v)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TypeReference, FloatName v)]
fnames,
        [(TypeReference, Term v a)]
tops,
        [(TypeReference, Term v a)]
dcmp
      )
  where
    f :: (v, Id) -> Maybe (TypeReference, TypeReference)
f (v
v, Id
i) = (,Id -> TypeReference
forall h t. Id' h -> Reference' t h
DerivedId Id
i) (TypeReference -> (TypeReference, TypeReference))
-> Maybe TypeReference -> Maybe (TypeReference, TypeReference)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> Map v TypeReference -> Maybe TypeReference
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v TypeReference
orig
    go0 :: State (FloatState v a) (Term v a)
go0 = State (FloatState v a) (Term v a)
-> Maybe (State (FloatState v a) (Term v a))
-> State (FloatState v a) (Term v a)
forall a. a -> Maybe a -> a
fromMaybe (Term v a -> State (FloatState v a) (Term v a)
go Term v a
tm) (Bool
-> (Term v a -> State (FloatState v a) (Term v a))
-> Term v a
-> Maybe (State (FloatState 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 (FloatState v a) (Term v a)
go Term v a
tm)
    go :: Term v a -> State (FloatState v a) (Term v a)
go = (Term v a -> Maybe (State (FloatState v a) (Term v a)))
-> Term v a -> State (FloatState 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 (FloatState v a) (Term v a)))
 -> Term v a -> State (FloatState v a) (Term v a))
-> (Term v a -> Maybe (State (FloatState v a) (Term v a)))
-> Term v a
-> State (FloatState v a) (Term v a)
forall a b. (a -> b) -> a -> b
$ Bool
-> (Term v a -> State (FloatState v a) (Term v a))
-> Term v a
-> Maybe (State (FloatState 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 (FloatState v a) (Term v a)
go

floatGroup ::
  (Var v) =>
  (Monoid a) =>
  Map v Reference ->
  [(v, Term v a)] ->
  ( [(v, Id)],
    [(Reference, FloatName v)],
    [(Reference, Term v a)],
    [(Reference, Term v a)]
  )
floatGroup :: forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> [(v, Term v a)]
-> ([(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
floatGroup Map v TypeReference
orig [(v, Term v a)]
grp = case State (FloatState v a) (Map v v)
-> FloatState v a -> (Map v v, FloatState v a)
forall s a. State s a -> s -> (a, s)
runState State (FloatState v a) (Map v v)
go0 FloatState v a
forall v a. FloatState v a
emptyState of
  (Map v v
_, FloatState v a
st) -> case Map v TypeReference
-> FloatState v a
-> ([(v, Term v a)], [(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> FloatState v a
-> ([(v, Term v a)], [(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
postFloat Map v TypeReference
orig FloatState v a
st of
    ([(v, Term v a)]
_, [(v, Id)]
subvs, [(TypeReference, FloatName v)]
fnames, [(TypeReference, Term v a)]
tops, [(TypeReference, Term v a)]
dcmp) -> ([(v, Id)]
subvs, [(TypeReference, FloatName v)]
fnames, [(TypeReference, Term v a)]
tops, [(TypeReference, Term v a)]
dcmp)
  where
    go :: Term v a -> StateT (FloatState v a) Identity (Term v a)
go = (Term v a -> Maybe (StateT (FloatState v a) Identity (Term v a)))
-> Term v a -> StateT (FloatState 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 (FloatState v a) Identity (Term v a)))
 -> Term v a -> StateT (FloatState v a) Identity (Term v a))
-> (Term v a
    -> Maybe (StateT (FloatState v a) Identity (Term v a)))
-> Term v a
-> StateT (FloatState v a) Identity (Term v a)
forall a b. (a -> b) -> a -> b
$ Bool
-> (Term v a -> StateT (FloatState v a) Identity (Term v a))
-> Term v a
-> Maybe (StateT (FloatState 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 (FloatState v a) Identity (Term v a)
go
    go0 :: State (FloatState v a) (Map v v)
go0 = (Term v a -> StateT (FloatState v a) Identity (Term v a))
-> [(v, Term v a)] -> State (FloatState 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 (FloatState 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)

-- Matches a lambda term with an annotation in the middle, like:
--
--   w x -> (y z -> ...) : ...
--
-- This can occur due to enclosing an annotated lambda term with free
-- variables.
pattern LamsAnnot ::
  [v] -> Maybe (Ty.Type v a) -> [v] -> Term v a -> Term v a
pattern $mLamsAnnot :: forall {r} {v} {a}.
Term v a
-> ([v] -> Maybe (Type v a) -> [v] -> Term v a -> r)
-> ((# #) -> r)
-> r
LamsAnnot us mty vs bd <-
  (unLamsAnnot -> Just (us, mty, vs, bd))

-- Builds a lambda term with arguments separated by an annotation, as
-- above. Just a convenience function that reverses the above pattern.
lamsAnnot ::
  (Var v) => a -> [v] -> Maybe (Ty.Type v a) -> [v] -> Term v a -> Term v a
lamsAnnot :: forall v a.
Var v =>
a -> [v] -> Maybe (Type v a) -> [v] -> Term v a -> Term v a
lamsAnnot a
a [v]
us Maybe (Type v a)
mty [v]
vs Term v a
bd =
  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]
us
    (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]
vs
    (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$ Term v a
bd

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,
    Map Reference (FloatName v),
    [(Reference, Term v a)],
    [(Reference, Term v a)]
  )
lamLift :: forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> Term v a
-> (Term v a, Map TypeReference TypeReference,
    Map TypeReference (FloatName v), [(TypeReference, Term v a)],
    [(TypeReference, Term v a)])
lamLift Map v TypeReference
orig = Map v TypeReference
-> Term v a
-> (Term v a, Map TypeReference TypeReference,
    Map TypeReference (FloatName v), [(TypeReference, Term v a)],
    [(TypeReference, Term v a)])
forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> Term v a
-> (Term v a, Map TypeReference TypeReference,
    Map TypeReference (FloatName v), [(TypeReference, Term v a)],
    [(TypeReference, Term v a)])
float Map v TypeReference
orig (Term v a
 -> (Term v a, Map TypeReference TypeReference,
     Map TypeReference (FloatName v), [(TypeReference, Term v a)],
     [(TypeReference, Term v a)]))
-> (Term v a -> Term v a)
-> Term v a
-> (Term v a, Map TypeReference TypeReference,
    Map TypeReference (FloatName v), [(TypeReference, Term v a)],
    [(TypeReference, 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, FloatName v)],
    [(Reference, Term v a)],
    [(Reference, Term v a)]
  )
lamLiftGroup :: forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> [(v, Term v a)]
-> ([(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
lamLiftGroup Map v TypeReference
orig [(v, Term v a)]
gr = Map v TypeReference
-> [(v, Term v a)]
-> ([(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
forall v a.
(Var v, Monoid a) =>
Map v TypeReference
-> [(v, Term v a)]
-> ([(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
floatGroup Map v TypeReference
orig ([(v, Term v a)]
 -> ([(v, Id)], [(TypeReference, FloatName v)],
     [(TypeReference, Term v a)], [(TypeReference, Term v a)]))
-> ([(v, Term v a)] -> [(v, Term v a)])
-> [(v, Term v a)]
-> ([(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, 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)], [(TypeReference, FloatName v)],
     [(TypeReference, Term v a)], [(TypeReference, Term v a)]))
-> [(v, Term v a)]
-> ([(v, Id)], [(TypeReference, FloatName v)],
    [(TypeReference, Term v a)], [(TypeReference, Term v a)])
forall a b. (a -> b) -> a -> b
$ [(v, Term v a)]
gr
  where
    keep :: Set v
keep = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v) -> [v] -> Set v
forall a b. (a -> b) -> a -> b
$ ((v, Term v a) -> v) -> [(v, Term v a)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, Term v a) -> v
forall a b. (a, b) -> a
fst [(v, Term v a)]
gr

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

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

defaultCaseVisitor ::
  (Var v) => (Monoid a) => Text -> Term v a -> Maybe (Term v a)
defaultCaseVisitor :: forall v a.
(Var v, Monoid a) =>
Text -> Term v a -> Maybe (Term v a)
defaultCaseVisitor Text
func m :: Term v a
m@(Match' Term v a
scrut [MatchCase a (Term v a)]
cases)
  | Term v a
scrut <- Text -> Term v a -> Term v a
forall v a. (Var v, Monoid a) => Text -> Term v a -> Term v a
addDefaultCases Text
func Term v a
scrut,
    [MatchCase a (Term v a)]
cases <- (Term v a -> Term v a)
-> MatchCase a (Term v a) -> MatchCase a (Term v a)
forall a b. (a -> b) -> MatchCase a a -> MatchCase a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Term v a -> Term v a
forall v a. (Var v, Monoid a) => Text -> Term v a -> Term v a
addDefaultCases Text
func) (MatchCase a (Term v a) -> MatchCase a (Term v a))
-> [MatchCase a (Term v a)] -> [MatchCase a (Term v a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MatchCase a (Term v a)]
cases =
      Term v a -> Maybe (Term v a)
forall a. a -> Maybe a
Just (Term v a -> Maybe (Term v a)) -> Term v a -> Maybe (Term v a)
forall a b. (a -> b) -> a -> b
$ a -> Term v a -> [MatchCase a (Term v a)] -> Term v a
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
match a
a Term v a
scrut ([MatchCase a (Term v a)]
cases [MatchCase a (Term v a)]
-> [MatchCase a (Term v a)] -> [MatchCase a (Term v a)]
forall a. [a] -> [a] -> [a]
++ [MatchCase a (Term v a)
dflt])
  where
    a :: a
a = Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
m
    v :: v
v = Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn Set v
forall a. Monoid a => a
mempty (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ Type -> v
forall v. Var v => Type -> v
typed Type
Var.Blank
    txt :: Text
txt = Text
"pattern match failure in function `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
func Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
    msg :: Term v a
msg = a -> Text -> Term v a
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
text a
a Text
txt
    bu :: Term v a
bu = a -> TypeReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> TypeReference -> Term2 vt at ap v a
ref a
a (Text -> TypeReference
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, Ord a) => Term v a -> Term v a
minimizeCyclesOrCrash :: forall v a. (Var v, Ord a) => Term v a -> Term v a
minimizeCyclesOrCrash Term v a
t = case Term v a -> Either (NonEmpty (v, NESet a)) (Term v a)
forall v a vt.
(Var v, Ord a) =>
Term' vt v a -> Either (NonEmpty (v, NESet a)) (Term' vt v a)
minimize' Term v a
t of
  Right Term v a
t -> Term v a
t
  Left NonEmpty (v, NESet a)
e ->
    [Word] -> String -> Term v a
forall a. HasCallStack => [Word] -> 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, NESet a) -> v
forall a b. (a, b) -> a
fst ((v, NESet a) -> v) -> [(v, NESet a)] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (v, NESet a) -> [(v, NESet a)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (v, NESet a)
e)

groupVars :: ANFM v (Set v)
groupVars :: forall v. ANFM v (Set v)
groupVars = ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
     r
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     r
forall a.
(Set v -> Set v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)])
 -> (v,
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     v
forall a.
((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
 -> (a,
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
  -> (v,
      (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      v)
-> ((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
    -> (v,
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     v
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
fr, Word16
bnd, [(v, SuperNormal TypeReference 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 TypeReference 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 <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, v
cv)
    else do
      v
bv <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
     Word16
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Direction Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  Word16
forall v. ANFM v Word16
binder
      pure ([Cte v] -> Ctx v
forall (f :: * -> *) v. Foldable f => f (Cte v) -> Ctx v
directed [Direction Word16 -> v -> Mem -> ANormal TypeReference v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d v
bv Mem
BX (ANormal TypeReference v -> Cte v)
-> ANormal TypeReference v -> Cte v
forall a b. (a -> b) -> a -> b
$ v -> [v] -> ANormal TypeReference v
forall v ref. Var v => v -> [v] -> ANormal ref v
TApv v
cv []], v
bv)
contextualize (Direction ()
d0, ANormal TypeReference v
tm) = do
  v
fv <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
  Direction Word16
d <- Direction ()
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Direction Word16)
forall a v. Direction a -> ANFM v (Direction Word16)
bindDirection Direction ()
d0
  pure ((Direction ()
d0, Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (Direction Word16 -> v -> Mem -> ANormal TypeReference v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d v
fv Mem
BX ANormal TypeReference v
tm)), v
fv)

binder :: ANFM v Word16
binder :: forall v. ANFM v Word16
binder = ((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
 -> (Word16,
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     Word16
forall a.
((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
 -> (a,
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
  -> (Word16,
      (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      Word16)
-> ((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
    -> (Word16,
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     Word16
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
fr, Word16
bnd, [(v, SuperNormal TypeReference v)]
cs) -> (Word16
bnd, (ConstructorId
fr, Word16
bnd Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
1, [(v, SuperNormal TypeReference 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 TypeReference v)]))
      Word16)
-> Direction a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
  Word16
-> a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     Word16
forall a b. a -> b -> a
const ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  Word16
forall v. ANFM v Word16
binder)

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

superNormalize :: (Var v) => Term v a -> SuperGroup Reference v
superNormalize :: forall v a. Var v => Term v a -> SuperGroup TypeReference v
superNormalize Term v a
tm = [(v, SuperNormal TypeReference v)]
-> SuperNormal TypeReference v -> SuperGroup TypeReference v
forall ref v.
[(v, SuperNormal ref v)] -> SuperNormal ref v -> SuperGroup ref v
Rec [(v, SuperNormal TypeReference v)]
l SuperNormal TypeReference 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 TypeReference v)]))
  (SuperNormal TypeReference v)
comp = ((v, Term v a)
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      ())
-> [(v, Term v a)]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference 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 TypeReference v)]))
  ()
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (SuperNormal TypeReference v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (SuperNormal TypeReference v)
forall a b.
ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     b
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
     (SuperNormal TypeReference v)
forall v a.
Var v =>
Term v a -> ANFM v (SuperNormal TypeReference v)
toSuperNormal Term v a
e
    subc :: State
  (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
  (SuperNormal TypeReference v)
subc = ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  (SuperNormal TypeReference v)
-> Set v
-> State
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
     (SuperNormal TypeReference v)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  (SuperNormal TypeReference v)
comp Set v
grp
    (SuperNormal TypeReference v
c, (ConstructorId
_, Word16
_, [(v, SuperNormal TypeReference v)]
l)) = State
  (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
  (SuperNormal TypeReference v)
-> (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
-> (SuperNormal TypeReference v,
    (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
forall s a. State s a -> s -> (a, s)
runState State
  (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
  (SuperNormal TypeReference 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 TypeReference v
nf <- Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (SuperNormal TypeReference v)
forall v a.
Var v =>
Term v a -> ANFM v (SuperNormal TypeReference v)
toSuperNormal Term v a
tm
  ((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
 -> (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
-> ANFM v ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
  -> (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
 -> ANFM v ())
-> ((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
    -> (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
-> ANFM v ()
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
cvs, Word16
bnd, [(v, SuperNormal TypeReference v)]
ctx) -> (ConstructorId
cvs, Word16
bnd, (v
v, SuperNormal TypeReference v
nf) (v, SuperNormal TypeReference v)
-> [(v, SuperNormal TypeReference v)]
-> [(v, SuperNormal TypeReference v)]
forall a. a -> [a] -> [a]
: [(v, SuperNormal TypeReference v)]
ctx)

toSuperNormal :: (Var v) => Term v a -> ANFM v (SuperNormal Reference v)
toSuperNormal :: forall v a.
Var v =>
Term v a -> ANFM v (SuperNormal TypeReference v)
toSuperNormal Term v a
tm = do
  Set v
grp <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 [Word] -> String -> ANFM v (SuperNormal TypeReference v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] (String -> ANFM v (SuperNormal TypeReference v))
-> String -> ANFM v (SuperNormal TypeReference 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 TypeReference v -> SuperNormal TypeReference v
forall ref v. [Mem] -> ANormal ref v -> SuperNormal ref 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 TypeReference v -> SuperNormal TypeReference v)
-> ((Direction (), ANormal TypeReference v)
    -> ANormal TypeReference v)
-> (Direction (), ANormal TypeReference v)
-> SuperNormal TypeReference v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
vs (ANormal TypeReference v -> ANormal TypeReference v)
-> ((Direction (), ANormal TypeReference v)
    -> ANormal TypeReference v)
-> (Direction (), ANormal TypeReference v)
-> ANormal TypeReference v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Direction (), ANormal TypeReference v) -> ANormal TypeReference v
forall a b. (a, b) -> b
snd
        ((Direction (), ANormal TypeReference v)
 -> SuperNormal TypeReference v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Direction (), ANormal TypeReference v)
-> ANFM v (SuperNormal TypeReference v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Direction (), ANormal TypeReference v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Direction (), ANormal TypeReference 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 TypeReference v)]))
     (Direction (), ANormal TypeReference 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 (), Seq (Cte v)),
 (Direction (), ANormal TypeReference v))
-> (Direction (), ANormal TypeReference v)
forall {v} {a}.
Var v =>
((a, Seq (Cte v)), (Direction (), ANormal TypeReference v))
-> (Direction (), ANormal TypeReference v)
f (((Direction (), Seq (Cte v)),
  (Direction (), ANormal TypeReference v))
 -> (Direction (), ANormal TypeReference v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     ((Direction (), Seq (Cte v)),
      (Direction (), ANormal TypeReference v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Direction (), ANormal TypeReference v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     ((Direction (), Seq (Cte v)),
      (Direction (), ANormal TypeReference 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, Seq (Cte v)), (Direction (), ANormal TypeReference v))
-> (Direction (), ANormal TypeReference v)
f ((a
_, Seq (Cte v)
Seq.Empty), (Direction (), ANormal TypeReference v)
dtm) = (Direction (), ANormal TypeReference v)
dtm
    f ((a
_, Seq (Cte v)
cx), (Direction ()
_, ANormal TypeReference v
tm)) = (() -> Direction ()
forall a. a -> Direction a
Indirect (), [Cte v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v.
Var v =>
[Cte v] -> ANormal TypeReference v -> ANormal TypeReference v
TBinds (Seq (Cte v) -> [Cte v]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Cte v)
cx) ANormal TypeReference v
tm)

floatableCtx :: (Var v) => Ctx v -> Bool
floatableCtx :: forall v. Var v => Ctx v -> Bool
floatableCtx = (CTE v (ANormal TypeReference v) -> Bool)
-> Seq (CTE v (ANormal TypeReference v)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CTE v (ANormal TypeReference v) -> Bool
forall {v} {v} {ref}. Var v => CTE v (ANormal ref v) -> Bool
p (Seq (CTE v (ANormal TypeReference v)) -> Bool)
-> (Ctx v -> Seq (CTE v (ANormal TypeReference v)))
-> Ctx v
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx v -> Seq (CTE v (ANormal TypeReference v))
forall a b. (a, b) -> b
snd
  where
    p :: CTE v (ANormal ref v) -> Bool
p (LZ v
_ Either TypeReference v
_ [v]
_) = Bool
True
    p (ST Direction Word16
_ [v]
_ [Mem]
_ ANormal ref v
tm) = ANormal ref v -> Bool
forall {v} {ref}. Var v => ANormal ref v -> Bool
q ANormal ref v
tm
    q :: ANormal ref v -> Bool
q (TLit Lit ref
_) = Bool
True
    q (TVar v
_) = Bool
True
    q (TCon ref
_ CTag
_ [v]
_) = Bool
True
    q ANormal ref 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 TypeReference v)]))
  a
-> (a
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
         b)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Ctx v
ctx, (Direction ()
_, t :: ANormal TypeReference 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
<> Seq (Cte v) -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (Direction Word16 -> v -> Mem -> ANormal TypeReference 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 TypeReference v
t)), ANormal TypeReference v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ANormal TypeReference v -> DNormal v)
-> ANormal TypeReference v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v -> ANormal TypeReference v
forall v ref. Var v => v -> ANormal ref v
TVar v
v)
    (Ctx v
ctx, (Direction ()
_, t :: ANormal TypeReference v
t@(TLit Lit TypeReference
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
<> Seq (Cte v) -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (Direction Word16 -> v -> Mem -> ANormal TypeReference 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 TypeReference v
t)), ANormal TypeReference v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ANormal TypeReference v -> DNormal v)
-> ANormal TypeReference v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v -> ANormal TypeReference v
forall v ref. Var v => v -> ANormal ref v
TVar v
v)
      where
        cc :: Mem
cc = case Lit TypeReference
l of T {} -> Mem
BX; LM {} -> Mem
BX; LY {} -> Mem
BX; Lit TypeReference
_ -> 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 TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v, DNormal v)
p

-- 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, Seq (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 (Seq (Cte v) -> [Cte v]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Cte v)
ctx) = ((Direction ()
d, [Cte v] -> Seq (Cte v)
forall a. [a] -> Seq a
Seq.fromList [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 TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
-> ([CTE v (Term (ANormalF TypeReference) 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 TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
-> ([CTE v (Term (ANormalF TypeReference) v)], Bool)
rn [CTE v (Term (ANormalF TypeReference) v)]
acc [] = ([CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. [a] -> [a]
reverse [CTE v (Term (ANormalF TypeReference) v)]
acc, Bool
False)
    rn [CTE v (Term (ANormalF TypeReference) v)]
acc (ST Direction Word16
d [v]
vs [Mem]
ccs Term (ANormalF TypeReference) v
b : [CTE v (Term (ANormalF TypeReference) 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 TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. [a] -> [a]
reverse [CTE v (Term (ANormalF TypeReference) v)]
acc [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. [a] -> [a] -> [a]
++ CTE v (Term (ANormalF TypeReference) v)
e CTE v (Term (ANormalF TypeReference) v)
-> [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. a -> [a] -> [a]
: [CTE v (Term (ANormalF TypeReference) v)]
es, Bool
True)
      | Bool
otherwise = [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
-> ([CTE v (Term (ANormalF TypeReference) v)], Bool)
rn (CTE v (Term (ANormalF TypeReference) v)
e CTE v (Term (ANormalF TypeReference) v)
-> [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. a -> [a] -> [a]
: [CTE v (Term (ANormalF TypeReference) v)]
acc) [CTE v (Term (ANormalF TypeReference) v)]
es
      where
        e :: CTE v (Term (ANormalF TypeReference) v)
e = Direction Word16
-> [v]
-> [Mem]
-> Term (ANormalF TypeReference) v
-> CTE v (Term (ANormalF TypeReference) v)
forall v s. Direction Word16 -> [v] -> [Mem] -> s -> CTE v s
ST Direction Word16
d [v]
vs [Mem]
ccs (Term (ANormalF TypeReference) v
 -> CTE v (Term (ANormalF TypeReference) v))
-> Term (ANormalF TypeReference) v
-> CTE v (Term (ANormalF TypeReference) v)
forall a b. (a -> b) -> a -> b
$ v
-> v
-> Term (ANormalF TypeReference) v
-> Term (ANormalF TypeReference) 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 TypeReference) v
b
    rn [CTE v (Term (ANormalF TypeReference) v)]
acc (LZ v
w Either TypeReference v
f [v]
as : [CTE v (Term (ANormalF TypeReference) v)]
es)
      | v
w v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v = ([CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. [a] -> [a]
reverse [CTE v (Term (ANormalF TypeReference) v)]
acc [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. [a] -> [a] -> [a]
++ CTE v (Term (ANormalF TypeReference) v)
e CTE v (Term (ANormalF TypeReference) v)
-> [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. a -> [a] -> [a]
: [CTE v (Term (ANormalF TypeReference) v)]
es, Bool
True)
      | Bool
otherwise = [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
-> ([CTE v (Term (ANormalF TypeReference) v)], Bool)
rn (CTE v (Term (ANormalF TypeReference) v)
e CTE v (Term (ANormalF TypeReference) v)
-> [CTE v (Term (ANormalF TypeReference) v)]
-> [CTE v (Term (ANormalF TypeReference) v)]
forall a. a -> [a] -> [a]
: [CTE v (Term (ANormalF TypeReference) v)]
acc) [CTE v (Term (ANormalF TypeReference) v)]
es
      where
        e :: CTE v (Term (ANormalF TypeReference) v)
e = v
-> Either TypeReference v
-> [v]
-> CTE v (Term (ANormalF TypeReference) v)
forall v s. v -> Either TypeReference v -> [v] -> CTE v s
LZ v
w (v -> v
swap (v -> v) -> Either TypeReference v -> Either TypeReference v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either TypeReference 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 TypeReference) v
b) = Direction Word16
-> [v] -> [Mem] -> Term (ANormalF TypeReference) 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 TypeReference) v
-> Term (ANormalF TypeReference) v
forall v (f :: * -> * -> *).
(Var v, Bifunctor f, Bifoldable f) =>
Map v v -> Term f v -> Term f v
ABTN.renames Map v v
rn Term (ANormalF TypeReference) v
b)
    f (LZ v
v Either TypeReference v
r [v]
as) = v -> Either TypeReference v -> [v] -> Cte v
forall v s. v -> Either TypeReference v -> [v] -> CTE v s
LZ v
v ((v -> v) -> Either TypeReference v -> Either TypeReference 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 TypeReference 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
. Seq (Cte v) -> [Cte v]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (Cte v) -> [Cte v])
-> (Ctx v -> Seq (Cte v)) -> Ctx v -> [Cte v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx v -> Seq (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 TypeReference a
r [a]
as) Set a
rest =
      [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ((TypeReference -> [a] -> [a])
-> (a -> [a] -> [a]) -> Either TypeReference a -> [a] -> [a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([a] -> [a]) -> TypeReference -> [a] -> [a]
forall a b. a -> b -> a
const [a] -> [a]
forall a. a -> a
id) (:) Either TypeReference 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, Seq (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 (Seq (Cte v) -> [Cte v]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Cte v)
ctx) of
    (Map v v
rn, [Cte v]
ctx) -> (Map v v
rn, (Direction ()
d, [Cte v] -> Seq (Cte v)
forall a. [a] -> Seq a
Seq.fromList [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 -> Seq (Cte v) -> Set v
forall b a. (b -> a -> b) -> b -> Seq 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 Seq (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 TypeReference 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 TypeReference v -> [v] -> Cte v
forall v s. v -> Either TypeReference v -> [v] -> CTE v s
LZ v
u Either TypeReference 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 TypeReference 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 TypeReference v -> Cte v
forall v s. Direction Word16 -> [v] -> [Mem] -> s -> CTE v s
ST Direction Word16
d [v]
us [Mem]
ccs ANormal TypeReference 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 TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v -> Term (ANormalF TypeReference) v
forall v ref. Var v => v -> ANormal ref 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 TypeReference 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 TypeReference) v
cf) <- Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (DNormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
f
  (Direction ()
dt, Term (ANormalF TypeReference) v
ct) <- Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, v)
forall v. Var v => DNormal v -> ANFM v (Ctx v, v)
contextualize DNormal v
cc
  let cases :: Branched TypeReference (Term (ANormalF TypeReference) v)
cases =
        TypeReference
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Maybe (Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e.
ref -> EnumMap CTag ([Mem], e) -> Maybe e -> Branched ref e
MatchData
          (Text -> TypeReference
forall t h. t -> Reference' t h
Builtin (Text -> TypeReference) -> Text -> TypeReference
forall a b. (a -> b) -> a -> b
$ String -> Text
Data.Text.pack String
"Boolean")
          (CTag
-> ([Mem], Term (ANormalF TypeReference) v)
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton CTag
0 ([], Term (ANormalF TypeReference) v
cf))
          (Term (ANormalF TypeReference) v
-> Maybe (Term (ANormalF TypeReference) v)
forall a. a -> Maybe a
Just Term (ANormalF TypeReference) v
ct)
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v Branched TypeReference (Term (ANormalF TypeReference) v)
cases))
anfBlock (And' Term v a
l Term v a
r) = do
  (Ctx v
lctx, v
vl) <- Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v
tmr) <- Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (DNormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
r
  let tree :: Term (ANormalF TypeReference) v
tree =
        v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
vl (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> Term (ANormalF TypeReference) v)
-> (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
    -> Branched TypeReference (Term (ANormalF TypeReference) v))
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeReference
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e. ref -> EnumMap CTag ([Mem], e) -> Branched ref e
MatchDataCover TypeReference
Ty.booleanRef (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
 -> Term (ANormalF TypeReference) v)
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall a b. (a -> b) -> a -> b
$
          [(CTag, ([Mem], Term (ANormalF TypeReference) v))]
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList
            [ (CTag
0, ([], Term (ANormalF TypeReference) v
forall {v}. Var v => ANormal TypeReference v
UFalse)),
              (CTag
1, ([], Term (ANormalF TypeReference) v
tmr))
            ]
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v
tree))
anfBlock (Or' Term v a
l Term v a
r) = do
  (Ctx v
lctx, v
vl) <- Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v
tmr) <- Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (DNormal v)
forall v a. Var v => Term v a -> ANFM v (DNormal v)
anfTerm Term v a
r
  let tree :: Term (ANormalF TypeReference) v
tree =
        v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
vl (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> Term (ANormalF TypeReference) v)
-> (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
    -> Branched TypeReference (Term (ANormalF TypeReference) v))
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeReference
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e. ref -> EnumMap CTag ([Mem], e) -> Branched ref e
MatchDataCover TypeReference
Ty.booleanRef (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
 -> Term (ANormalF TypeReference) v)
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall a b. (a -> b) -> a -> b
$
          [(CTag, ([Mem], Term (ANormalF TypeReference) v))]
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
mapFromList
            [ (CTag
1, ([], Term (ANormalF TypeReference) v
forall {v}. Var v => ANormal TypeReference v
UTrue)),
              (CTag
0, ([], Term (ANormalF TypeReference) v
tmr))
            ]
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v
tree))
anfBlock (Handle' Term v a
h Term v a
body) =
  Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, v)
anfArg Term v a
h ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  (Ctx v, v)
-> ((Ctx v, v)
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  a
-> (a
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
         b)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference 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 TypeReference v)]))
  (Ctx v, DNormal v)
-> ((Ctx v, DNormal v)
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  a
-> (a
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
         b)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Ctx v
ctx, (Direction ()
_, TCom TypeReference
f [v]
as)) | Ctx v -> Bool
forall v. Var v => Ctx v -> Bool
floatableCtx Ctx v
ctx -> do
        v
v <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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
<> Seq (Cte v) -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (v -> Either TypeReference v -> [v] -> Cte v
forall v s. v -> Either TypeReference v -> [v] -> CTE v s
LZ v
v (TypeReference -> Either TypeReference v
forall a b. a -> Either a b
Left TypeReference
f) [v]
as)),
            (() -> Direction ()
forall a. a -> Direction a
Indirect (), Func TypeReference v -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => Func ref v -> [v] -> ANormal ref v
TApp (v -> Func TypeReference v
forall ref v. v -> Func ref 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 <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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
<> Seq (Cte v) -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (v -> Either TypeReference v -> [v] -> Cte v
forall v s. v -> Either TypeReference v -> [v] -> CTE v s
LZ v
v (v -> Either TypeReference v
forall a b. b -> Either a b
Right v
f) [v]
as)),
            (() -> Direction ()
forall a. a -> Direction a
Indirect (), Func TypeReference v -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => Func ref v -> [v] -> ANormal ref v
TApp (v -> Func TypeReference v
forall ref v. v -> Func ref 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 TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => Func ref v -> [v] -> ANormal ref v
TApp (v -> Func TypeReference v
forall ref v. v -> Func ref v
FVar v
vh) [v
v]))
      p :: (Ctx v, DNormal v)
p@(Ctx v
_, DNormal v
_) ->
        [Word]
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] (String
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      (Ctx v, DNormal v))
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference 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
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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)]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Directed () (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 TypeReference v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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) -> Ctx v
directed -> Ctx v
dctx) Term (ANormalF TypeReference) v
df) -> do
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term (ANormalF TypeReference) v
df)
    AccumRequest Map
  TypeReference
  (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v))
_ Maybe (Term (ANormalF TypeReference) v)
Nothing ->
      [Word]
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] String
"anfBlock: AccumRequest without default"
    AccumPure (ABTN.TAbss [v]
us Term (ANormalF TypeReference) v
bd)
      | [v
u] <- [v]
us,
        TBinds ([Cte v] -> Ctx v
forall (f :: * -> *) v. Foldable f => f (Cte v) -> Ctx v
directed -> Ctx v
bx) Term (ANormalF TypeReference) v
bd <- Term (ANormalF TypeReference) v
bd ->
          case Ctx v
cx of
            (Direction ()
_, Seq (Cte v)
Seq.Empty) -> do
              Direction Word16
d0 <- Word16 -> Direction Word16
forall a. a -> Direction a
Indirect (Word16 -> Direction Word16)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     Word16
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Direction Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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
<> Seq (Cte v) -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) 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 TypeReference) v
forall v ref. Var v => v -> ANormal ref v
TFrc v
v))) Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
bx, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term (ANormalF TypeReference) v
bd)
            (Direction ()
d0, ST1 Direction Word16
d1 v
_ Mem
BX Term (ANormalF TypeReference) v
tm Seq.:<| Seq (Cte v)
Seq.Empty) ->
              (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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, Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d1 v
u Mem
BX Term (ANormalF TypeReference) v
tm)) Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Ctx v
bx, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term (ANormalF TypeReference) v
bd)
            Ctx v
_ -> [Word]
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] String
"anfBlock|AccumPure: impossible"
      | Bool
otherwise -> [Word]
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] String
"pure handler with too many variables"
    AccumRequest Map
  TypeReference
  (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v))
abr (Just Term (ANormalF TypeReference) v
df) -> do
      (v
r, [v]
vs) <- do
        v
r <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
        v
v <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
        ([v]
hfvs, SuperNormal TypeReference v
hcomb) <- v
-> Map
     TypeReference
     (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v))
-> Term (ANormalF TypeReference) v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     ([v], SuperNormal TypeReference v)
forall v.
Var v =>
v
-> ReqBranches TypeReference v
-> ANormal TypeReference v
-> ANFM v ([v], SuperNormal TypeReference v)
makeHandler v
v Map
  TypeReference
  (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v))
abr Term (ANormalF TypeReference) v
df
        (v, SuperNormal TypeReference v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     ()
forall v. Var v => (v, SuperNormal TypeReference v) -> ANFM v ()
record (v
r, SuperNormal TypeReference v
hcomb)
        pure (v
r, [v]
hfvs)
      v
hv <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
      let (Direction ()
d, Term (ANormalF TypeReference) v
msc)
            | (Direction ()
d, ST1 Direction Word16
_ v
_ Mem
BX Term (ANormalF TypeReference) v
tm Seq.:<| Seq (Cte v)
Seq.Empty) <- Ctx v
cx = (Direction ()
d, Term (ANormalF TypeReference) v
tm)
            | (Direction ()
_, ST Direction Word16
_ [v]
_ [Mem]
_ Term (ANormalF TypeReference) v
_ Seq.:<| Seq (Cte v)
Seq.Empty) <- Ctx v
cx =
                [Word] -> String -> DNormal v
forall a. HasCallStack => [Word] -> String -> a
internalBug [] String
"anfBlock: impossible"
            | Bool
otherwise = (() -> Direction ()
forall a. a -> Direction a
Indirect (), v -> Term (ANormalF TypeReference) v
forall v ref. Var v => v -> ANormal ref v
TFrc v
v)
      pure
        ( Ctx v
sctx Ctx v -> Ctx v -> Ctx v
forall a. Semigroup a => a -> a -> a
<> Seq (Cte v) -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (v -> Either TypeReference v -> [v] -> Cte v
forall v s. v -> Either TypeReference v -> [v] -> CTE v s
LZ v
hv (v -> Either TypeReference v
forall a b. b -> Either a b
Right v
r) [v]
vs)),
          (Direction ()
d, [TypeReference]
-> v
-> Maybe v
-> Term (ANormalF TypeReference) v
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
[ref] -> v -> Maybe v -> ANormal ref v -> ANormal ref v
THnd (Map
  TypeReference
  (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v))
-> [TypeReference]
forall k a. Map k a -> [k]
Map.keys Map
  TypeReference
  (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v))
abr) v
hv Maybe v
forall a. Maybe a
Nothing Term (ANormalF TypeReference) v
msc)
        )
    AccumText Maybe (Term (ANormalF TypeReference) v)
df Map Text (Term (ANormalF TypeReference) v)
cs ->
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> (Branched TypeReference (Term (ANormalF TypeReference) v)
    -> Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> DNormal v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> DNormal v
forall a b. (a -> b) -> a -> b
$ Map Text (Term (ANormalF TypeReference) v)
-> Maybe (Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e. Map Text e -> Maybe e -> Branched ref e
MatchText Map Text (Term (ANormalF TypeReference) v)
cs Maybe (Term (ANormalF TypeReference) v)
df)
    AccumBytes Maybe (Term (ANormalF TypeReference) v)
df Map Bytes (Term (ANormalF TypeReference) v)
cs ->
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> (Branched TypeReference (Term (ANormalF TypeReference) v)
    -> Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> DNormal v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> DNormal v
forall a b. (a -> b) -> a -> b
$ Map Bytes (Term (ANormalF TypeReference) v)
-> Maybe (Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e. Map Bytes e -> Maybe e -> Branched ref e
MatchBytes Map Bytes (Term (ANormalF TypeReference) v)
cs Maybe (Term (ANormalF TypeReference) v)
df)
    AccumIntegral TypeReference
r Maybe (Term (ANormalF TypeReference) v)
df EnumMap ConstructorId (Term (ANormalF TypeReference) v)
cs ->
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall a b. (a -> b) -> a -> b
$ TypeReference
-> EnumMap ConstructorId (Term (ANormalF TypeReference) v)
-> Maybe (Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e.
ref -> EnumMap ConstructorId e -> Maybe e -> Branched ref e
MatchNumeric TypeReference
r EnumMap ConstructorId (Term (ANormalF TypeReference) v)
cs Maybe (Term (ANormalF TypeReference) v)
df)
    AccumData TypeReference
r Maybe (Term (ANormalF TypeReference) v)
df EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
cs ->
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> (Branched TypeReference (Term (ANormalF TypeReference) v)
    -> Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> DNormal v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> DNormal v
forall a b. (a -> b) -> a -> b
$ TypeReference
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Maybe (Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e.
ref -> EnumMap CTag ([Mem], e) -> Maybe e -> Branched ref e
MatchData TypeReference
r EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
cs Maybe (Term (ANormalF TypeReference) v)
df)
    AccumRec RecordSchema
rs Term (ANormalF TypeReference) v
bd -> do
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall a b. (a -> b) -> a -> b
$ RecordSchema
-> Term (ANormalF TypeReference) v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e. RecordSchema -> e -> Branched ref e
MatchRec RecordSchema
rs Term (ANormalF TypeReference) v
bd)
    AccumSeqEmpty Term (ANormalF TypeReference) v
_ ->
      [Word]
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] String
"anfBlock: non-exhaustive AccumSeqEmpty"
    AccumSeqView SeqEnd
en (Just Term (ANormalF TypeReference) v
em) Term (ANormalF TypeReference) v
bd -> do
      v
r <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
      let op :: TypeReference
op
            | SeqEnd
SLeft <- SeqEnd
en = Text -> TypeReference
forall t h. t -> Reference' t h
Builtin Text
"List.viewl"
            | Bool
otherwise = Text -> TypeReference
forall t h. t -> Reference' t h
Builtin Text
"List.viewr"
      Word16
b <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 (), Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) 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 (TypeReference -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => ref -> [v] -> ANormal ref v
TCom TypeReference
op [v
v]))),
          Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> (Branched TypeReference (Term (ANormalF TypeReference) v)
    -> Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
r (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> DNormal v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> DNormal v
forall a b. (a -> b) -> a -> b
$
            TypeReference
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e. ref -> EnumMap CTag ([Mem], e) -> Branched ref e
MatchDataCover
              TypeReference
Ty.seqViewRef
              ( [(CTag, ([Mem], Term (ANormalF TypeReference) v))]
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) 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 TypeReference) v
em)),
                    (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
Ty.seqViewElem, ([Mem
BX, Mem
BX], Term (ANormalF TypeReference) v
bd))
                  ]
              )
        )
    AccumSeqView {} ->
      [Word]
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] String
"anfBlock: non-exhaustive AccumSeqView"
    AccumSeqSplit SeqEnd
en Int
n Maybe (Term (ANormalF TypeReference) v)
mdf Term (ANormalF TypeReference) v
bd -> do
      v
i <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
      v
r <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
      v
s <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
      Word16
b <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  Word16
forall v. ANFM v Word16
binder
      let split :: Cte v
split = Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) 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 (TypeReference -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => ref -> [v] -> ANormal ref v
TCom TypeReference
op [v
i, v
v])
      (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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) -> Ctx v
directed [v -> Cte v
lit v
i, Cte v
split],
          Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
    -> Term (ANormalF TypeReference) v)
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
r (Branched TypeReference (Term (ANormalF TypeReference) v)
 -> Term (ANormalF TypeReference) v)
-> (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
    -> Branched TypeReference (Term (ANormalF TypeReference) v))
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeReference
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e. ref -> EnumMap CTag ([Mem], e) -> Branched ref e
MatchDataCover TypeReference
Ty.seqViewRef (EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
 -> DNormal v)
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) v)
-> DNormal v
forall a b. (a -> b) -> a -> b
$
            [(CTag, ([Mem], Term (ANormalF TypeReference) v))]
-> EnumMap CTag ([Mem], Term (ANormalF TypeReference) 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 TypeReference) 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 TypeReference) v
bd))
              ]
        )
      where
        op :: TypeReference
op
          | SeqEnd
SLeft <- SeqEnd
en = Text -> TypeReference
forall t h. t -> Reference' t h
Builtin Text
"List.splitLeft"
          | Bool
otherwise = Text -> TypeReference
forall t h. t -> Reference' t h
Builtin Text
"List.splitRight"
        lit :: v -> Cte v
lit v
i = Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) 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 TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TBLit (Lit TypeReference -> Term (ANormalF TypeReference) v)
-> (ConstructorId -> Lit TypeReference)
-> ConstructorId
-> Term (ANormalF TypeReference) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId -> Lit TypeReference
forall ref. ConstructorId -> Lit ref
N (ConstructorId -> Term (ANormalF TypeReference) v)
-> ConstructorId -> Term (ANormalF TypeReference) 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 TypeReference) v
df v
n =
          Term (ANormalF TypeReference) v
-> Maybe (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall a. a -> Maybe a -> a
fromMaybe
            ( Direction Word16
-> v
-> Mem
-> Term (ANormalF TypeReference) v
-> Term (ANormalF TypeReference) v
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
Direction Word16
-> v -> Mem -> ANormal ref v -> ANormal ref v -> ANormal ref v
TLet Direction Word16
forall a. Direction a
Direct v
n Mem
BX (Lit TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TLit (Text -> Lit TypeReference
forall ref. Text -> Lit ref
T Text
"pattern match failure")) (Term (ANormalF TypeReference) v
 -> Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
-> Term (ANormalF TypeReference) v
forall a b. (a -> b) -> a -> b
$
                POp -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => POp -> [v] -> ANormal ref v
TPrm POp
EROR [v
n, v
v]
            )
            Maybe (Term (ANormalF TypeReference) v)
mdf
    BranchAccum v
AccumEmpty -> (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ v
-> Branched TypeReference (Term (ANormalF TypeReference) v)
-> Term (ANormalF TypeReference) v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v Branched TypeReference (Term (ANormalF TypeReference) v)
forall ref e. Branched ref 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 TypeReference 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 TypeReference v)]))
  (Ctx v, DNormal v)
-> ((Ctx v, DNormal v)
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
         (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a b.
ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  a
-> (a
    -> ReaderT
         (Set v)
         (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
         b)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference 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 TypeReference 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
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     v
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      v)
-> v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
     (Ctx v, Bool)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Ctx v, Bool)
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      (Ctx v, Bool))
-> (Ctx v, Bool)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNormal v
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      (DNormal v))
-> DNormal v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (DNormal v)
forall a b. (a -> b) -> a -> b
$ if Bool
shaded then DNormal v
ce else v
-> v
-> Term (ANormalF TypeReference) v
-> Term (ANormalF TypeReference) 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 TypeReference) v
 -> Term (ANormalF TypeReference) 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 TypeReference) v
cb)) -> [v]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
   (Ctx v, DNormal v)
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference 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 TypeReference 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 TypeReference 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 TypeReference) v
cb <- Term (ANormalF TypeReference) v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Term (ANormalF TypeReference) v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      (Term (ANormalF TypeReference) v))
-> Term (ANormalF TypeReference) v
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Term (ANormalF TypeReference) v)
forall a b. (a -> b) -> a -> b
$ Map v v
-> Term (ANormalF TypeReference) v
-> Term (ANormalF TypeReference) v
forall v (f :: * -> * -> *).
(Var v, Bifunctor f, Bifoldable f) =>
Map v v -> Term f v -> Term f v
ABTN.renames Map v v
brn Term (ANormalF TypeReference) 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) -> Ctx v
directed [Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) v -> Cte v
forall v s. Direction Word16 -> v -> Mem -> s -> CTE v s
ST1 Direction Word16
d v
v Mem
BX Term (ANormalF TypeReference) 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 TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
  (Ctx v
actx, [v]
cas) <- [Term v a]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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
<> Seq (Cte v) -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cte v -> Seq (Cte v)
forall a. a -> Seq a
Seq.singleton (Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) 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 TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TLit (Text -> Lit TypeReference
forall ref. Text -> Lit ref
T Text
msg)))),
      Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ POp -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => POp -> [v] -> ANormal ref 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 TypeReference v
cf)) <- Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, Directed () (Func TypeReference v))
forall v a.
Var v =>
Term v a -> ANFM v (Ctx v, Directed () (Func TypeReference v))
anfFunc Term v a
f
  (Ctx v
actx, [v]
cas) <- [Term v a]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => Func ref v -> [v] -> ANormal ref v
TApp Func TypeReference v
cf [v]
cas))
anfBlock (Constructor' (ConstructorReference TypeReference
r ConstructorId
t)) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ TypeReference -> CTag -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => ref -> CTag -> [v] -> ANormal ref v
TCon TypeReference
r (ConstructorId -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral ConstructorId
t) [])
anfBlock (Request' (ConstructorReference TypeReference
r ConstructorId
t)) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 (), TypeReference -> CTag -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => ref -> CTag -> [v] -> ANormal ref v
TReq TypeReference
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 TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ TypeReference -> CTag -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => ref -> CTag -> [v] -> ANormal ref v
TCon TypeReference
Ty.booleanRef (if Bool
b then CTag
1 else CTag
0) [])
anfBlock (Lit' l :: Lit TypeReference
l@(T Text
_)) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ Lit TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TLit Lit TypeReference
l)
anfBlock (Lit' Lit TypeReference
l) =
  (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ Lit TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TBLit Lit TypeReference
l)
anfBlock (Ref' TypeReference
r) = (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 (), TypeReference -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => ref -> [v] -> ANormal ref v
TCom TypeReference
r []))
anfBlock (Blank' Blank a
b) = do
  v
nm <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
  v
ev <- ReaderT
  (Set v)
  (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
  v
forall v. Var v => ANFM v v
fresh
  pure
    ( Seq (Cte v) -> Ctx v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq (Cte v) -> Ctx v) -> Seq (Cte v) -> Ctx v
forall a b. (a -> b) -> a -> b
$
        [Cte v] -> Seq (Cte v)
forall a. [a] -> Seq a
Seq.fromList
          [ Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) 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 TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TLit (Text -> Lit TypeReference
forall ref. Text -> Lit ref
T Text
name)),
            Direction Word16
-> v -> Mem -> Term (ANormalF TypeReference) 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 TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TLit (Text -> Lit TypeReference
forall ref. Text -> Lit ref
T (Text -> Lit TypeReference) -> Text -> Lit TypeReference
forall a b. (a -> b) -> a -> b
$ String -> Text
Util.Text.pack String
msg))
          ],
      Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> Term (ANormalF TypeReference) v -> DNormal v
forall a b. (a -> b) -> a -> b
$ POp -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => POp -> [v] -> ANormal ref 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 TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> (Lit TypeReference -> Term (ANormalF TypeReference) v)
-> Lit TypeReference
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TLit (Lit TypeReference -> DNormal v) -> Lit TypeReference -> DNormal v
forall a b. (a -> b) -> a -> b
$ Referent -> Lit TypeReference
forall ref. Referent' ref -> Lit ref
LM Referent
r)
anfBlock (TypeLink' TypeReference
r) = (Ctx v, DNormal v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx v
forall a. Monoid a => a
mempty, Term (ANormalF TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> (Lit TypeReference -> Term (ANormalF TypeReference) v)
-> Lit TypeReference
-> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit TypeReference -> Term (ANormalF TypeReference) v
forall v ref. Var v => Lit ref -> ANormal ref v
TLit (Lit TypeReference -> DNormal v) -> Lit TypeReference -> DNormal v
forall a b. (a -> b) -> a -> b
$ TypeReference -> Lit TypeReference
forall ref. ref -> Lit ref
LY TypeReference
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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> ([v] -> Term (ANormalF TypeReference) v) -> [v] -> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POp -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => POp -> [v] -> ANormal ref v
TPrm POp
BLDS) ((Ctx v, [v]) -> (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, [v])
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term v a]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 (Record' Map Text (Term v a)
fields) = ([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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> ([v] -> Term (ANormalF TypeReference) v) -> [v] -> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordSchema -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => RecordSchema -> [v] -> ANormal ref v
TRec RecordSchema
recSchema) ((Ctx v, [v]) -> (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, [v])
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term v a]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, [v])
forall v a. Var v => [Term v a] -> ANFM v (Ctx v, [v])
anfArgs [Term v a]
tms
  where
    recSchema :: RecordSchema
recSchema = Set Text -> RecordSchema
RecordSchema (Map Text (Term v a) -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text (Term v a)
fields)
    tms :: [Term v a]
tms = Map Text (Term v a) -> [Term v a]
forall a. Map Text a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map Text (Term v a)
fields
anfBlock (RecordSet' Text
field Term v a
r Term v a
v) = ([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 TypeReference) v -> DNormal v
forall a. a -> (Direction (), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term (ANormalF TypeReference) v -> DNormal v)
-> ([v] -> Term (ANormalF TypeReference) v) -> [v] -> DNormal v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [v] -> Term (ANormalF TypeReference) v
forall v ref. Var v => Text -> [v] -> ANormal ref v
TRecSet Text
field) ((Ctx v, [v]) -> (Ctx v, DNormal v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, [v])
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term v a]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, [v])
forall v a. Var v => [Term v a] -> ANFM v (Ctx v, [v])
anfArgs [Term v a
r, Term v a
v]
-- A record-set block is sugar: expand it to the match and `RecordSet` chain it
-- means, then compile that.
anfBlock t :: Term v a
t@(RecordSetBlock' [Text]
_ [(Text, Term v a)]
_ Term v a
_) = Term v a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 -> Term v a
forall vt v at a.
(Ord vt, Ord v, Var v) =>
Term2 vt at a v a -> Term2 vt at a v a
expandRecordSetBlock Term v a
t)
anfBlock Term v a
t = [Word]
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, DNormal v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] (String
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      (Ctx v, DNormal v))
-> String
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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

type ReqBranches ref v =
  Map Reference (EnumMap CTag ([Mem], ANormal ref v))

makeHandler ::
  (Var v) => v -> ReqBranches Reference v -> ANormal Reference v -> ANFM v ([v], SuperNormal Reference v)
makeHandler :: forall v.
Var v =>
v
-> ReqBranches TypeReference v
-> ANormal TypeReference v
-> ANFM v ([v], SuperNormal TypeReference v)
makeHandler v
v ReqBranches TypeReference v
abr ANormal TypeReference v
df = do
  [v]
hfvs <-
    ANFM v (Set v)
forall v. ANFM v (Set v)
groupVars ANFM v (Set v)
-> (Set v -> [v])
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     [v]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Set v
gvs ->
      Set v -> [v]
forall a. Set a -> [a]
Set.toList (Set v -> [v]) -> Set v -> [v]
forall a b. (a -> b) -> a -> b
$ ANormal TypeReference v -> Set v
forall (f :: * -> * -> *) v. Term f v -> Set v
ABTN.freeVars ANormal TypeReference v
hfb Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set v
gvs
  pure ([v]
hfvs, [Mem] -> ANormal TypeReference v -> SuperNormal TypeReference v
forall ref v. [Mem] -> ANormal ref v -> SuperNormal ref 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]) (ANormal TypeReference v -> SuperNormal TypeReference v)
-> ANormal TypeReference v -> SuperNormal TypeReference v
forall a b. (a -> b) -> a -> b
$ [v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
hfvs ANormal TypeReference v
hfb)
  where
    hfb :: ANormal TypeReference v
hfb = v -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => v -> Term f v -> Term f v
ABTN.TAbs v
v (ANormal TypeReference v -> ANormal TypeReference v)
-> (Branched TypeReference (ANormal TypeReference v)
    -> ANormal TypeReference v)
-> Branched TypeReference (ANormal TypeReference v)
-> ANormal TypeReference v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v
-> Branched TypeReference (ANormal TypeReference v)
-> ANormal TypeReference v
forall v ref.
Var v =>
v -> Branched ref (ANormal ref v) -> ANormal ref v
TMatch v
v (Branched TypeReference (ANormal TypeReference v)
 -> ANormal TypeReference v)
-> Branched TypeReference (ANormal TypeReference v)
-> ANormal TypeReference v
forall a b. (a -> b) -> a -> b
$ [(TypeReference, EnumMap CTag ([Mem], ANormal TypeReference v))]
-> ANormal TypeReference v
-> Branched TypeReference (ANormal TypeReference v)
forall ref e.
[(ref, EnumMap CTag ([Mem], e))] -> e -> Branched ref e
MatchRequest (ReqBranches TypeReference v
-> [(TypeReference, EnumMap CTag ([Mem], ANormal TypeReference v))]
forall k a. Map k a -> [(k, a)]
Map.toList ReqBranches TypeReference v
abr) ANormal TypeReference v
df

-- 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 = [Word] -> String -> ANFD v (BranchAccum v)
forall a. HasCallStack => [Word] -> String -> a
internalBug [] String
"anfInitCase: unexpected guard"
  | P.Unbound p
_ <- Pattern p
p,
    [] <- [v]
vs =
      ANormal TypeReference v -> BranchAccum v
forall v. ANormal TypeReference v -> BranchAccum v
AccumDefault (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
  | P.Var p
_ <- Pattern p
p,
    [v
v] <- [v]
vs =
      ANormal TypeReference v -> BranchAccum v
forall v. ANormal TypeReference v -> BranchAccum v
AccumDefault (ANormal TypeReference v -> BranchAccum v)
-> (ANormal TypeReference v -> ANormal TypeReference v)
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> v -> ANormal TypeReference v -> ANormal TypeReference 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 TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
  | P.Var p
_ <- Pattern p
p =
      [Word] -> String -> ANFD v (BranchAccum v)
forall a. HasCallStack => [Word] -> 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 =
      TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap ConstructorId (ANormal TypeReference v)
-> BranchAccum v
forall v.
TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap ConstructorId (ANormal TypeReference v)
-> BranchAccum v
AccumIntegral TypeReference
Ty.intRef Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing (EnumMap ConstructorId (ANormal TypeReference v) -> BranchAccum v)
-> (ANormal TypeReference v
    -> EnumMap ConstructorId (ANormal TypeReference v))
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId
-> ANormal TypeReference v
-> EnumMap ConstructorId (ANormal TypeReference v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton ConstructorId
i (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
  | P.Nat p
_ ConstructorId
i <- Pattern p
p =
      TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap ConstructorId (ANormal TypeReference v)
-> BranchAccum v
forall v.
TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap ConstructorId (ANormal TypeReference v)
-> BranchAccum v
AccumIntegral TypeReference
Ty.natRef Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing (EnumMap ConstructorId (ANormal TypeReference v) -> BranchAccum v)
-> (ANormal TypeReference v
    -> EnumMap ConstructorId (ANormal TypeReference v))
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId
-> ANormal TypeReference v
-> EnumMap ConstructorId (ANormal TypeReference v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton ConstructorId
i (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference 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 =
      TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap ConstructorId (ANormal TypeReference v)
-> BranchAccum v
forall v.
TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap ConstructorId (ANormal TypeReference v)
-> BranchAccum v
AccumIntegral TypeReference
Ty.charRef Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing (EnumMap ConstructorId (ANormal TypeReference v) -> BranchAccum v)
-> (ANormal TypeReference v
    -> EnumMap ConstructorId (ANormal TypeReference v))
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorId
-> ANormal TypeReference v
-> EnumMap ConstructorId (ANormal TypeReference v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton ConstructorId
w (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference 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 =
      TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap CTag ([Mem], ANormal TypeReference v)
-> BranchAccum v
forall v.
TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap CTag ([Mem], ANormal TypeReference v)
-> BranchAccum v
AccumData TypeReference
Ty.booleanRef Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing
        (EnumMap CTag ([Mem], ANormal TypeReference v) -> BranchAccum v)
-> (ANormal TypeReference v
    -> EnumMap CTag ([Mem], ANormal TypeReference v))
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag
-> ([Mem], ANormal TypeReference v)
-> EnumMap CTag ([Mem], ANormal TypeReference v)
forall k a. EnumKey k => k -> a -> EnumMap k a
EC.mapSingleton CTag
t
        (([Mem], ANormal TypeReference v)
 -> EnumMap CTag ([Mem], ANormal TypeReference v))
-> (ANormal TypeReference v -> ([Mem], ANormal TypeReference v))
-> ANormal TypeReference v
-> EnumMap CTag ([Mem], ANormal TypeReference v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([],)
        (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
  | P.Text p
_ Text
t <- Pattern p
p,
    [] <- [v]
vs =
      Maybe (ANormal TypeReference v)
-> Map Text (ANormal TypeReference v) -> BranchAccum v
forall v.
Maybe (ANormal TypeReference v)
-> Map Text (ANormal TypeReference v) -> BranchAccum v
AccumText Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing (Map Text (ANormal TypeReference v) -> BranchAccum v)
-> (ANormal TypeReference v -> Map Text (ANormal TypeReference v))
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> ANormal TypeReference v -> Map Text (ANormal TypeReference v)
forall k a. k -> a -> Map k a
Map.singleton (Text -> Text
Util.Text.fromText Text
t) (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
  | P.Bytes p
_ Bytes
b <- Pattern p
p,
    [] <- [v]
vs =
      Maybe (ANormal TypeReference v)
-> Map Bytes (ANormal TypeReference v) -> BranchAccum v
forall v.
Maybe (ANormal TypeReference v)
-> Map Bytes (ANormal TypeReference v) -> BranchAccum v
AccumBytes Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing (Map Bytes (ANormal TypeReference v) -> BranchAccum v)
-> (ANormal TypeReference v -> Map Bytes (ANormal TypeReference v))
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes
-> ANormal TypeReference v -> Map Bytes (ANormal TypeReference v)
forall k a. k -> a -> Map k a
Map.singleton Bytes
b (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
  | P.Constructor p
_ (ConstructorReference TypeReference
r ConstructorId
t) [Pattern p]
ps <- Pattern p
p = do
      (,)
        ([v] -> ANormal TypeReference v -> ([v], ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (ANormal TypeReference v -> ([v], ANormal TypeReference 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 TypeReference v -> ([v], ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> Compose
     (ANFM v) ((,) (Direction ())) ([v], ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
        Compose
  (ANFM v) ((,) (Direction ())) ([v], ANormal TypeReference v)
-> (([v], ANormal TypeReference v) -> BranchAccum v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([v]
us, ANormal TypeReference v
bd) ->
          TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap CTag ([Mem], ANormal TypeReference v)
-> BranchAccum v
forall v.
TypeReference
-> Maybe (ANormal TypeReference v)
-> EnumMap CTag ([Mem], ANormal TypeReference v)
-> BranchAccum v
AccumData TypeReference
r Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing (EnumMap CTag ([Mem], ANormal TypeReference v) -> BranchAccum v)
-> (ANormal TypeReference v
    -> EnumMap CTag ([Mem], ANormal TypeReference v))
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag
-> ([Mem], ANormal TypeReference v)
-> EnumMap CTag ([Mem], ANormal TypeReference 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 TypeReference v)
 -> EnumMap CTag ([Mem], ANormal TypeReference v))
-> (ANormal TypeReference v -> ([Mem], ANormal TypeReference v))
-> ANormal TypeReference v
-> EnumMap CTag ([Mem], ANormal TypeReference 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 TypeReference v -> BranchAccum v)
-> ANormal TypeReference v -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ [v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
us ANormal TypeReference v
bd
  | P.RecordLiteral p
_ Map Text (Pattern p)
fields <- Pattern p
p = do
      (,)
        ([v] -> ANormal TypeReference v -> ([v], ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (ANormal TypeReference v -> ([v], ANormal TypeReference 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 (Map Text (Pattern p) -> [Pattern p]
forall k a. Map k a -> [a]
Map.elems Map Text (Pattern p)
fields) [v]
vs
        Compose
  (ANFM v)
  ((,) (Direction ()))
  (ANormal TypeReference v -> ([v], ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> Compose
     (ANFM v) ((,) (Direction ())) ([v], ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
        Compose
  (ANFM v) ((,) (Direction ())) ([v], ANormal TypeReference v)
-> (([v], ANormal TypeReference v) -> BranchAccum v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([v]
us, ANormal TypeReference v
bd) -> RecordSchema -> ANormal TypeReference v -> BranchAccum v
forall v. RecordSchema -> ANormal TypeReference v -> BranchAccum v
AccumRec (Set Text -> RecordSchema
RecordSchema (Set Text -> RecordSchema) -> Set Text -> RecordSchema
forall a b. (a -> b) -> a -> b
$ Map Text (Pattern p) -> Set Text
forall k a. Map k a -> Set k
Map.keysSet Map Text (Pattern p)
fields) (ANormal TypeReference v -> BranchAccum v)
-> ANormal TypeReference v -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ [v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
us ANormal TypeReference v
bd
  | P.EffectPure p
_ Pattern p
q <- Pattern p
p =
      (,)
        ([v] -> ANormal TypeReference v -> ([v], ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (ANormal TypeReference v -> ([v], ANormal TypeReference 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 TypeReference v -> ([v], ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> Compose
     (ANFM v) ((,) (Direction ())) ([v], ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
        Compose
  (ANFM v) ((,) (Direction ())) ([v], ANormal TypeReference v)
-> (([v], ANormal TypeReference v) -> BranchAccum v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([v]
us, ANormal TypeReference v
bd) -> ANormal TypeReference v -> BranchAccum v
forall v. ANormal TypeReference v -> BranchAccum v
AccumPure (ANormal TypeReference v -> BranchAccum v)
-> ANormal TypeReference v -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ [v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
us ANormal TypeReference v
bd
  | P.EffectBind p
_ (ConstructorReference TypeReference
r ConstructorId
t) [Pattern p]
ps Pattern p
pk <- Pattern p
p = do
      (,,)
        ([v]
 -> v
 -> ANormal TypeReference v
 -> ([v], v, ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (v -> ANormal TypeReference v -> ([v], v, ANormal TypeReference 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 TypeReference v -> ([v], v, ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) v
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (ANormal TypeReference v -> ([v], v, ANormal TypeReference 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 TypeReference v -> ([v], v, ANormal TypeReference v))
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> Compose
     (ANFM v) ((,) (Direction ())) ([v], v, ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd
        Compose
  (ANFM v) ((,) (Direction ())) ([v], v, ANormal TypeReference v)
-> (([v], v, ANormal TypeReference v) -> BranchAccum v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([v]
exp, v
kf, ANormal TypeReference 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 ([Word] -> String -> ([v], v)
forall a. HasCallStack => [Word] -> 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 TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v))
 -> Maybe (ANormal TypeReference v) -> BranchAccum v)
-> Maybe (ANormal TypeReference v)
-> Map
     TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v))
-> BranchAccum v
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v))
-> Maybe (ANormal TypeReference v) -> BranchAccum v
forall v.
Map TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v))
-> Maybe (ANormal TypeReference v) -> BranchAccum v
AccumRequest Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing
                (Map TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v))
 -> BranchAccum v)
-> (ANormal TypeReference v
    -> Map
         TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v)))
-> ANormal TypeReference v
-> BranchAccum v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeReference
-> EnumMap CTag ([Mem], ANormal TypeReference v)
-> Map
     TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v))
forall k a. k -> a -> Map k a
Map.singleton TypeReference
r
                (EnumMap CTag ([Mem], ANormal TypeReference v)
 -> Map
      TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v)))
-> (ANormal TypeReference v
    -> EnumMap CTag ([Mem], ANormal TypeReference v))
-> ANormal TypeReference v
-> Map
     TypeReference (EnumMap CTag ([Mem], ANormal TypeReference v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag
-> ([Mem], ANormal TypeReference v)
-> EnumMap CTag ([Mem], ANormal TypeReference 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 TypeReference v)
 -> EnumMap CTag ([Mem], ANormal TypeReference v))
-> (ANormal TypeReference v -> ([Mem], ANormal TypeReference v))
-> ANormal TypeReference v
-> EnumMap CTag ([Mem], ANormal TypeReference 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 TypeReference v -> ([Mem], ANormal TypeReference v))
-> (ANormal TypeReference v -> ANormal TypeReference v)
-> ANormal TypeReference v
-> ([Mem], ANormal TypeReference v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss [v]
us
                (ANormal TypeReference v -> ANormal TypeReference v)
-> (ANormal TypeReference v -> ANormal TypeReference v)
-> ANormal TypeReference v
-> ANormal TypeReference v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeReference
-> v -> ANormal TypeReference v -> ANormal TypeReference v
forall v ref. Var v => ref -> v -> ANormal ref v -> ANormal ref v
TShift TypeReference
r v
kf
                (ANormal TypeReference v -> BranchAccum v)
-> ANormal TypeReference v -> BranchAccum v
forall a b. (a -> b) -> a -> b
$ v
-> Either TypeReference v
-> [v]
-> ANormal TypeReference v
-> ANormal TypeReference v
forall v ref.
Var v =>
v -> Either ref v -> [v] -> ANormal ref v -> ANormal ref v
TName v
uk (TypeReference -> Either TypeReference v
forall a b. a -> Either a b
Left TypeReference
forall {h}. Reference' Text h
jn) [v
kf] ANormal TypeReference v
bd
  | P.SequenceLiteral p
_ [] <- Pattern p
p =
      ANormal TypeReference v -> BranchAccum v
forall v. ANormal TypeReference v -> BranchAccum v
AccumSeqEmpty (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference 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 TypeReference v)
-> ANormal TypeReference v
-> BranchAccum v
forall v.
SeqEnd
-> Int
-> Maybe (ANormal TypeReference v)
-> ANormal TypeReference 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 TypeReference v)
forall a. Maybe a
Nothing
        (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss ([v] -> ANormal TypeReference v -> ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (ANormal TypeReference v -> ANormal TypeReference 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 TypeReference v -> ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference 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 TypeReference v)
-> ANormal TypeReference v
-> BranchAccum v
forall v.
SeqEnd
-> Int
-> Maybe (ANormal TypeReference v)
-> ANormal TypeReference 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 TypeReference v)
forall a. Maybe a
Nothing
        (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss ([v] -> ANormal TypeReference v -> ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (ANormal TypeReference v -> ANormal TypeReference 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 TypeReference v -> ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference 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 TypeReference v)
-> ANormal TypeReference v
-> BranchAccum v
forall v.
SeqEnd
-> Maybe (ANormal TypeReference v)
-> ANormal TypeReference v
-> BranchAccum v
AccumSeqView SeqEnd
dir Maybe (ANormal TypeReference v)
forall a. Maybe a
Nothing
        (ANormal TypeReference v -> BranchAccum v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> ANFD v (BranchAccum v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([v] -> ANormal TypeReference v -> ANormal TypeReference v
forall v (f :: * -> * -> *). Var v => [v] -> Term f v -> Term f v
ABTN.TAbss ([v] -> ANormal TypeReference v -> ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) [v]
-> Compose
     (ANFM v)
     ((,) (Direction ()))
     (ANormal TypeReference v -> ANormal TypeReference 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 TypeReference v -> ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference v)
anfBody Term v a
bd)
  where
    anfBody :: Term v a
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
anfBody Term v a
tm = ReaderT
  (Set v)
  (StateT
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
     Identity)
  (Direction (), ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference 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 TypeReference v)])
      Identity)
   (Direction (), ANormal TypeReference v)
 -> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v))
-> (ReaderT
      (Set v)
      (StateT
         (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
         Identity)
      (Direction (), ANormal TypeReference v)
    -> ReaderT
         (Set v)
         (StateT
            (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
            Identity)
         (Direction (), ANormal TypeReference v))
-> ReaderT
     (Set v)
     (StateT
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
        Identity)
     (Direction (), ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v]
-> ReaderT
     (Set v)
     (StateT
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
        Identity)
     (Direction (), ANormal TypeReference v)
-> ReaderT
     (Set v)
     (StateT
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
        Identity)
     (Direction (), ANormal TypeReference v)
forall v r. Ord v => [v] -> ANFM v r -> ANFM v r
bindLocal [v]
vs (ReaderT
   (Set v)
   (StateT
      (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
      Identity)
   (Direction (), ANormal TypeReference v)
 -> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v))
-> ReaderT
     (Set v)
     (StateT
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
        Identity)
     (Direction (), ANormal TypeReference v)
-> Compose (ANFM v) ((,) (Direction ())) (ANormal TypeReference v)
forall a b. (a -> b) -> a -> b
$ Term v a
-> ReaderT
     (Set v)
     (StateT
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
        Identity)
     (Direction (), ANormal TypeReference 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
_) =
  [Word] -> String -> ANFD v (BranchAccum v)
forall a. HasCallStack => [Word] -> 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

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 TypeReference 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 TypeReference v)])))
      ((,) (Direction ()))
      [v])
-> (((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
     -> (Directed () [v],
         (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
    -> ANFM v (Directed () [v]))
-> ((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
    -> (Directed () [v],
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> Compose
     (ReaderT
        (Set v)
        (State
           (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
     ((,) (Direction ()))
     [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
 -> (Directed () [v],
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> ANFM v (Directed () [v])
forall a.
((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
 -> (a,
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
  -> (Directed () [v],
      (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
 -> Compose
      (ReaderT
         (Set v)
         (State
            (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
      ((,) (Direction ()))
      [v])
-> ((ConstructorId, Word16, [(v, SuperNormal TypeReference v)])
    -> (Directed () [v],
        (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> Compose
     (ReaderT
        (Set v)
        (State
           (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
     ((,) (Direction ()))
     [v]
forall a b. (a -> b) -> a -> b
$ \(ConstructorId
fr, Word16
bnd, [(v, SuperNormal TypeReference 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 -> [Word]
-> String
-> (Directed () [v],
    (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
forall a. HasCallStack => [Word] -> String -> a
internalBug [] (String
 -> (Directed () [v],
     (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
-> String
-> (Directed () [v],
    (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference 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 TypeReference v)])))
  ((,) (Direction ()))
  (BranchAccum v)
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)])))
   ((,) (Direction ()))
   (BranchAccum v)
 -> ReaderT
      (Set v)
      (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
      (Direction (), BranchAccum v))
-> ([MatchCase p (Term v a)]
    -> Compose
         (ReaderT
            (Set v)
            (State
               (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
         ((,) (Direction ()))
         (BranchAccum v))
-> [MatchCase p (Term v a)]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)])))
     ((,) (Direction ()))
     [BranchAccum v]
-> Compose
     (ReaderT
        (Set v)
        (State
           (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
     ((,) (Direction ()))
     (BranchAccum v)
forall a b.
(a -> b)
-> Compose
     (ReaderT
        (Set v)
        (State
           (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
     ((,) (Direction ()))
     a
-> Compose
     (ReaderT
        (Set v)
        (State
           (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)])))
   ((,) (Direction ()))
   [BranchAccum v]
 -> Compose
      (ReaderT
         (Set v)
         (State
            (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
      ((,) (Direction ()))
      (BranchAccum v))
-> ([MatchCase p (Term v a)]
    -> Compose
         (ReaderT
            (Set v)
            (State
               (ConstructorId, Word16, [(v, SuperNormal TypeReference v)])))
         ((,) (Direction ()))
         [BranchAccum v])
-> [MatchCase p (Term v a)]
-> Compose
     (ReaderT
        (Set v)
        (State
           (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)])))
      ((,) (Direction ()))
      (BranchAccum v))
-> [MatchCase p (Term v a)]
-> Compose
     (ReaderT
        (Set v)
        (State
           (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference 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 Reference v))
anfFunc :: forall v a.
Var v =>
Term v a -> ANFM v (Ctx v, Directed () (Func TypeReference v))
anfFunc (Var' v
v) = (Ctx v, Directed () (Func TypeReference v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, Directed () (Func TypeReference v))
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v
forall ref v. v -> Func ref v
FVar v
v))
anfFunc (Ref' TypeReference
r) = (Ctx v, Directed () (Func TypeReference v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, Directed () (Func TypeReference v))
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 (), TypeReference -> Func TypeReference v
forall ref v. ref -> Func ref v
FComb TypeReference
r))
anfFunc (Constructor' (ConstructorReference TypeReference
r ConstructorId
t)) = (Ctx v, Directed () (Func TypeReference v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, Directed () (Func TypeReference v))
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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, TypeReference -> CTag -> Func TypeReference v
forall ref v. ref -> CTag -> Func ref v
FCon TypeReference
r (CTag -> Func TypeReference v) -> CTag -> Func TypeReference 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 TypeReference
r ConstructorId
t)) = (Ctx v, Directed () (Func TypeReference v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, Directed () (Func TypeReference v))
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 (), TypeReference -> CTag -> Func TypeReference v
forall ref v. ref -> CTag -> Func ref v
FReq TypeReference
r (CTag -> Func TypeReference v) -> CTag -> Func TypeReference 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
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, v)
forall v. Var v => DNormal v -> ANFM v (Ctx v, v)
contextualize DNormal v
ctm
  (Ctx v, Directed () (Func TypeReference v))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     (Ctx v, Directed () (Func TypeReference v))
forall a.
a
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v
forall ref v. v -> Func ref 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
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference 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 (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip ([(Ctx v, v)] -> (Ctx v, [v]))
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference v)]))
     [(Ctx v, v)]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
      (Ctx v, v))
-> [Term v a]
-> ReaderT
     (Set v)
     (State (ConstructorId, Word16, [(v, SuperNormal TypeReference 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 TypeReference v)]))
     (Ctx v, v)
forall v a. Var v => Term v a -> ANFM v (Ctx v, v)
anfArg [Term v a]
tms