{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE EmptyCase                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

module Language.Expression.Choice where
  -- (
  -- -- * Expressions
  --   HFree'(..)
  -- , _EVar'
  -- , _EOp'
  -- , squashExpression
  -- , eop'

  -- -- * HTraversable union
  -- , OpChoice(..)
  -- , ChooseOp(..)
  -- , SubsetOp(..)
  -- ) where

import           Data.Data

-- import           Data.Functor.Classes

import           Data.Union

import           Control.Lens         hiding (op)

import           Language.Expression

--------------------------------------------------------------------------------
--  Operator List Union
--------------------------------------------------------------------------------

-- | Form the union of a list of operators. This creates an operator which is a
-- choice from one of its constituents.
--
-- For example, @'OpChoice' '[NumOp, EqOp]@ is an operator that can either
-- represent an arithmetic operation or an equality comparison.
data OpChoice ops (t :: * -> *) a where
  OpThis :: op t a -> OpChoice (op : ops) t a
  OpThat :: OpChoice ops t a -> OpChoice (op : ops) t a
  deriving (Typeable)

_OpThis :: Prism' (OpChoice (op : ops) t a) (op t a)
_OpThis :: forall (op :: (* -> *) -> * -> *) (ops :: [(* -> *) -> * -> *])
       (t :: * -> *) a.
Prism' (OpChoice (op : ops) t a) (op t a)
_OpThis = (op t a -> OpChoice (op : ops) t a)
-> (OpChoice (op : ops) t a -> Maybe (op t a))
-> Prism
     (OpChoice (op : ops) t a)
     (OpChoice (op : ops) t a)
     (op t a)
     (op t a)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' op t a -> OpChoice (op : ops) t a
forall (ops :: (* -> *) -> * -> *) (t :: * -> *) a
       (op :: [(* -> *) -> * -> *]).
ops t a -> OpChoice (ops : op) t a
OpThis ((OpChoice (op : ops) t a -> Maybe (op t a))
 -> p (op t a) (f (op t a))
 -> p (OpChoice (op : ops) t a) (f (OpChoice (op : ops) t a)))
-> (OpChoice (op : ops) t a -> Maybe (op t a))
-> p (op t a) (f (op t a))
-> p (OpChoice (op : ops) t a) (f (OpChoice (op : ops) t a))
forall a b. (a -> b) -> a -> b
$ \case
  OpThis op t a
x -> op t a -> Maybe (op t a)
forall a. a -> Maybe a
Just op t a
x
  OpThat OpChoice ops t a
_ -> Maybe (op t a)
forall a. Maybe a
Nothing

_OpThat :: Prism' (OpChoice (op : ops) t a) (OpChoice ops t a)
_OpThat :: forall (op :: (* -> *) -> * -> *) (ops :: [(* -> *) -> * -> *])
       (t :: * -> *) a.
Prism' (OpChoice (op : ops) t a) (OpChoice ops t a)
_OpThat = (OpChoice ops t a -> OpChoice (op : ops) t a)
-> (OpChoice (op : ops) t a -> Maybe (OpChoice ops t a))
-> Prism
     (OpChoice (op : ops) t a)
     (OpChoice (op : ops) t a)
     (OpChoice ops t a)
     (OpChoice ops t a)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' OpChoice ops t a -> OpChoice (op : ops) t a
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a
       (op :: (* -> *) -> * -> *).
OpChoice ops t a -> OpChoice (op : ops) t a
OpThat ((OpChoice (op : ops) t a -> Maybe (OpChoice ops t a))
 -> p (OpChoice ops t a) (f (OpChoice ops t a))
 -> p (OpChoice (op : ops) t a) (f (OpChoice (op : ops) t a)))
-> (OpChoice (op : ops) t a -> Maybe (OpChoice ops t a))
-> p (OpChoice ops t a) (f (OpChoice ops t a))
-> p (OpChoice (op : ops) t a) (f (OpChoice (op : ops) t a))
forall a b. (a -> b) -> a -> b
$ \case
  OpThis op t a
_ -> Maybe (OpChoice ops t a)
forall a. Maybe a
Nothing
  OpThat OpChoice ops t a
x -> OpChoice ops t a -> Maybe (OpChoice ops t a)
forall a. a -> Maybe a
Just OpChoice ops t a
x

noOps :: OpChoice '[] t a -> x
noOps :: forall (t :: * -> *) a x. OpChoice '[] t a -> x
noOps = OpChoice '[] t a -> x
\case

instance HFunctor (OpChoice '[]) where
  hmap :: forall (t :: * -> *) (t' :: * -> *) a.
(forall b. t b -> t' b) -> OpChoice '[] t a -> OpChoice '[] t' a
hmap forall b. t b -> t' b
_ = OpChoice '[] t a -> OpChoice '[] t' a
forall (t :: * -> *) a x. OpChoice '[] t a -> x
noOps

instance HTraversable (OpChoice '[]) where
  htraverse :: forall (f :: * -> *) (t :: * -> *) (t' :: * -> *) a.
Applicative f =>
(forall b. t b -> f (t' b))
-> OpChoice '[] t a -> f (OpChoice '[] t' a)
htraverse forall b. t b -> f (t' b)
_ = OpChoice '[] t a -> f (OpChoice '[] t' a)
forall (t :: * -> *) a x. OpChoice '[] t a -> x
noOps

instance HFoldableAt k (OpChoice '[]) where
  hfoldMap :: forall (t :: * -> *) a.
(forall b. t b -> k b) -> OpChoice '[] t a -> k a
hfoldMap forall b. t b -> k b
_ = OpChoice '[] t a -> k a
forall (t :: * -> *) a x. OpChoice '[] t a -> x
noOps

-- instance HEq (OpChoice '[]) where
--   liftHEq _ _ _ = noOps

instance (HFunctor op, HFunctor (OpChoice ops)) =>
  HFunctor (OpChoice (op : ops)) where

  hmap :: forall (t :: * -> *) (t' :: * -> *) a.
(forall b. t b -> t' b)
-> OpChoice (op : ops) t a -> OpChoice (op : ops) t' a
hmap forall b. t b -> t' b
f = \case
    OpThis op t a
x -> op t' a -> OpChoice (op : ops) t' a
forall (ops :: (* -> *) -> * -> *) (t :: * -> *) a
       (op :: [(* -> *) -> * -> *]).
ops t a -> OpChoice (ops : op) t a
OpThis ((forall b. t b -> t' b) -> op t a -> op t' a
forall u (h :: (u -> *) -> u -> *) (t :: u -> *) (t' :: u -> *)
       (a :: u).
HFunctor h =>
(forall (b :: u). t b -> t' b) -> h t a -> h t' a
hmap forall b. t b -> t' b
f op t a
x)
    OpThat OpChoice ops t a
x -> OpChoice ops t' a -> OpChoice (op : ops) t' a
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a
       (op :: (* -> *) -> * -> *).
OpChoice ops t a -> OpChoice (op : ops) t a
OpThat ((forall b. t b -> t' b) -> OpChoice ops t a -> OpChoice ops t' a
forall u (h :: (u -> *) -> u -> *) (t :: u -> *) (t' :: u -> *)
       (a :: u).
HFunctor h =>
(forall (b :: u). t b -> t' b) -> h t a -> h t' a
hmap forall b. t b -> t' b
f OpChoice ops t a
x)

instance (HTraversable op, HTraversable (OpChoice ops)) =>
  HTraversable (OpChoice (op : ops)) where

  htraverse :: forall (f :: * -> *) (t :: * -> *) (t' :: * -> *) a.
Applicative f =>
(forall b. t b -> f (t' b))
-> OpChoice (op : ops) t a -> f (OpChoice (op : ops) t' a)
htraverse forall b. t b -> f (t' b)
f = \case
    OpThis op t a
x -> op t' a -> OpChoice (op : ops) t' a
forall (ops :: (* -> *) -> * -> *) (t :: * -> *) a
       (op :: [(* -> *) -> * -> *]).
ops t a -> OpChoice (ops : op) t a
OpThis (op t' a -> OpChoice (op : ops) t' a)
-> f (op t' a) -> f (OpChoice (op : ops) t' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. t b -> f (t' b)) -> op t a -> f (op t' a)
forall {u} (h :: (u -> *) -> u -> *) (f :: * -> *) (t :: u -> *)
       (t' :: u -> *) (a :: u).
(HTraversable h, Applicative f) =>
(forall (b :: u). t b -> f (t' b)) -> h t a -> f (h t' a)
htraverse forall b. t b -> f (t' b)
f op t a
x
    OpThat OpChoice ops t a
x -> OpChoice ops t' a -> OpChoice (op : ops) t' a
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a
       (op :: (* -> *) -> * -> *).
OpChoice ops t a -> OpChoice (op : ops) t a
OpThat (OpChoice ops t' a -> OpChoice (op : ops) t' a)
-> f (OpChoice ops t' a) -> f (OpChoice (op : ops) t' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. t b -> f (t' b))
-> OpChoice ops t a -> f (OpChoice ops t' a)
forall {u} (h :: (u -> *) -> u -> *) (f :: * -> *) (t :: u -> *)
       (t' :: u -> *) (a :: u).
(HTraversable h, Applicative f) =>
(forall (b :: u). t b -> f (t' b)) -> h t a -> f (h t' a)
htraverse forall b. t b -> f (t' b)
f OpChoice ops t a
x

instance (HFoldableAt k op, HFoldableAt k (OpChoice ops)) =>
  HFoldableAt k (OpChoice (op : ops)) where

  hfoldMap :: forall (t :: * -> *) a.
(forall b. t b -> k b) -> OpChoice (op : ops) t a -> k a
hfoldMap forall b. t b -> k b
f = \case
    OpThis op t a
x -> (forall b. t b -> k b) -> op t a -> k a
forall {k} (k :: k -> *) (h :: (k -> *) -> k -> *) (t :: k -> *)
       (a :: k).
HFoldableAt k h =>
(forall (b :: k). t b -> k b) -> h t a -> k a
hfoldMap forall b. t b -> k b
f op t a
x
    OpThat OpChoice ops t a
x -> (forall b. t b -> k b) -> OpChoice ops t a -> k a
forall {k} (k :: k -> *) (h :: (k -> *) -> k -> *) (t :: k -> *)
       (a :: k).
HFoldableAt k h =>
(forall (b :: k). t b -> k b) -> h t a -> k a
hfoldMap forall b. t b -> k b
f OpChoice ops t a
x

-- instance (HEq op, HEq (OpChoice ops)) =>
--   HEq (OpChoice (op : ops)) where

--   liftHEq le eq (OpThis x) (OpThis y) = liftHEq le eq x y
--   liftHEq le eq (OpThat x) (OpThat y) = liftHEq le eq x y
--   liftHEq _ _ _ _ = False


-- instance (HEq (OpChoice ops), Eq1 t) => Eq1 (OpChoice ops t) where
--   liftEq = liftLiftEq
-- instance (Eq1 (OpChoice ops t), Eq a) => Eq (OpChoice ops t a) where
--   (==) = liftEq (==)


newtype AsOp (t :: * -> *) a op = AsOp (op t a)

makeWrapped ''AsOp

choiceToUnion :: OpChoice ops t a -> Union (AsOp t a) ops
choiceToUnion :: forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a.
OpChoice ops t a -> Union (AsOp t a) ops
choiceToUnion = \case
  OpThis op t a
x -> AsOp t a op -> Union (AsOp t a) (op : ops)
forall {u} (f :: u -> *) (a :: u) (as1 :: [u]).
f a -> Union f (a : as1)
This (op t a -> AsOp t a op
forall (t :: * -> *) a (op :: (* -> *) -> * -> *).
op t a -> AsOp t a op
AsOp op t a
x)
  OpThat OpChoice ops t a
x -> Union (AsOp t a) ops -> Union (AsOp t a) (op : ops)
forall {u} (f :: u -> *) (as1 :: [u]) (a :: u).
Union f as1 -> Union f (a : as1)
That (OpChoice ops t a -> Union (AsOp t a) ops
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a.
OpChoice ops t a -> Union (AsOp t a) ops
choiceToUnion OpChoice ops t a
x)

unionToChoice :: Union (AsOp t a) ops -> OpChoice ops t a
unionToChoice :: forall (t :: * -> *) a (ops :: [(* -> *) -> * -> *]).
Union (AsOp t a) ops -> OpChoice ops t a
unionToChoice = \case
  This (AsOp a t a
x) -> a t a -> OpChoice (a : as1) t a
forall (ops :: (* -> *) -> * -> *) (t :: * -> *) a
       (op :: [(* -> *) -> * -> *]).
ops t a -> OpChoice (ops : op) t a
OpThis a t a
x
  That Union (AsOp t a) as1
x -> OpChoice as1 t a -> OpChoice (a : as1) t a
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a
       (op :: (* -> *) -> * -> *).
OpChoice ops t a -> OpChoice (op : ops) t a
OpThat (Union (AsOp t a) as1 -> OpChoice as1 t a
forall (t :: * -> *) a (ops :: [(* -> *) -> * -> *]).
Union (AsOp t a) ops -> OpChoice ops t a
unionToChoice Union (AsOp t a) as1
x)

_OpChoice
  :: Iso (OpChoice ops t a) (OpChoice ops' t' a')
         (Union (AsOp t a) ops) (Union (AsOp t' a') ops')
_OpChoice :: forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a
       (ops' :: [(* -> *) -> * -> *]) (t' :: * -> *) a'.
Iso
  (OpChoice ops t a)
  (OpChoice ops' t' a')
  (Union (AsOp t a) ops)
  (Union (AsOp t' a') ops')
_OpChoice = (OpChoice ops t a -> Union (AsOp t a) ops)
-> (Union (AsOp t' a') ops' -> OpChoice ops' t' a')
-> Iso
     (OpChoice ops t a)
     (OpChoice ops' t' a')
     (Union (AsOp t a) ops)
     (Union (AsOp t' a') ops')
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso OpChoice ops t a -> Union (AsOp t a) ops
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a.
OpChoice ops t a -> Union (AsOp t a) ops
choiceToUnion Union (AsOp t' a') ops' -> OpChoice ops' t' a'
forall (t :: * -> *) a (ops :: [(* -> *) -> * -> *]).
Union (AsOp t a) ops -> OpChoice ops t a
unionToChoice


-- | This class provides a low-boilerplate way of lifting individual operators
-- into a union, and extracting operators from a union.
class ChooseOp op ops where
  -- | Project a single operator from a union which contains it.
  chooseOp :: Prism' (OpChoice ops t a) (op t a)

instance UElem op ops i => ChooseOp op ops where
  chooseOp :: forall (t :: * -> *) a. Prism' (OpChoice ops t a) (op t a)
chooseOp = p (Union (AsOp t a) ops) (f (Union (AsOp t a) ops))
-> p (OpChoice ops t a) (f (OpChoice ops t a))
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a
       (ops' :: [(* -> *) -> * -> *]) (t' :: * -> *) a'.
Iso
  (OpChoice ops t a)
  (OpChoice ops' t' a')
  (Union (AsOp t a) ops)
  (Union (AsOp t' a') ops')
_OpChoice (p (Union (AsOp t a) ops) (f (Union (AsOp t a) ops))
 -> p (OpChoice ops t a) (f (OpChoice ops t a)))
-> (p (op t a) (f (op t a))
    -> p (Union (AsOp t a) ops) (f (Union (AsOp t a) ops)))
-> p (op t a) (f (op t a))
-> p (OpChoice ops t a) (f (OpChoice ops t a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (AsOp t a op) (f (AsOp t a op))
-> p (Union (AsOp t a) ops) (f (Union (AsOp t a) ops))
forall u (a :: u) (as :: [u]) (i :: Nat) (f :: u -> *).
UElem a as i =>
Prism' (Union f as) (f a)
uprism (p (AsOp t a op) (f (AsOp t a op))
 -> p (Union (AsOp t a) ops) (f (Union (AsOp t a) ops)))
-> (p (op t a) (f (op t a)) -> p (AsOp t a op) (f (AsOp t a op)))
-> p (op t a) (f (op t a))
-> p (Union (AsOp t a) ops) (f (Union (AsOp t a) ops))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (op t a) (f (op t a)) -> p (AsOp t a op) (f (AsOp t a op))
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped


class SubsetOp ops1 ops2 where
  subsetOp :: Prism' (OpChoice ops2 t a) (OpChoice ops1 t a)

instance USubset ops1 ops2 is => SubsetOp ops1 ops2 where
  subsetOp :: forall (t :: * -> *) a.
Prism' (OpChoice ops2 t a) (OpChoice ops1 t a)
subsetOp = p (Union (AsOp t a) ops2) (f (Union (AsOp t a) ops2))
-> p (OpChoice ops2 t a) (f (OpChoice ops2 t a))
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a
       (ops' :: [(* -> *) -> * -> *]) (t' :: * -> *) a'.
Iso
  (OpChoice ops t a)
  (OpChoice ops' t' a')
  (Union (AsOp t a) ops)
  (Union (AsOp t' a') ops')
_OpChoice (p (Union (AsOp t a) ops2) (f (Union (AsOp t a) ops2))
 -> p (OpChoice ops2 t a) (f (OpChoice ops2 t a)))
-> (p (OpChoice ops1 t a) (f (OpChoice ops1 t a))
    -> p (Union (AsOp t a) ops2) (f (Union (AsOp t a) ops2)))
-> p (OpChoice ops1 t a) (f (OpChoice ops1 t a))
-> p (OpChoice ops2 t a) (f (OpChoice ops2 t a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (Union (AsOp t a) ops1) (f (Union (AsOp t a) ops1))
-> p (Union (AsOp t a) ops2) (f (Union (AsOp t a) ops2))
forall u (as :: [u]) (bs :: [u]) (is :: [Nat]) (f :: u -> *).
USubset as bs is =>
Prism' (Union f bs) (Union f as)
usubset (p (Union (AsOp t a) ops1) (f (Union (AsOp t a) ops1))
 -> p (Union (AsOp t a) ops2) (f (Union (AsOp t a) ops2)))
-> (p (OpChoice ops1 t a) (f (OpChoice ops1 t a))
    -> p (Union (AsOp t a) ops1) (f (Union (AsOp t a) ops1)))
-> p (OpChoice ops1 t a) (f (OpChoice ops1 t a))
-> p (Union (AsOp t a) ops2) (f (Union (AsOp t a) ops2))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnIso
  (OpChoice ops1 t a)
  (OpChoice ops1 t a)
  (Union (AsOp t a) ops1)
  (Union (AsOp t a) ops1)
-> Iso
     (Union (AsOp t a) ops1)
     (Union (AsOp t a) ops1)
     (OpChoice ops1 t a)
     (OpChoice ops1 t a)
forall s t a b. AnIso s t a b -> Iso b a t s
from AnIso
  (OpChoice ops1 t a)
  (OpChoice ops1 t a)
  (Union (AsOp t a) ops1)
  (Union (AsOp t a) ops1)
forall (ops :: [(* -> *) -> * -> *]) (t :: * -> *) a
       (ops' :: [(* -> *) -> * -> *]) (t' :: * -> *) a'.
Iso
  (OpChoice ops t a)
  (OpChoice ops' t' a')
  (Union (AsOp t a) ops)
  (Union (AsOp t' a') ops')
_OpChoice

--------------------------------------------------------------------------------
--  Expressions over a choice of operators
--------------------------------------------------------------------------------

-- | @'HFree'' ops v a@ is a higher-order free monad over the list of operators
-- @ops@ with variables in the type @v@ and it represents a value of type @a@.
--
-- Intuitively, it represents an expression which may contain operations from
-- any of the operators in the list @ops@.
newtype HFree' ops v a = HFree' { forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree' ops v a -> HFree (OpChoice ops) v a
getHFree' :: HFree (OpChoice ops) v a }
  deriving (Typeable)

deriving instance
         (Data (HFree (OpChoice ops) v a), Typeable (HFree' ops v a)) =>
         Data (HFree' ops v a)

-- instance (HEq (OpChoice ops)) => HEq (HFree' ops) where
--   liftHEq le eq (HFree' x) (HFree' y) = liftHEq le eq x y

-- instance (Eq1 v, HEq (OpChoice ops)) => Eq1 (HFree' ops v) where
--   liftEq = liftLiftEq

-- instance (Eq1 v, HEq (OpChoice ops), Eq a) => Eq (HFree' ops v a) where
--   (==) = eq1


-- TODO: Figure out type roles so these instances can be derived by
-- GeneralizedNewtypeDeriving

instance (HFunctor (OpChoice ops)) => HFunctor (HFree' ops) where
  hmap :: forall (t :: * -> *) (t' :: * -> *) a.
(forall b. t b -> t' b) -> HFree' ops t a -> HFree' ops t' a
hmap forall b. t b -> t' b
f = HFree (OpChoice ops) t' a -> HFree' ops t' a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree (OpChoice ops) v a -> HFree' ops v a
HFree' (HFree (OpChoice ops) t' a -> HFree' ops t' a)
-> (HFree' ops t a -> HFree (OpChoice ops) t' a)
-> HFree' ops t a
-> HFree' ops t' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. t b -> t' b)
-> HFree (OpChoice ops) t a -> HFree (OpChoice ops) t' a
forall u (h :: (u -> *) -> u -> *) (t :: u -> *) (t' :: u -> *)
       (a :: u).
HFunctor h =>
(forall (b :: u). t b -> t' b) -> h t a -> h t' a
hmap forall b. t b -> t' b
f (HFree (OpChoice ops) t a -> HFree (OpChoice ops) t' a)
-> (HFree' ops t a -> HFree (OpChoice ops) t a)
-> HFree' ops t a
-> HFree (OpChoice ops) t' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HFree' ops t a -> HFree (OpChoice ops) t a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree' ops v a -> HFree (OpChoice ops) v a
getHFree'

instance (HTraversable (OpChoice ops)) => HTraversable (HFree' ops) where
  htraverse :: forall (f :: * -> *) (t :: * -> *) (t' :: * -> *) a.
Applicative f =>
(forall b. t b -> f (t' b))
-> HFree' ops t a -> f (HFree' ops t' a)
htraverse forall b. t b -> f (t' b)
f = (HFree (OpChoice ops) t' a -> HFree' ops t' a)
-> f (HFree (OpChoice ops) t' a) -> f (HFree' ops t' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HFree (OpChoice ops) t' a -> HFree' ops t' a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree (OpChoice ops) v a -> HFree' ops v a
HFree' (f (HFree (OpChoice ops) t' a) -> f (HFree' ops t' a))
-> (HFree' ops t a -> f (HFree (OpChoice ops) t' a))
-> HFree' ops t a
-> f (HFree' ops t' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. t b -> f (t' b))
-> HFree (OpChoice ops) t a -> f (HFree (OpChoice ops) t' a)
forall {u} (h :: (u -> *) -> u -> *) (f :: * -> *) (t :: u -> *)
       (t' :: u -> *) (a :: u).
(HTraversable h, Applicative f) =>
(forall (b :: u). t b -> f (t' b)) -> h t a -> f (h t' a)
htraverse forall b. t b -> f (t' b)
f (HFree (OpChoice ops) t a -> f (HFree (OpChoice ops) t' a))
-> (HFree' ops t a -> HFree (OpChoice ops) t a)
-> HFree' ops t a
-> f (HFree (OpChoice ops) t' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HFree' ops t a -> HFree (OpChoice ops) t a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree' ops v a -> HFree (OpChoice ops) v a
getHFree'

instance HPointed (HFree' ops) where
  hpure :: forall (t :: * -> *) a. t a -> HFree' ops t a
hpure = HFree (OpChoice ops) t a -> HFree' ops t a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree (OpChoice ops) v a -> HFree' ops v a
HFree' (HFree (OpChoice ops) t a -> HFree' ops t a)
-> (t a -> HFree (OpChoice ops) t a) -> t a -> HFree' ops t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> HFree (OpChoice ops) t a
forall {k} (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
HPointed h =>
t a -> h t a
hpure

instance (HFunctor (OpChoice ops)) => HBind (HFree' ops) where
  HFree' ops t a
x ^>>= :: forall (t :: * -> *) a (t' :: * -> *).
HFree' ops t a
-> (forall b. t b -> HFree' ops t' b) -> HFree' ops t' a
^>>= forall b. t b -> HFree' ops t' b
f = (HFree (OpChoice ops) t' a -> HFree' ops t' a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree (OpChoice ops) v a -> HFree' ops v a
HFree' (HFree (OpChoice ops) t' a -> HFree' ops t' a)
-> (HFree' ops t a -> HFree (OpChoice ops) t' a)
-> HFree' ops t a
-> HFree' ops t' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HFree (OpChoice ops) t a
-> (forall b. t b -> HFree (OpChoice ops) t' b)
-> HFree (OpChoice ops) t' a
forall {k} (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k)
       (t' :: k -> *).
HBind h =>
h t a -> (forall (b :: k). t b -> h t' b) -> h t' a
^>>= (HFree' ops t' b -> HFree (OpChoice ops) t' b
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree' ops v a -> HFree (OpChoice ops) v a
getHFree' (HFree' ops t' b -> HFree (OpChoice ops) t' b)
-> (t b -> HFree' ops t' b) -> t b -> HFree (OpChoice ops) t' b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t b -> HFree' ops t' b
forall b. t b -> HFree' ops t' b
f)) (HFree (OpChoice ops) t a -> HFree (OpChoice ops) t' a)
-> (HFree' ops t a -> HFree (OpChoice ops) t a)
-> HFree' ops t a
-> HFree (OpChoice ops) t' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HFree' ops t a -> HFree (OpChoice ops) t a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree' ops v a -> HFree (OpChoice ops) v a
getHFree') HFree' ops t a
x

instance (HFunctor (OpChoice ops)) => HMonad (HFree' ops) where

instance (HFoldableAt k (OpChoice ops), HFunctor (OpChoice ops)) =>
         HFoldableAt k (HFree' ops) where
  hfoldMap :: forall (t :: * -> *) a.
(forall b. t b -> k b) -> HFree' ops t a -> k a
hfoldMap forall b. t b -> k b
f (HFree' HFree (OpChoice ops) t a
x) = (forall b. t b -> k b) -> HFree (OpChoice ops) t a -> k a
forall {k} (k :: k -> *) (h :: (k -> *) -> k -> *) (t :: k -> *)
       (a :: k).
HFoldableAt k h =>
(forall (b :: k). t b -> k b) -> h t a -> k a
hfoldMap forall b. t b -> k b
f HFree (OpChoice ops) t a
x

-- | Squash a composition of expressions over different operators into a
-- single-layered expression over a choice of the two operators.
squashExpression
  :: (HFunctor op1,
      HFunctor op2,
      HFunctor (OpChoice ops),
      ChooseOp op1 ops,
      ChooseOp op2 ops)
  => HFree op1 (HFree op2 v) a -> HFree' ops v a
squashExpression :: forall (op1 :: (* -> *) -> * -> *) (op2 :: (* -> *) -> * -> *)
       (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
(HFunctor op1, HFunctor op2, HFunctor (OpChoice ops),
 ChooseOp op1 ops, ChooseOp op2 ops) =>
HFree op1 (HFree op2 v) a -> HFree' ops v a
squashExpression
  = HFree (OpChoice ops) v a -> HFree' ops v a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree (OpChoice ops) v a -> HFree' ops v a
HFree'
  (HFree (OpChoice ops) v a -> HFree' ops v a)
-> (HFree op1 (HFree op2 v) a -> HFree (OpChoice ops) v a)
-> HFree op1 (HFree op2 v) a
-> HFree' ops v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HFree (OpChoice ops) (HFree (OpChoice ops) v) a
-> HFree (OpChoice ops) v a
forall {k} (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
HBind h =>
h (h t) a -> h t a
hjoin
  (HFree (OpChoice ops) (HFree (OpChoice ops) v) a
 -> HFree (OpChoice ops) v a)
-> (HFree op1 (HFree op2 v) a
    -> HFree (OpChoice ops) (HFree (OpChoice ops) v) a)
-> HFree op1 (HFree op2 v) a
-> HFree (OpChoice ops) v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. HFree op2 v b -> HFree (OpChoice ops) v b)
-> HFree (OpChoice ops) (HFree op2 v) a
-> HFree (OpChoice ops) (HFree (OpChoice ops) v) a
forall u (h :: (u -> *) -> u -> *) (t :: u -> *) (t' :: u -> *)
       (a :: u).
HFunctor h =>
(forall (b :: u). t b -> t' b) -> h t a -> h t' a
hmap ((forall (g :: * -> *) b. op2 g b -> OpChoice ops g b)
-> HFree op2 v b -> HFree (OpChoice ops) v b
forall {u} (h :: ((u -> *) -> u -> *) -> (u -> *) -> u -> *)
       (s :: (u -> *) -> u -> *) (s' :: (u -> *) -> u -> *) (t :: u -> *)
       (a :: u).
(HDuofunctor h, HFunctor s) =>
(forall (g :: u -> *) (b :: u). s g b -> s' g b)
-> h s t a -> h s' t a
hduomapFirst' (AReview (OpChoice ops g b) (op2 g b) -> op2 g b -> OpChoice ops g b
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview (OpChoice ops g b) (op2 g b)
forall (op :: (* -> *) -> * -> *) (ops :: [(* -> *) -> * -> *])
       (t :: * -> *) a.
ChooseOp op ops =>
Prism' (OpChoice ops t a) (op t a)
chooseOp))
  (HFree (OpChoice ops) (HFree op2 v) a
 -> HFree (OpChoice ops) (HFree (OpChoice ops) v) a)
-> (HFree op1 (HFree op2 v) a
    -> HFree (OpChoice ops) (HFree op2 v) a)
-> HFree op1 (HFree op2 v) a
-> HFree (OpChoice ops) (HFree (OpChoice ops) v) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (g :: * -> *) b. op1 g b -> OpChoice ops g b)
-> HFree op1 (HFree op2 v) a
-> HFree (OpChoice ops) (HFree op2 v) a
forall {u} (h :: ((u -> *) -> u -> *) -> (u -> *) -> u -> *)
       (s :: (u -> *) -> u -> *) (s' :: (u -> *) -> u -> *) (t :: u -> *)
       (a :: u).
(HDuofunctor h, HFunctor s) =>
(forall (g :: u -> *) (b :: u). s g b -> s' g b)
-> h s t a -> h s' t a
hduomapFirst' (AReview (OpChoice ops g b) (op1 g b) -> op1 g b -> OpChoice ops g b
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview (OpChoice ops g b) (op1 g b)
forall (op :: (* -> *) -> * -> *) (ops :: [(* -> *) -> * -> *])
       (t :: * -> *) a.
ChooseOp op ops =>
Prism' (OpChoice ops t a) (op t a)
chooseOp)
  -- (review chooseOp)

hwrap'
  :: (HFunctor op, HFunctor (OpChoice ops), ChooseOp op ops)
  => op (HFree' ops v) a -> HFree' ops v a
hwrap' :: forall (op :: (* -> *) -> * -> *) (ops :: [(* -> *) -> * -> *])
       (v :: * -> *) a.
(HFunctor op, HFunctor (OpChoice ops), ChooseOp op ops) =>
op (HFree' ops v) a -> HFree' ops v a
hwrap' = HFree (OpChoice ops) v a -> HFree' ops v a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree (OpChoice ops) v a -> HFree' ops v a
HFree' (HFree (OpChoice ops) v a -> HFree' ops v a)
-> (op (HFree' ops v) a -> HFree (OpChoice ops) v a)
-> op (HFree' ops v) a
-> HFree' ops v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpChoice ops (HFree (OpChoice ops) v) a -> HFree (OpChoice ops) v a
forall {k} (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
h (HFree h t) a -> HFree h t a
HWrap (OpChoice ops (HFree (OpChoice ops) v) a
 -> HFree (OpChoice ops) v a)
-> (op (HFree' ops v) a -> OpChoice ops (HFree (OpChoice ops) v) a)
-> op (HFree' ops v) a
-> HFree (OpChoice ops) v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AReview
  (OpChoice ops (HFree (OpChoice ops) v) a)
  (op (HFree (OpChoice ops) v) a)
-> op (HFree (OpChoice ops) v) a
-> OpChoice ops (HFree (OpChoice ops) v) a
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview
  (OpChoice ops (HFree (OpChoice ops) v) a)
  (op (HFree (OpChoice ops) v) a)
forall (op :: (* -> *) -> * -> *) (ops :: [(* -> *) -> * -> *])
       (t :: * -> *) a.
ChooseOp op ops =>
Prism' (OpChoice ops t a) (op t a)
chooseOp (op (HFree (OpChoice ops) v) a
 -> OpChoice ops (HFree (OpChoice ops) v) a)
-> (op (HFree' ops v) a -> op (HFree (OpChoice ops) v) a)
-> op (HFree' ops v) a
-> OpChoice ops (HFree (OpChoice ops) v) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. HFree' ops v b -> HFree (OpChoice ops) v b)
-> op (HFree' ops v) a -> op (HFree (OpChoice ops) v) a
forall u (h :: (u -> *) -> u -> *) (t :: u -> *) (t' :: u -> *)
       (a :: u).
HFunctor h =>
(forall (b :: u). t b -> t' b) -> h t a -> h t' a
hmap forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree' ops v a -> HFree (OpChoice ops) v a
forall b. HFree' ops v b -> HFree (OpChoice ops) v b
getHFree'

--------------------------------------------------------------------------------
--  Lenses
--------------------------------------------------------------------------------

makeWrapped ''HFree'