{-# LANGUAGE PatternSynonyms #-} -- For aliased combinators
{-# LANGUAGE TemplateHaskell #-} -- For optimizeCombNode
{-# LANGUAGE ViewPatterns #-} -- For optimizeCombNode
{-# OPTIONS_GHC -fno-warn-orphans #-} -- For MakeLetName TH.Name
module Symantic.Parser.Grammar.Optimize where

import Data.Bool (Bool(..))
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
import Data.Foldable (all, foldr)
import Data.Function ((.))
import Data.Kind (Type)
import qualified Data.Functor as Functor
import qualified Data.List as List
import qualified Language.Haskell.TH.Syntax as TH

import Symantic.Parser.Grammar.Combinators as Comb
import Symantic.Parser.Haskell (ValueCode(..), Value(..), getValue, code)
import Symantic.Univariant.Letable
import Symantic.Univariant.Trans
import qualified Symantic.Parser.Haskell as H

-- import Debug.Trace (trace)

-- * Type 'Comb'
-- | Pattern-matchable 'Comb'inators of the grammar.
-- @(repr)@ is not strictly necessary since it's only a phantom type
-- (no constructor use it as a value), but having it:
--
-- 1. emphasizes that those 'Comb'inators will be 'trans'formed again
--    (eg. in 'DumpComb' or 'Instr'uctions).
--
-- 2. Avoid overlapping instances between
--    @('Trans' ('Comb' repr) repr)@ and
--    @('Trans' ('Comb' repr) ('OptimizeComb' letName repr))@
data Comb (repr :: Type -> Type) a where
  Pure :: H.Haskell a -> Comb repr a
  Satisfy ::
    Satisfiable repr tok =>
    [ErrorItem tok] ->
    H.Haskell (tok -> Bool) -> Comb repr tok
  Item :: Satisfiable repr tok => Comb repr tok
  Try :: Comb repr a -> Comb repr a
  Look :: Comb repr a -> Comb repr a
  NegLook :: Comb repr a -> Comb repr ()
  Eof :: Comb repr ()
  (:<*>) :: Comb repr (a -> b) -> Comb repr a -> Comb repr b
  (:<|>) :: Comb repr a -> Comb repr a -> Comb repr a
  Empty :: Comb repr a
  Branch ::
    Comb repr (Either a b) ->
    Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
  Match :: Eq a =>
    [H.Haskell (a -> Bool)] ->
    [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b
  ChainPre :: Comb repr (a -> a) -> Comb repr a -> Comb repr a
  ChainPost :: Comb repr a -> Comb repr (a -> a) -> Comb repr a
  Def :: TH.Name -> Comb repr a -> Comb repr a
  Ref :: Bool -> TH.Name -> Comb repr a

pattern (:<$>) :: H.Haskell (a -> b) -> Comb repr a -> Comb repr b
pattern (:$>) :: Comb repr a -> H.Haskell b -> Comb repr b
pattern (:<$) :: H.Haskell a -> Comb repr b -> Comb repr a
pattern (:*>) :: Comb repr a -> Comb repr b -> Comb repr b
pattern (:<*) :: Comb repr a -> Comb repr b -> Comb repr a
pattern x $b:<$> :: forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
$m:<$> :: forall {r} {b} {repr :: * -> *}.
Comb repr b
-> (forall {a}. Haskell (a -> b) -> Comb repr a -> r)
-> (Void# -> r)
-> r
:<$> p = Pure x :<*> p
pattern p $b:$> :: forall (repr :: * -> *) b a.
Comb repr a -> Haskell b -> Comb repr b
$m:$> :: forall {r} {repr :: * -> *} {b}.
Comb repr b
-> (forall {a}. Comb repr a -> Haskell b -> r) -> (Void# -> r) -> r
:$> x = p :*> Pure x
pattern x $b:<$ :: forall a (repr :: * -> *) b.
Haskell a -> Comb repr b -> Comb repr a
$m:<$ :: forall {r} {a} {repr :: * -> *}.
Comb repr a
-> (forall {b}. Haskell a -> Comb repr b -> r) -> (Void# -> r) -> r
:<$ p = Pure x :<* p
pattern x $b:<* :: forall (repr :: * -> *) a b.
Comb repr a -> Comb repr b -> Comb repr a
$m:<* :: forall {r} {repr :: * -> *} {a}.
Comb repr a
-> (forall {b}. Comb repr a -> Comb repr b -> r)
-> (Void# -> r)
-> r
:<* p = H.Const :<$> x :<*> p
pattern p $b:*> :: forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
$m:*> :: forall {r} {repr :: * -> *} {b}.
Comb repr b
-> (forall {a}. Comb repr a -> Comb repr b -> r)
-> (Void# -> r)
-> r
:*> x = H.Id :<$ p :<*> x

infixl 3 :<|>
infixl 4 :<*>, :<*, :*>
infixl 4 :<$>, :<$, :$>

instance Applicable (Comb repr) where
  pure :: forall a. Haskell a -> Comb repr a
pure = Haskell a -> Comb repr a
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure
  <*> :: forall a b. Comb repr (a -> b) -> Comb repr a -> Comb repr b
(<*>) = Comb repr (a -> b) -> Comb repr a -> Comb repr b
forall (repr :: * -> *) a b.
Comb repr (a -> b) -> Comb repr a -> Comb repr b
(:<*>)
instance Alternable (Comb repr) where
  <|> :: forall a. Comb repr a -> Comb repr a -> Comb repr a
(<|>) = Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a.
Comb repr a -> Comb repr a -> Comb repr a
(:<|>)
  empty :: forall a. Comb repr a
empty = Comb repr a
forall (repr :: * -> *) a. Comb repr a
Empty
  try :: forall a. Comb repr a -> Comb repr a
try = Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Try
instance Selectable (Comb repr) where
  branch :: forall a b c.
Comb repr (Either a b)
-> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
branch = Comb repr (Either a b)
-> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
forall (repr :: * -> *) a b c.
Comb repr (Either a b)
-> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
Branch
instance Matchable (Comb repr) where
  conditional :: forall a b.
Eq a =>
[Haskell (a -> Bool)]
-> [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b
conditional = [Haskell (a -> Bool)]
-> [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b
forall a (repr :: * -> *) b.
Eq a =>
[Haskell (a -> Bool)]
-> [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b
Match
instance Foldable (Comb repr) where
  chainPre :: forall a. Comb repr (a -> a) -> Comb repr a -> Comb repr a
chainPre = Comb repr (a -> a) -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a.
Comb repr (a -> a) -> Comb repr a -> Comb repr a
ChainPre
  chainPost :: forall a. Comb repr a -> Comb repr (a -> a) -> Comb repr a
chainPost = Comb repr a -> Comb repr (a -> a) -> Comb repr a
forall (repr :: * -> *) a.
Comb repr a -> Comb repr (a -> a) -> Comb repr a
ChainPost
instance Satisfiable repr tok => Satisfiable (Comb repr) tok where
  satisfy :: [ErrorItem tok] -> Haskell (tok -> Bool) -> Comb repr tok
satisfy = [ErrorItem tok] -> Haskell (tok -> Bool) -> Comb repr tok
forall (repr :: * -> *) tok.
Satisfiable repr tok =>
[ErrorItem tok] -> Haskell (tok -> Bool) -> Comb repr tok
Satisfy
instance Lookable (Comb repr) where
  look :: forall a. Comb repr a -> Comb repr a
look = Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Look
  negLook :: forall a. Comb repr a -> Comb repr ()
negLook = Comb repr a -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr ()
NegLook
  eof :: Comb repr ()
eof = Comb repr ()
forall (repr :: * -> *). Comb repr ()
Eof
instance Letable TH.Name (Comb repr) where
  def :: forall a. Name -> Comb repr a -> Comb repr a
def = Name -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Name -> Comb repr a -> Comb repr a
Def
  ref :: forall a. Bool -> Name -> Comb repr a
ref = Bool -> Name -> Comb repr a
forall (repr :: * -> *) a. Bool -> Name -> Comb repr a
Ref
instance MakeLetName TH.Name where
  makeLetName :: SharingName -> IO Name
makeLetName SharingName
_ = String -> IO Name
forall (m :: * -> *). Quasi m => String -> m Name
TH.qNewName String
"name"

-- Pattern-matchable 'Comb'inators keep enough structure
-- to have some of the symantics producing them interpreted again
-- (eg. after being modified by 'optimizeComb').
type instance Output (Comb repr) = repr
instance
  ( Applicable repr
  , Alternable repr
  , Selectable repr
  , Foldable repr
  , Lookable repr
  , Matchable repr
  , Letable TH.Name repr
  ) => Trans (Comb repr) repr where
  trans :: forall a. Comb repr a -> repr a
trans = \case
    Pure Haskell a
a -> Haskell a -> repr a
forall (repr :: * -> *) a. Applicable repr => Haskell a -> repr a
pure Haskell a
a
    Satisfy [ErrorItem a]
es Haskell (a -> Bool)
p -> [ErrorItem a] -> Haskell (a -> Bool) -> repr a
forall (repr :: * -> *) tok.
Satisfiable repr tok =>
[ErrorItem tok] -> Haskell (tok -> Bool) -> repr tok
satisfy [ErrorItem a]
es Haskell (a -> Bool)
p
    Comb repr a
Item -> repr a
forall (repr :: * -> *) tok. Satisfiable repr tok => repr tok
item
    Try Comb repr a
x -> repr a -> repr a
forall (repr :: * -> *) a. Alternable repr => repr a -> repr a
try (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
x)
    Look Comb repr a
x -> repr a -> repr a
forall (repr :: * -> *) a. Lookable repr => repr a -> repr a
look (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
x)
    NegLook Comb repr a
x -> repr a -> repr ()
forall (repr :: * -> *) a. Lookable repr => repr a -> repr ()
negLook (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
x)
    Comb repr a
Eof -> repr a
forall (repr :: * -> *). Lookable repr => repr ()
eof
    Comb repr (a -> a)
x :<*> Comb repr a
y -> Comb repr (a -> a) -> repr (a -> a)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr (a -> a)
x repr (a -> a) -> repr a -> repr a
forall (repr :: * -> *) a b.
Applicable repr =>
repr (a -> b) -> repr a -> repr b
<*> Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
y
    Comb repr a
x :<|> Comb repr a
y -> Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
x repr a -> repr a -> repr a
forall (repr :: * -> *) a.
Alternable repr =>
repr a -> repr a -> repr a
<|> Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
y
    Comb repr a
Empty -> repr a
forall (repr :: * -> *) a. Alternable repr => repr a
empty
    Branch Comb repr (Either a b)
lr Comb repr (a -> a)
l Comb repr (b -> a)
r -> repr (Either a b) -> repr (a -> a) -> repr (b -> a) -> repr a
forall (repr :: * -> *) a b c.
Selectable repr =>
repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
branch (Comb repr (Either a b) -> repr (Either a b)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr (Either a b)
lr) (Comb repr (a -> a) -> repr (a -> a)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr (a -> a)
l) (Comb repr (b -> a) -> repr (b -> a)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr (b -> a)
r)
    Match [Haskell (a -> Bool)]
ps [Comb repr a]
bs Comb repr a
a Comb repr a
b -> [Haskell (a -> Bool)] -> [repr a] -> repr a -> repr a -> repr a
forall (repr :: * -> *) a b.
(Matchable repr, Eq a) =>
[Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
conditional [Haskell (a -> Bool)]
ps (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans (Comb repr a -> repr a) -> [Comb repr a] -> [repr a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Functor.<$> [Comb repr a]
bs) (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
a) (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
b)
    ChainPre Comb repr (a -> a)
x Comb repr a
y -> repr (a -> a) -> repr a -> repr a
forall (repr :: * -> *) a.
Foldable repr =>
repr (a -> a) -> repr a -> repr a
chainPre (Comb repr (a -> a) -> repr (a -> a)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr (a -> a)
x) (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
y)
    ChainPost Comb repr a
x Comb repr (a -> a)
y -> repr a -> repr (a -> a) -> repr a
forall (repr :: * -> *) a.
Foldable repr =>
repr a -> repr (a -> a) -> repr a
chainPost (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
x) (Comb repr (a -> a) -> repr (a -> a)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr (a -> a)
y)
    Def Name
n Comb repr a
x -> Name -> repr a -> repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
letName -> repr a -> repr a
def Name
n (Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans Comb repr a
x)
    Ref Bool
r Name
n -> Bool -> Name -> repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
Bool -> letName -> repr a
ref Bool
r Name
n

-- * Type 'OptimizeComb'
-- Bottom-up application of 'optimizeCombNode'.
newtype OptimizeComb letName repr a =
        OptimizeComb { forall letName (repr :: * -> *) a.
OptimizeComb letName repr a -> Comb repr a
unOptimizeComb :: Comb repr a }

optimizeComb ::
  Trans (OptimizeComb TH.Name repr) repr =>
  OptimizeComb TH.Name repr a -> repr a
optimizeComb :: forall (repr :: * -> *) a.
Trans (OptimizeComb Name repr) repr =>
OptimizeComb Name repr a -> repr a
optimizeComb = OptimizeComb Name repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans
instance
  Trans (Comb repr) repr =>
  Trans (OptimizeComb letName repr) repr where
  trans :: forall a. OptimizeComb letName repr a -> repr a
trans = Comb repr a -> repr a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans (Comb repr a -> repr a)
-> (OptimizeComb letName repr a -> Comb repr a)
-> OptimizeComb letName repr a
-> repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptimizeComb letName repr a -> Comb repr a
forall letName (repr :: * -> *) a.
OptimizeComb letName repr a -> Comb repr a
unOptimizeComb

type instance Output (OptimizeComb _letName repr) = Comb repr
instance Trans (OptimizeComb letName repr) (Comb repr) where
  trans :: forall a. OptimizeComb letName repr a -> Comb repr a
trans = OptimizeComb letName repr a -> Comb repr a
forall letName (repr :: * -> *) a.
OptimizeComb letName repr a -> Comb repr a
unOptimizeComb
instance Trans (Comb repr) (OptimizeComb letName repr) where
  trans :: forall a. Comb repr a -> OptimizeComb letName repr a
trans = Comb repr a -> OptimizeComb letName repr a
forall letName (repr :: * -> *) a.
Comb repr a -> OptimizeComb letName repr a
OptimizeComb (Comb repr a -> OptimizeComb letName repr a)
-> (Comb repr a -> Comb repr a)
-> Comb repr a
-> OptimizeComb letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode
instance Trans1 (Comb repr) (OptimizeComb letName repr)
instance Trans2 (Comb repr) (OptimizeComb letName repr)
instance Trans3 (Comb repr) (OptimizeComb letName repr)

instance
  Letable letName (Comb repr) =>
  Letable letName (OptimizeComb letName repr) where
  -- Disable useless calls to 'optimizeCombNode'
  -- because 'Def' or 'Ref' have no matching in it.
  def :: forall a.
letName
-> OptimizeComb letName repr a -> OptimizeComb letName repr a
def letName
n = Comb repr a -> OptimizeComb letName repr a
forall letName (repr :: * -> *) a.
Comb repr a -> OptimizeComb letName repr a
OptimizeComb (Comb repr a -> OptimizeComb letName repr a)
-> (OptimizeComb letName repr a -> Comb repr a)
-> OptimizeComb letName repr a
-> OptimizeComb letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. letName -> Comb repr a -> Comb repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
letName -> repr a -> repr a
def letName
n (Comb repr a -> Comb repr a)
-> (OptimizeComb letName repr a -> Comb repr a)
-> OptimizeComb letName repr a
-> Comb repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptimizeComb letName repr a -> Comb repr a
forall letName (repr :: * -> *) a.
OptimizeComb letName repr a -> Comb repr a
unOptimizeComb
  ref :: forall a. Bool -> letName -> OptimizeComb letName repr a
ref Bool
r letName
n = Comb repr a -> OptimizeComb letName repr a
forall letName (repr :: * -> *) a.
Comb repr a -> OptimizeComb letName repr a
OptimizeComb (Bool -> letName -> Comb repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
Bool -> letName -> repr a
ref Bool
r letName
n)
instance Comb.Applicable (OptimizeComb letName repr)
instance Comb.Alternable (OptimizeComb letName repr)
instance Comb.Satisfiable repr tok =>
         Comb.Satisfiable (OptimizeComb letName repr) tok
instance Comb.Selectable (OptimizeComb letName repr)
instance Comb.Matchable (OptimizeComb letName repr)
instance Comb.Lookable (OptimizeComb letName repr)
instance Comb.Foldable (OptimizeComb letName repr)

optimizeCombNode :: Comb repr a -> Comb repr a
optimizeCombNode :: forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode = \case
  -- Functor Identity Law
  Haskell (a -> a)
H.Id :<$> Comb repr a
x ->
    -- trace "Functor Identity Law" $
    Comb repr a
Comb repr a
x
  -- Functor Commutativity Law
  Haskell a
x :<$ Comb repr b
u ->
    -- trace "Functor Commutativity Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr b
u Comb repr b -> Haskell a -> Comb repr a
forall (repr :: * -> *) b a.
Comb repr a -> Haskell b -> Comb repr b
:$> Haskell a
x)
  -- Functor Flip Const Law
  Haskell (a -> a -> a)
H.Flip H.:@ Haskell a
H.Const :<$> Comb repr a
u ->
    -- trace "Functor Flip Const Law" $
    Comb repr (a -> a) -> Comb repr (a -> a)
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a
u Comb repr a -> Comb repr (a -> a) -> Comb repr (a -> a)
forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
:*> Haskell (a -> a) -> Comb repr (a -> a)
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure Haskell (a -> a)
forall a. Haskell (a -> a)
H.Id)
  -- Functor Homomorphism Law
  Haskell (a -> a)
f :<$> Pure Haskell a
x ->
    -- trace "Functor Homomorphism Law" $
    Haskell a -> Comb repr a
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure (Haskell (a -> a)
f Haskell (a -> a) -> Haskell a -> Haskell a
forall (repr :: * -> *) a b.
Haskellable repr =>
repr (a -> b) -> repr a -> repr b
H..@ Haskell a
x)

  -- App Right Absorption Law
  Comb repr (a -> a)
Empty :<*> Comb repr a
_ ->
    -- trace "App Right Absorption Law" $
    Comb repr a
forall (repr :: * -> *) a. Comb repr a
Empty
  Comb repr (a -> a)
_ :<*> Comb repr a
Empty ->
    -- In Parsley: this is only a weakening to u :*> Empty
    -- but here :*> is an alias to :<*>
    -- hence it would loop on itself forever.
    -- trace "App Left Absorption Law" $
    Comb repr a
forall (repr :: * -> *) a. Comb repr a
Empty
  -- App Composition Law
  Comb repr (a -> a)
u :<*> (Comb repr (a -> a)
v :<*> Comb repr a
w) ->
    -- trace "App Composition Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr (a -> a) -> Comb repr (a -> a)
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr ((a -> a) -> a -> a) -> Comb repr ((a -> a) -> a -> a)
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Haskell ((a -> a) -> (a -> a) -> a -> a)
forall a b c. Haskell ((a -> b) -> (c -> a) -> c -> b)
(H.:.) Haskell ((a -> a) -> (a -> a) -> a -> a)
-> Comb repr (a -> a) -> Comb repr ((a -> a) -> a -> a)
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$> Comb repr (a -> a)
u) Comb repr ((a -> a) -> a -> a)
-> Comb repr (a -> a) -> Comb repr (a -> a)
forall (repr :: * -> *) a b.
Comb repr (a -> b) -> Comb repr a -> Comb repr b
:<*> Comb repr (a -> a)
v) Comb repr (a -> a) -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a b.
Comb repr (a -> b) -> Comb repr a -> Comb repr b
:<*> Comb repr a
w)
  -- App Interchange Law
  Comb repr (a -> a)
u :<*> Pure Haskell a
x ->
    -- trace "App Interchange Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Haskell (((a -> a) -> a -> a) -> a -> (a -> a) -> a)
forall a b c. Haskell ((a -> b -> c) -> b -> a -> c)
H.Flip Haskell (((a -> a) -> a -> a) -> a -> (a -> a) -> a)
-> Haskell ((a -> a) -> a -> a) -> Haskell (a -> (a -> a) -> a)
forall (repr :: * -> *) a b.
Haskellable repr =>
repr (a -> b) -> repr a -> repr b
H..@ Haskell ((a -> a) -> a -> a)
forall a b. Haskell ((a -> b) -> a -> b)
(H.:$) Haskell (a -> (a -> a) -> a)
-> Haskell a -> Haskell ((a -> a) -> a)
forall (repr :: * -> *) a b.
Haskellable repr =>
repr (a -> b) -> repr a -> repr b
H..@ Haskell a
x Haskell ((a -> a) -> a) -> Comb repr (a -> a) -> Comb repr a
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$> Comb repr (a -> a)
u)
  -- App Left Absorption Law
  Comb repr a
p :<* (Haskell (a -> b)
_ :<$> Comb repr a
q) ->
    -- trace "App Left Absorption Law" $
    Comb repr a
p Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a b.
Comb repr a -> Comb repr b -> Comb repr a
:<* Comb repr a
q
  -- App Right Absorption Law
  (Haskell (a -> a)
_ :<$> Comb repr a
p) :*> Comb repr a
q ->
    -- trace "App Right Absorption Law" $
    Comb repr a
p Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
:*> Comb repr a
q
  -- App Pure Left Identity Law
  Pure Haskell a
_ :*> Comb repr a
u ->
    -- trace "App Pure Left Identity Law" $
    Comb repr a
u
  -- App Functor Left Identity Law
  (Comb repr a
u :$> Haskell a
_) :*> Comb repr a
v ->
    -- trace "App Functor Left Identity Law" $
    Comb repr a
u Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
:*> Comb repr a
v
  -- App Pure Right Identity Law
  Comb repr a
u :<* Pure Haskell b
_ ->
    -- trace "App Pure Right Identity Law" $
    Comb repr a
u
  -- App Functor Right Identity Law
  Comb repr a
u :<* (Comb repr a
v :$> Haskell b
_) ->
    -- trace "App Functor Right Identity Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a
u Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a b.
Comb repr a -> Comb repr b -> Comb repr a
:<* Comb repr a
v)
  -- App Left Associativity Law
  (Comb repr a
u :<* Comb repr b
v) :<* Comb repr b
w ->
    -- trace "App Left Associativity Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a
u Comb repr a -> Comb repr b -> Comb repr a
forall (repr :: * -> *) a b.
Comb repr a -> Comb repr b -> Comb repr a
:<* Comb repr b -> Comb repr b
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr b
v Comb repr b -> Comb repr b -> Comb repr b
forall (repr :: * -> *) a b.
Comb repr a -> Comb repr b -> Comb repr a
:<* Comb repr b
w))

  -- Alt Left CatchFail Law
  p :: Comb repr a
p@Pure{} :<|> Comb repr a
_ ->
    -- trace "Alt Left CatchFail Law" $
    Comb repr a
p
  -- Alt Left Neutral Law
  Comb repr a
Empty :<|> Comb repr a
u ->
    -- trace "Alt Left Neutral Law" $
    Comb repr a
u
  -- All Right Neutral Law
  Comb repr a
u :<|> Comb repr a
Empty ->
    -- trace "Alt Right Neutral Law" $
    Comb repr a
u
  -- Alt Associativity Law
  (Comb repr a
u :<|> Comb repr a
v) :<|> Comb repr a
w ->
    -- trace "Alt Associativity Law" $
    Comb repr a
u Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a.
Comb repr a -> Comb repr a -> Comb repr a
:<|> Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a
v Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a.
Comb repr a -> Comb repr a -> Comb repr a
:<|> Comb repr a
w)

  -- Look Pure Law
  Look p :: Comb repr a
p@Pure{} ->
    -- trace "Look Pure Law" $
    Comb repr a
p
  -- Look Empty Law
  Look p :: Comb repr a
p@Comb repr a
Empty ->
    -- trace "Look Empty Law" $
    Comb repr a
p
  -- NegLook Pure Law
  NegLook Pure{} ->
    -- trace "NegLook Pure Law" $
    Comb repr a
forall (repr :: * -> *) a. Comb repr a
Empty
  -- NegLook Empty Law
  NegLook Comb repr a
Empty ->
    -- trace "NegLook Dead Law" $
    Haskell () -> Comb repr ()
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure Haskell ()
forall (repr :: * -> *). Haskellable repr => repr ()
H.unit
  -- NegLook Double Negation Law
  NegLook (NegLook Comb repr a
p) ->
    -- trace "NegLook Double Negation Law" $
    Comb repr () -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Look (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Try Comb repr a
p) Comb repr a -> Comb repr () -> Comb repr ()
forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
:*> Haskell () -> Comb repr ()
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure Haskell ()
forall (repr :: * -> *). Haskellable repr => repr ()
H.unit)
  -- NegLook Zero Consumption Law
  NegLook (Try Comb repr a
p) ->
    -- trace "NegLook Zero Consumption Law" $
    Comb repr () -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr ()
NegLook Comb repr a
p)
  -- Idempotence Law
  Look (Look Comb repr a
p) ->
    -- trace "Look Idempotence Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Look Comb repr a
p
  -- Look Right Identity Law
  NegLook (Look Comb repr a
p) ->
    -- trace "Look Right Identity Law" $
    Comb repr () -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr ()
NegLook Comb repr a
p)
  -- Look Left Identity Law
  Look (NegLook Comb repr a
p) ->
    -- trace "Look Left Identity Law" $
    Comb repr a -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr ()
NegLook Comb repr a
p
  -- NegLook Transparency Law
  NegLook (Try Comb repr a
p :<|> Comb repr a
q) ->
    -- trace "NegLook Transparency Law" $
    Comb repr () -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr () -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr ()
NegLook Comb repr a
p) Comb repr () -> Comb repr () -> Comb repr ()
forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
:*> Comb repr () -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr ()
NegLook Comb repr a
q))
  -- Look Distributivity Law
  Look Comb repr a
p :<|> Look Comb repr a
q ->
    -- trace "Look Distributivity Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Look (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Try Comb repr a
p Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a.
Comb repr a -> Comb repr a -> Comb repr a
:<|> Comb repr a
q)))
  -- Look Interchange Law
  Look (Haskell (a -> a)
f :<$> Comb repr a
p) ->
    -- trace "Look Interchange Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Haskell (a -> a)
f Haskell (a -> a) -> Comb repr a -> Comb repr a
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$> Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Look Comb repr a
p))
  -- NegLook Idempotence Right Law
  NegLook (Haskell (a -> a)
_ :<$> Comb repr a
p) ->
    -- trace "NegLook Idempotence Law" $
    Comb repr () -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr ()
forall (repr :: * -> *) a. Comb repr a -> Comb repr ()
NegLook Comb repr a
p)
  -- Try Interchange Law
  Try (Haskell (a -> a)
f :<$> Comb repr a
p) ->
    -- trace "Try Interchange Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Haskell (a -> a)
f Haskell (a -> a) -> Comb repr a -> Comb repr a
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$> Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
Try Comb repr a
p))

  -- Branch Absorption Law
  Branch Comb repr (Either a b)
Empty Comb repr (a -> a)
_ Comb repr (b -> a)
_ ->
    -- trace "Branch Absorption Law" $
    Comb repr a
forall (repr :: * -> *) a. Alternable repr => repr a
empty
  -- Branch Weakening Law
  Branch Comb repr (Either a b)
b Comb repr (a -> a)
Empty Comb repr (b -> a)
Empty ->
    -- trace "Branch Weakening Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr (Either a b)
b Comb repr (Either a b) -> Comb repr a -> Comb repr a
forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
:*> Comb repr a
forall (repr :: * -> *) a. Comb repr a
Empty)
  -- Branch Pure Left/Right Laws
  Branch (Pure (Haskell (Either a b) -> ValueCode (Either a b)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans -> ValueCode (Either a b)
lr)) Comb repr (a -> a)
l Comb repr (b -> a)
r ->
    -- trace "Branch Pure Left/Right Law" $
    case ValueCode (Either a b) -> Either a b
forall a. ValueCode a -> a
getValue ValueCode (Either a b)
lr of
     Left a
v -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr (a -> a)
l Comb repr (a -> a) -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a b.
Comb repr (a -> b) -> Comb repr a -> Comb repr b
:<*> Haskell a -> Comb repr a
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure (ValueCode a -> Haskell a
forall a. ValueCode a -> Haskell a
H.Haskell (Value a -> CodeQ a -> ValueCode a
forall a. Value a -> CodeQ a -> ValueCode a
ValueCode (a -> Value a
forall a. a -> Value a
Value a
v) CodeQ a
c)))
      where c :: CodeQ a
c = [|| case $$(code lr) of Left x -> x ||]
     Right b
v -> Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr (b -> a)
r Comb repr (b -> a) -> Comb repr b -> Comb repr a
forall (repr :: * -> *) a b.
Comb repr (a -> b) -> Comb repr a -> Comb repr b
:<*> Haskell b -> Comb repr b
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure (ValueCode b -> Haskell b
forall a. ValueCode a -> Haskell a
H.Haskell (Value b -> CodeQ b -> ValueCode b
forall a. Value a -> CodeQ a -> ValueCode a
ValueCode (b -> Value b
forall a. a -> Value a
Value b
v) CodeQ b
c)))
      where c :: CodeQ b
c = [|| case $$(code lr) of Right x -> x ||]
  -- Branch Generalised Identity Law
  Branch Comb repr (Either a b)
b (Pure (Haskell (a -> a) -> ValueCode (a -> a)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans -> ValueCode (a -> a)
l)) (Pure (Haskell (b -> a) -> ValueCode (b -> a)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans -> ValueCode (b -> a)
r)) ->
    -- trace "Branch Generalised Identity Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (ValueCode (Either a b -> a) -> Haskell (Either a b -> a)
forall a. ValueCode a -> Haskell a
H.Haskell (Value (Either a b -> a)
-> CodeQ (Either a b -> a) -> ValueCode (Either a b -> a)
forall a. Value a -> CodeQ a -> ValueCode a
ValueCode Value (Either a b -> a)
v CodeQ (Either a b -> a)
c) Haskell (Either a b -> a) -> Comb repr (Either a b) -> Comb repr a
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$> Comb repr (Either a b)
b)
    where
    v :: Value (Either a b -> a)
v = (Either a b -> a) -> Value (Either a b -> a)
forall a. a -> Value a
Value ((a -> a) -> (b -> a) -> Either a b -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ValueCode (a -> a) -> a -> a
forall a. ValueCode a -> a
getValue ValueCode (a -> a)
l) (ValueCode (b -> a) -> b -> a
forall a. ValueCode a -> a
getValue ValueCode (b -> a)
r))
    c :: CodeQ (Either a b -> a)
c = [|| either $$(code l) $$(code r) ||]
  -- Branch Interchange Law
  Branch (Comb repr a
x :*> Comb repr (Either a b)
y) Comb repr (a -> a)
p Comb repr (b -> a)
q ->
    -- trace "Branch Interchange Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a
x Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
:*> Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr (Either a b)
-> Comb repr (a -> a) -> Comb repr (b -> a) -> Comb repr a
forall (repr :: * -> *) a b c.
Comb repr (Either a b)
-> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
Branch Comb repr (Either a b)
y Comb repr (a -> a)
p Comb repr (b -> a)
q))
  -- Branch Empty Right Law
  Branch Comb repr (Either a b)
b Comb repr (a -> a)
l Comb repr (b -> a)
Empty ->
    -- trace " Branch Empty Right Law" $
    Comb repr (Either b a)
-> Comb repr (b -> a) -> Comb repr (a -> a) -> Comb repr a
forall (repr :: * -> *) a b c.
Comb repr (Either a b)
-> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
Branch (Haskell (Either a b -> Either b a)
-> Comb repr (Either a b -> Either b a)
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure (ValueCode (Either a b -> Either b a)
-> Haskell (Either a b -> Either b a)
forall a. ValueCode a -> Haskell a
H.Haskell (Value (Either a b -> Either b a)
-> CodeQ (Either a b -> Either b a)
-> ValueCode (Either a b -> Either b a)
forall a. Value a -> CodeQ a -> ValueCode a
ValueCode Value (Either a b -> Either b a)
forall {a} {a}. Value (Either a a -> Either a a)
v CodeQ (Either a b -> Either b a)
forall {a} {a}. Code Q (Either a a -> Either a a)
c)) Comb repr (Either a b -> Either b a)
-> Comb repr (Either a b) -> Comb repr (Either b a)
forall (repr :: * -> *) a b.
Comb repr (a -> b) -> Comb repr a -> Comb repr b
:<*> Comb repr (Either a b)
b) Comb repr (b -> a)
forall (repr :: * -> *) a. Comb repr a
Empty Comb repr (a -> a)
l
    where
    v :: Value (Either a a -> Either a a)
v = (Either a a -> Either a a) -> Value (Either a a -> Either a a)
forall a. a -> Value a
Value ((a -> Either a a) -> (a -> Either a a) -> Either a a -> Either a a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Either a a
forall a b. b -> Either a b
Right a -> Either a a
forall a b. a -> Either a b
Left)
    c :: Code Q (Either a a -> Either a a)
c = [||either Right Left||]
  -- Branch Fusion Law
  Branch (Branch Comb repr (Either a b)
b Comb repr (a -> Either a b)
Empty (Pure (Haskell (b -> Either a b) -> ValueCode (b -> Either a b)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans -> ValueCode (b -> Either a b)
lr))) Comb repr (a -> a)
Empty Comb repr (b -> a)
br ->
    -- trace "Branch Fusion Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr (Either () b)
-> Comb repr (() -> a) -> Comb repr (b -> a) -> Comb repr a
forall (repr :: * -> *) a b c.
Comb repr (Either a b)
-> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
Branch (Comb repr (Either () b) -> Comb repr (Either () b)
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Haskell (Either a b -> Either () b)
-> Comb repr (Either a b -> Either () b)
forall a (repr :: * -> *). Haskell a -> Comb repr a
Pure (ValueCode (Either a b -> Either () b)
-> Haskell (Either a b -> Either () b)
forall a. ValueCode a -> Haskell a
H.Haskell (Value (Either a b -> Either () b)
-> CodeQ (Either a b -> Either () b)
-> ValueCode (Either a b -> Either () b)
forall a. Value a -> CodeQ a -> ValueCode a
ValueCode ((Either a b -> Either () b) -> Value (Either a b -> Either () b)
forall a. a -> Value a
Value Either a b -> Either () b
v) CodeQ (Either a b -> Either () b)
c)) Comb repr (Either a b -> Either () b)
-> Comb repr (Either a b) -> Comb repr (Either () b)
forall (repr :: * -> *) a b.
Comb repr (a -> b) -> Comb repr a -> Comb repr b
:<*> Comb repr (Either a b)
b))
                             Comb repr (() -> a)
forall (repr :: * -> *) a. Comb repr a
Empty Comb repr (b -> a)
br)
    where
    v :: Either a b -> Either () b
v Left{} = () -> Either () b
forall a b. a -> Either a b
Left ()
    v (Right b
r) = case ValueCode (b -> Either a b) -> b -> Either a b
forall a. ValueCode a -> a
getValue ValueCode (b -> Either a b)
lr b
r of
                   Left a
_ -> () -> Either () b
forall a b. a -> Either a b
Left ()
                   Right b
rr -> b -> Either () b
forall a b. b -> Either a b
Right b
rr
    c :: CodeQ (Either a b -> Either () b)
c = [|| \case Left{} -> Left ()
                  Right r -> case $$(code lr) r of
                              Left _ -> Left ()
                              Right rr -> Right rr ||]
  -- Branch Distributivity Law
  Haskell (a -> a)
f :<$> Branch Comb repr (Either a b)
b Comb repr (a -> a)
l Comb repr (b -> a)
r ->
    -- trace "Branch Distributivity Law" $
    Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr (Either a b)
-> Comb repr (a -> a) -> Comb repr (b -> a) -> Comb repr a
forall (repr :: * -> *) a b c.
Comb repr (Either a b)
-> Comb repr (a -> c) -> Comb repr (b -> c) -> Comb repr c
Branch Comb repr (Either a b)
b (Comb repr (a -> a) -> Comb repr (a -> a)
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Haskell ((a -> a) -> (a -> a) -> a -> a)
-> Haskell (a -> a) -> Haskell ((a -> a) -> a -> a)
forall (repr :: * -> *) a b.
Haskellable repr =>
repr (a -> b) -> repr a -> repr b
(H..@) Haskell ((a -> a) -> (a -> a) -> a -> a)
forall (repr :: * -> *) b c a.
Haskellable repr =>
repr ((b -> c) -> (a -> b) -> a -> c)
(H..) Haskell (a -> a)
f Haskell ((a -> a) -> a -> a)
-> Comb repr (a -> a) -> Comb repr (a -> a)
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$> Comb repr (a -> a)
l))
                               (Comb repr (b -> a) -> Comb repr (b -> a)
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Haskell ((a -> a) -> (b -> a) -> b -> a)
-> Haskell (a -> a) -> Haskell ((b -> a) -> b -> a)
forall (repr :: * -> *) a b.
Haskellable repr =>
repr (a -> b) -> repr a -> repr b
(H..@) Haskell ((a -> a) -> (b -> a) -> b -> a)
forall (repr :: * -> *) b c a.
Haskellable repr =>
repr ((b -> c) -> (a -> b) -> a -> c)
(H..) Haskell (a -> a)
f Haskell ((b -> a) -> b -> a)
-> Comb repr (b -> a) -> Comb repr (b -> a)
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$> Comb repr (b -> a)
r)))

  -- Match Absorption Law
  Match [Haskell (a -> Bool)]
_ [Comb repr a]
_ Comb repr a
Empty Comb repr a
d ->
    -- trace "Match Absorption Law" $
    Comb repr a
d
  -- Match Weakening Law
  Match [Haskell (a -> Bool)]
_ [Comb repr a]
bs Comb repr a
a Comb repr a
Empty
    | (Comb repr a -> Bool) -> [Comb repr a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\case {Comb repr a
Empty -> Bool
True; Comb repr a
_ -> Bool
False}) [Comb repr a]
bs ->
      -- trace "Match Weakening Law" $
      Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a
a Comb repr a -> Comb repr a -> Comb repr a
forall (repr :: * -> *) b a.
Comb repr a -> Comb repr b -> Comb repr b
:*> Comb repr a
forall (repr :: * -> *) a. Comb repr a
Empty)
  -- Match Pure Law
  Match [Haskell (a -> Bool)]
ps [Comb repr a]
bs (Pure (Haskell a -> ValueCode a
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans -> ValueCode a
a)) Comb repr a
d ->
    -- trace "Match Pure Law" $
    ((Haskell (a -> Bool), Comb repr a) -> Comb repr a -> Comb repr a)
-> Comb repr a
-> [(Haskell (a -> Bool), Comb repr a)]
-> Comb repr a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Haskell (a -> Bool) -> ValueCode (a -> Bool)
forall (from :: * -> *) (to :: * -> *) a.
Trans from to =>
from a -> to a
trans -> ValueCode (a -> Bool)
p, Comb repr a
b) Comb repr a
next ->
      if ValueCode (a -> Bool) -> a -> Bool
forall a. ValueCode a -> a
getValue ValueCode (a -> Bool)
p (ValueCode a -> a
forall a. ValueCode a -> a
getValue ValueCode a
a) then Comb repr a
b else Comb repr a
next
    ) Comb repr a
d ([Haskell (a -> Bool)]
-> [Comb repr a] -> [(Haskell (a -> Bool), Comb repr a)]
forall a b. [a] -> [b] -> [(a, b)]
List.zip [Haskell (a -> Bool)]
ps [Comb repr a]
bs)
  -- Match Distributivity Law
  Haskell (a -> a)
f :<$> Match [Haskell (a -> Bool)]
ps [Comb repr a]
bs Comb repr a
a Comb repr a
d ->
    -- trace "Match Distributivity Law" $
    [Haskell (a -> Bool)]
-> [Comb repr a] -> Comb repr a -> Comb repr a -> Comb repr a
forall a (repr :: * -> *) b.
Eq a =>
[Haskell (a -> Bool)]
-> [Comb repr b] -> Comb repr a -> Comb repr b -> Comb repr b
Match [Haskell (a -> Bool)]
ps (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Comb repr a -> Comb repr a)
-> (Comb repr a -> Comb repr a) -> Comb repr a -> Comb repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Haskell (a -> a)
f Haskell (a -> a) -> Comb repr a -> Comb repr a
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$>) (Comb repr a -> Comb repr a) -> [Comb repr a] -> [Comb repr a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Functor.<$> [Comb repr a]
bs) Comb repr a
a
             (Comb repr a -> Comb repr a
forall (repr :: * -> *) a. Comb repr a -> Comb repr a
optimizeCombNode (Haskell (a -> a)
f Haskell (a -> a) -> Comb repr a -> Comb repr a
forall b (repr :: * -> *) a.
Haskell (a -> b) -> Comb repr a -> Comb repr b
:<$> Comb repr a
d))

  {- Possibly useless laws to be tested
  Empty  :*> _ -> Empty
  Empty :<*  _ -> Empty
  -- App Definition of *> Law
  H.Flip H..@ H.Const :<$> p :<*> q ->
    -- -- trace "EXTRALAW: App Definition of *> Law" $
    p :*> q
  -- App Definition of <* Law
  H.Const :<$> p :<*> q ->
    -- -- trace "EXTRALAW: App Definition of <* Law" $
    p :<* q

  -- Functor Composition Law
  -- (a shortcut that could also have been be caught
  -- by the Composition Law and Homomorphism Law)
  f :<$> (g :<$> p) ->
    -- -- trace "EXTRALAW: Functor Composition Law" $
    optimizeCombNode ((H.:.) H..@ f H..@ g :<$> p)
  -- Applicable Failure Weakening Law
  u :<*  Empty ->
    -- -- trace "EXTRALAW: App Failure Weakening Law" $
    optimizeCombNode (u :*> Empty)
  Try (p :$> x) ->
    -- -- trace "EXTRALAW: Try Interchange Right Law" $
    optimizeCombNode (optimizeCombNode (Try p) :$> x)
  -- App Reassociation Law 1
  (u :*> v) :<*> w ->
    -- -- trace "EXTRALAW: App Reassociation Law 1" $
    optimizeCombNode (u :*> optimizeCombNode (v :<*> w))
  -- App Reassociation Law 2
  u :<*> (v :<* w) ->
    -- -- trace "EXTRALAW: App Reassociation Law 2" $
    optimizeCombNode (optimizeCombNode (u :<*> v) :<* w)
  -- App Right Associativity Law
  u :*> (v :*> w) ->
    -- -- trace "EXTRALAW: App Right Associativity Law" $
    optimizeCombNode (optimizeCombNode (u :*> v) :*> w)
  -- App Reassociation Law 3
  u :<*> (v :$> x) ->
    -- -- trace "EXTRALAW: App Reassociation Law 3" $
    optimizeCombNode (optimizeCombNode (u :<*> Pure x) :<* v)

  Look (p :$> x) ->
    optimizeCombNode (optimizeCombNode (Look p) :$> x)
  NegLook (p :$> _) -> optimizeCombNode (NegLook p)

  -- NegLook Absorption Law
  p :<*> NegLook q ->
    -- trace "EXTRALAW: Neglook Absorption Law" $
    optimizeCombNode (optimizeCombNode (p :<*> Pure H.unit) :<* NegLook q)
    -- Infinite loop, because :<* expands to :<*>
  -}

  Comb repr a
x -> Comb repr a
x