{-# LANGUAGE CPP #-}

#if !(MIN_VERSION_base(4,16,0)) || !(MIN_VERSION_transformers(0,6,0))
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif

#define GHC_GENERICS_OK __GLASGOW_HASKELL__ >= 702

#if GHC_GENERICS_OK
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
#endif

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif

{-|
Module:      Data.Functor.Invariant
Copyright:   (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Portable

Haskell98 invariant functors (also known as exponential functors).

For more information, see Edward Kmett's article \"Rotten Bananas\":

<http://comonad.com/reader/2008/rotten-bananas/>

-}
module Data.Functor.Invariant
  ( -- * @Invariant@
    Invariant(..)
  , invmapFunctor
#if GHC_GENERICS_OK
    -- ** @GHC.Generics@
    -- $ghcgenerics
  , genericInvmap
#endif
  , WrappedFunctor(..)
  , invmapContravariant
  , invmapProfunctor
  , invmapArrow
  , WrappedContravariant(..)
  , InvariantProfunctor(..)
  , InvariantArrow(..)
    -- * @Invariant2@
  , Invariant2(..)
  , invmap2Bifunctor
  , WrappedBifunctor(..)
  , invmap2Profunctor
  , WrappedProfunctor(..)
  ) where

-- base
import           Control.Applicative as App
import qualified Control.Arrow as Arr
import           Control.Arrow hiding (first, second)
import qualified Control.Category as Cat
import           Control.Exception (Handler(..))
import           Control.Monad (MonadPlus(..), liftM)
import qualified Control.Monad.ST as Strict (ST)
import qualified Control.Monad.ST.Lazy as Lazy (ST)
#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex(..))
#endif
import qualified Data.Foldable as F (Foldable(..))
import qualified Data.Functor.Compose as Functor (Compose(..))
import           Data.Functor.Identity (Identity)
import           Data.Functor.Product as Functor (Product(..))
import           Data.Functor.Sum as Functor (Sum(..))
#if __GLASGOW_HASKELL__ < 711
import           Data.Ix (Ix)
#endif
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Monoid as Monoid (First(..), Last(..), Product(..), Sum(..))
#if MIN_VERSION_base(4,8,0)
import           Data.Monoid (Alt(..))
#endif
import           Data.Monoid (Dual(..), Endo(..))
import           Data.Proxy (Proxy(..))
import qualified Data.Semigroup as Semigroup (First(..), Last(..))
#if !(MIN_VERSION_base(4,16,0))
import qualified Data.Semigroup as Semigroup (Option(..))
#endif
import           Data.Semigroup (Min(..), Max(..), Arg(..))
import qualified Data.Traversable as T (Traversable(..))
#if GHC_GENERICS_OK
import           GHC.Generics
#endif
import           System.Console.GetOpt as GetOpt
import           Text.ParserCombinators.ReadP (ReadP)
import           Text.ParserCombinators.ReadPrec (ReadPrec)

-- array
import           Data.Array (Array)

-- bifunctors
import           Data.Bifunctor
import           Data.Bifunctor.Biff
import           Data.Bifunctor.Clown
import           Data.Bifunctor.Fix
import           Data.Bifunctor.Flip
import           Data.Bifunctor.Join
import           Data.Bifunctor.Joker
import qualified Data.Bifunctor.Product as Bifunctor
import qualified Data.Bifunctor.Sum as Bifunctor
import           Data.Bifunctor.Tannen
import           Data.Bifunctor.Wrapped

-- comonad
import           Control.Comonad (Comonad(..), Cokleisli(..), liftW)

-- containers
import           Data.IntMap (IntMap)
import           Data.Map (Map)
import           Data.Sequence (Seq, ViewL, ViewR)
import           Data.Tree (Tree)

-- contravariant
import           Data.Functor.Contravariant
import           Data.Functor.Contravariant.Compose as Contravariant
import           Data.Functor.Contravariant.Divisible

-- profunctors
import           Data.Profunctor as Pro
import           Data.Profunctor.Cayley
import           Data.Profunctor.Choice
import           Data.Profunctor.Closed
import           Data.Profunctor.Composition
import           Data.Profunctor.Mapping
import           Data.Profunctor.Monad
import           Data.Profunctor.Rep
import           Data.Profunctor.Ran
import           Data.Profunctor.Strong
import           Data.Profunctor.Traversing
import           Data.Profunctor.Unsafe
import           Data.Profunctor.Yoneda

-- StateVar
import           Data.StateVar (StateVar(..), SettableStateVar(..))

-- stm
import           Control.Concurrent.STM (STM)

-- tagged
import           Data.Tagged (Tagged(..))

-- transformers
import           Control.Applicative.Backwards (Backwards(..))
import           Control.Applicative.Lift (Lift(..))
import           Control.Monad.Trans.Cont (ContT)
import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import           Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
import           Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
import           Control.Monad.Trans.Reader (ReaderT, mapReaderT)
import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
import qualified Control.Monad.Trans.State.Strict as Strict (StateT(..))
import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT, mapWriterT)
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT)
#if !(MIN_VERSION_transformers(0,6,0))
import           Control.Monad.Trans.Error (ErrorT(..))
import           Control.Monad.Trans.List (ListT, mapListT)
#endif
import           Data.Functor.Constant (Constant(..))
import           Data.Functor.Reverse (Reverse(..))

-- unordered-containers
import           Data.HashMap.Lazy (HashMap)

-------------------------------------------------------------------------------
-- The Invariant class
-------------------------------------------------------------------------------

-- | Any @* -> *@ type parametric in the argument permits an instance of
-- @Invariant@.
--
-- Instances should satisfy the following laws:
--
-- > invmap id id = id
-- > invmap f2 f2' . invmap f1 f1' = invmap (f2 . f1) (f1' . f2')
class Invariant f where
  invmap :: (a -> b) -> (b -> a) -> f a -> f b
#if GHC_GENERICS_OK
  default invmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
  invmap = genericInvmap
#endif

-- | Every 'Functor' is also an 'Invariant' functor.
invmapFunctor :: Functor f => (a -> b) -> (b -> a) -> f a -> f b
invmapFunctor = flip $ const fmap

-- | Every 'Contravariant' functor is also an 'Invariant' functor.
invmapContravariant :: Contravariant f => (a -> b) -> (b -> a) -> f a -> f b
invmapContravariant = const contramap

-- | A 'Profunctor' with the same input and output types can be seen as an 'Invariant' functor.
invmapProfunctor :: Profunctor p => (a -> b) -> (b -> a) -> p a a -> p b b
invmapProfunctor = flip dimap

-- | An 'Arrow' with the same input and output types can be seen as an 'Invariant' functor.
invmapArrow :: Arrow arr => (a -> b) -> (b -> a) -> arr a a -> arr b b
invmapArrow fn1 fn2 arrow = arr fn1 Cat.. arrow Cat.. arr fn2

-------------------------------------------------------------------------------
-- Invariant instances
-------------------------------------------------------------------------------

instance Invariant Maybe where invmap = invmapFunctor
instance Invariant [] where invmap = invmapFunctor
instance Invariant IO where invmap = invmapFunctor
instance Invariant (Strict.ST s) where invmap = invmapFunctor
instance Invariant (Lazy.ST s) where invmap = invmapFunctor
instance Invariant ReadP where invmap = invmapFunctor
instance Invariant ReadPrec where invmap = invmapFunctor
instance Invariant ((->) a) where invmap = invmapFunctor
instance Invariant (Either a) where invmap = invmapFunctor
instance Invariant ((,) a) where invmap = invmapFunctor
instance Invariant ((,,) a b) where invmap f _ ~(a, b, x) = (a, b, f x)
instance Invariant ((,,,) a b c) where
  invmap f _ ~(a, b, c, x) = (a, b, c, f x)
instance Invariant ((,,,,) a b c d) where
  invmap f _ ~(a, b, c, d, x) = (a, b, c, d, f x)

-- | from "Control.Applicative"
instance Invariant (Const a) where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Invariant ZipList where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Monad m => Invariant (WrappedMonad m) where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Arrow arr => Invariant (App.WrappedArrow arr a) where
  invmap f _ (App.WrapArrow x) = App.WrapArrow $ ((arr f) Cat.. x)

-- | from "Control.Arrow"
instance
#if MIN_VERSION_base(4,4,0)
  Arrow a
#else
  ArrowApply a
#endif
  => Invariant (ArrowMonad a) where
  invmap f _ (ArrowMonad m) = ArrowMonad (m >>> arr f)
-- | from "Control.Arrow"
instance Monad m => Invariant (Kleisli m a) where
  invmap = invmap2 id id

-- | from "Control.Exception"
instance Invariant Handler where
  invmap f _ (Handler h) = Handler (fmap f . h)

#if MIN_VERSION_base(4,4,0)
-- | from "Data.Complex"
instance Invariant Complex where
  invmap f _ (r :+ i) = f r :+ f i
#endif

-- | from "Data.Functor.Compose"
instance (Invariant f, Invariant g) => Invariant (Functor.Compose f g) where
  invmap f g (Functor.Compose x) =
    Functor.Compose (invmap (invmap f g) (invmap g f) x)

-- | from "Data.Functor.Identity"
instance Invariant Identity where
  invmap = invmapFunctor

-- | from "Data.Functor.Product"
instance (Invariant f, Invariant g) => Invariant (Functor.Product f g) where
  invmap f g (Functor.Pair x y) = Functor.Pair (invmap f g x) (invmap f g y)

-- | from "Data.Functor.Sum"
instance (Invariant f, Invariant g) => Invariant (Functor.Sum f g) where
  invmap f g (InL x) = InL (invmap f g x)
  invmap f g (InR y) = InR (invmap f g y)

-- | from "Data.List.NonEmpty"
instance Invariant NonEmpty where
  invmap = invmapFunctor

-- | from "Data.Monoid"
instance Invariant Dual where
  invmap f _ (Dual x) = Dual (f x)
-- | from "Data.Monoid"
instance Invariant Endo where
  invmap f g (Endo x) = Endo (f . x . g)
-- | from "Data.Monoid"
instance Invariant Monoid.First where
  invmap f g (Monoid.First x) = Monoid.First (invmap f g x)
-- | from "Data.Monoid"
instance Invariant Monoid.Last where
  invmap f g (Monoid.Last x) = Monoid.Last (invmap f g x)
-- | from "Data.Monoid"
instance Invariant Monoid.Product where
  invmap f _ (Monoid.Product x) = Monoid.Product (f x)
-- | from "Data.Monoid"
instance Invariant Monoid.Sum where
  invmap f _ (Monoid.Sum x) = Monoid.Sum (f x)
#if MIN_VERSION_base(4,8,0)
-- | from "Data.Monoid"
instance Invariant f => Invariant (Alt f) where
  invmap f g (Alt x) = Alt (invmap f g x)
#endif

-- | from "Data.Proxy"
instance Invariant Proxy where
  invmap = invmapFunctor

-- | from "Data.Semigroup"
instance Invariant Min where
  invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Max where
  invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.First where
  invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.Last where
  invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant (Arg a) where
  invmap = invmapFunctor
#if !(MIN_VERSION_base(4,16,0))
-- | from "Data.Semigroup"
instance Invariant Semigroup.Option where
  invmap = invmapFunctor
#endif

-- | from "System.Console.GetOpt"
instance Invariant ArgDescr where
  invmap f _ (NoArg a)    = NoArg (f a)
  invmap f _ (ReqArg g s) = ReqArg (f . g) s
  invmap f _ (OptArg g s) = OptArg (f . g) s
-- | from "System.Console.GetOpt"
instance Invariant ArgOrder where
  invmap _ _ RequireOrder      = RequireOrder
  invmap _ _ Permute           = Permute
  invmap f _ (ReturnInOrder g) = ReturnInOrder (f . g)
-- | from "System.Console.GetOpt"
instance Invariant OptDescr where
  invmap f g (GetOpt.Option a b argDescr c) = GetOpt.Option a b (invmap f g argDescr) c

-- | from the @array@ package
instance
#if __GLASGOW_HASKELL__ < 711
  Ix i =>
#endif
    Invariant (Array i) where
  invmap = invmapFunctor

-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant g) => Invariant (Biff p f g a) where
  invmap f g = Biff . invmap2 id id (invmap f g) (invmap g f) . runBiff
-- | from the @bifunctors@ package
instance Invariant (Clown f a) where
  invmap = invmapFunctor
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Fix p) where
  invmap f g = In . invmap2 (invmap f g) (invmap g f) f g . out
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Flip p a) where
  invmap = invmap2 id id
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Join p) where
  invmap f g = Join . invmap2 f g f g . runJoin
-- | from the @bifunctors@ package
instance Invariant g => Invariant (Joker g a) where
  invmap f g = Joker . invmap f g . runJoker
-- | from the @bifunctors@ package
instance (Invariant f, Invariant2 p) => Invariant (Tannen f p a) where
  invmap = invmap2 id id
-- | from the @bifunctors@ package
instance Bifunctor p => Invariant (WrappedBifunctor p a) where
  invmap = invmap2 id id

-- | from the @comonad@ package
instance Invariant (Cokleisli w a) where
  invmap = invmapFunctor

-- | from the @containers@ package
instance Invariant IntMap where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant (Map k) where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant Seq where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant ViewL where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant ViewR where
  invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant Tree where
  invmap = invmapFunctor

-- | from the @contravariant@ package
instance Invariant Predicate where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant Comparison where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant Equivalence where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant (Op a) where invmap = invmapContravariant
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (Contravariant.Compose f g) where
  invmap f g (Contravariant.Compose x) =
    Contravariant.Compose $ invmap (invmap f g) (invmap g f) x
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (ComposeCF f g) where
  invmap f g (ComposeCF x) = ComposeCF $ invmap (invmap f g) (invmap g f) x
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (ComposeFC f g) where
  invmap f g (ComposeFC x) = ComposeFC $ invmap (invmap f g) (invmap g f) x

-- | from the @profunctors@ package
instance Invariant f => Invariant (Star f a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Costar f a) where
  invmap = invmapFunctor
-- | from the @profunctors@ package
instance Arrow arr => Invariant (Pro.WrappedArrow arr a) where
  invmap f _ (Pro.WrapArrow x) = Pro.WrapArrow $ ((arr f) Cat.. x)
-- | from the @profunctors@ package
instance Invariant (Forget r a) where
  invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Closure p a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Codensity p a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Coprep p) where
  invmap f g (Coprep h) = Coprep (h . invmap2 g f id id)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Prep p) where
  invmap f g (Prep x p) = Prep x (invmap2 id id f g p)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Procompose p q a) where
  invmap k k' (Procompose f g) = Procompose (invmap2 id id k k' f) g
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Rift p q a) where
  invmap bd db (Rift f) = Rift (f . invmap2 db bd id id)
-- | from the @profunctors@ package
instance Invariant2 q => Invariant (Ran p q a) where
  invmap bd db (Ran f) = Ran (invmap2 id id bd db . f)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Tambara p a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Cotambara p a) where
  invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant (CotambaraSum p a) where
  invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (TambaraSum p a) where
  invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Yoneda p a) where
  invmap = invmapFunctor

-- | from the @StateVar@ package
instance Invariant StateVar where
  invmap f g (StateVar ga sa) = StateVar (fmap f ga) (lmap g sa)
-- | from the @StateVar@ package
instance Invariant SettableStateVar where
  invmap = invmapContravariant

-- | from the @stm@ package
instance Invariant STM where
  invmap = invmapFunctor

-- | from the @tagged@ package
instance Invariant (Tagged s) where
  invmap = invmapFunctor

-- | from the @transformers@ package
instance Invariant f => Invariant (Backwards f) where
  invmap f g (Backwards a) = Backwards (invmap f g a)
-- | from the @transformers@ package
instance Invariant f => Invariant (Lift f) where
  invmap f _ (Pure x)  = Pure (f x)
  invmap f g (Other y) = Other (invmap f g y)
-- | from the @transformers@ package
instance Invariant (ContT r m) where
  invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant m => Invariant (ExceptT e m) where
  invmap f g = ExceptT . invmap (invmap f g) (invmap g f) . runExceptT
-- | from the @transformers@ package
instance Invariant m => Invariant (IdentityT m) where
  invmap f g = mapIdentityT (invmap f g)
-- | from the @transformers@ package
instance Invariant m => Invariant (MaybeT m) where
  invmap f g = mapMaybeT $ invmap (invmap f g) (invmap g f)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.RWST r w s m) where
  invmap f g m = Lazy.RWST $ \r s ->
    invmap (mapFstTriple f) (mapFstTriple g) $ Lazy.runRWST m r s
      where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d)
            mapFstTriple h ~(a, s, w) = (h a, s, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.RWST r w s m) where
  invmap f g m = Strict.RWST $ \r s ->
    invmap (mapFstTriple f) (mapFstTriple g) $ Strict.runRWST m r s
      where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d)
            mapFstTriple h (a, s, w) = (h a, s, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (ReaderT r m) where
  invmap f g = mapReaderT (invmap f g)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.StateT s m) where
  invmap f g m = Lazy.StateT $ \s ->
    invmap (mapFstPair f) (mapFstPair g) $ Lazy.runStateT m s
      where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
            mapFstPair h ~(a, s) = (h a, s)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.StateT s m) where
  invmap f g m = Strict.StateT $ \s ->
    invmap (mapFstPair f) (mapFstPair g) $ Strict.runStateT m s
      where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
            mapFstPair h (a, s) = (h a, s)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.WriterT w m) where
  invmap f g = Lazy.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
    where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
          mapFstPair h ~(a, w) = (h a, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.WriterT w m) where
  invmap f g = Strict.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
    where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
          mapFstPair h (a, w) = (h a, w)
-- | from the @transformers@ package
instance Invariant (Constant a) where
  invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant f => Invariant (Reverse f) where
  invmap f g (Reverse a) = Reverse (invmap f g a)
#if !(MIN_VERSION_transformers(0,6,0))
-- | from the @transformers@ package
instance Invariant m => Invariant (ErrorT e m) where
  invmap f g = ErrorT . invmap (invmap f g) (invmap g f) . runErrorT
-- | from the @transformers@ package
instance Invariant m => Invariant (ListT m) where
  invmap f g = mapListT $ invmap (invmap f g) (invmap g f)
#endif

-- | from the @unordered-containers@ package
instance Invariant (HashMap k) where
  invmap = invmapFunctor

-------------------------------------------------------------------------------
-- WrappedFunctor
-------------------------------------------------------------------------------

-- | Wrap a 'Functor' to be used as a member of 'Invariant'.
newtype WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a }
  deriving (Eq, Ord, Read, Show)

instance Functor f => Invariant (WrappedFunctor f) where
  invmap = invmapFunctor

instance Functor f => Functor (WrappedFunctor f) where
  fmap f = WrapFunctor . fmap f . unwrapFunctor
  x <$ WrapFunctor f = WrapFunctor (x <$ f)

instance Applicative f => Applicative (WrappedFunctor f) where
  pure = WrapFunctor . pure
  WrapFunctor f <*> WrapFunctor x = WrapFunctor (f <*> x)
  WrapFunctor a *>  WrapFunctor b = WrapFunctor (a *>  b)
  WrapFunctor a <*  WrapFunctor b = WrapFunctor (a <*  b)

instance Alternative f => Alternative (WrappedFunctor f) where
  empty = WrapFunctor empty
  WrapFunctor x <|> WrapFunctor y = WrapFunctor (x <|> y)
  some = WrapFunctor . some . unwrapFunctor
  many = WrapFunctor . many . unwrapFunctor

instance Monad m => Monad (WrappedFunctor m) where
  WrapFunctor x >>= f = WrapFunctor (x >>= unwrapFunctor . f)
#if !(MIN_VERSION_base(4,11,0))
  return = WrapFunctor . return
  WrapFunctor a >> WrapFunctor b = WrapFunctor (a >> b)
#endif

instance MonadPlus m => MonadPlus (WrappedFunctor m) where
  mzero = WrapFunctor mzero
  WrapFunctor x `mplus` WrapFunctor y = WrapFunctor (x `mplus` y)

instance F.Foldable f => F.Foldable (WrappedFunctor f) where
  fold       = F.fold       . unwrapFunctor
  foldMap f  = F.foldMap f  . unwrapFunctor
  foldr f z  = F.foldr f z  . unwrapFunctor
  foldl f q  = F.foldl f q  . unwrapFunctor
  foldr1 f   = F.foldr1 f   . unwrapFunctor
  foldl1 f   = F.foldl1 f   . unwrapFunctor
#if MIN_VERSION_base(4,6,0)
  foldr' f z = F.foldr' f z . unwrapFunctor
  foldl' f q = F.foldl' f q . unwrapFunctor
#endif
#if MIN_VERSION_base(4,8,0)
  toList     = F.toList     . unwrapFunctor
  null       = F.null       . unwrapFunctor
  length     = F.length     . unwrapFunctor
  elem x     = F.elem x     . unwrapFunctor
  maximum    = F.maximum    . unwrapFunctor
  minimum    = F.minimum    . unwrapFunctor
  sum        = F.sum        . unwrapFunctor
  product    = F.product    . unwrapFunctor
#endif
#if MIN_VERSION_base(4,13,0)
  foldMap' f = F.foldMap' f . unwrapFunctor
#endif

instance T.Traversable f => T.Traversable (WrappedFunctor f) where
  traverse f = fmap  WrapFunctor . T.traverse f . unwrapFunctor
  sequenceA  = fmap  WrapFunctor . T.sequenceA  . unwrapFunctor
  mapM f     = liftM WrapFunctor . T.mapM f     . unwrapFunctor
  sequence   = liftM WrapFunctor . T.sequence   . unwrapFunctor

-------------------------------------------------------------------------------
-- WrappedContravariant
-------------------------------------------------------------------------------

-- | Wrap a 'Contravariant' functor to be used as a member of 'Invariant'.
newtype WrappedContravariant f a = WrapContravariant { unwrapContravariant :: f a }
  deriving (Eq, Ord, Read, Show)

instance Contravariant f => Invariant (WrappedContravariant f) where
  invmap = invmapContravariant

instance Contravariant f => Contravariant (WrappedContravariant f) where
  contramap f = WrapContravariant . contramap f . unwrapContravariant
  x >$ WrapContravariant f = WrapContravariant (x >$ f)

instance Divisible f => Divisible (WrappedContravariant f) where
  divide f (WrapContravariant l) (WrapContravariant r) =
    WrapContravariant $ divide f l r
  conquer = WrapContravariant conquer

instance Decidable f => Decidable (WrappedContravariant f) where
  lose = WrapContravariant . lose
  choose f (WrapContravariant l) (WrapContravariant r) =
    WrapContravariant $ choose f l r

-------------------------------------------------------------------------------
-- The Invariant2 class
-------------------------------------------------------------------------------

-- | Any @* -> * -> *@ type parametric in both arguments permits an instance of
-- @Invariant2@.
--
-- Instances should satisfy the following laws:
--
-- > invmap2 id id id id = id
-- > invmap2 f2 f2' g2 g2' . invmap2 f1 f1' g1 g1' =
-- >   invmap2 (f2 . f1) (f1' . f2') (g2 . g1) (g1' . g2')
class Invariant2 f where
  invmap2 :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d

-- | Every 'Bifunctor' is also an 'Invariant2' functor.
invmap2Bifunctor :: Bifunctor f
                 => (a -> c) -> (c -> a)
                 -> (b -> d) -> (d -> b)
                 -> f a b    -> f c d
invmap2Bifunctor f _ g _ = bimap f g

-- | Every 'Profunctor' is also an 'Invariant2' functor.
invmap2Profunctor :: Profunctor f
                  => (a -> c) -> (c -> a)
                  -> (b -> d) -> (d -> b)
                  -> f a b    -> f c d
invmap2Profunctor _ f' g _ = dimap f' g

-------------------------------------------------------------------------------
-- Invariant2 instances
-------------------------------------------------------------------------------

instance Invariant2 (->) where invmap2 = invmap2Profunctor
instance Invariant2 Either where invmap2 = invmap2Bifunctor
instance Invariant2 (,) where invmap2 f _ g _ ~(x, y) = (f x, g y)
instance Invariant2 ((,,) a) where invmap2 f _ g _ ~(a, x, y) = (a, f x, g y)
instance Invariant2 ((,,,) a b) where
  invmap2 f _ g _ ~(a, b, x, y) = (a, b, f x, g y)
instance Invariant2 ((,,,,) a b c) where
  invmap2 f _ g _ ~(a, b, c, x, y) = (a, b, c, f x, g y)

-- | from "Control.Applicative"
instance Invariant2 Const where invmap2 = invmap2Bifunctor
-- | from "Control.Applicative"
instance Arrow arr => Invariant2 (App.WrappedArrow arr) where
  invmap2 _ f' g _ (App.WrapArrow x) = App.WrapArrow $ arr g Cat.. x Cat.. arr f'

-- | from "Control.Arrow"
instance Monad m => Invariant2 (Kleisli m) where
  invmap2 _ f' g _ (Kleisli m) = Kleisli $ liftM g . m . f'

-- | from "Data.Semigroup"
instance Invariant2 Arg where
  invmap2 = invmap2Bifunctor

-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant f, Invariant g) => Invariant2 (Biff p f g) where
  invmap2 f f' g g' =
    Biff . invmap2 (invmap f f') (invmap f' f) (invmap g g') (invmap g' g) . runBiff
-- | from the @bifunctors@ package
instance Invariant f => Invariant2 (Clown f) where
  invmap2 f f' _ _ = Clown . invmap f f' . runClown
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant2 (Flip p) where
  invmap2 f f' g g' = Flip . invmap2 g g' f f' . runFlip
-- | from the @bifunctors@ package
instance Invariant g => Invariant2 (Joker g) where
  invmap2 _ _ g g' = Joker . invmap g g' . runJoker
-- | from the @bifunctors@ package
instance (Invariant2 f, Invariant2 g) => Invariant2 (Bifunctor.Product f g) where
  invmap2 f f' g g' (Bifunctor.Pair x y) =
    Bifunctor.Pair (invmap2 f f' g g' x) (invmap2 f f' g g' y)
-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Bifunctor.Sum p q) where
  invmap2 f f' g g' (Bifunctor.L2 l) = Bifunctor.L2 (invmap2 f f' g g' l)
  invmap2 f f' g g' (Bifunctor.R2 r) = Bifunctor.R2 (invmap2 f f' g g' r)
-- | from the @bifunctors@ package
instance (Invariant f, Invariant2 p) => Invariant2 (Tannen f p) where
  invmap2 f f' g g' =
    Tannen . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runTannen
-- | from the @bifunctors@ package
instance Bifunctor p => Invariant2 (WrappedBifunctor p) where
  invmap2 = invmap2Bifunctor

-- | from the @comonad@ package
instance Comonad w => Invariant2 (Cokleisli w) where
   invmap2 _ f' g _ (Cokleisli w) = Cokleisli $ g . w . liftW f'

-- | from the @contravariant@ package
instance Invariant2 Op where
  invmap2 f f' g g' (Op x) = Op $ invmap2 g g' f f' x

-- | from the @profunctors@ package
instance Invariant f => Invariant2 (Star f) where
  invmap2 _ ba cd dc (Star afc) = Star $ invmap cd dc . afc . ba
-- | from the @profunctors@ package
instance Invariant f => Invariant2 (Costar f) where
  invmap2 ab ba cd _ (Costar fbc) = Costar $ cd . fbc . invmap ba ab
-- | from the @profunctors@ package
instance Arrow arr => Invariant2 (Pro.WrappedArrow arr) where
  invmap2 _ f' g _ (Pro.WrapArrow x) = Pro.WrapArrow $ arr g Cat.. x Cat.. arr f'
-- | from the @profunctors@ package
instance Invariant2 (Forget r) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance (Invariant f, Invariant2 p) => Invariant2 (Cayley f p) where
  invmap2 f f' g g' =
    Cayley . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runCayley
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Closure p) where
  invmap2 f f' g g' (Closure p) = Closure $ invmap2 (f .) (f' .) (g .) (g' .) p
-- | from the @profunctors@ package
instance Invariant2 (Environment p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Codensity p) where
  invmap2 ac ca bd db (Codensity f) =
    Codensity (invmap2 id id bd db . f . invmap2 id id ca ac)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Procompose p q) where
  invmap2 l l' r r' (Procompose f g) =
    Procompose (invmap2 id id r r' f) (invmap2 l l' id id g)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Rift p q) where
  invmap2 ac ca bd db (Rift f) = Rift (invmap2 ac ca id id . f . invmap2 db bd id id)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Ran p q) where
  invmap2 ac ca bd db (Ran f) = Ran (invmap2 id id bd db . f . invmap2 id id ca ac)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Tambara p) where
  invmap2 f f' g g' (Tambara p) =
    Tambara $ invmap2 (first f) (first f') (first g) (first g') p
-- | from the @profunctors@ package
instance Invariant2 (PastroSum p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (CofreeMapping p) where
  invmap2 f f' g g' (CofreeMapping p) =
    CofreeMapping (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p)
-- | from the @profunctors@ package
instance Invariant2 (FreeMapping p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (CofreeTraversing p) where
  invmap2 f f' g g' (CofreeTraversing p) =
    CofreeTraversing (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p)
-- | from the @profunctors@ package
instance Invariant2 (FreeTraversing p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Pastro p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Cotambara p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (CopastroSum p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (CotambaraSum p) where
  invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (TambaraSum p) where
  invmap2 f f' g g' (TambaraSum p) =
    TambaraSum (invmap2 (first f) (first f') (first g) (first g') p)
-- | from the @profunctors@ package
instance Invariant2 (Yoneda p) where
  invmap2 = invmap2Profunctor

-- | from the @tagged@ package
instance Invariant2 Tagged where
  invmap2 = invmap2Bifunctor

-- | from the @transformers@ package
instance Invariant2 Constant where
  invmap2 f _ _ _ (Constant x) = Constant (f x)

-------------------------------------------------------------------------------
-- WrappedProfunctor
-------------------------------------------------------------------------------

-- | Wrap a 'Profunctor' to be used as a member of 'Invariant2'.
newtype WrappedProfunctor p a b = WrapProfunctor { unwrapProfunctor :: p a b }
  deriving (Eq, Ord, Read, Show)

instance Profunctor p => Invariant2 (WrappedProfunctor p) where
  invmap2 = invmap2Profunctor

instance Profunctor p => Invariant (WrappedProfunctor p a) where
  invmap = invmap2 id id

instance Profunctor p => Profunctor (WrappedProfunctor p) where
  dimap f g = WrapProfunctor . dimap f g . unwrapProfunctor
  lmap f    = WrapProfunctor . lmap f    . unwrapProfunctor
  rmap g    = WrapProfunctor . rmap g    . unwrapProfunctor
  WrapProfunctor x .# f = WrapProfunctor (x .# f)
  g #. WrapProfunctor x = WrapProfunctor (g #. x)

instance Cat.Category p => Cat.Category (WrappedProfunctor p) where
  id = WrapProfunctor Cat.id
  WrapProfunctor p1 . WrapProfunctor p2 = WrapProfunctor (p1 Cat.. p2)

instance Arrow p => Arrow (WrappedProfunctor p) where
  arr    = WrapProfunctor . arr
  first  = WrapProfunctor . Arr.first  . unwrapProfunctor
  second = WrapProfunctor . Arr.second . unwrapProfunctor
  WrapProfunctor p1 *** WrapProfunctor p2 = WrapProfunctor (p1 *** p2)
  WrapProfunctor p1 &&& WrapProfunctor p2 = WrapProfunctor (p1 &&& p2)

instance ArrowZero p => ArrowZero (WrappedProfunctor p) where
  zeroArrow = WrapProfunctor zeroArrow

instance ArrowPlus p => ArrowPlus (WrappedProfunctor p) where
  WrapProfunctor p1 <+> WrapProfunctor p2 = WrapProfunctor (p1 <+> p2)

instance ArrowChoice p => ArrowChoice (WrappedProfunctor p) where
  left  = WrapProfunctor . left  . unwrapProfunctor
  right = WrapProfunctor . right . unwrapProfunctor
  WrapProfunctor p1 +++ WrapProfunctor p2 = WrapProfunctor (p1 +++ p2)
  WrapProfunctor p1 ||| WrapProfunctor p2 = WrapProfunctor (p1 ||| p2)

instance ArrowLoop p => ArrowLoop (WrappedProfunctor p) where
  loop = WrapProfunctor . loop . unwrapProfunctor

instance Strong p => Strong (WrappedProfunctor p) where
  first'  = WrapProfunctor . first'  . unwrapProfunctor
  second' = WrapProfunctor . second' . unwrapProfunctor

instance Choice p => Choice (WrappedProfunctor p) where
  left'  = WrapProfunctor . left'  . unwrapProfunctor
  right' = WrapProfunctor . right' . unwrapProfunctor

instance Costrong p => Costrong (WrappedProfunctor p) where
  unfirst  = WrapProfunctor . unfirst  . unwrapProfunctor
  unsecond = WrapProfunctor . unsecond . unwrapProfunctor

instance Cochoice p => Cochoice (WrappedProfunctor p) where
  unleft  = WrapProfunctor . unleft  . unwrapProfunctor
  unright = WrapProfunctor . unright . unwrapProfunctor

instance Closed p => Closed (WrappedProfunctor p) where
  closed = WrapProfunctor . closed . unwrapProfunctor

instance Traversing p => Traversing (WrappedProfunctor p) where
  traverse' = WrapProfunctor . traverse' . unwrapProfunctor
  wander f  = WrapProfunctor . wander f  . unwrapProfunctor

instance Mapping p => Mapping (WrappedProfunctor p) where
  map' = WrapProfunctor . map' . unwrapProfunctor

instance ProfunctorFunctor WrappedProfunctor where
  promap f = WrapProfunctor . f . unwrapProfunctor

instance ProfunctorMonad WrappedProfunctor where
  proreturn = WrapProfunctor
  projoin   = unwrapProfunctor

instance ProfunctorComonad WrappedProfunctor where
  proextract   = unwrapProfunctor
  produplicate = WrapProfunctor

#if GHC_GENERICS_OK
-------------------------------------------------------------------------------
-- GHC Generics
-------------------------------------------------------------------------------

-- | from "GHC.Generics"
instance Invariant V1 where
  -- NSF 25 July 2015: I'd prefer an -XEmptyCase, but Haskell98.
  invmap _ _ x = x `seq` error "Invariant V1"
-- | from "GHC.Generics"
instance Invariant U1 where invmap _ _ _ = U1
-- | from "GHC.Generics"
instance (Invariant l, Invariant r) => Invariant ((:+:) l r) where
  invmap f g (L1 l) = L1 $ invmap f g l
  invmap f g (R1 r) = R1 $ invmap f g r
-- | from "GHC.Generics"
instance (Invariant l, Invariant r) => Invariant ((:*:) l r) where
  invmap f g ~(l :*: r) = invmap f g l :*: invmap f g r
-- | from "GHC.Generics"
instance Invariant (K1 i c) where invmap _ _ (K1 c) = K1 c
-- | from "GHC.Generics"
instance Invariant2 (K1 i) where invmap2 f _ _ _ (K1 c) = K1 $ f c
-- | from "GHC.Generics"
instance Invariant f => Invariant (M1 i t f) where invmap f g (M1 fp) = M1 $ invmap f g fp
-- | from "GHC.Generics"
instance Invariant Par1 where invmap f _ (Par1 c) = Par1 $ f c
-- | from "GHC.Generics"
instance Invariant f => Invariant (Rec1 f) where invmap f g (Rec1 fp) = Rec1 $ invmap f g fp
-- | from "GHC.Generics"
instance (Invariant f, Invariant g) => Invariant ((:.:) f g) where
  invmap f g (Comp1 fgp) = Comp1 $ invmap (invmap f g) (invmap g f) fgp

# if __GLASGOW_HASKELL__ >= 800
-- | from "GHC.Generics"
instance Invariant UAddr where
  invmap _ _ (UAddr a) = UAddr a

-- | from "GHC.Generics"
instance Invariant UChar where
  invmap _ _ (UChar c) = UChar c

-- | from "GHC.Generics"
instance Invariant UDouble where
  invmap _ _ (UDouble d) = UDouble d

-- | from "GHC.Generics"
instance Invariant UFloat where
  invmap _ _ (UFloat f) = UFloat f

-- | from "GHC.Generics"
instance Invariant UInt where
  invmap _ _ (UInt i) = UInt i

-- | from "GHC.Generics"
instance Invariant UWord where
  invmap _ _ (UWord w) = UWord w
# endif

{- $ghcgenerics
With GHC 7.2 or later, 'Invariant' instances can be defined easily using GHC
generics like so:

@
{-# LANGUAGE DeriveGeneric, FlexibleContexts #-}

import Data.Functor.Invariant
import GHC.Generics

data T f a = T (f a) deriving Generic1

instance Invariant f => 'Invariant' (T f)
@

Be aware that generic 'Invariant' instances cannot be derived for data types
that have function arguments in which the last type parameter appears in a
position other than the result type (e.g., @data Fun a = Fun (a -> a)@). For
these, you can derive them using the "Data.Functor.Invariant.TH" module.
-}

-- | A generic implementation of 'invmap'.
genericInvmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
genericInvmap f g = to1 . invmap f g . from1
#endif

-------------------------------------------------------------------------------
-- Wrappers
-------------------------------------------------------------------------------

-- | A 'Profunctor' with the same input and output types can be seen as an 'Invariant' functor.
newtype InvariantProfunctor p a = InvariantProfunctor (p a a)

instance Profunctor p => Invariant (InvariantProfunctor p) where
  invmap fn1 fn2 (InvariantProfunctor f) = InvariantProfunctor (dimap fn2 fn1 f)

-- | An 'Arrow' with the same input and output types can be seen as an 'Invariant' functor.
newtype InvariantArrow c a = InvariantArrow (c a a)

instance Arrow c => Invariant (InvariantArrow c) where
  invmap fn1 fn2 (InvariantArrow arrow) = InvariantArrow (arr fn1 Cat.. arrow Cat.. arr fn2)


-----------------------------------------------------------------------------
-- |
-- Module      :  Control.DeepSeq
-- Copyright   :  (c) The University of Glasgow 2001-2009
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- Provides an overloaded function 'deepseq' for fully evaluating data
-- structures.
--

module Control.DeepSeq (
     deepseq,
     NFData(..),
  ) where

import Data.Int
import Data.Word
import Data.Ratio
import Data.Complex
import Data.Map
import Data.Set
import Data.IntMap
import Data.IntSet
import Data.Tree
import Data.Array

-- | Fully evaluates its argument.  The name 'deepseq' is used to
-- illustrate the relationship to 'seq': where 'seq' is shallow in
-- the sense that it only evaluates the top level of its argument,
-- 'deepseq' traverses the entire data structure evaluating it
-- completely.
--
-- 'deepseq' can be useful for forcing pending exceptions,
-- eradicating space leaks, or forcing lazy I/O to happen.  It is
-- also useful in conjunction with parallel Strategies (see the
-- @parallel@ package).
--
-- There is no guarantee about the ordering of evaluation.  The
-- implementation may evaluate the components of the structure in
-- any order or in parallel.  To impose an actual order on
-- evaluation, use 'pseq' from "Control.Parallel" in the
-- @parallel@ package.
--
deepseq :: NFData a => a -> b -> b
deepseq a b = rnf a `seq` b

-- A class of types that can be fully evaluated.
class NFData a where
    -- | rnf should reduce its argument to normal form (that is, fully
    -- evaluate all sub-components), and then return '()'.
    --
    -- The default implementation of 'rnf' is
    --
    -- > rnf a = a `seq` ()
    --
    -- which may be convenient when defining instances for data types with
    -- no unevaluated fields (e.g. enumerations).
    rnf :: a -> ()
    rnf a = a `seq` ()

instance NFData Int
instance NFData Word
instance NFData Integer
instance NFData Float
instance NFData Double

instance NFData Char
instance NFData Bool
instance NFData ()

instance NFData Int8
instance NFData Int16
instance NFData Int32
instance NFData Int64

instance NFData Word8
instance NFData Word16
instance NFData Word32
instance NFData Word64

--Rational and complex numbers.

instance (Integral a, NFData a) => NFData (Ratio a) where
  rnf x = rnf (numerator x, denominator x)

instance (RealFloat a, NFData a) => NFData (Complex a) where
  rnf (x:+y) = rnf x `seq`
               rnf y `seq`
               ()

instance NFData a => NFData (Maybe a) where
    rnf Nothing  = ()
    rnf (Just x) = rnf x

instance (NFData a, NFData b) => NFData (Either a b) where
    rnf (Left x)  = rnf x
    rnf (Right y) = rnf y

instance (NFData k, NFData a) => NFData (Data.Map.Map k a) where
    rnf = rnf . Data.Map.toList

instance NFData a => NFData (Data.Set.Set a) where
    rnf = rnf . Data.Set.toList

instance NFData a => NFData (Data.Tree.Tree a) where
    rnf (Data.Tree.Node r f) = rnf r `seq` rnf f

instance NFData a => NFData (Data.IntMap.IntMap a) where
    rnf = rnf . Data.IntMap.toList

instance NFData Data.IntSet.IntSet where
    rnf = rnf . Data.IntSet.toList

instance NFData a => NFData [a] where
    rnf [] = ()
    rnf (x:xs) = rnf x `seq` rnf xs

instance (Ix a, NFData a, NFData b) => NFData (Array a b) where
    rnf x = rnf (bounds x, Data.Array.elems x)

instance (NFData a, NFData b) => NFData (a,b) where
  rnf (x,y) = rnf x `seq` rnf y

instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
  rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z

instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
  rnf (x1,x2,x3,x4) = rnf x1 `seq`
		        rnf x2 `seq`
		        rnf x3 `seq`
		        rnf x4

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData (a1, a2, a3, a4, a5) where
  rnf (x1, x2, x3, x4, x5) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData (a1, a2, a3, a4, a5, a6) where
  rnf (x1, x2, x3, x4, x5, x6) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData (a1, a2, a3, a4, a5, a6, a7) where
  rnf (x1, x2, x3, x4, x5, x6, x7) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8 `seq`
                  rnf x9


{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Trustworthy #-}

#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE NoPolyKinds #-}
{-# LANGUAGE NoDataKinds #-}
#endif

-- Disable the warnings generated by 'to', 'ito', 'like', 'ilike'.
-- These functions are intended to produce 'Getters'. Without this constraint
-- users would get warnings when annotating types at uses of these functions.
#if __GLASGOW_HASKELL__ >= 711
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif

#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -Wno-trustworthy-safe #-}
#endif
-------------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Getter
-- Copyright   :  (C) 2012-16 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types
--
--
-- A @'Getter' s a@ is just any function @(s -> a)@, which we've flipped
-- into continuation passing style, @(a -> r) -> s -> r@ and decorated
-- with 'Const' to obtain:
--
-- @type 'Getting' r s a = (a -> 'Const' r a) -> s -> 'Const' r s@
--
-- If we restrict access to knowledge about the type 'r', we could get:
--
-- @type 'Getter' s a = forall r. 'Getting' r s a@
--
-- However, for 'Getter' (but not for 'Getting') we actually permit any
-- functor @f@ which is an instance of both 'Functor' and 'Contravar.Functor':
--
-- @type 'Getter' s a = forall f. ('Contravar.Functor' f, 'Functor' f) => (a -> f a) -> s -> f s@
--
-- Everything you can do with a function, you can do with a 'Getter', but
-- note that because of the continuation passing style ('.') composes them
-- in the opposite order.
--
-- Since it is only a function, every 'Getter' obviously only retrieves a
-- single value for a given input.
--
-- A common question is whether you can combine multiple 'Getter's to
-- retrieve multiple values. Recall that all 'Getter's are 'Fold's and that
-- we have a @'Monoid' m => 'Applicative' ('Const' m)@ instance to play
-- with. Knowing this, we can use @'Data.Monoid.<>'@ to glue 'Fold's
-- together:
--
-- >>> import Data.Monoid
-- >>> (1, 2, 3, 4, 5) ^.. (_2 <> _3 <> _5)
-- [2,3,5]
--
-------------------------------------------------------------------------------
module Control.Lens.Getter
  (
  -- * Getters
    Getter -- , IndexedGetter
  , Getting -- , IndexedGetting
  , Accessing
  -- * Building Getters
  , to
--  , ito
  , like
--  , ilike
  -- * Combinators for Getters and Folds
  , (^.)
  , view, views
  , use, uses
  , listening, listenings
{-
  -- * Indexed Getters
  -- ** Indexed Getter Combinators
  , (^@.)
  , iview, iviews
  , iuse, iuses
  , ilistening, ilistenings
-}
  -- * Implementation Details
  , getting
  , Const(..)
  ) where

import Control.Applicative
--import Control.Lens.Internal.Indexed
import Control.Lens.Type
import Control.Monad.Reader.Class as Reader
import Control.Monad.State        as State
import Control.Monad.Writer       as Writer
import Data.Functor.Contravariant (gmap, phantom)
import qualified Data.Functor.Contravariant as Contravar
import Data.Profunctor
import Data.Profunctor.Unsafe

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
-- >>> import Data.List.Lens
-- >>> import Debug.SimpleReflect.Expr
-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)
-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g

infixl 8 ^. {- , ^@. -}

-------------------------------------------------------------------------------
-- Getters
-------------------------------------------------------------------------------

-- | Build an (index-preserving) 'Getter' from an arbitrary Haskell function.
--
-- @
-- 'to' f '.' 'to' g ≡ 'to' (g '.' f)
-- @
--
-- @
-- a '^.' 'to' f ≡ f a
-- @
--
-- >>> a ^.to f
-- f a
--
-- >>> ("hello","world")^.to snd
-- "world"
--
-- >>> 5^.to succ
-- 6
--
-- >>> (0, -5)^._2.to abs
-- 5
--
-- @
-- 'to' :: (s -> a) -> 'IndexPreservingGetter' s a
-- @
to :: (Profunctor p, Contravar.Functor f) => (s -> a) -> Optic' p f s a
to k = dimap k (gmap k)
{-# INLINE to #-}

{-
-- |
-- @
-- 'ito' :: (s -> (i, a)) -> 'IndexedGetter' i s a
-- @
ito :: (Indexable i p, Contravar.Functor f) => (s -> (i, a)) -> Over' p f s a
ito k = dimap k (gmap (snd . k)) . uncurry . indexed
{-# INLINE ito #-}
-}

-- | Build an constant-valued (index-preserving) 'Getter' from an arbitrary Haskell value.
--
-- @
-- 'like' a '.' 'like' b ≡ 'like' b
-- a '^.' 'like' b ≡ b
-- a '^.' 'like' b ≡ a '^.' 'to' ('const' b)
-- @
--
-- This can be useful as a second case 'failing' a 'Fold'
-- e.g. @foo `failing` 'like' 0@
--
-- @
-- 'like' :: a -> 'IndexPreservingGetter' s a
-- @
like :: (Profunctor p, Contravar.Functor f, Functor f) => a -> Optic' p f s a
like a = to (const a)
{-# INLINE like #-}

{-
-- |
-- @
-- 'ilike' :: i -> a -> 'IndexedGetter' i s a
-- @
ilike :: (Indexable i p, Contravar.Functor f, Functor f) => i -> a -> Over' p f s a
ilike i a = ito (const (i, a))
{-# INLINE ilike #-}
-}

-- | When you see this in a type signature it indicates that you can
-- pass the function a 'Lens', 'Getter',
-- 'Control.Lens.Traversal.Traversal', 'Control.Lens.Fold.Fold',
-- 'Control.Lens.Prism.Prism', 'Control.Lens.Iso.Iso', or one of
-- the indexed variants, and it will just \"do the right thing\".
--
-- Most 'Getter' combinators are able to be used with both a 'Getter' or a
-- 'Control.Lens.Fold.Fold' in limited situations, to do so, they need to be
-- monomorphic in what we are going to extract with 'Control.Applicative.Const'. To be compatible
-- with 'Lens', 'Control.Lens.Traversal.Traversal' and
-- 'Control.Lens.Iso.Iso' we also restricted choices of the irrelevant @t@ and
-- @b@ parameters.
--
-- If a function accepts a @'Getting' r s a@, then when @r@ is a 'Data.Monoid.Monoid', then
-- you can pass a 'Control.Lens.Fold.Fold' (or
-- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a
-- 'Getter' or 'Lens'.
type Getting r s a = (a -> Const r a) -> s -> Const r s

{-
-- | Used to consume an 'Control.Lens.Fold.IndexedFold'.
type IndexedGetting i m s a = Indexed i a (Const m a) -> s -> Const m s
-}

-- | This is a convenient alias used when consuming (indexed) getters and (indexed) folds
-- in a highly general fashion.
type Accessing p m s a = p a (Const m a) -> s -> Const m s

-------------------------------------------------------------------------------
-- Getting Values
-------------------------------------------------------------------------------

-- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or
-- 'Lens' or the result of folding over all the results of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- at a monoidal value.
--
-- @
-- 'view' '.' 'to' ≡ 'id'
-- @
--
-- >>> view (to f) a
-- f a
--
-- >>> view _2 (1,"hello")
-- "hello"
--
-- >>> view (to succ) 5
-- 6
--
-- >>> view (_2._1) ("hello",("world","!!!"))
-- "world"
--
--
-- As 'view' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restricted signatures:
--
-- @
-- 'view' ::             'Getter' s a     -> s -> a
-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s m       -> s -> m
-- 'view' ::             'Control.Lens.Iso.Iso'' s a       -> s -> a
-- 'view' ::             'Lens'' s a      -> s -> a
-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s m -> s -> m
-- @
--
-- In a more general setting, such as when working with a 'Monad' transformer stack you can use:
--
-- @
-- 'view' :: 'MonadReader' s m             => 'Getter' s a     -> m a
-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Fold.Fold' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Iso.Iso'' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Lens'' s a      -> m a
-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> m a
-- @
view :: MonadReader s m => Getting a s a -> m a
view l = Reader.asks (getConst #. l Const)
{-# INLINE view #-}

-- | View a function of the value pointed to by a 'Getter' or 'Lens' or the result of
-- folding over the result of mapping the targets of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal'.
--
-- @
-- 'views' l f ≡ 'view' (l '.' 'to' f)
-- @
--
-- >>> views (to f) g a
-- g (f a)
--
-- >>> views _2 length (1,"hello")
-- 5
--
-- As 'views' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restricted signatures:
--
-- @
-- 'views' ::             'Getter' s a     -> (a -> r) -> s -> r
-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s a       -> (a -> m) -> s -> m
-- 'views' ::             'Control.Lens.Iso.Iso'' s a       -> (a -> r) -> s -> r
-- 'views' ::             'Lens'' s a      -> (a -> r) -> s -> r
-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s a -> (a -> m) -> s -> m
-- @
--
-- In a more general setting, such as when working with a 'Monad' transformer stack you can use:
--
-- @
-- 'views' :: 'MonadReader' s m             => 'Getter' s a     -> (a -> r) -> m r
-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a       -> (a -> r) -> m r
-- 'views' :: 'MonadReader' s m             => 'Control.Lens.Iso.Iso'' s a       -> (a -> r) -> m r
-- 'views' :: 'MonadReader' s m             => 'Lens'' s a      -> (a -> r) -> m r
-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r
-- @
--
-- @
-- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r
-- @
views :: MonadReader s m => LensLike' (Const r) s a -> (a -> r) -> m r
views l f = Reader.asks (getConst #. l (Const #. f))
{-# INLINE views #-}

-- | View the value pointed to by a 'Getter' or 'Lens' or the
-- result of folding over all the results of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal' that points at a monoidal values.
--
-- This is the same operation as 'view' with the arguments flipped.
--
-- The fixity and semantics are such that subsequent field accesses can be
-- performed with ('Prelude..').
--
-- >>> (a,b)^._2
-- b
--
-- >>> ("hello","world")^._2
-- "world"
--
-- >>> import Data.Complex
-- >>> ((0, 1 :+ 2), 3)^._1._2.to magnitude
-- 2.23606797749979
--
-- @
-- ('^.') ::             s -> 'Getter' s a     -> a
-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Fold.Fold' s m       -> m
-- ('^.') ::             s -> 'Control.Lens.Iso.Iso'' s a       -> a
-- ('^.') ::             s -> 'Lens'' s a      -> a
-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Traversal.Traversal'' s m -> m
-- @
(^.) :: s -> Getting a s a -> a
s ^. l = getConst (l Const s)
{-# INLINE (^.) #-}

-------------------------------------------------------------------------------
-- MonadState
-------------------------------------------------------------------------------

-- | Use the target of a 'Lens', 'Control.Lens.Iso.Iso', or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- to a monoidal value.
--
-- >>> evalState (use _1) (a,b)
-- a
--
-- >>> evalState (use _1) ("hello","world")
-- "hello"
--
-- @
-- 'use' :: 'MonadState' s m             => 'Getter' s a     -> m a
-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s r       -> m r
-- 'use' :: 'MonadState' s m             => 'Control.Lens.Iso.Iso'' s a       -> m a
-- 'use' :: 'MonadState' s m             => 'Lens'' s a      -> m a
-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s r -> m r
-- @
use :: MonadState s m => Getting a s a -> m a
use l = State.gets (view l)
{-# INLINE use #-}

-- | Use the target of a 'Lens', 'Control.Lens.Iso.Iso' or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that
-- points to a monoidal value.
--
-- >>> evalState (uses _1 length) ("hello","world")
-- 5
--
-- @
-- 'uses' :: 'MonadState' s m             => 'Getter' s a     -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a       -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Lens'' s a      -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Control.Lens.Iso.Iso'' s a       -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r
-- @
--
-- @
-- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r
-- @
uses :: MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r
uses l f = State.gets (views l f)
{-# INLINE uses #-}

-- | This is a generalized form of 'listen' that only extracts the portion of
-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'listening' :: 'MonadWriter' w m             => 'Getter' w u     -> m a -> m (a, u)
-- 'listening' :: 'MonadWriter' w m             => 'Lens'' w u      -> m a -> m (a, u)
-- 'listening' :: 'MonadWriter' w m             => 'Iso'' w u       -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Fold' w u       -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Traversal'' w u -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Prism'' w u     -> m a -> m (a, u)
-- @
listening :: MonadWriter w m => Getting u w u -> m a -> m (a, u)
listening l m = do
  (a, w) <- listen m
  return (a, view l w)
{-# INLINE listening #-}

{-
-- | This is a generalized form of 'listen' that only extracts the portion of
-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'ilistening' :: 'MonadWriter' w m             => 'IndexedGetter' i w u     -> m a -> m (a, (i, u))
-- 'ilistening' :: 'MonadWriter' w m             => 'IndexedLens'' i w u      -> m a -> m (a, (i, u))
-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedFold' i w u       -> m a -> m (a, (i, u))
-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedTraversal'' i w u -> m a -> m (a, (i, u))
-- @
ilistening :: MonadWriter w m => IndexedGetting i (i, u) w u -> m a -> m (a, (i, u))
ilistening l m = do
  (a, w) <- listen m
  return (a, iview l w)
{-# INLINE ilistening #-}
-}

-- | This is a generalized form of 'listen' that only extracts the portion of
-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'listenings' :: 'MonadWriter' w m             => 'Getter' w u     -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: 'MonadWriter' w m             => 'Lens'' w u      -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: 'MonadWriter' w m             => 'Iso'' w u       -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Fold' w u       -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Traversal'' w u -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Prism'' w u     -> (u -> v) -> m a -> m (a, v)
-- @
listenings :: MonadWriter w m => Getting v w u -> (u -> v) -> m a -> m (a, v)
listenings l uv m = do
  (a, w) <- listen m
  return (a, views l uv w)
{-# INLINE listenings #-}

{-
-- | This is a generalized form of 'listen' that only extracts the portion of
-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'ilistenings' :: 'MonadWriter' w m             => 'IndexedGetter' w u     -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: 'MonadWriter' w m             => 'IndexedLens'' w u      -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedFold' w u       -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedTraversal'' w u -> (i -> u -> v) -> m a -> m (a, v)
-- @
ilistenings :: MonadWriter w m => IndexedGetting i v w u -> (i -> u -> v) -> m a -> m (a, v)
ilistenings l iuv m = do
  (a, w) <- listen m
  return (a, iviews l iuv w)
{-# INLINE ilistenings #-}
-}

------------------------------------------------------------------------------
-- Indexed Getters
------------------------------------------------------------------------------

{-
-- | View the index and value of an 'IndexedGetter' into the current environment as a pair.
--
-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of
-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted.
iview :: MonadReader s m => IndexedGetting i (i,a) s a -> m (i,a)
iview l = asks (getConst #. l (Indexed $ \i -> Const #. (,) i))
{-# INLINE iview #-}

-- | View a function of the index and value of an 'IndexedGetter' into the current environment.
--
-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer.
--
-- @
-- 'iviews' ≡ 'Control.Lens.Fold.ifoldMapOf'
-- @
iviews :: MonadReader s m => IndexedGetting i r s a -> (i -> a -> r) -> m r
iviews l f = asks (getConst #. l (Const #. Indexed f))
{-# INLINE iviews #-}

-- | Use the index and value of an 'IndexedGetter' into the current state as a pair.
--
-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of
-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted.
iuse :: MonadState s m => IndexedGetting i (i,a) s a -> m (i,a)
iuse l = gets (getConst #. l (Indexed $ \i -> Const #. (,) i))
{-# INLINE iuse #-}

-- | Use a function of the index and value of an 'IndexedGetter' into the current state.
--
-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer.
iuses :: MonadState s m => IndexedGetting i r s a -> (i -> a -> r) -> m r
iuses l f = gets (getConst #. l (Const #. Indexed f))
{-# INLINE iuses #-}

-- | View the index and value of an 'IndexedGetter' or 'IndexedLens'.
--
-- This is the same operation as 'iview' with the arguments flipped.
--
-- The fixity and semantics are such that subsequent field accesses can be
-- performed with ('Prelude..').
--
-- @
-- ('^@.') :: s -> 'IndexedGetter' i s a -> (i, a)
-- ('^@.') :: s -> 'IndexedLens'' i s a  -> (i, a)
-- @
--
-- The result probably doesn't have much meaning when applied to an 'IndexedFold'.
(^@.) :: s -> IndexedGetting i (i, a) s a -> (i, a)
s ^@. l = getConst $ l (Indexed $ \i -> Const #. (,) i) s
{-# INLINE (^@.) #-}
-}

-- | Coerce a 'Getter'-compatible 'Optical' to an 'Optical''. This
-- is useful when using a 'Traversal' that is not simple as a 'Getter' or a
-- 'Fold'.
--
-- @
-- 'getting' :: 'Traversal' s t a b          -> 'Fold' s a
-- 'getting' :: 'Lens' s t a b               -> 'Getter' s a
-- 'getting' :: 'IndexedTraversal' i s t a b -> 'IndexedFold' i s a
-- 'getting' :: 'IndexedLens' i s t a b      -> 'IndexedGetter' i s a
-- @
getting :: (Profunctor p, Profunctor q, Functor f, Contravar.Functor f)
        => Optical p q f s t a b -> Optical' p q f s a
getting l f = rmap phantom . l $ rmap phantom f


module Polestar.PrettyPrint
  (prettyPrintTypeP
  ,prettyPrintType
  ,prettyPrintCanonicalTypeP
  ,prettyPrintICanonicalTypeP
  ,prettyPrintTermP
  ,prettyPrintTerm
  ) where
import Polestar.Type
import Polestar.Parse (NameBinding(..))
import Data.List (intersperse)
import Data.Complex

varNames :: [NameBinding] -> [String]
varNames = foldr (\x ys -> case x of
                             NVarBind n -> n:ys
                             _ -> ys) []

tyVarNames :: [NameBinding] -> [String]
tyVarNames = foldr (\x ys -> case x of
                               NTyVarBind n -> n:ys
                               _ -> ys) []

rename :: [String] -> String -> String
rename ctx name | name `notElem` ctx = name
                | otherwise = loop 1
  where loop :: Int -> String
        loop i = case name ++ show i of
          m | m `notElem` ctx -> m
          _ -> loop (i + 1)

showPrimType :: PrimType -> ShowS
showPrimType p = case p of
  PTyZero -> showString "Zero"
  PTyNat -> showString "Nat"
  PTyInt -> showString "Int"
  PTyNNReal -> showString "NNReal"
  PTyReal -> showString "Real"
  PTyImaginary -> showString "Imaginary"
  PTyComplex -> showString "Complex"
  PTyTrue -> showString "True"
  PTyFalse -> showString "False"
  PTyBool -> showString "Bool"
  PTyUnit -> showString "Unit"

-- <3>: <primitive type> | <type variable> | <0>
-- <2>: <3> -> <2>
-- <1>: <2> & .. & <2>
-- <0>: forall a <: <1>. <0> | <1>
prettyPrintTypeP :: Int -> [NameBinding] -> Type -> ShowS
prettyPrintTypeP p ctx t = case t of
  TyPrim p -> showPrimType p
  TyArr s t -> showParen (p > 2) $ prettyPrintTypeP 3 ctx s . showString " -> " . prettyPrintTypeP 2 (NAnonymousBind : ctx) t
  TyRef i | i < length ctx -> case ctx !! i of
              NTyVarBind n -> showString n
              n -> showString "<invalid type variable reference #" . shows i . showString ": " . shows n . showChar '>'
          | otherwise -> showString "<invalid type variable reference #" . shows i . showString ", index out of range>"
  TyAll (Id name) Nothing t -> showParen (p > 0) $ showString "forall " . showString name' . showString ". " . prettyPrintTypeP 0 (NTyVarBind name' : ctx) t
    where name' = rename (tyVarNames ctx) name
  TyAll (Id name) (Just b) t -> showParen (p > 0) $ showString "forall " . showString name' . showString "<:" . prettyPrintTypeP 1 ctx b . showString ". " . prettyPrintTypeP 0 (NTyVarBind name' : ctx) t
    where name' = rename (tyVarNames ctx) name
  TyInter tys -> showParen (p > 1) $ foldr (.) id $ intersperse (showString " & ") $ map (prettyPrintTypeP 2 ctx) tys
  TyTuple components -> showParen True $ foldr (.) id $ intersperse (showString ", ") $ map (prettyPrintTypeP 0 ctx) components

prettyPrintType :: Type -> String
prettyPrintType t = prettyPrintTypeP 0 [] t ""

prettyPrintCanonicalTypeP :: Int -> [NameBinding] -> CanonicalType -> ShowS
prettyPrintCanonicalTypeP p ctx [] = showString "<untyped>"
prettyPrintCanonicalTypeP p ctx [t] = prettyPrintICanonicalTypeP p ctx t
prettyPrintCanonicalTypeP p ctx ts = showParen (p > 1) $ foldl1 (\x y -> x . showString " & " . y) $ map (prettyPrintICanonicalTypeP 2 ctx) ts

prettyPrintICanonicalTypeP :: Int -> [NameBinding] -> ICanonicalType -> ShowS
prettyPrintICanonicalTypeP p ctx t = case t of
  CTyPrim p -> showPrimType p
  CTyArr s t -> showParen (p > 2) $ prettyPrintCanonicalTypeP 3 ctx s . showString " -> " . prettyPrintICanonicalTypeP 2 (NAnonymousBind : ctx) t
  CTyRef i | i < length ctx -> case ctx !! i of
               NTyVarBind n -> showString n
               n -> showString "<invalid type variable reference #" . shows i . showString ": " . shows n . showChar '>'
           | otherwise -> showString "<invalid type variable reference #" . shows i . showString ", index out of range>"
  CTyAll (Id name) [] t -> showParen (p > 0) $ showString "forall " . showString name' . showString ". " . prettyPrintICanonicalTypeP 0 (NTyVarBind name' : ctx) t
    where name' = rename (tyVarNames ctx) name
  CTyAll (Id name) b t -> showParen (p > 0) $ showString "forall " . showString name' . showString "<:" . prettyPrintCanonicalTypeP 1 ctx b . showString ". " . prettyPrintICanonicalTypeP 0 (NTyVarBind name' : ctx) t
    where name' = rename (tyVarNames ctx) name
  CTyTuple components -> showParen True $ foldr (.) id $ intersperse (showString ", ") $ map (prettyPrintICanonicalTypeP 0 ctx) components

-- <2>: <primitive> | <variable> | (<0>)
-- <1>: <1> <2> | <1> [ty] | <1> as <type>
-- <0>: \x:t. <0> | ?a. <0> | if <0> then <0> else <0>
prettyPrintTermP :: Int -> [NameBinding] -> Term -> ShowS
prettyPrintTermP p ctx t = case t of
  TmPrim (PVZero) -> showChar '0'
  TmPrim (PVInt x) -> shows x
  TmPrim (PVReal x) -> shows x
  TmPrim (PVImaginary x) -> shows x . showChar 'i'
  TmPrim (PVComplex (x :+ y)) -> showParen True $ shows x . showChar '+' . shows y . showChar 'i'
  TmPrim (PVBool x) -> if x then showString "true" else showString "false"
  TmPrim PVUnit -> showString "unit"
  TmPrim (PVBuiltin f) -> showString $ case f of
    BNegate -> "negate"
    BLogicalNot -> "not"
    BNatToInt -> "natToInt"
    BNatToNNReal -> "natToNNReal"
    BIntToNat -> "intToNat"
    BIntToReal -> "intToReal"
    BNNRealToReal -> "nnrealToReal"
    BRealToComplex -> "realToComplex"
    BMkImaginary -> "mkImaginary"
    BImaginaryToComplex -> "imaginaryToComplex"
    BRealPart -> "realPart"
    BImagPart -> "imagPart"
    BAbs -> "abs"
    BSqrt -> "sqrt"
    BExp -> "exp"
    BExpm1 -> "expm1"
    BLog -> "log"
    BLog1p -> "log1p"
    BSin -> "sin"
    BCos -> "cos"
    BTan -> "tan"
    BSinh -> "sinh"
    BCosh -> "cosh"
    BTanh -> "tanh"
    BAsin -> "asin"
    BAcos -> "acos"
    BAtan -> "atan"
    BAsinh -> "asinh"
    BAcosh -> "acosh"
    BAtanh -> "atanh"
    BAdd -> "add"
    BSub -> "sub"
    BMul -> "mul"
    BDiv -> "div"
    BPow -> "pow"
    BTSubNat -> "tSub"
    BLt -> "lt"
    BLe -> "le"
    BEqual -> "equal"
    BMax -> "max"
    BMin -> "min"
    BIntDiv -> "intDiv"
    BIntMod -> "mod"
    BGcd -> "gcd"
    BLcm -> "lcm"
    BLogicalAnd -> "and"
    BLogicalOr -> "or"
    BIterate -> "iterate"
  TmAbs (Id name) ty body -> showParen (p > 0) $ showChar '\\' . showString name' . showChar ':' . prettyPrintTypeP 1 ctx ty . showString ". " . prettyPrintTermP 0 (NVarBind name' : ctx) body
    where name' = rename (varNames ctx) name
  TmTyAbs (Id name) Nothing body -> showParen (p > 0) $ showString "?" . showString name' . showString ". " . prettyPrintTermP 0 (NTyVarBind name' : ctx) body
    where name' = rename (tyVarNames ctx) name
  TmTyAbs (Id name) (Just b) body -> showParen (p > 0) $ showString "?" . showString name' . showString "<:" . prettyPrintTypeP 1 ctx b . showString ". " . prettyPrintTermP 0 (NTyVarBind name' : ctx) body
    where name' = rename (tyVarNames ctx) name
  TmRef i | i < length ctx -> case ctx !! i of
              NVarBind n -> showString n
              n -> showString "<invalid variable reference #" . shows i . showString ": " . shows n . showChar '>'
          | otherwise -> showString "<invalid variable reference #" . shows i . showString ", index out of range>"
  TmApp u v -> showParen (p > 1) $ prettyPrintTermP 1 ctx u . showChar ' ' . prettyPrintTermP 2 ctx v
  TmTyApp u t -> showParen (p > 1) $ prettyPrintTermP 1 ctx u . showString " [" . prettyPrintTypeP 0 ctx t . showChar ']'
  TmLet (Id name) def body -> showParen (p > 0) $ showString "let " . showString name' . showString " = " . prettyPrintTermP 0 ctx def . showString " in " . prettyPrintTermP 0 (NVarBind name' : ctx) body
    where name' = rename (varNames ctx) name
  TmIf cond then_ else_ -> showParen (p > 0) $ showString "if " . prettyPrintTermP 0 ctx cond . showString " then " . prettyPrintTermP 0 ctx then_ . showString " else " . prettyPrintTermP 0 ctx else_
  TmCoerce x t -> showParen (p > 1) $ prettyPrintTermP 1 ctx x . showString " as " . prettyPrintTypeP 1 ctx t
  TmAlt (Id name) candidates body -> showParen (p > 0) $ showString "for " . showString name' . showString " in " . foldr (.) id (intersperse (showString ", ") $ map (prettyPrintTypeP 1 ctx) candidates) . showString ". " . prettyPrintTermP 0 (NTyVarBind name' : ctx) body
    where name' = rename (tyVarNames ctx) name
  TmTuple components -> showParen True $ foldr (.) id $ intersperse (showString ", ") $ map (prettyPrintTermP 0 ctx) components
  TmProj tuple i -> showParen (p > 1) $ prettyPrintTermP 1 ctx tuple . showString " @" . shows i
  TmCoherentTuple components -> showString "<coherent tuple: " . (foldr (.) id $ intersperse (showString ", ") $ map (prettyPrintTermP 0 ctx) components) . showString ">"

prettyPrintTerm :: Term -> String
prettyPrintTerm t = prettyPrintTermP 0 [] t ""


module MNIST.Prelude
  ( module X
  , UVector
  , GVector
  , identity
  ) where

import Prelude                       as X hiding (id)
import Control.Applicative           as X
import Control.Arrow                 as X
import Control.Exception.Safe        as X
import Control.Monad                 as X
-- import Control.Monad.Random          as X
import Control.Monad.IO.Class        as X (liftIO)
import Control.Monad.Trans           as X (lift)
import Control.Monad.Trans.Except    as X hiding (liftCallCC, liftListen, liftPass)
import Control.Monad.Trans.Maybe     as X (MaybeT(..))
import Control.Monad.Trans.Reader    as X hiding (liftCallCC, liftCatch)
import Control.Monad.Trans.State     as X
import Control.DeepSeq               as X
import Criterion.Main                as X
import Criterion.Types               as X
import Data.Bitraversable            as X
import Data.Foldable                 as X
import Data.IDX                      as X
import Data.Int                      as X (Int32, Int64)
import Data.List                     as X (genericLength)
import Data.List.Split               as X
import Data.Maybe                    as X
import Data.Monoid                   as X
import Text.Printf                   as X
import Data.Time.Clock               as X
import Data.Time.Format              as X
import Data.Time.LocalTime           as X
import Data.Traversable              as X
import Data.Tuple                    as X
import Data.Type.Combinator          as X
import Data.Type.Index               as X
import Data.Type.Product             as X hiding (toList)
import Data.Vector                   as X (Vector)
import GHC.Generics                  as X (Generic)
import GHC.TypeLits                  as X
import GHC.IO                        as X (evaluate)
import Numeric.Backprop              as X (Op, op2')
import System.Directory              as X
import TensorFlow.Core               as X (Tensor, Shape, Build, TensorData, Session)
import Numeric.LinearAlgebra.Static  as X (R, L)

-- ========================================================================= --
-- Prelude customizations

import Data.Vector.Unboxed as UV (Vector)
import Data.Vector.Generic as G (Vector)
import qualified Prelude   as P

type UVector = UV.Vector
type GVector = G.Vector

identity :: a -> a
identity = P.id


module HtmlReport (htmlReport) where

import Data.Foldable (traverse_)
import Data.Semigroup((<>))
import Data.ByteString.Lazy (ByteString)
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes (src)
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)

import QuoteData
import StatReport (showStatEntryValue)
import Statistics
import Fmt

htmlReport :: (Functor t, Foldable t) => String -> t QuoteData -> StatInfo -> [FilePath] -> ByteString
htmlReport title quotes si images = renderHtml $
  docTypeHtml $ do
    H.head $ do
      H.title $ string title
      H.style style
    body $ do
      renderDiagram images
      rendetStatInfo si
      renderData quotes
  where
    style = "table {border-collapse: collapse}" <> "td, th {border: 1px solid black; padding: 3px}"

    renderDiagram [] = pure ()
    renderDiagram images = do
      h1 "Diagrams"
      traverse_ ((img!) . src . toValue) images

    rendetStatInfo [] = pure ()
    rendetStatInfo si@((_, ses):_) = do
      h1 "Statistic Report"
      table $ do
        thead . tr . traverse_ th $ "Quoted Field" : [text . fmt . build . stat $ s | s <- ses]
        tbody . traverse_ statData2TR $ si

    statData2TR (qf, entries) = tr $ do
      td . string $ show qf
      traverse_ (td . string . showStatEntryValue) entries

    renderData quotes = do
      h1 "Stock Quotes Data"
      table $ do
        thead . tr . traverse_ th $ ["Day", "Close", "Volume", "Open", "High", "Low"]
        tbody . traverse_ quoteData2TR $ quotes

    quoteData2TR QuoteData {..} = tr $ do
      td. string $ show day
      traverse_ (td . string . show) [close, volume, open, high, low]


module Parser.Parser (
    parseScheme
)
where

import Parser.MetaNode
import Control.Monad.State.Lazy
import Data.Data
import Common.Number
import Data.Complex
import Lexer.Token

parseScheme :: [Token] -> [MetaNode]
parseScheme st = case runState (parseExpression "Scheme Program") st of
    (mn, []) -> [mn]
    (mn, up) -> mn:parseScheme up
    --(_, t:_) -> error $ "Unexpected token " ++ show t ++ " not allowed in top level of program"

push :: Token -> State [Token] ()
push t = do
    ts <- get
    put (t:ts)

pull :: String -> State [Token] Token
pull context = do
    ts <- get
    case ts of
        (t:ts) -> do
            put ts
            return t
        _ -> error $ "Unexpected end of token stream in " ++ context

pullEq :: String -> Token -> State [Token] ()
pullEq context c = do
    t <- pull context
    if  t ==  c then
        return ()
    else
        error $ (show c) ++ " in " ++ context ++ " expected, but not found"

peek :: String -> State [Token] Token
peek context = do
    ts <- get
    case ts of
        (t:ts) -> return t
        _ -> error $ "Unexpected end of token stream in " ++ context

parseExpression :: String -> State [Token] MetaNode
parseExpression context = do
    t <- peek context
    case t of
        POpen -> parseSyntax
        ShortQuote -> do
            pullEq "Datum" ShortQuote
            parseQuotedDatum
        ShortQuasiQuote -> do
            pullEq "Quasiquoted Datum" ShortQuasiQuote
            parseQuasiQuotedDatum
        CommentDatum -> do
            pullEq "Commented Datum" CommentDatum
            parseExpression "Commented Datum"
            parseExpression context
        _ -> parseAtom

parseSyntax :: State [Token] MetaNode
parseSyntax = do
    pullEq "Syntactic construct" POpen
    t <- peek "Syntactic construct"
    case t of
        Lambda -> parseLambda
        Define -> parseDefine
        Quote -> parseQuote
        QuasiQuote -> parseQuasiQuote
        If -> parseIf
        Set -> parseSet
        PClose -> do
            pullEq "PClose" PClose
            return EmptyAtom
        DefineSyntax -> parseDefineSyntax
        LetSyntax -> parseLetSyntax
        LetrecSyntax -> parseLetrecSyntax
        _ -> parseApplication

parseAtom :: State [Token] MetaNode
parseAtom = do
    t <- pull "Atom"
    case t of
        Bool b -> return $ BoolAtom b
        String s -> return $ StringAtom s
        Char c -> return $ CharAtom c
        Number n -> return $ NumberAtom n
        Identifier i -> return $ IdentifierAtom i 0
        Quote -> return $ IdentifierAtom "quote" 0
        Unquote -> return $ IdentifierAtom "unquote" 0
        QuasiQuote -> return $ IdentifierAtom "quasiquote" 0
        Set  -> return $ IdentifierAtom "set!" 0
        Define  -> return $ IdentifierAtom "define" 0
        _ -> error $ "Unexpected token " ++ show t ++ " not allowed in current context"

parseQuote :: State [Token] MetaNode
parseQuote = do
    pullEq "Quote" Quote
    d <- parseQuotedDatum
    pullEq "Quote" PClose
    return d

parseQuasiQuote :: State [Token] MetaNode
parseQuasiQuote = do
    pullEq "Quasiquote" QuasiQuote
    d <- parseQuasiQuotedDatum
    pullEq "Quasiquote" PClose
    return d

parseLambda :: State [Token] MetaNode
parseLambda = do
    pullEq "Lambda" Lambda
    (c, l) <- parseFormalParameters
    e <- parseExpressionList "Body"
    return (LambdaNode c l e)

parseIf :: State [Token] MetaNode
parseIf = do
    pullEq "If" If
    p <- parseExpression "If Condition"
    a <- parseExpression "If Then Branch"
    next <- peek "If"
    if next /= PClose then do
        b <- parseExpression "If Else Branch"
        pullEq "If" PClose
        return (IfNode p a b)
    else do
        pullEq "If" PClose
        return (IfNode p a UnspecifiedAtom)

parseSet :: State [Token] MetaNode
parseSet = do
    pullEq "Set" Set
    t <- pull "Set"
    case t of
        (Identifier str) -> do
            e <- parseExpression "Set Body"
            pullEq "Set" PClose
            return (SetNode (IdentifierAtom str 0) e)
        _ -> error "Expected Identifier as first argument of set"

parseDefine :: State [Token] MetaNode
parseDefine = do
    pullEq "Define" Define
    t <- pull "Define"
    case t of
        (Identifier str) -> do
            p <- peek "Define"
            if p /= PClose then do
                e <- parseExpression "Define Body"
                pullEq "Define" PClose
                return (DefineNode (IdentifierAtom str 0) e)
            else do
                pullEq "Define" PClose
                return (DefineNode (IdentifierAtom str 0) UnspecifiedAtom)
        POpen -> parseDefineFunction
        _ -> error "Expected Identifier oder Parantheses as first argument of define"

parseDefineFunction :: State [Token] MetaNode
parseDefineFunction =  do
            (ps, p) <- parseFormalParameterList
            es <- parseExpressionList "Define Body"
            case ps of
                (i:ps) -> return (DefineNode i (LambdaNode ps p es))
                _ -> error "Expected parameter list in function definition"

parseDefineSyntax :: State [Token] MetaNode
parseDefineSyntax = do
    pullEq "Define-Syntax" DefineSyntax
    t <- pull "Define-Syntax"
    case t of
        (Identifier str) -> do
            e <- parseExpression "Define-Syntax Rules"
            pullEq "Define-Syntax" PClose
            return (DefineSyntaxNode (IdentifierAtom str 0) e)
        _ -> error "Expected Identifier as first argument of define-syntax"

parseLetSyntax :: State [Token] MetaNode
parseLetSyntax = do
    pullEq "Let-Syntax" LetSyntax
    e <- parseExpression "Let-Syntax Rules"
    body <- parseExpressionList "Let-Syntax Body"
    return (LetSyntaxNode e body)

parseLetrecSyntax :: State [Token] MetaNode
parseLetrecSyntax = do
    pullEq "Letrec-Syntax" LetrecSyntax
    e <- parseExpression "Letrec-Syntax Rules"
    body <- parseExpressionList "Letrec-Syntax Body"
    return (LetrecSyntaxNode e body)

parseApplication :: State [Token] MetaNode
parseApplication = do
    f <- parseExpression "Lambda Application"
    arg <- parseExpressionList "Argument"
    return (ApplicationNode f arg)

parseQuotedDatum :: State [Token] MetaNode
parseQuotedDatum = do
    t <- peek "Datum"
    case t of
        POpen -> do
            pullEq "Compound Datum" POpen
            parseQuotedCompoundDatum
        CommentDatum -> do
            pullEq "Commented Quoted Datum" CommentDatum
            parseQuotedDatum
            parseQuotedDatum
        ShortQuote -> parseQuotedShortForm
        ShortUnquote -> parseQuotedShortForm
        ShortQuasiQuote -> parseQuotedShortForm
        Identifier str -> do
            pull "Symbol"
            return $ SymbolAtom str
        _ -> parseAtom

parseQuotedCompoundDatum :: State [Token] MetaNode
parseQuotedCompoundDatum = do
    t <- peek "Compound Datum"
    case t of
        PClose -> do
            pullEq "Compound Datum" PClose
            return EmptyAtom
        Dot -> do
            pullEq "Compound Datum" Dot
            end <- parseQuotedDatum
            pullEq "Compound Datum" PClose
            return end
        _ -> do
            e <- parseQuotedDatum
            es <- parseQuotedCompoundDatum
            return (PairNode e es)

parseQuotedShortForm :: State [Token] MetaNode
parseQuotedShortForm = do
    t <- pull "Quoted Shortform"
    d <- parseQuotedDatum
    return $ PairNode (IdentifierAtom (show t) 0) (PairNode d EmptyAtom)

parseQuasiQuotedDatum :: State [Token] MetaNode
parseQuasiQuotedDatum = do
    t <- peek "Quasiquoted Datum"
    case t of
        POpen -> do
            pullEq "Quasiquoted Datum" POpen
            t <- peek "Quasiquoted Datum"
            case t of
                Unquote -> parseUnquotedExpression
                _ -> parseQuasiQuotedCompoundDatum
        ShortUnquote -> do
            pullEq "Unquoted Expression" ShortUnquote
            parseExpression "Unquoted Expression"
        CommentDatum -> do
            pullEq "Commented Quasiquoted Datum" CommentDatum
            parseQuasiQuotedDatum
            parseQuasiQuotedDatum
        ShortQuote -> parseQuasiQuotedShortForm
        ShortQuasiQuote -> parseQuasiQuotedShortForm
        Identifier str -> do
            pull "Symbol"
            return $ SymbolAtom str
        _ -> parseAtom

parseQuasiQuotedCompoundDatum :: State [Token] MetaNode
parseQuasiQuotedCompoundDatum = do
    t <- peek "Quasiquoted Compound Datum"
    case t of
        PClose -> do
            pullEq "Quasiquoted Compound Datum" PClose
            return EmptyAtom
        Dot -> do
            pullEq "Quasiquoted Compound Datum" Dot
            end <- parseQuasiQuotedDatum
            pullEq "Quasiquoted Compound Datum" PClose
            return end
        _ -> do
            e <- parseQuasiQuotedDatum
            es <- parseQuasiQuotedCompoundDatum
            return (PairNode e es)

parseQuasiQuotedShortForm :: State [Token] MetaNode
parseQuasiQuotedShortForm = do
    t <- pull "Quasiquoted Shortform"
    d <- parseQuasiQuotedDatum
    return $ PairNode (IdentifierAtom (show t) 0) (PairNode d EmptyAtom)

parseUnquotedExpression :: State [Token] MetaNode
parseUnquotedExpression = do
    pullEq "Unquoted Expression" Unquote
    e <- parseExpression "Unquoted Expression"
    pullEq "Unquoted Expression" PClose
    return e

parseExpressionList :: String -> State [Token] [MetaNode]
parseExpressionList  context = do
    t <- peek (context ++ " List")
    case t of
        PClose -> do
            pullEq context PClose
            return []
        _ -> do
            e <- parseExpression context
            es <- parseExpressionList (context ++ " List")
            return (e:es)

parseFormalParameters :: State [Token] ([MetaNode], MetaNode)
parseFormalParameters = do
    t <- pull "Formal Paramters"
    case t of
        POpen -> parseFormalParameterList
        Identifier s -> return ([],IdentifierAtom s 0)
        _ -> error "Expected parameter list or single parameter in lambda definition"

parseFormalParameterList :: State [Token] ([MetaNode], MetaNode)
parseFormalParameterList = do
    t <- pull "Formal Paramterlist"
    case t of
        PClose -> do
            return ([], IdentifierAtom "" 0)
        Dot -> do
            t <- pull "Formal Paramterlist"
            case t of
                Identifier str -> do
                    pullEq "Formal Paramterlist" PClose
                    return ([], IdentifierAtom str 0)
                _ -> error $ "Expected formal parameters in formal parameterlist not token " ++ show t
        Identifier str -> do
            (is, i) <- parseFormalParameterList
            return ((IdentifierAtom str 0):is, i)
        _ -> error $ "Expected formal parameters in formal parameterlist not token " ++ show t


-----------------------------------------------------------------------------
--
-- Module      :  Drool.Utils.Conversions
-- Copyright   :
-- License     :  AllRightsReserved
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module Drool.Utils.Conversions (
    gtkColorToGLColor3,
    gtkColorToGLColor4,
    glColor3ToGtkColor,
    glColor4ToGtkColor,
    freqToMs,
    msToFreq,
    floatToComplexDouble,
    floatsToComplexDoubles,
    complexDoubleToFloat,
    complexDoublesToFloats,
    listToCArray,
    listFromCArray,
    interleave,
    interleaveArrays,
    aMax,
    aLength,
    aZip,
    adjustBufferSize,
    adjustBufferSizeBack,
    blendModeSourceFromIndex,
    blendModeFrameBufferFromIndex,
    blendModeSourceIndex,
    blendModeFrameBufferIndex,
) where

import qualified Graphics.UI.Gtk as Gtk
import Graphics.Rendering.OpenGL
import Data.Complex
import Data.Array ( Array )
import Data.Array.IArray ( (!), bounds, listArray, ixmap, amap, rangeSize )
import Data.Array.CArray ( createCArray, elems )
import Foreign.Marshal.Array ( pokeArray, peekArray )
import GHC.Float
import Data.Word ( Word16 )

gtkColorToGLColor3 :: Gtk.Color -> Color3 GLfloat
gtkColorToGLColor3 (Gtk.Color r g b) = Color3 r' g' b'
  where r' = ((fromIntegral r) / 65535.0) :: GLfloat
        g' = ((fromIntegral g) / 65535.0) :: GLfloat
        b' = ((fromIntegral b) / 65535.0) :: GLfloat

gtkColorToGLColor4 :: Gtk.Color -> Word16 -> Color4 GLfloat
gtkColorToGLColor4 (Gtk.Color r g b) a = Color4 r' g' b' a'
  where r' = ((fromIntegral r) / 65535.0) :: GLfloat
        g' = ((fromIntegral g) / 65535.0) :: GLfloat
        b' = ((fromIntegral b) / 65535.0) :: GLfloat
        a' = ((fromIntegral a) / 65535.0) :: GLfloat

glColor3ToGtkColor :: Color3 GLfloat -> Gtk.Color
glColor3ToGtkColor (Color3 r g b) = Gtk.Color r' g' b'
  where r' = round(r * 65535.0)
        g' = round(g * 65535.0)
        b' = round(b * 65535.0)

glColor4ToGtkColor :: Color4 GLfloat -> ( Gtk.Color, Word16 )
glColor4ToGtkColor (Color4 r g b a) = (Gtk.Color r' g' b', a')
  where r' = round(r * 65535.0)
        g' = round(g * 65535.0)
        b' = round(b * 65535.0)
        a' = round(a * 65535.0)

freqToMs :: Int -> Int
freqToMs f = round(1000.0 / fromIntegral f)

msToFreq :: Int -> Int
msToFreq ms = round(1000.0 / fromIntegral ms)

floatToComplexDouble :: Float -> Complex Double
floatToComplexDouble f = (float2Double f :+ 0.0) :: Complex Double

floatsToComplexDoubles :: [Float] -> [Complex Double]
floatsToComplexDoubles fs = (map (\x -> floatToComplexDouble x) fs)

-- Returns magnitude of complex double as float, with magnitude = (re^2 + im^2)^0.5
complexDoubleToFloat :: Complex Double -> Float
complexDoubleToFloat cd = realToFrac(sqrt (realPart cd * realPart cd + imagPart cd * imagPart cd)) :: Float
-- complexDoubleToFloat cd = realToFrac(sqrt (realPart cd * realPart cd)) :: Float

complexDoublesToFloats :: [Complex Double] -> [Float]
complexDoublesToFloats cds = map (\x -> (complexDoubleToFloat x) / n) cds
  where n = fromIntegral $ length cds

listToCArray lst = createCArray (0,(length lst)-1) ( \ptr -> do { pokeArray ptr lst } )

listFromCArray carr = elems carr

interleave :: [a] -> [a] -> [a]
interleave xsA xsB = foldl (\acc (a,b) -> acc ++ [a,b] ) [] (zip xsA xsB)

aLength a = rangeSize $ bounds a

aMax a = snd $ bounds a

interleaveArrays :: Array Int e -> Array Int e -> Array Int e
interleaveArrays a b = listArray (0,(aLength a) + (aMax b)) (concat [ [(a ! i),(b ! i)] | i <- [0..(min (aMax a) (aMax b))] ])

aZip a b = [ ((a ! i),(b ! i)) | i <- [0..(min (aMax a) (aMax b))] ]

adjustBufferSize :: [a] -> Int -> [a]
adjustBufferSize buf maxLen = drop ((length buf)-maxLen) buf -- drop does not alter list for values <= 0

adjustBufferSizeBack :: [a] -> Int -> [a]
adjustBufferSizeBack buf maxLen = take maxLen buf -- drop does not alter list for values <= 0

blendSourceModes :: [ BlendingFactor ]
blendSourceModes = [ Zero, One, DstColor, OneMinusDstColor, SrcAlpha,
                     OneMinusSrcAlpha, DstAlpha, OneMinusDstAlpha,
                     SrcAlphaSaturate ]
blendFrameBufferModes :: [ BlendingFactor ]
blendFrameBufferModes = [ Zero, One, SrcColor, OneMinusSrcColor, SrcAlpha,
                          OneMinusSrcAlpha, DstAlpha, OneMinusDstAlpha ]

blendModeSourceFromIndex :: Int -> BlendingFactor
blendModeSourceFromIndex i = blendSourceModes !! i

blendModeFrameBufferFromIndex :: Int -> BlendingFactor
blendModeFrameBufferFromIndex i = blendFrameBufferModes !! i

blendModeSourceIndex :: BlendingFactor -> Int
blendModeSourceIndex bm = blendModeSourceIndex' bm 0 blendSourceModes
blendModeSourceIndex' :: BlendingFactor -> Int -> [ BlendingFactor ] -> Int
blendModeSourceIndex' bm i (mode:modes) = index
  where index = if bm == mode then i else blendModeSourceIndex' bm (i+1) modes
blendModeSourceIndex' _ _ [] = 0

blendModeFrameBufferIndex :: BlendingFactor -> Int
blendModeFrameBufferIndex bm = blendModeFrameBufferIndex' bm 0 blendFrameBufferModes
blendModeFrameBufferIndex' :: BlendingFactor -> Int -> [ BlendingFactor ] -> Int
blendModeFrameBufferIndex' bm i (mode:modes) = index
  where index = if bm == mode then i else blendModeFrameBufferIndex' bm (i+1) modes
blendModeFrameBufferIndex' _ _ [] = 0