{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase    #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wall #-}

{-# OPTIONS_GHC -Wno-deprecations #-} -- for errorWithStackTrace

-- | Miscellany

module ConCat.Misc(module ConCat.Misc, oops) where

import GHC.Types (Constraint)

-- import Control.Arrow ((&&&))
-- import Data.Type.Equality

import Data.Typeable (Typeable,TypeRep,typeRep,Proxy(..))
import Data.Data (Data)
import Data.Monoid (Endo(..))
import Data.Semigroup (Semigroup(..))
import Data.Complex (Complex)
import GHC.Generics hiding (R)
import GHC.TypeLits

import Control.Newtype.Generics

import ConCat.Oops

{--------------------------------------------------------------------
    Type abbreviations
-------------------------------------------------------------------
-}

infixr 8 :^
infixl 7 :*
infixl 6 :+
infixr 1 :=>

type s :^ n = n -> s
type (:*)  = (,)
type (:+)  = Either
type (:=>) = (->)

{--------------------------------------------------------------------
    Helpers for GHC.Generics
--------------------------------------------------------------------}

-- | Operate inside a Generic1
inGeneric1 :: (Generic1 f, Generic1 g) => (Rep1 f a -> Rep1 g b) -> (f a -> g b)
inGeneric1 :: forall {k} {k} (f :: k -> *) (g :: k -> *) (a :: k) (b :: k).
(Generic1 f, Generic1 g) =>
(Rep1 f a -> Rep1 g b) -> f a -> g b
inGeneric1 = Rep1 g b -> g b
forall (a :: k). Rep1 g a -> g a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 g b -> g b)
-> (f a -> Rep1 f a) -> (Rep1 f a -> Rep1 g b) -> f a -> g b
forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ f a -> Rep1 f a
forall (a :: k). f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1
{-# INLINE inGeneric1 #-}

-- | Apply a unary function within the 'Comp1' constructor.
inComp :: (g (f a) -> g' (f' a')) -> ((g :.: f) a -> (g' :.: f') a')
inComp :: forall {k2} {k1} {k2} {k1} (g :: k2 -> *) (f :: k1 -> k2) (a :: k1)
       (g' :: k2 -> *) (f' :: k1 -> k2) (a' :: k1).
(g (f a) -> g' (f' a')) -> (:.:) g f a -> (:.:) g' f' a'
inComp = g' (f' a') -> (:.:) g' f' a'
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (g' (f' a') -> (:.:) g' f' a')
-> ((:.:) g f a -> g (f a))
-> (g (f a) -> g' (f' a'))
-> (:.:) g f a
-> (:.:) g' f' a'
forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ (:.:) g f a -> g (f a)
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1
{-# INLINE inComp #-}

-- | Apply a binary function within the 'Comp1' constructor.
inComp2 :: (  g (f a)   -> g' (f' a')     -> g'' (f'' a''))
        -> ((g :.: f) a -> (g' :.: f') a' -> (g'' :.: f'') a'')
inComp2 :: forall {k2} {k1} {k2} {k1} {k2} {k1} (g :: k2 -> *) (f :: k1 -> k2)
       (a :: k1) (g' :: k2 -> *) (f' :: k1 -> k2) (a' :: k1)
       (g'' :: k2 -> *) (f'' :: k1 -> k2) (a'' :: k1).
(g (f a) -> g' (f' a') -> g'' (f'' a''))
-> (:.:) g f a -> (:.:) g' f' a' -> (:.:) g'' f'' a''
inComp2 = (g' (f' a') -> g'' (f'' a''))
-> (:.:) g' f' a' -> (:.:) g'' f'' a''
forall {k2} {k1} {k2} {k1} (g :: k2 -> *) (f :: k1 -> k2) (a :: k1)
       (g' :: k2 -> *) (f' :: k1 -> k2) (a' :: k1).
(g (f a) -> g' (f' a')) -> (:.:) g f a -> (:.:) g' f' a'
inComp ((g' (f' a') -> g'' (f'' a''))
 -> (:.:) g' f' a' -> (:.:) g'' f'' a'')
-> ((:.:) g f a -> g (f a))
-> (g (f a) -> g' (f' a') -> g'' (f'' a''))
-> (:.:) g f a
-> (:.:) g' f' a'
-> (:.:) g'' f'' a''
forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ (:.:) g f a -> g (f a)
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1
{-# INLINE inComp2 #-}

-- TODO: phase out inComp and inComp2 in favor of inNew and inNew2.

absurdF :: V1 a -> b
absurdF :: forall {k} (a :: k) b. V1 a -> b
absurdF = V1 a -> b
\ case
{-# INLINE absurdF #-}

-- infixr 1 +->
-- data (a +-> b) p = Fun1 { unFun1 :: a p -> b p }

-- -- TODO: resolve name conflict with tries. Using ":->:" for functors fits with
-- -- other type constructors in GHC.Generics.

-- instance Newtype ((a +-> b) t) where
--   type O ((a +-> b) t) = a t -> b t
--   pack = Fun1
--   unpack = unFun1

#if 0

{--------------------------------------------------------------------
    Evaluation
--------------------------------------------------------------------}

-- class Evalable e where
--   type ValT e
--   eval :: e -> ValT e

class PrimBasics p where
  unitP :: p ()
  pairP :: p (a :=> b :=> a :* b)

class Evalable p where eval :: p a -> a

-- TODO: Are we still using PrimBasics or Evalable?

#endif

{--------------------------------------------------------------------
    Other
--------------------------------------------------------------------}

type Unop   a = a -> a
type Binop  a = a -> Unop a
type Ternop a = a -> Binop a

infixl 1 <~
infixr 1 ~>

-- | Add pre- and post-processing
(~>) :: forall a b a' b'. (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b'))
(a' -> a
f ~> :: forall a b a' b'. (a' -> a) -> (b -> b') -> (a -> b) -> a' -> b'
~> b -> b'
h) a -> b
g = b -> b'
h (b -> b') -> (a' -> b) -> a' -> b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g (a -> b) -> (a' -> a) -> a' -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f
-- (~>) = flip (<~)
{-# INLINE (~>) #-}

-- | Add post- and pre-processing
(<~) :: forall a b a' b'. (b -> b') -> (a' -> a) -> ((a -> b) -> (a' -> b'))
(b -> b'
h <~ :: forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ a' -> a
f) a -> b
g = b -> b'
h (b -> b') -> (a' -> b) -> a' -> b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g (a -> b) -> (a' -> a) -> a' -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f
{-# INLINE (<~) #-}

-- For SEC-style programming. I was using fmap instead, but my rules interfered.
result :: (b -> c) -> ((a -> b) -> (a -> c))
result :: forall b c a. (b -> c) -> (a -> b) -> a -> c
result = (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
{-# INLINE result #-}

class    Yes0
instance Yes0
Yes0

class    Yes1 a
instance Yes1 a

class    Yes2 a b
instance Yes2 a b

-- | Compose list of unary transformations
compose :: Foldable f => f (Unop a) -> Unop a
compose :: forall (f :: * -> *) a. Foldable f => f (Unop a) -> Unop a
compose = Endo a -> a -> a
forall a. Endo a -> a -> a
appEndo (Endo a -> a -> a)
-> (f (a -> a) -> Endo a) -> f (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> a) -> Endo a) -> f (a -> a) -> Endo a
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo
-- compose = foldr (.) id

infixr 3 `xor`

xor :: Binop Bool
xor :: Binop Bool
xor = Binop Bool
forall a. Eq a => a -> a -> Bool
(/=)
{-# NOINLINE xor #-}

newtype Parity = Parity { Parity -> Bool
getParity :: Bool }

instance Newtype Parity where
  type O Parity = Bool
  pack :: O Parity -> Parity
pack = Bool -> Parity
O Parity -> Parity
Parity
  unpack :: Parity -> O Parity
unpack (Parity Bool
x) = Bool
O Parity
x

instance Semigroup Parity where
  Parity Bool
a <> :: Parity -> Parity -> Parity
<> Parity Bool
b = Bool -> Parity
Parity (Bool
a Binop Bool
`xor` Bool
b)

instance Monoid Parity where
  mempty :: Parity
mempty = Bool -> Parity
Parity Bool
False
  mappend :: Parity -> Parity -> Parity
mappend = Parity -> Parity -> Parity
forall a. Semigroup a => a -> a -> a
(<>)
  -- Parity a `mappend` Parity b = Parity (a `xor` b)

boolToInt :: Bool -> Int
boolToInt :: Bool -> Int
boolToInt Bool
c = if Bool
c then Int
1 else Int
0
{-# INLINE boolToInt #-}

cond :: a -> a -> Bool -> a
cond :: forall a. a -> a -> Bool -> a
cond a
t a
e Bool
i = if Bool
i then a
t else a
e
{-# INLINE cond #-}  -- later INLINE?

{--------------------------------------------------------------------
    Type level computations
--------------------------------------------------------------------}

infixr 3 &&

class    (a,b) => a && b
instance (a,b) => a && b

-- Saying (b,a) instead of (a,b) causes Oks k [a,b,c] to expand in order, oddly.
-- TODO: investigate.

infixr 3 &+&
class    (a t, b t) => (a &+& b) t
instance (a t, b t) => (a &+& b) t

class    f b a => Flip f a b
instance f b a => Flip f a b

-- • Potential superclass cycle for ‘&&’
--     one of whose superclass constraints is headed by a type variable: ‘a’
--   Use UndecidableSuperClasses to accept this

-- Same for Flip

type family FoldrC op b0 as where
  FoldrC op z '[]      = z
  FoldrC op z (a : as) = a `op` FoldrC op z as

type family MapC f us where
  MapC f '[]      = '[]
  MapC f (u : us) = f u : MapC f us

-- type Comp g f u = g (f u)
-- -- Operator applied to too few arguments: :
-- type MapC' f us = FoldrC (Comp (':) f) '[] us

type AndC   cs = FoldrC (&&) Yes0 cs
type AllC f us = AndC (MapC f us)

-- type family AndC' cs where
--   AndC' '[]      = Yes0
--   AndC' (c : cs) = c && AndC' cs

-- type family AllC f as where
--   AllC f '[]      = Yes0
--   AllC f (a : as) = f a && AllC f as

-- -- Operator applied to too few arguments: :
-- type as ++ bs = FoldrC (':) bs as

infixr 5 ++
type family as ++ bs where
  '[]      ++ bs = bs
  (a : as) ++ bs = a : as ++ bs

type family CrossWith f as bs where
  CrossWith f '[]      bs = '[]
  CrossWith f (a : as) bs = MapC (f a) bs ++ CrossWith f as bs

-- Illegal nested type family application ‘MapC (f a1) bs
--                                               ++ CrossWith f as bs’
--       (Use UndecidableInstances to permit this)

type AllC2 f as bs = AndC (CrossWith f as bs)

-- | Annotation for pseudo-function, i.e., defined by rules. During ccc
-- generation, don't split applications. TODO: maybe add an arity.
data PseudoFun = PseudoFun { PseudoFun -> Int
pseudoArgs :: Int } deriving (Typeable,Typeable PseudoFun
Typeable PseudoFun
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> PseudoFun -> c PseudoFun)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c PseudoFun)
-> (PseudoFun -> Constr)
-> (PseudoFun -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c PseudoFun))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PseudoFun))
-> ((forall b. Data b => b -> b) -> PseudoFun -> PseudoFun)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> PseudoFun -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> PseudoFun -> r)
-> (forall u. (forall d. Data d => d -> u) -> PseudoFun -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> PseudoFun -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun)
-> Data PseudoFun
PseudoFun -> Constr
PseudoFun -> DataType
(forall b. Data b => b -> b) -> PseudoFun -> PseudoFun
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> PseudoFun -> u
forall u. (forall d. Data d => d -> u) -> PseudoFun -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PseudoFun -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PseudoFun -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PseudoFun
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PseudoFun -> c PseudoFun
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PseudoFun)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PseudoFun)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PseudoFun -> c PseudoFun
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PseudoFun -> c PseudoFun
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PseudoFun
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PseudoFun
$ctoConstr :: PseudoFun -> Constr
toConstr :: PseudoFun -> Constr
$cdataTypeOf :: PseudoFun -> DataType
dataTypeOf :: PseudoFun -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PseudoFun)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PseudoFun)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PseudoFun)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PseudoFun)
$cgmapT :: (forall b. Data b => b -> b) -> PseudoFun -> PseudoFun
gmapT :: (forall b. Data b => b -> b) -> PseudoFun -> PseudoFun
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PseudoFun -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PseudoFun -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PseudoFun -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PseudoFun -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> PseudoFun -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> PseudoFun -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PseudoFun -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PseudoFun -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PseudoFun -> m PseudoFun
Data)

-- Alternatively, we could keep PseudoFun abstract:

-- pseudoFun :: Int -> PseudoFun
-- pseudoFun = PseudoFun

--     In the use of ‘errorWithStackTrace’ (imported from GHC.Stack):
--     Deprecated: "'error' appends the call stack now"

-- When we use error, the divergence checker eliminates a lot of code early. An
-- alternative is unsafeCoerce, but it leads to terrible run-time errors. A safe
-- alternative seems to be errorWithStackTrace. Oddly, the doc for
-- errorWithStackTrace says "Deprecated: error appends the call stack now."

-- | Hack: delay inlining to thwart some of GHC's rewrites
delay :: a -> a
delay :: forall a. a -> a
delay a
a = a
a
{-# INLINE [0] delay #-}

bottom :: a
-- bottom = error "bottom evaluated"
bottom :: forall a. a
bottom = String -> a
forall b. String -> b
oops String
"bottom evaluated"
{-# NOINLINE bottom #-}

-- Convenient alternative to typeRep
typeR :: forall a. Typeable a => TypeRep
typeR :: forall {k} (a :: k). Typeable a => TypeRep
typeR = Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

type R = Double -- Float

type C = Complex R

sqr :: Num a => a -> a
sqr :: forall a. Num a => a -> a
sqr a
a = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
a
{-# INLINE sqr #-}

magSqr :: Num a => a :* a -> a
magSqr :: forall a. Num a => (a :* a) -> a
magSqr (a
a,a
b) = a -> a
forall a. Num a => a -> a
sqr a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a. Num a => a -> a
sqr a
b
{-# INLINE magSqr #-}

transpose :: (Traversable t, Applicative f) => t (f a) -> f (t a)
transpose :: forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
transpose = t (f a) -> f (t a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)
sequenceA

inTranspose :: (Applicative f, Traversable t, Applicative f', Traversable t')
            => (f (t a) -> t' (f' a)) -> (t (f a) -> f' (t' a))
inTranspose :: forall (f :: * -> *) (t :: * -> *) (f' :: * -> *) (t' :: * -> *) a.
(Applicative f, Traversable t, Applicative f', Traversable t') =>
(f (t a) -> t' (f' a)) -> t (f a) -> f' (t' a)
inTranspose = t' (f' a) -> f' (t' a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
transpose (t' (f' a) -> f' (t' a))
-> (t (f a) -> f (t a))
-> (f (t a) -> t' (f' a))
-> t (f a)
-> f' (t' a)
forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ t (f a) -> f (t a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
transpose
{-# INLINE inTranspose #-}
-- inTranspose h = transpose . h . transpose

unzip :: Functor f => f (a :* b) -> f a :* f b
unzip :: forall (f :: * -> *) a b. Functor f => f (a :* b) -> f a :* f b
unzip f (a :* b)
ps = ((a :* b) -> a
forall a b. (a, b) -> a
fst ((a :* b) -> a) -> f (a :* b) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a :* b)
ps, (a :* b) -> b
forall a b. (a, b) -> b
snd ((a :* b) -> b) -> f (a :* b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a :* b)
ps)
{-# INLINE unzip #-}

natValAt :: forall n. KnownNat n => Integer
natValAt :: forall (n :: Nat). KnownNat n => Integer
natValAt = forall (n :: Nat). KnownNat n => Integer
nat @n

-- Shorter name
nat :: forall n. KnownNat n => Integer
nat :: forall (n :: Nat). KnownNat n => Integer
nat = Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)
{-# INLINE nat #-}

int :: forall n. KnownNat n => Int
int :: forall (n :: Nat). KnownNat n => Int
int = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat). KnownNat n => Integer
nat @n)
{-# INLINE int #-}

{--------------------------------------------------------------------
    Newtype
--------------------------------------------------------------------}

-- See <https://github.com/jcristovao/newtype-generics/pull/5>

-- Type generalization of underF from newtype-generics.
underF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f, Functor g)
       => (o -> n) -> (f n -> g n') -> (f o -> g o')
underF :: forall n n' o' o (f :: * -> *) (g :: * -> *).
(Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f,
 Functor g) =>
(o -> n) -> (f n -> g n') -> f o -> g o'
underF o -> n
_ f n -> g n'
f = (n' -> o') -> g n' -> g o'
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n' -> o'
n' -> O n'
forall n. Newtype n => n -> O n
unpack (g n' -> g o') -> (f o -> g n') -> f o -> g o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f n -> g n'
f (f n -> g n') -> (f o -> f n) -> f o -> g n'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> n) -> f o -> f n
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o -> n
O n -> n
forall n. Newtype n => O n -> n
pack
{-# INLINE underF #-}

-- Type generalization of overF from newtype-generics.
overF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f, Functor g)
      => (o -> n) -> (f o -> g o') -> (f n -> g n')
overF :: forall n n' o' o (f :: * -> *) (g :: * -> *).
(Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f,
 Functor g) =>
(o -> n) -> (f o -> g o') -> f n -> g n'
overF o -> n
_ f o -> g o'
f = (o' -> n') -> g o' -> g n'
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o' -> n'
O n' -> n'
forall n. Newtype n => O n -> n
pack (g o' -> g n') -> (f n -> g o') -> f n -> g n'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f o -> g o'
f (f o -> g o') -> (f n -> f o) -> f n -> g o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> o) -> f n -> f o
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> o
n -> O n
forall n. Newtype n => n -> O n
unpack
{-# INLINE overF #-}

inNew :: (Newtype p, Newtype q) =>
         (O p -> O q) -> (p -> q)
inNew :: forall p q. (Newtype p, Newtype q) => (O p -> O q) -> p -> q
inNew = O q -> q
forall n. Newtype n => O n -> n
pack (O q -> q) -> (p -> O p) -> (O p -> O q) -> p -> q
forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ p -> O p
forall n. Newtype n => n -> O n
unpack
{-# INLINE inNew #-}

inNew2 :: (Newtype p, Newtype q, Newtype r) =>
          (O p -> O q -> O r) -> (p -> q -> r)
inNew2 :: forall p q r.
(Newtype p, Newtype q, Newtype r) =>
(O p -> O q -> O r) -> p -> q -> r
inNew2 = (O q -> O r) -> q -> r
forall p q. (Newtype p, Newtype q) => (O p -> O q) -> p -> q
inNew ((O q -> O r) -> q -> r)
-> (p -> O p) -> (O p -> O q -> O r) -> p -> q -> r
forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ p -> O p
forall n. Newtype n => n -> O n
unpack
{-# INLINE inNew2 #-}

-- TODO: use inNew and inNew2 in place of ad hoc versions throughout.

exNew :: (Newtype p, Newtype q) =>
         (p -> q) -> (O p -> O q)
exNew :: forall p q. (Newtype p, Newtype q) => (p -> q) -> O p -> O q
exNew = q -> O q
forall n. Newtype n => n -> O n
unpack (q -> O q) -> (O p -> p) -> (p -> q) -> O p -> O q
forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ O p -> p
forall n. Newtype n => O n -> n
pack
{-# INLINE exNew #-}

exNew2 :: (Newtype p, Newtype q, Newtype r) =>
          (p -> q -> r) -> (O p -> O q -> O r)
exNew2 :: forall p q r.
(Newtype p, Newtype q, Newtype r) =>
(p -> q -> r) -> O p -> O q -> O r
exNew2 = (q -> r) -> O q -> O r
forall p q. (Newtype p, Newtype q) => (p -> q) -> O p -> O q
exNew ((q -> r) -> O q -> O r)
-> (O p -> p) -> (p -> q -> r) -> O p -> O q -> O r
forall a b a' b'. (b -> b') -> (a' -> a) -> (a -> b) -> a' -> b'
<~ O p -> p
forall n. Newtype n => O n -> n
pack
{-# INLINE exNew2 #-}

{--------------------------------------------------------------------
    Constraint shorthands
--------------------------------------------------------------------}

#if 1
-- Experiment. Smaller Core?
type C1 (con :: u -> Constraint) a = con a
type C2 (con :: u -> Constraint) a b = (con a, con b)
type C3 (con :: u -> Constraint) a b c = (con a, con b, con c)
type C4 (con :: u -> Constraint) a b c d = (con a, con b, con c, con d)
type C5 (con :: u -> Constraint) a b c d e = (con a, con b, con c, con d, con e)
type C6 (con :: u -> Constraint) a b c d e f = (con a, con b, con c, con d, con e, con f)
#else
type C1 (con :: u -> Constraint) a = con a
type C2 con a b         = (C1 con a, con b)
type C3 con a b c       = (C2 con a b, con c)
type C4 con a b c d     = (C2 con a b, C2 con c d)
type C5 con a b c d e   = (C3 con a b c, C2 con d e)
type C6 con a b c d e f = (C3 con a b c, C3 con d e f)
#endif