{-# LANGUAGE DerivingStrategies #-}
module Parsley.Internal.Frontend.Analysis.Cut (cutAnalysis) where
import Parsley.Internal.Common.Indexed (Fix(..), zygo, (:*:)(..))
import Parsley.Internal.Core.CombinatorAST (Combinator(..), MetaCombinator(..))
import Data.Bifunctor (first)
import Data.Coerce (coerce)
import Data.Kind (Type)
cutAnalysis :: Fix Combinator a -> Fix Combinator a
cutAnalysis :: forall a. Fix Combinator a -> Fix Combinator a
cutAnalysis = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ Bool
False) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: (Type -> Type) -> Type -> Type) (a :: Type -> Type)
(b :: Type -> Type) i.
IFunctor f =>
(forall j. f (a :*: b) j -> a j)
-> (forall j. f b j -> b j) -> Fix f i -> a i
zygo (forall a. (Bool -> (Fix Combinator a, Bool)) -> CutAnalysis a
CutAnalysis forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Combinator (CutAnalysis :*: Guardedness) a
-> Bool -> (Fix Combinator a, Bool)
cutAlg) forall a. Combinator Guardedness a -> Guardedness a
guardednessAlg
newtype CutAnalysis a = CutAnalysis { forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut :: Bool -> (Fix Combinator a, Bool) }
data Guardedness (a :: Type) = Guarded | UnguardedEffect | NoEffect deriving stock Guardedness a -> Guardedness a -> Bool
forall a. Guardedness a -> Guardedness a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Guardedness a -> Guardedness a -> Bool
$c/= :: forall a. Guardedness a -> Guardedness a -> Bool
== :: Guardedness a -> Guardedness a -> Bool
$c== :: forall a. Guardedness a -> Guardedness a -> Bool
Eq
guardednessAlg :: Combinator Guardedness a -> Guardedness a
guardednessAlg :: forall a. Combinator Guardedness a -> Guardedness a
guardednessAlg Pure{} = forall a. Guardedness a
NoEffect
guardednessAlg Satisfy{} = forall a. Guardedness a
Guarded
guardednessAlg Combinator Guardedness a
Empty = forall a. Guardedness a
NoEffect
guardednessAlg Let{} = forall a. Guardedness a
UnguardedEffect
guardednessAlg (Try Guardedness a
p) = Guardedness a
p
guardednessAlg (Guardedness a
p :<|>: Guardedness a
q) = forall a b c. Guardedness a -> Guardedness b -> Guardedness c
altGuardedness Guardedness a
p Guardedness a
q
guardednessAlg (Guardedness (a1 -> a)
l :<*>: Guardedness a1
r) = forall a b c. Guardedness a -> Guardedness b -> Guardedness c
seqGuardedness Guardedness (a1 -> a)
l Guardedness a1
r
guardednessAlg (Guardedness a
l :<*: Guardedness b
r) = forall a b c. Guardedness a -> Guardedness b -> Guardedness c
seqGuardedness Guardedness a
l Guardedness b
r
guardednessAlg (Guardedness a1
l :*>: Guardedness a
r) = forall a b c. Guardedness a -> Guardedness b -> Guardedness c
seqGuardedness Guardedness a1
l Guardedness a
r
guardednessAlg (LookAhead Guardedness a
UnguardedEffect) = forall a. Guardedness a
UnguardedEffect
guardednessAlg LookAhead{} = forall a. Guardedness a
NoEffect
guardednessAlg (NotFollowedBy Guardedness a1
UnguardedEffect) = forall a. Guardedness a
UnguardedEffect
guardednessAlg NotFollowedBy{} = forall a. Guardedness a
NoEffect
guardednessAlg (Debug String
_ Guardedness a
p) = Guardedness a
p
guardednessAlg (Loop Guardedness ()
UnguardedEffect Guardedness a
_) = forall a. Guardedness a
UnguardedEffect
guardednessAlg (Loop Guardedness ()
_ Guardedness a
exit) = Guardedness a
exit
guardednessAlg (Branch Guardedness (Either a1 b)
b Guardedness (a1 -> a)
p Guardedness (b -> a)
q) = forall a b c. Guardedness a -> Guardedness b -> Guardedness c
seqGuardedness Guardedness (Either a1 b)
b (forall a b c. Guardedness a -> Guardedness b -> Guardedness c
altGuardedness Guardedness (a1 -> a)
p Guardedness (b -> a)
q)
guardednessAlg (Match Guardedness a1
p [Defunc (a1 -> Bool)]
_ [Guardedness a]
qs Guardedness a
def) = forall a b c. Guardedness a -> Guardedness b -> Guardedness c
seqGuardedness Guardedness a1
p (forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b c. Guardedness a -> Guardedness b -> Guardedness c
altGuardedness Guardedness a
def [Guardedness a]
qs)
guardednessAlg (MakeRegister ΣVar a1
_ Guardedness a1
l Guardedness a
r) = forall a b c. Guardedness a -> Guardedness b -> Guardedness c
seqGuardedness Guardedness a1
l Guardedness a
r
guardednessAlg GetRegister{} = forall a. Guardedness a
NoEffect
guardednessAlg PutRegister{} = forall a. Guardedness a
UnguardedEffect
guardednessAlg Position{} = forall a. Guardedness a
NoEffect
guardednessAlg (MetaCombinator MetaCombinator
_ Guardedness a
p) = Guardedness a
p
seqGuardedness :: Guardedness a -> Guardedness b -> Guardedness c
seqGuardedness :: forall a b c. Guardedness a -> Guardedness b -> Guardedness c
seqGuardedness Guardedness a
Guarded Guardedness b
_ = forall a. Guardedness a
Guarded
seqGuardedness Guardedness a
UnguardedEffect Guardedness b
_ = forall a. Guardedness a
UnguardedEffect
seqGuardedness Guardedness a
NoEffect Guardedness b
guardedness = coerce :: forall a b. Coercible a b => a -> b
coerce Guardedness b
guardedness
altGuardedness :: Guardedness a -> Guardedness b -> Guardedness c
altGuardedness :: forall a b c. Guardedness a -> Guardedness b -> Guardedness c
altGuardedness Guardedness a
Guarded Guardedness b
Guarded = forall a. Guardedness a
Guarded
altGuardedness Guardedness a
UnguardedEffect Guardedness b
_ = forall a. Guardedness a
UnguardedEffect
altGuardedness Guardedness a
_ Guardedness b
UnguardedEffect = forall a. Guardedness a
UnguardedEffect
altGuardedness Guardedness a
_ Guardedness b
_ = forall a. Guardedness a
NoEffect
cutAlg :: Combinator (CutAnalysis :*: Guardedness) a -> Bool -> (Fix Combinator a, Bool)
cutAlg :: forall a.
Combinator (CutAnalysis :*: Guardedness) a
-> Bool -> (Fix Combinator a, Bool)
cutAlg (Pure Defunc a
x) Bool
_ = (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (forall a (k :: Type -> Type). Defunc a -> Combinator k a
Pure Defunc a
x), Bool
False)
cutAlg (Satisfy CharPred
f) Bool
backtracks = (forall a. Bool -> Fix Combinator a -> Fix Combinator a
mkCut (Bool -> Bool
not Bool
backtracks) (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (forall (k :: Type -> Type). CharPred -> Combinator k Char
Satisfy CharPred
f)), Bool
True)
cutAlg Combinator (CutAnalysis :*: Guardedness) a
Empty Bool
_ = (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In forall (k :: Type -> Type) a. Combinator k a
Empty, Bool
False)
cutAlg (Let MVar a
μ) Bool
_ = (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (forall a (k :: Type -> Type). MVar a -> Combinator k a
Let MVar a
μ), Bool
False)
cutAlg (Try (CutAnalysis a
p :*: Guardedness a
_)) Bool
backtracks =
let (Fix Combinator a
p', Bool
cuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis a
p Bool
True
in (forall a. Bool -> Fix Combinator a -> Fix Combinator a
mkCut (Bool
cuts Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
backtracks) (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (forall (k :: Type -> Type) a. k a -> Combinator k a
Try Fix Combinator a
p')), Bool
cuts)
cutAlg ((CutAnalysis a
p :*: Guardedness a
_) :<|>: (CutAnalysis a
q :*: Guardedness a
guardedness)) Bool
backtracks =
let (Fix Combinator a
p', Bool
pcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis a
p (Bool
backtracks Bool -> Bool -> Bool
&& Guardedness a
guardedness forall a. Eq a => a -> a -> Bool
== forall a. Guardedness a
Guarded)
(Fix Combinator a
q', Bool
qcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis a
q Bool
backtracks
in (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (Fix Combinator a
p' forall (k :: Type -> Type) a. k a -> k a -> Combinator k a
:<|>: Fix Combinator a
q'), Bool
pcuts Bool -> Bool -> Bool
&& Bool
qcuts)
cutAlg ((CutAnalysis (a1 -> a)
l :*: Guardedness (a1 -> a)
_) :<*>: (CutAnalysis a1
r :*: Guardedness a1
_)) Bool
backtracks = forall a b c.
(Fix Combinator a
-> Fix Combinator b -> Combinator (Fix Combinator) c)
-> Bool
-> CutAnalysis a
-> CutAnalysis b
-> (Fix Combinator c, Bool)
seqCutAlg forall (k :: Type -> Type) a1 a.
k (a1 -> a) -> k a1 -> Combinator k a
(:<*>:) Bool
backtracks CutAnalysis (a1 -> a)
l CutAnalysis a1
r
cutAlg ((CutAnalysis a
l :*: Guardedness a
_) :<*: (CutAnalysis b
r :*: Guardedness b
_)) Bool
backtracks = forall a b c.
(Fix Combinator a
-> Fix Combinator b -> Combinator (Fix Combinator) c)
-> Bool
-> CutAnalysis a
-> CutAnalysis b
-> (Fix Combinator c, Bool)
seqCutAlg forall (k :: Type -> Type) a b. k a -> k b -> Combinator k a
(:<*:) Bool
backtracks CutAnalysis a
l CutAnalysis b
r
cutAlg ((CutAnalysis a1
l :*: Guardedness a1
_) :*>: (CutAnalysis a
r :*: Guardedness a
_)) Bool
backtracks = forall a b c.
(Fix Combinator a
-> Fix Combinator b -> Combinator (Fix Combinator) c)
-> Bool
-> CutAnalysis a
-> CutAnalysis b
-> (Fix Combinator c, Bool)
seqCutAlg forall (k :: Type -> Type) a1 a. k a1 -> k a -> Combinator k a
(:*>:) Bool
backtracks CutAnalysis a1
l CutAnalysis a
r
cutAlg (LookAhead (CutAnalysis a
p :*: Guardedness a
_)) Bool
backtracks = Bool
False forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ forall a b.
(Fix Combinator a -> Combinator (Fix Combinator) b)
-> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)
rewrap forall (k :: Type -> Type) a. k a -> Combinator k a
LookAhead Bool
backtracks CutAnalysis a
p
cutAlg (NotFollowedBy (CutAnalysis a1
p :*: Guardedness a1
_)) Bool
_ = Bool
False forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ forall a b.
(Fix Combinator a -> Combinator (Fix Combinator) b)
-> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)
rewrap forall (k :: Type -> Type) a1. k a1 -> Combinator k ()
NotFollowedBy Bool
True CutAnalysis a1
p
cutAlg (Debug String
msg (CutAnalysis a
p :*: Guardedness a
_)) Bool
backtracks = forall a b.
(Fix Combinator a -> Combinator (Fix Combinator) b)
-> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)
rewrap (forall (k :: Type -> Type) a. String -> k a -> Combinator k a
Debug String
msg) Bool
backtracks CutAnalysis a
p
cutAlg (Loop (CutAnalysis ()
body :*: Guardedness ()
_) (CutAnalysis a
exit :*: Guardedness a
_)) Bool
backtracks =
let (Fix Combinator ()
body', Bool
_) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis ()
body Bool
False
in forall a b.
(Fix Combinator a -> Combinator (Fix Combinator) b)
-> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)
rewrap (forall (k :: Type -> Type) a. k () -> k a -> Combinator k a
Loop Fix Combinator ()
body') Bool
backtracks CutAnalysis a
exit
cutAlg (Branch (CutAnalysis (Either a1 b)
b :*: Guardedness (Either a1 b)
_) (CutAnalysis (a1 -> a)
p :*: Guardedness (a1 -> a)
_) (CutAnalysis (b -> a)
q :*: Guardedness (b -> a)
_)) Bool
backtracks =
let (Fix Combinator (Either a1 b)
b', Bool
bcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis (Either a1 b)
b Bool
backtracks
(Fix Combinator (a1 -> a)
p', Bool
pcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis (a1 -> a)
p (Bool
backtracks Bool -> Bool -> Bool
|| Bool
bcuts)
(Fix Combinator (b -> a)
q', Bool
qcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis (b -> a)
q (Bool
backtracks Bool -> Bool -> Bool
|| Bool
bcuts)
in (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (forall (k :: Type -> Type) a1 b a.
k (Either a1 b) -> k (a1 -> a) -> k (b -> a) -> Combinator k a
Branch Fix Combinator (Either a1 b)
b' Fix Combinator (a1 -> a)
p' Fix Combinator (b -> a)
q'), Bool
bcuts Bool -> Bool -> Bool
|| (Bool
pcuts Bool -> Bool -> Bool
&& Bool
qcuts))
cutAlg (Match (CutAnalysis a1
p :*: Guardedness a1
_) [Defunc (a1 -> Bool)]
f [(:*:) CutAnalysis Guardedness a]
qs (CutAnalysis a
def :*: Guardedness a
_)) Bool
backtracks =
let (Fix Combinator a1
p', Bool
pcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis a1
p Bool
backtracks
(Fix Combinator a
def', Bool
defcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis a
def (Bool
backtracks Bool -> Bool -> Bool
|| Bool
pcuts)
([Fix Combinator a]
qs', Bool
allcut) = forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(CutAnalysis a
q :*: Guardedness a
_) -> forall a b c x y z.
(a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)
biliftA2 (:) Bool -> Bool -> Bool
(&&) (forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis a
q (Bool
backtracks Bool -> Bool -> Bool
|| Bool
pcuts))) ([], Bool
defcuts) [(:*:) CutAnalysis Guardedness a]
qs
in (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (forall (k :: Type -> Type) a1 a.
k a1 -> [Defunc (a1 -> Bool)] -> [k a] -> k a -> Combinator k a
Match Fix Combinator a1
p' [Defunc (a1 -> Bool)]
f [Fix Combinator a]
qs' Fix Combinator a
def'), Bool
pcuts Bool -> Bool -> Bool
|| Bool
allcut)
cutAlg (MakeRegister ΣVar a1
σ (CutAnalysis a1
l :*: Guardedness a1
_) (CutAnalysis a
r :*: Guardedness a
_)) Bool
backtracks = forall a b c.
(Fix Combinator a
-> Fix Combinator b -> Combinator (Fix Combinator) c)
-> Bool
-> CutAnalysis a
-> CutAnalysis b
-> (Fix Combinator c, Bool)
seqCutAlg (forall a1 (k :: Type -> Type) a.
ΣVar a1 -> k a1 -> k a -> Combinator k a
MakeRegister ΣVar a1
σ) Bool
backtracks CutAnalysis a1
l CutAnalysis a
r
cutAlg (GetRegister ΣVar a
σ) Bool
_ = (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (forall a (k :: Type -> Type). ΣVar a -> Combinator k a
GetRegister ΣVar a
σ), Bool
False)
cutAlg (PutRegister ΣVar a1
σ (CutAnalysis a1
p :*: Guardedness a1
_)) Bool
backtracks = forall a b.
(Fix Combinator a -> Combinator (Fix Combinator) b)
-> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)
rewrap (forall a1 (k :: Type -> Type). ΣVar a1 -> k a1 -> Combinator k ()
PutRegister ΣVar a1
σ) Bool
backtracks CutAnalysis a1
p
cutAlg (Position PosSelector
sel) Bool
_ = (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (forall (k :: Type -> Type). PosSelector -> Combinator k Int
Position PosSelector
sel), Bool
False)
cutAlg (MetaCombinator MetaCombinator
m (CutAnalysis a
p :*: Guardedness a
_)) Bool
backtracks = forall a b.
(Fix Combinator a -> Combinator (Fix Combinator) b)
-> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)
rewrap (forall (k :: Type -> Type) a.
MetaCombinator -> k a -> Combinator k a
MetaCombinator MetaCombinator
m) Bool
backtracks CutAnalysis a
p
seqCutAlg :: (Fix Combinator a -> Fix Combinator b -> Combinator (Fix Combinator) c) -> Bool -> CutAnalysis a -> CutAnalysis b -> (Fix Combinator c, Bool)
seqCutAlg :: forall a b c.
(Fix Combinator a
-> Fix Combinator b -> Combinator (Fix Combinator) c)
-> Bool
-> CutAnalysis a
-> CutAnalysis b
-> (Fix Combinator c, Bool)
seqCutAlg Fix Combinator a
-> Fix Combinator b -> Combinator (Fix Combinator) c
con Bool
backtracks CutAnalysis a
l CutAnalysis b
r =
let (Fix Combinator a
l', Bool
lcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis a
l Bool
backtracks
(Fix Combinator b
r', Bool
rcuts) = forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis b
r (Bool
backtracks Bool -> Bool -> Bool
|| Bool
lcuts)
in (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In (Fix Combinator a
-> Fix Combinator b -> Combinator (Fix Combinator) c
con Fix Combinator a
l' Fix Combinator b
r'), Bool
lcuts Bool -> Bool -> Bool
|| Bool
rcuts)
mkCut :: Bool -> Fix Combinator a -> Fix Combinator a
mkCut :: forall a. Bool -> Fix Combinator a -> Fix Combinator a
mkCut Bool
True = forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (k :: Type -> Type) a.
MetaCombinator -> k a -> Combinator k a
MetaCombinator MetaCombinator
Cut
mkCut Bool
False = forall a. a -> a
id
rewrap :: (Fix Combinator a -> Combinator (Fix Combinator) b) -> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)
rewrap :: forall a b.
(Fix Combinator a -> Combinator (Fix Combinator) b)
-> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)
rewrap Fix Combinator a -> Combinator (Fix Combinator) b
con Bool
backtracks CutAnalysis a
p = forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall {k} (f :: (k -> Type) -> k -> Type) (a :: k).
f (Fix f) a -> Fix f a
In forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix Combinator a -> Combinator (Fix Combinator) b
con) (forall a. CutAnalysis a -> Bool -> (Fix Combinator a, Bool)
doCut CutAnalysis a
p Bool
backtracks)
biliftA2 :: (a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)
biliftA2 :: forall a b c x y z.
(a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)
biliftA2 a -> b -> c
f x -> y -> z
g (a
x1, x
y1) (b
x2, y
y2) = (a -> b -> c
f a
x1 b
x2, x -> y -> z
g x
y1 y
y2)