{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{-# OPTIONS_GHC -Wall #-}

-- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP
-- {-# OPTIONS_GHC -fno-warn-unused-binds   #-} -- TEMP

#define SpecialPair

----------------------------------------------------------------------
-- | Uniform pairs
----------------------------------------------------------------------

module ConCat.Pair
  (
#ifdef SpecialPair
    Pair(..)
#else
    Pair
#endif
  -- , pattern (:#)
  ) where

-- import GHC.Generics (Par1(..),(:*:)(..))
#ifdef SpecialPair
-- import GHC.Generics (Generic1(..))
#endif

#ifdef SpecialPair
import Prelude hiding (zipWith)

import Data.Monoid ((<>))
import Control.Applicative (liftA2)
import Data.Key
import Data.Pointed
import Data.Distributive (Distributive(..))
import Data.Functor.Rep (Representable(tabulate,index),distributeRep)
import qualified Data.Functor.Rep as R
import Control.Newtype.Generics (Newtype(..))
import Data.Constraint (Dict(..),(:-)(..))

import ConCat.Misc ((:*))
import ConCat.Rep (HasRep(..))
import ConCat.Additive (Additive(..))
import ConCat.Sized
import ConCat.Scan
import ConCat.Circuit ((:>),GenBuses(..),Buses(..),BusesM,Ty(..),abstB)
import ConCat.Free.VectorSpace (HasV(..))
import ConCat.AltCat (type (|-)(..),Additive1(..),OkFunctor(..))
#endif

#ifndef SpecialPair

-- | Uniform pair
type Pair = Par1 :*: Par1

pattern (:#) :: a -> a -> Pair a
pattern x :# y = Par1 x :*: Par1 y

#else

-- type GPair = Par1 :*: Par1

-- newtype Pair a = Pair (GPair a)

-- instance Newtype (Pair a) where
--   type O (Pair a) = GPair a
--   pack as = Pair as
--   unpack (Pair as) = as

-- instance Generic1 Pair where
--   type Rep1 Pair = GPair
--   to1 p = Pair p
--   from1 (Pair p) = p

infixl 1 :#

data Pair a = a :# a

instance Newtype (Pair a) where
  type O (Pair a) = a :* a
  pack :: O (Pair a) -> Pair a
pack (a
a,a
a') = a
a a -> a -> Pair a
forall a. a -> a -> Pair a
:# a
a'
  unpack :: Pair a -> O (Pair a)
unpack (a
a :# a
a') = (a
a,a
a')

instance Additive1 Pair where additive1 :: forall a. Sat Additive a |- Sat Additive (Pair a)
additive1 = (Con (Sat Additive a) :- Con (Sat Additive (Pair a)))
-> Sat Additive a |- Sat Additive (Pair a)
forall a b. (Con a :- Con b) -> a |- b
Entail ((Additive a => Dict (Additive (Pair a)))
-> Additive a :- Additive (Pair a)
forall (a :: Constraint) (b :: Constraint). (a => Dict b) -> a :- b
Sub Dict (Additive (Pair a))
Additive a => Dict (Additive (Pair a))
forall (a :: Constraint). a => Dict a
Dict)

-- pattern (:#) :: a -> a -> Pair a
-- pattern x :# y = Pair (Par1 x :*: Par1 y)

instance Show a => Show (Pair a) where
  showsPrec :: Int -> Pair a -> ShowS
showsPrec Int
p = \ (a
x :# a
y) -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
1 a
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" :# " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
1 a
y

instance HasRep (Pair a) where
  type Rep (Pair a) = a :* a
  -- repr (a :# a') = (a,a')  -- *
  repr :: Pair a -> Rep (Pair a)
repr = \ (a
a :# a
a') -> (a
a,a
a')
  abst :: Rep (Pair a) -> Pair a
abst (a
a,a
a') = a
a a -> a -> Pair a
forall a. a -> a -> Pair a
:# a
a'

-- * GHC 8.0.2 objects to the first version of repr:
-- 
--     Pattern match(es) are non-exhaustive
--     In an equation for ‘repr’: Patterns not matched: _
--
-- TODO: try again with a later GHC.

deriving instance Functor Pair
deriving instance Foldable Pair
deriving instance Traversable Pair

-- deriving instance Applicative Pair
-- deriving instance Monad Pair
-- deriving instance Pointed Pair

instance Pointed Pair where point :: forall a. a -> Pair a
point a
a = a
a a -> a -> Pair a
forall a. a -> a -> Pair a
:# a
a

instance Zip Pair where
  zipWith :: forall a b c. (a -> b -> c) -> Pair a -> Pair b -> Pair c
zipWith a -> b -> c
f (a
a :# a
a') (b
b :# b
b') = a -> b -> c
f a
a b
b c -> c -> Pair c
forall a. a -> a -> Pair a
:# a -> b -> c
f a
a' b
b'

instance Applicative Pair where
  pure :: forall a. a -> Pair a
pure = a -> Pair a
forall a. a -> Pair a
forall (p :: * -> *) a. Pointed p => a -> p a
point
  <*> :: forall a b. Pair (a -> b) -> Pair a -> Pair b
(<*>) = ((a -> b) -> a -> b) -> Pair (a -> b) -> Pair a -> Pair b
forall a b c. (a -> b -> c) -> Pair a -> Pair b -> Pair c
forall (f :: * -> *) a b c.
Zip f =>
(a -> b -> c) -> f a -> f b -> f c
zipWith (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)

-- instance Monad Pair where ...

instance Additive a => Additive (Pair a)

-- instance Distributive Pair where
--   distribute ps = pack (distribute (unpack <$> ps))

-- instance Representable Pair where
--   type Rep Pair = R.Rep GPair
--   tabulate f = Pair (tabulate f)
--   index (Pair xs) = R.index xs

instance Distributive Pair where
  distribute :: forall (f :: * -> *) a. Functor f => f (Pair a) -> Pair (f a)
distribute = f (Pair a) -> Pair (f a)
forall (f :: * -> *) (w :: * -> *) a.
(Representable f, Functor w) =>
w (f a) -> f (w a)
distributeRep

instance Representable Pair where
  type Rep Pair = Bool
  tabulate :: forall a. (Rep Pair -> a) -> Pair a
tabulate Rep Pair -> a
f = Rep Pair -> a
f Bool
Rep Pair
False a -> a -> Pair a
forall a. a -> a -> Pair a
:# Rep Pair -> a
f Bool
Rep Pair
True
  index :: forall a. Pair a -> Rep Pair -> a
index (a
f :# a
t) Rep Pair
c = if Bool
Rep Pair
c then a
t else a
f

instance HasV s a => HasV s (Pair a)

-- -- "Ambiguous type variable ‘f0’ arising from a use of ‘size’"
-- deriving instance Sized Pair

instance Sized Pair where size :: Int
size = Int
2

instance GenBuses a => GenBuses (Pair a) where
  genBuses' :: forall u v. Template u v -> [Source] -> BusesM (Buses (Pair a))
genBuses' Template u v
prim [Source]
ins = Buses (a :* a) -> Buses (Pair a)
Buses (Rep (Pair a)) -> Buses (Pair a)
forall a. OkCAR a => Buses (Rep a) -> Buses a
abstB (Buses (a :* a) -> Buses (Pair a))
-> StateT Int CircuitM (Buses (a :* a)) -> BusesM (Buses (Pair a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Buses a -> Buses a -> Buses (a :* a)
forall a1 b. Ok2 (:>) a1 b => Buses a1 -> Buses b -> Buses (a1, b)
ProdB (Buses a -> Buses a -> Buses (a :* a))
-> StateT Int CircuitM (Buses a)
-> StateT Int CircuitM (Buses a -> Buses (a :* a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Int CircuitM (Buses a)
gb StateT Int CircuitM (Buses a -> Buses (a :* a))
-> StateT Int CircuitM (Buses a)
-> StateT Int CircuitM (Buses (a :* a))
forall a b.
StateT Int CircuitM (a -> b)
-> StateT Int CircuitM a -> StateT Int CircuitM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT Int CircuitM (Buses a)
gb)
   where
     gb :: BusesM (Buses a)
     gb :: StateT Int CircuitM (Buses a)
gb = Template u v -> [Source] -> StateT Int CircuitM (Buses a)
forall a u v.
GenBuses a =>
Template u v -> [Source] -> BusesM (Buses a)
forall u v.
Template u v -> [Source] -> StateT Int CircuitM (Buses a)
genBuses' Template u v
prim [Source]
ins
     {-# NOINLINE gb #-}
  ty :: Ty
ty = Ty -> Ty -> Ty
Prod Ty
t Ty
t
   where
     t :: Ty
t = forall a. GenBuses a => Ty
ty @a
     {-# NOINLINE t #-}
  unflattenB' :: State [Source] (Buses (Pair a))
unflattenB' = Buses (a :* a) -> Buses (Pair a)
forall a1 a. Ok2 (:>) a1 a => Buses a1 -> Buses a
ConvertB (Buses (a :* a) -> Buses (Pair a))
-> StateT [Source] Identity (Buses (a :* a))
-> State [Source] (Buses (Pair a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Buses a -> Buses a -> Buses (a :* a))
-> StateT [Source] Identity (Buses a)
-> StateT [Source] Identity (Buses a)
-> StateT [Source] Identity (Buses (a :* a))
forall a b c.
(a -> b -> c)
-> StateT [Source] Identity a
-> StateT [Source] Identity b
-> StateT [Source] Identity c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Buses a -> Buses a -> Buses (a :* a)
forall a1 b. Ok2 (:>) a1 b => Buses a1 -> Buses b -> Buses (a1, b)
ProdB StateT [Source] Identity (Buses a)
u StateT [Source] Identity (Buses a)
u
   where
     u :: StateT [Source] Identity (Buses a)
u = forall a. GenBuses a => State [Source] (Buses a)
unflattenB' @a
     {-# NOINLINE u #-}

instance OkFunctor (:>) Pair where
  okFunctor :: forall a. Ok' (:>) a |- Ok' (:>) (Pair a)
okFunctor = (Con (Sat GenBuses a) :- Con (Sat GenBuses (Pair a)))
-> Sat GenBuses a |- Sat GenBuses (Pair a)
forall a b. (Con a :- Con b) -> a |- b
Entail ((GenBuses a => Dict (GenBuses (Pair a)))
-> GenBuses a :- GenBuses (Pair a)
forall (a :: Constraint) (b :: Constraint). (a => Dict b) -> a :- b
Sub Dict (GenBuses (Pair a))
GenBuses a => Dict (GenBuses (Pair a))
forall (a :: Constraint). a => Dict a
Dict)

-- Without these NOINLINE pragmas, GHC's typechecker does exponential work for
-- binary trees.

-- instance LScan Pair
-- deriving instance Zip Pair

instance LScan Pair where
  lscan :: Monoid a => Pair a -> Pair a :* a
  lscan :: forall a. Monoid a => Pair a -> Pair a :* a
lscan (a
a :# a
b) = (a
forall a. Monoid a => a
mempty a -> a -> Pair a
forall a. a -> a -> Pair a
:# a
a, a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b)

#endif