module Unison.PatternMatchCoverage.Desugar
  ( desugarMatch,
  )
where

import U.Core.ABT qualified as ABT
import Unison.Pattern
import Unison.Pattern qualified as Pattern
import Unison.PatternMatchCoverage.Class
import Unison.PatternMatchCoverage.GrdTree
import Unison.PatternMatchCoverage.PmGrd
import Unison.PatternMatchCoverage.PmLit qualified as PmLit
import Unison.Term (MatchCase (..), Term', app, var)
import Unison.Type (Type)
import Unison.Type qualified as Type
import Unison.Util.Recursion

-- | Desugar a match into a 'GrdTree'
desugarMatch ::
  forall loc vt v m.
  (Pmc vt v loc m) =>
  -- | scrutinee type
  Type vt loc ->
  -- | scrutinee variable
  v ->
  -- | match cases
  [MatchCase loc (Term' vt v loc)] ->
  m (GrdTree (PmGrd vt v loc) loc)
desugarMatch :: forall loc vt v (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> [MatchCase loc (Term' vt v loc)]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarMatch Type vt loc
scrutineeType v
v0 [MatchCase loc (Term' vt v loc)]
cs0 = [GrdTree (PmGrd vt v loc) loc] -> GrdTree (PmGrd vt v loc) loc
forall n l. [GrdTree n l] -> GrdTree n l
Fork ([GrdTree (PmGrd vt v loc) loc] -> GrdTree (PmGrd vt v loc) loc)
-> m [GrdTree (PmGrd vt v loc) loc]
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MatchCase loc (Term' vt v loc)
 -> m (GrdTree (PmGrd vt v loc) loc))
-> [MatchCase loc (Term' vt v loc)]
-> m [GrdTree (PmGrd vt v loc) loc]
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 MatchCase loc (Term' vt v loc) -> m (GrdTree (PmGrd vt v loc) loc)
desugarClause [MatchCase loc (Term' vt v loc)]
cs0
  where
    desugarClause :: MatchCase loc (Term' vt v loc) -> m (GrdTree (PmGrd vt v loc) loc)
    desugarClause :: MatchCase loc (Term' vt v loc) -> m (GrdTree (PmGrd vt v loc) loc)
desugarClause MatchCase {Pattern loc
matchPattern :: Pattern loc
$sel:matchPattern:MatchCase :: forall loc a. MatchCase loc a -> Pattern loc
matchPattern, Maybe (Term' vt v loc)
matchGuard :: Maybe (Term' vt v loc)
$sel:matchGuard:MatchCase :: forall loc a. MatchCase loc a -> Maybe a
matchGuard} =
      Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarPattern Type vt loc
scrutineeType v
v0 Pattern loc
matchPattern (loc
-> Maybe (Term' vt v loc)
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
finalK (Pattern loc -> loc
forall loc. Pattern loc -> loc
Pattern.loc Pattern loc
matchPattern) Maybe (Term' vt v loc)
matchGuard) []

    finalK :: loc -> Maybe (Term' vt v loc) -> [v] -> m (GrdTree (PmGrd vt v loc) loc)
    finalK :: loc
-> Maybe (Term' vt v loc)
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
finalK loc
loc Maybe (Term' vt v loc)
mterm [v]
vs = case Maybe (Term' vt v loc)
mterm of
      Maybe (Term' vt v loc)
Nothing -> GrdTree (PmGrd vt v loc) loc -> m (GrdTree (PmGrd vt v loc) loc)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (loc -> GrdTree (PmGrd vt v loc) loc
forall l n. l -> GrdTree n l
Leaf loc
loc)
      Just Term' vt v loc
grdExpr -> do
        let ann :: loc
ann = Term' vt v loc -> loc
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term' vt v loc
grdExpr
            expr :: Term' vt v loc
expr = (v -> Term' vt v loc -> Term' vt v loc)
-> Term' vt v loc -> [v] -> Term' vt v loc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\v
a Term' vt v loc
b -> loc -> Term' vt v loc -> Term' vt v loc -> Term' vt v loc
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
app loc
ann (loc -> v -> Term' vt v loc
forall a v vt at ap. a -> v -> Term2 vt at ap v a
var loc
ann v
a) Term' vt v loc
b) Term' vt v loc
grdExpr [v]
vs
            typ :: Type vt loc
typ = loc -> Type vt loc
forall v a. Ord v => a -> Type v a
Type.boolean loc
ann
        v
v <- m v
forall vt v loc (m :: * -> *). Pmc vt v loc m => m v
fresh
        pure (PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> Term' vt v loc -> Type vt loc -> PmGrd vt v loc
forall vt v loc.
v -> Term' vt v loc -> Type vt loc -> PmGrd vt v loc
PmLet v
v Term' vt v loc
expr Type vt loc
typ) (PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> PmLit -> PmGrd vt v loc
forall vt v loc. v -> PmLit -> PmGrd vt v loc
PmLit v
v (Bool -> PmLit
PmLit.Boolean Bool
True)) (loc -> GrdTree (PmGrd vt v loc) loc
forall l n. l -> GrdTree n l
Leaf loc
loc)))

desugarPattern ::
  forall v vt loc m.
  (Pmc vt v loc m) =>
  Type vt loc ->
  v ->
  Pattern loc ->
  ([v] -> m (GrdTree (PmGrd vt v loc) loc)) ->
  [v] ->
  m (GrdTree (PmGrd vt v loc) loc)
desugarPattern :: forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarPattern Type vt loc
typ v
v0 Pattern loc
pat [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs = case Pattern loc
pat of
  Unbound loc
_ -> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  Var loc
_ -> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k (v
v0 v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
vs)
  Boolean loc
_ Bool
x -> PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> PmLit -> PmGrd vt v loc
forall vt v loc. v -> PmLit -> PmGrd vt v loc
PmLit v
v0 (PmLit -> PmGrd vt v loc) -> PmLit -> PmGrd vt v loc
forall a b. (a -> b) -> a -> b
$ Bool -> PmLit
PmLit.Boolean Bool
x) (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  Int loc
_ Int64
x -> PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> PmLit -> PmGrd vt v loc
forall vt v loc. v -> PmLit -> PmGrd vt v loc
PmLit v
v0 (PmLit -> PmGrd vt v loc) -> PmLit -> PmGrd vt v loc
forall a b. (a -> b) -> a -> b
$ Int64 -> PmLit
PmLit.Int Int64
x) (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  Nat loc
_ Word64
x -> PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> PmLit -> PmGrd vt v loc
forall vt v loc. v -> PmLit -> PmGrd vt v loc
PmLit v
v0 (PmLit -> PmGrd vt v loc) -> PmLit -> PmGrd vt v loc
forall a b. (a -> b) -> a -> b
$ Word64 -> PmLit
PmLit.Nat Word64
x) (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  Float loc
_ Double
x -> PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> PmLit -> PmGrd vt v loc
forall vt v loc. v -> PmLit -> PmGrd vt v loc
PmLit v
v0 (PmLit -> PmGrd vt v loc) -> PmLit -> PmGrd vt v loc
forall a b. (a -> b) -> a -> b
$ Double -> PmLit
PmLit.Float Double
x) (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  Text loc
_ Text
x -> PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> PmLit -> PmGrd vt v loc
forall vt v loc. v -> PmLit -> PmGrd vt v loc
PmLit v
v0 (PmLit -> PmGrd vt v loc) -> PmLit -> PmGrd vt v loc
forall a b. (a -> b) -> a -> b
$ Text -> PmLit
PmLit.Text Text
x) (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  Char loc
_ Char
x -> PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> PmLit -> PmGrd vt v loc
forall vt v loc. v -> PmLit -> PmGrd vt v loc
PmLit v
v0 (PmLit -> PmGrd vt v loc) -> PmLit -> PmGrd vt v loc
forall a b. (a -> b) -> a -> b
$ Char -> PmLit
PmLit.Char Char
x) (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  Constructor loc
_loc ConstructorReference
consRef [Pattern loc]
pats -> do
    [Type vt loc]
contyps <- Type vt loc -> ConstructorReference -> m [Type vt loc]
forall vt v loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc -> ConstructorReference -> m [Type vt loc]
getConstructorVarTypes Type vt loc
typ ConstructorReference
consRef
    [(v, Pattern loc)]
patvars <- [Pattern loc] -> m [(v, Pattern loc)]
forall vt v loc (m :: * -> *).
Pmc vt v loc m =>
[Pattern loc] -> m [(v, Pattern loc)]
assignFreshPatternVars [Pattern loc]
pats
    let c :: PmGrd vt v loc
c = v -> ConstructorReference -> [(v, Type vt loc)] -> PmGrd vt v loc
forall vt v loc.
v -> ConstructorReference -> [(v, Type vt loc)] -> PmGrd vt v loc
PmCon v
v0 ConstructorReference
consRef [(v, Type vt loc)]
convars
        convars :: [(v, Type vt loc)]
        convars :: [(v, Type vt loc)]
convars = ((v, Pattern loc, Type vt loc) -> (v, Type vt loc))
-> [(v, Pattern loc, Type vt loc)] -> [(v, Type vt loc)]
forall a b. (a -> b) -> [a] -> [b]
map (\(v
v, Pattern loc
_, Type vt loc
t) -> (v
v, Type vt loc
t)) [(v, Pattern loc, Type vt loc)]
tpatvars
        tpatvars :: [(v, Pattern loc, Type vt loc)]
tpatvars = ((v, Pattern loc) -> Type vt loc -> (v, Pattern loc, Type vt loc))
-> [(v, Pattern loc)]
-> [Type vt loc]
-> [(v, Pattern loc, Type vt loc)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(v
v, Pattern loc
p) Type vt loc
t -> (v
v, Pattern loc
p, Type vt loc
t)) [(v, Pattern loc)]
patvars [Type vt loc]
contyps
    GrdTree (PmGrd vt v loc) loc
rest <- ((v, Pattern loc, Type vt loc)
 -> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
 -> [v]
 -> m (GrdTree (PmGrd vt v loc) loc))
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [(v, Pattern loc, Type vt loc)]
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(v
v, Pattern loc
pat, Type vt loc
t) [v] -> m (GrdTree (PmGrd vt v loc) loc)
b -> Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarPattern Type vt loc
t v
v Pattern loc
pat [v] -> m (GrdTree (PmGrd vt v loc) loc)
b) [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [(v, Pattern loc, Type vt loc)]
tpatvars [v]
vs
    pure (PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd PmGrd vt v loc
c GrdTree (PmGrd vt v loc) loc
rest)
  As loc
_ Pattern loc
rest -> Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarPattern Type vt loc
typ v
v0 Pattern loc
rest [v] -> m (GrdTree (PmGrd vt v loc) loc)
k (v
v0 v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
vs)
  EffectPure loc
_ Pattern loc
resume -> do
    v
v <- m v
forall vt v loc (m :: * -> *). Pmc vt v loc m => m v
fresh
    let rt :: Type vt loc
rt = case Type vt loc
typ of
          Type.Apps' (Type.Ref' TypeReference
r) [Type vt loc
_et, Type vt loc
ret] | TypeReference
r TypeReference -> TypeReference -> Bool
forall a. Eq a => a -> a -> Bool
== TypeReference
Type.effectRef -> Type vt loc
ret
          Type vt loc
_ -> [Char] -> Type vt loc
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: pattern EffectPure doesn't correspond to a scrutinee of type Request?"
    PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> (v, Type vt loc) -> PmGrd vt v loc
forall vt v loc. v -> (v, Type vt loc) -> PmGrd vt v loc
PmEffectPure v
v0 (v
v, Type vt loc
rt)) (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarPattern Type vt loc
rt v
v Pattern loc
resume [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  EffectBind loc
_loc ConstructorReference
consRef [Pattern loc]
pats Pattern loc
_resume -> do
    [Type vt loc]
contyps <- Type vt loc -> ConstructorReference -> m [Type vt loc]
forall vt v loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc -> ConstructorReference -> m [Type vt loc]
getConstructorVarTypes Type vt loc
typ ConstructorReference
consRef
    [(v, Pattern loc)]
patvars <- [Pattern loc] -> m [(v, Pattern loc)]
forall vt v loc (m :: * -> *).
Pmc vt v loc m =>
[Pattern loc] -> m [(v, Pattern loc)]
assignFreshPatternVars [Pattern loc]
pats
    let c :: PmGrd vt v loc
c = v -> ConstructorReference -> [(v, Type vt loc)] -> PmGrd vt v loc
forall vt v loc.
v -> ConstructorReference -> [(v, Type vt loc)] -> PmGrd vt v loc
PmEffect v
v0 ConstructorReference
consRef [(v, Type vt loc)]
convars
        convars :: [(v, Type vt loc)]
        convars :: [(v, Type vt loc)]
convars = ((v, Pattern loc, Type vt loc) -> (v, Type vt loc))
-> [(v, Pattern loc, Type vt loc)] -> [(v, Type vt loc)]
forall a b. (a -> b) -> [a] -> [b]
map (\(v
v, Pattern loc
_, Type vt loc
t) -> (v
v, Type vt loc
t)) [(v, Pattern loc, Type vt loc)]
tpatvars
        tpatvars :: [(v, Pattern loc, Type vt loc)]
tpatvars = ((v, Pattern loc) -> Type vt loc -> (v, Pattern loc, Type vt loc))
-> [(v, Pattern loc)]
-> [Type vt loc]
-> [(v, Pattern loc, Type vt loc)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(v
v, Pattern loc
p) Type vt loc
t -> (v
v, Pattern loc
p, Type vt loc
t)) [(v, Pattern loc)]
patvars [Type vt loc]
contyps
    GrdTree (PmGrd vt v loc) loc
rest <- ((v, Pattern loc, Type vt loc)
 -> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
 -> [v]
 -> m (GrdTree (PmGrd vt v loc) loc))
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [(v, Pattern loc, Type vt loc)]
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(v
v, Pattern loc
pat, Type vt loc
t) [v] -> m (GrdTree (PmGrd vt v loc) loc)
b -> Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarPattern Type vt loc
t v
v Pattern loc
pat [v] -> m (GrdTree (PmGrd vt v loc) loc)
b) [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [(v, Pattern loc, Type vt loc)]
tpatvars [v]
vs
    pure (PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd PmGrd vt v loc
c GrdTree (PmGrd vt v loc) loc
rest)
  SequenceLiteral {} -> Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
handleSequence Type vt loc
typ v
v0 Pattern loc
pat [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
  SequenceOp {} -> Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
handleSequence Type vt loc
typ v
v0 Pattern loc
pat [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs

handleSequence ::
  forall v vt loc m.
  (Pmc vt v loc m) =>
  Type vt loc ->
  v ->
  Pattern loc ->
  ([v] -> m (GrdTree (PmGrd vt v loc) loc)) ->
  [v] ->
  m (GrdTree (PmGrd vt v loc) loc)
handleSequence :: forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
handleSequence Type vt loc
typ v
v Pattern loc
pat [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs = do
  let listArg :: Type vt loc
listArg = case Type vt loc
typ of
        Type.App' Type vt loc
_list Type vt loc
arg -> Type vt loc
arg
        Type vt loc
_ -> [Char] -> Type vt loc
forall a. HasCallStack => [Char] -> a
error [Char]
"list type is not an application?"
  Type vt loc
-> Type vt loc
-> v
-> NormalizedList loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> Type vt loc
-> v
-> NormalizedList loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
listToGrdTree Type vt loc
typ Type vt loc
listArg v
v (Pattern loc -> NormalizedList loc
forall loc. Pattern loc -> NormalizedList loc
normalizeList Pattern loc
pat) [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs

listToGrdTree ::
  forall v vt loc m.
  (Pmc vt v loc m) =>
  Type vt loc ->
  Type vt loc ->
  v ->
  NormalizedList loc ->
  ([v] -> m (GrdTree (PmGrd vt v loc) loc)) ->
  [v] ->
  m (GrdTree (PmGrd vt v loc) loc)
listToGrdTree :: forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> Type vt loc
-> v
-> NormalizedList loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
listToGrdTree Type vt loc
_listTyp Type vt loc
elemTyp v
listVar NormalizedList loc
nl0 [v] -> m (GrdTree (PmGrd vt v loc) loc)
k0 [v]
vs0 =
  let (Int
minLen, Int
maxLen) = Algebra (NormalizedListF loc) (Int -> (Int, Int))
-> NormalizedList loc -> Int -> (Int, Int)
forall a.
Algebra (NormalizedListF loc) a -> NormalizedList loc -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
cata Algebra (NormalizedListF loc) (Int -> (Int, Int))
countMinListLen NormalizedList loc
nl0 Int
0
   in PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd (v -> Int -> Int -> PmGrd vt v loc
forall vt v loc. v -> Int -> Int -> PmGrd vt v loc
PmListInterval v
listVar Int
minLen Int
maxLen) (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Algebra
  (NormalizedListF loc)
  (Int
   -> Int
   -> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
   -> [v]
   -> m (GrdTree (PmGrd vt v loc) loc))
-> NormalizedList loc
-> Int
-> Int
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall a.
Algebra (NormalizedListF loc) a -> NormalizedList loc -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
cata Algebra
  (NormalizedListF loc)
  (Int
   -> Int
   -> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
   -> [v]
   -> m (GrdTree (PmGrd vt v loc) loc))
go NormalizedList loc
nl0 Int
0 Int
0 [v] -> m (GrdTree (PmGrd vt v loc) loc)
k0 [v]
vs0
  where
    go :: Algebra
  (NormalizedListF loc)
  (Int
   -> Int
   -> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
   -> [v]
   -> m (GrdTree (PmGrd vt v loc) loc))
go NormalizedListF
  loc
  (Int
   -> Int
   -> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
   -> [v]
   -> m (GrdTree (PmGrd vt v loc) loc))
pat Int
consCount Int
snocCount [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs = case NormalizedListF
  loc
  (Int
   -> Int
   -> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
   -> [v]
   -> m (GrdTree (PmGrd vt v loc) loc))
pat of
      N'ConsF Pattern loc
x Int
-> Int
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
xs -> do
        v
element <- m v
forall vt v loc (m :: * -> *). Pmc vt v loc m => m v
fresh
        let grd :: PmGrd vt v loc
grd = v -> Int -> v -> Type vt loc -> PmGrd vt v loc
forall vt v loc. v -> Int -> v -> Type vt loc -> PmGrd vt v loc
PmListHead v
listVar Int
consCount v
element Type vt loc
elemTyp
        let !consCount' :: Int
consCount' = Int
consCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd PmGrd vt v loc
grd (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarPattern Type vt loc
elemTyp v
element Pattern loc
x (Int
-> Int
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
xs Int
consCount' Int
snocCount [v] -> m (GrdTree (PmGrd vt v loc) loc)
k) [v]
vs
      N'SnocF Int
-> Int
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
xs Pattern loc
x -> do
        v
element <- m v
forall vt v loc (m :: * -> *). Pmc vt v loc m => m v
fresh
        let grd :: PmGrd vt v loc
grd = v -> Int -> v -> Type vt loc -> PmGrd vt v loc
forall vt v loc. v -> Int -> v -> Type vt loc -> PmGrd vt v loc
PmListTail v
listVar Int
snocCount v
element Type vt loc
elemTyp
        let !snocCount' :: Int
snocCount' = Int
snocCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        PmGrd vt v loc
-> GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc
forall n l. n -> GrdTree n l -> GrdTree n l
Grd PmGrd vt v loc
grd (GrdTree (PmGrd vt v loc) loc -> GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
-> m (GrdTree (PmGrd vt v loc) loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Int
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
xs Int
consCount Int
snocCount' (Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
forall v vt loc (m :: * -> *).
Pmc vt v loc m =>
Type vt loc
-> v
-> Pattern loc
-> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
-> [v]
-> m (GrdTree (PmGrd vt v loc) loc)
desugarPattern Type vt loc
elemTyp v
element Pattern loc
x [v] -> m (GrdTree (PmGrd vt v loc) loc)
k) [v]
vs
      NormalizedListF
  loc
  (Int
   -> Int
   -> ([v] -> m (GrdTree (PmGrd vt v loc) loc))
   -> [v]
   -> m (GrdTree (PmGrd vt v loc) loc))
N'NilF -> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs
      N'VarF loc
_ -> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k (v
listVar v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
vs)
      N'UnboundF loc
_ -> [v] -> m (GrdTree (PmGrd vt v loc) loc)
k [v]
vs

    countMinListLen :: Algebra (NormalizedListF loc) (Int -> (Int, Int))
    countMinListLen :: Algebra (NormalizedListF loc) (Int -> (Int, Int))
countMinListLen = \case
      N'ConsF Pattern loc
_ Int -> (Int, Int)
b -> \Int
acc -> Int -> (Int, Int)
b (Int -> (Int, Int)) -> Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$! Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      N'SnocF Int -> (Int, Int)
b Pattern loc
_ -> \Int
acc -> Int -> (Int, Int)
b (Int -> (Int, Int)) -> Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$! Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      NormalizedListF loc (Int -> (Int, Int))
N'NilF -> \ !Int
n -> (Int
n, Int
n)
      N'VarF loc
_ -> \ !Int
n -> (Int
n, Int
forall a. Bounded a => a
maxBound)
      N'UnboundF loc
_ -> \ !Int
n -> (Int
n, Int
forall a. Bounded a => a
maxBound)

data NormalizedListF loc a
  = N'ConsF (Pattern loc) a
  | N'SnocF a (Pattern loc)
  | N'NilF
  | N'VarF loc
  | N'UnboundF loc
  deriving stock ((forall a b.
 (a -> b) -> NormalizedListF loc a -> NormalizedListF loc b)
-> (forall a b.
    a -> NormalizedListF loc b -> NormalizedListF loc a)
-> Functor (NormalizedListF loc)
forall a b. a -> NormalizedListF loc b -> NormalizedListF loc a
forall a b.
(a -> b) -> NormalizedListF loc a -> NormalizedListF loc b
forall loc a b. a -> NormalizedListF loc b -> NormalizedListF loc a
forall loc a b.
(a -> b) -> NormalizedListF loc a -> NormalizedListF loc b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall loc a b.
(a -> b) -> NormalizedListF loc a -> NormalizedListF loc b
fmap :: forall a b.
(a -> b) -> NormalizedListF loc a -> NormalizedListF loc b
$c<$ :: forall loc a b. a -> NormalizedListF loc b -> NormalizedListF loc a
<$ :: forall a b. a -> NormalizedListF loc b -> NormalizedListF loc a
Functor)

type NormalizedList loc = Fix (NormalizedListF loc)

pattern N'Cons :: Pattern loc -> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
pattern $mN'Cons :: forall {r} {loc}.
Fix (NormalizedListF loc)
-> (Pattern loc -> Fix (NormalizedListF loc) -> r)
-> ((# #) -> r)
-> r
$bN'Cons :: forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
N'Cons x xs = Fix (N'ConsF x xs)

pattern N'Snoc :: Fix (NormalizedListF loc) -> Pattern loc -> Fix (NormalizedListF loc)
pattern $mN'Snoc :: forall {r} {loc}.
Fix (NormalizedListF loc)
-> (Fix (NormalizedListF loc) -> Pattern loc -> r)
-> ((# #) -> r)
-> r
$bN'Snoc :: forall loc.
Fix (NormalizedListF loc)
-> Pattern loc -> Fix (NormalizedListF loc)
N'Snoc xs x = Fix (N'SnocF xs x)

pattern N'Nil :: Fix (NormalizedListF loc)
pattern $mN'Nil :: forall {r} {loc}.
Fix (NormalizedListF loc) -> ((# #) -> r) -> ((# #) -> r) -> r
$bN'Nil :: forall loc. Fix (NormalizedListF loc)
N'Nil = Fix N'NilF

pattern N'Var :: loc -> Fix (NormalizedListF loc)
pattern $mN'Var :: forall {r} {loc}.
Fix (NormalizedListF loc) -> (loc -> r) -> ((# #) -> r) -> r
$bN'Var :: forall loc. loc -> Fix (NormalizedListF loc)
N'Var x = Fix (N'VarF x)

pattern N'Unbound :: loc -> Fix (NormalizedListF loc)
pattern $mN'Unbound :: forall {r} {loc}.
Fix (NormalizedListF loc) -> (loc -> r) -> ((# #) -> r) -> r
$bN'Unbound :: forall loc. loc -> Fix (NormalizedListF loc)
N'Unbound x = Fix (N'UnboundF x)

-- | strip out sequence literals and concats
normalizeList :: Pattern loc -> NormalizedList loc
normalizeList :: forall loc. Pattern loc -> NormalizedList loc
normalizeList Pattern loc
pat0 = case Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall loc.
Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
goCons Pattern loc
pat0 of
  Left NormalizedList loc -> NormalizedList loc
f -> NormalizedList loc -> NormalizedList loc
f NormalizedList loc
forall loc. Fix (NormalizedListF loc)
N'Nil
  Right NormalizedList loc
x -> NormalizedList loc
x
  where
    goCons :: Pattern loc -> Either (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
    goCons :: forall loc.
Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
goCons = \case
      SequenceLiteral loc
_loc [Pattern loc]
xs ->
        (NormalizedList loc -> NormalizedList loc)
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. a -> Either a b
Left \NormalizedList loc
nil -> (Pattern loc -> NormalizedList loc -> NormalizedList loc)
-> NormalizedList loc -> [Pattern loc] -> NormalizedList loc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
N'Cons NormalizedList loc
nil [Pattern loc]
xs
      SequenceOp loc
_loc Pattern loc
lhs SeqOp
op Pattern loc
rhs -> case SeqOp
op of
        SeqOp
Cons ->
          case Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall loc.
Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
goCons Pattern loc
rhs of
            Left NormalizedList loc -> NormalizedList loc
f -> (NormalizedList loc -> NormalizedList loc)
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. a -> Either a b
Left (Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
N'Cons Pattern loc
lhs (NormalizedList loc -> NormalizedList loc)
-> (NormalizedList loc -> NormalizedList loc)
-> NormalizedList loc
-> NormalizedList loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedList loc -> NormalizedList loc
f)
            Right NormalizedList loc
x -> NormalizedList loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. b -> Either a b
Right (Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
N'Cons Pattern loc
lhs NormalizedList loc
x)
        SeqOp
Snoc ->
          case Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall loc.
Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
goCons Pattern loc
lhs of
            Left NormalizedList loc -> NormalizedList loc
f -> (NormalizedList loc -> NormalizedList loc)
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. a -> Either a b
Left (NormalizedList loc -> NormalizedList loc
f (NormalizedList loc -> NormalizedList loc)
-> (NormalizedList loc -> NormalizedList loc)
-> NormalizedList loc
-> NormalizedList loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
N'Cons Pattern loc
rhs)
            Right NormalizedList loc
x -> NormalizedList loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. b -> Either a b
Right (NormalizedList loc -> Pattern loc -> NormalizedList loc
forall loc.
Fix (NormalizedListF loc)
-> Pattern loc -> Fix (NormalizedListF loc)
N'Snoc NormalizedList loc
x Pattern loc
rhs)
        SeqOp
Concat ->
          case Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall loc.
Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
goCons Pattern loc
lhs of
            Left NormalizedList loc -> NormalizedList loc
f -> case Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall loc.
Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
goCons Pattern loc
rhs of
              Left NormalizedList loc -> NormalizedList loc
g -> (NormalizedList loc -> NormalizedList loc)
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. a -> Either a b
Left (NormalizedList loc -> NormalizedList loc
f (NormalizedList loc -> NormalizedList loc)
-> (NormalizedList loc -> NormalizedList loc)
-> NormalizedList loc
-> NormalizedList loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedList loc -> NormalizedList loc
g)
              Right NormalizedList loc
x -> NormalizedList loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. b -> Either a b
Right (NormalizedList loc -> NormalizedList loc
f NormalizedList loc
x)
            Right NormalizedList loc
x -> NormalizedList loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. b -> Either a b
Right (Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
goSnoc Pattern loc
rhs NormalizedList loc
x)
      Var loc
loc -> NormalizedList loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. b -> Either a b
Right (loc -> NormalizedList loc
forall loc. loc -> Fix (NormalizedListF loc)
N'Var loc
loc)
      Unbound loc
loc -> NormalizedList loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a b. b -> Either a b
Right (loc -> NormalizedList loc
forall loc. loc -> Fix (NormalizedListF loc)
N'Unbound loc
loc)
      -- as-patterns are not handled properly here, which is fine while we
      -- only have boolean guards, but this needs to be fixed if we
      -- introduce pattern guards
      As loc
_loc Pattern loc
pat -> Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall loc.
Pattern loc
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
goCons Pattern loc
pat
      Pattern loc
_ -> [Char]
-> Either
     (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
forall a. HasCallStack => [Char] -> a
error [Char]
"goCons: unexpected pattern"

    goSnoc :: Pattern loc -> NormalizedList loc -> NormalizedList loc
    goSnoc :: forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
goSnoc Pattern loc
pat NormalizedList loc
nlp = case Pattern loc
pat of
      SequenceLiteral loc
_loc [Pattern loc]
xs ->
        (NormalizedList loc -> Pattern loc -> NormalizedList loc)
-> NormalizedList loc -> [Pattern loc] -> NormalizedList loc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl NormalizedList loc -> Pattern loc -> NormalizedList loc
forall loc.
Fix (NormalizedListF loc)
-> Pattern loc -> Fix (NormalizedListF loc)
N'Snoc NormalizedList loc
nlp [Pattern loc]
xs
      SequenceOp loc
_loc Pattern loc
lhs SeqOp
op Pattern loc
rhs -> case SeqOp
op of
        SeqOp
Cons ->
          Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
goSnoc Pattern loc
rhs (NormalizedList loc -> Pattern loc -> NormalizedList loc
forall loc.
Fix (NormalizedListF loc)
-> Pattern loc -> Fix (NormalizedListF loc)
N'Snoc NormalizedList loc
nlp Pattern loc
lhs)
        SeqOp
Snoc ->
          NormalizedList loc -> Pattern loc -> NormalizedList loc
forall loc.
Fix (NormalizedListF loc)
-> Pattern loc -> Fix (NormalizedListF loc)
N'Snoc (Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
goSnoc Pattern loc
rhs NormalizedList loc
nlp) Pattern loc
lhs
        SeqOp
Concat ->
          Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
goSnoc Pattern loc
rhs (Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
goSnoc Pattern loc
lhs NormalizedList loc
nlp)
      As loc
_loc Pattern loc
pat -> Pattern loc -> NormalizedList loc -> NormalizedList loc
forall loc.
Pattern loc
-> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
goSnoc Pattern loc
pat NormalizedList loc
nlp
      Pattern loc
_ -> [Char] -> NormalizedList loc
forall a. HasCallStack => [Char] -> a
error [Char]
"goSnoc: unexpected pattern"

assignFreshPatternVars :: (Pmc vt v loc m) => [Pattern loc] -> m [(v, Pattern loc)]
assignFreshPatternVars :: forall vt v loc (m :: * -> *).
Pmc vt v loc m =>
[Pattern loc] -> m [(v, Pattern loc)]
assignFreshPatternVars [Pattern loc]
pats = (Pattern loc -> m (v, Pattern loc))
-> [Pattern loc] -> m [(v, Pattern loc)]
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 (\Pattern loc
p -> (,Pattern loc
p) (v -> (v, Pattern loc)) -> m v -> m (v, Pattern loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m v
forall vt v loc (m :: * -> *). Pmc vt v loc m => m v
fresh) [Pattern loc]
pats