content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE Rank2Types #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  #if __GLASGOW_HASKELL__ >= 707
  {-# LANGUAGE RoleAnnotations #-}
  #endif
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Silica.Internal.Magma
  -- Copyright   :  (C) 2012-2016 Edward Kmett
  -- License     :  BSD-style (see the file LICENSE)
  -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  -- Stability   :  experimental
  -- Portability :  non-portable
  --
  ----------------------------------------------------------------------------
  module Silica.Internal.Magma
    (
    -- * Magma
      Magma(..)
    , runMagma
    -- * Molten
    , Molten(..)
    -- * Mafic
    , Mafic(..)
    , runMafic
    -- * TakingWhile
    , TakingWhile(..)
    , runTakingWhile
    ) where
  
  import Control.Applicative
  import Control.Category
  import Control.Comonad
  import Silica.Internal.Bazaar
  import Silica.Internal.Context
  import Silica.Internal.Indexed
  import Data.Foldable
  import Data.Functor.Apply
  import Data.Functor.Contravariant
  import Data.Monoid
  import Data.Profunctor.Rep
  import Data.Profunctor.Sieve
  import Data.Profunctor.Unsafe
  import Data.Traversable
  import Prelude hiding ((.),id)
  
  ------------------------------------------------------------------------------
  -- Magma
  ------------------------------------------------------------------------------
  
  -- | This provides a way to peek at the internal structure of a
  -- 'Silica.Traversal.Traversal' or 'Silica.Traversal.IndexedTraversal'
  data Magma i t b a where
    MagmaAp   :: Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a
    MagmaPure :: x -> Magma i x b a
    MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a
    Magma :: i -> a -> Magma i b b a
  
  #if __GLASGOW_HASKELL__ >= 707
  -- note the 3rd argument infers as phantom, but that would be unsound
  type role Magma representational nominal nominal nominal
  #endif
  
  instance Functor (Magma i t b) where
    fmap f (MagmaAp x y)    = MagmaAp (fmap f x) (fmap f y)
    fmap _ (MagmaPure x)    = MagmaPure x
    fmap f (MagmaFmap xy x) = MagmaFmap xy (fmap f x)
    fmap f (Magma i a)  = Magma i (f a)
  
  instance Foldable (Magma i t b) where
    foldMap f (MagmaAp x y)   = foldMap f x `mappend` foldMap f y
    foldMap _ MagmaPure{}     = mempty
    foldMap f (MagmaFmap _ x) = foldMap f x
    foldMap f (Magma _ a) = f a
  
  instance Traversable (Magma i t b) where
    traverse f (MagmaAp x y)    = MagmaAp <$> traverse f x <*> traverse f y
    traverse _ (MagmaPure x)    = pure (MagmaPure x)
    traverse f (MagmaFmap xy x) = MagmaFmap xy <$> traverse f x
    traverse f (Magma i a)  = Magma i <$> f a
  
  instance (Show i, Show a) => Show (Magma i t b a) where
    showsPrec d (MagmaAp x y) = showParen (d > 4) $
      showsPrec 4 x . showString " <*> " . showsPrec 5 y
    showsPrec d (MagmaPure _) = showParen (d > 10) $
      showString "pure .."
    showsPrec d (MagmaFmap _ x) = showParen (d > 4) $
      showString ".. <$> " . showsPrec 5 x
    showsPrec d (Magma i a) = showParen (d > 10) $
      showString "Magma " . showsPrec 11 i . showChar ' ' . showsPrec 11 a
  
  -- | Run a 'Magma' where all the individual leaves have been converted to the
  -- expected type
  runMagma :: Magma i t a a -> t
  runMagma (MagmaAp l r)   = runMagma l (runMagma r)
  runMagma (MagmaFmap f r) = f (runMagma r)
  runMagma (MagmaPure x)   = x
  runMagma (Magma _ a) = a
  
  ------------------------------------------------------------------------------
  -- Molten
  ------------------------------------------------------------------------------
  
  -- | This is a a non-reassociating initially encoded version of 'Bazaar'.
  newtype Molten i a b t = Molten { runMolten :: Magma i t b a }
  
  instance Functor (Molten i a b) where
    fmap f (Molten xs) = Molten (MagmaFmap f xs)
    {-# INLINE fmap #-}
  
  instance Apply (Molten i a b) where
    (<.>) = (<*>)
    {-# INLINE (<.>) #-}
  
  instance Applicative (Molten i a b) where
    pure  = Molten #. MagmaPure
    {-# INLINE pure #-}
    Molten xs <*> Molten ys = Molten (MagmaAp xs ys)
    {-# INLINE (<*>) #-}
  
  instance Sellable (Indexed i) (Molten i) where
    sell = Indexed (\i -> Molten #. Magma i)
    {-# INLINE sell #-}
  
  instance Bizarre (Indexed i) (Molten i) where
    bazaar f (Molten (MagmaAp x y))   = bazaar f (Molten x) <*> bazaar f (Molten y)
    bazaar f (Molten (MagmaFmap g x)) = g <$> bazaar f (Molten x)
    bazaar _ (Molten (MagmaPure x))   = pure x
    bazaar f (Molten (Magma i a)) = indexed f i a
  
  instance IndexedFunctor (Molten i) where
    ifmap f (Molten xs) = Molten (MagmaFmap f xs)
    {-# INLINE ifmap #-}
  
  instance IndexedComonad (Molten i) where
    iextract (Molten (MagmaAp x y))   = iextract (Molten x) (iextract (Molten y))
    iextract (Molten (MagmaFmap f y)) = f (iextract (Molten y))
    iextract (Molten (MagmaPure x))   = x
    iextract (Molten (Magma _ a)) = a
  
    iduplicate (Molten (Magma i a)) = Molten #. Magma i <$> Molten (Magma i a)
    iduplicate (Molten (MagmaPure x))   = pure (pure x)
    iduplicate (Molten (MagmaFmap f y)) = iextend (fmap f) (Molten y)
    iduplicate (Molten (MagmaAp x y))   = iextend (<*>) (Molten x) <*> iduplicate (Molten y)
  
    iextend k (Molten (Magma i a)) = (k .# Molten) . Magma i <$> Molten (Magma i a)
    iextend k (Molten (MagmaPure x))   = pure (k (pure x))
    iextend k (Molten (MagmaFmap f y)) = iextend (k . fmap f) (Molten y)
    iextend k (Molten (MagmaAp x y))   = iextend (\x' y' -> k $ x' <*> y') (Molten x) <*> iduplicate (Molten y)
  
  instance a ~ b => Comonad (Molten i a b) where
    extract   = iextract
    {-# INLINE extract #-}
    extend    = iextend
    {-# INLINE extend #-}
    duplicate = iduplicate
    {-# INLINE duplicate #-}
  
  ------------------------------------------------------------------------------
  -- Mafic
  ------------------------------------------------------------------------------
  
  -- | This is used to generate an indexed magma from an unindexed source
  --
  -- By constructing it this way we avoid infinite reassociations in sums where possible.
  data Mafic a b t = Mafic Int (Int -> Magma Int t b a)
  
  -- | Generate a 'Magma' using from a prefix sum.
  runMafic :: Mafic a b t -> Magma Int t b a
  runMafic (Mafic _ k) = k 0
  
  instance Functor (Mafic a b) where
    fmap f (Mafic w k) = Mafic w (MagmaFmap f . k)
    {-# INLINE fmap #-}
  
  instance Apply (Mafic a b) where
    Mafic wf mf <.> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf))
    {-# INLINE (<.>) #-}
  
  instance Applicative (Mafic a b) where
    pure a = Mafic 0 $ \_ -> MagmaPure a
    {-# INLINE pure #-}
    Mafic wf mf <*> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf))
    {-# INLINE (<*>) #-}
  
  instance Sellable (->) Mafic where
    sell a = Mafic 1 $ \ i -> Magma i a
    {-# INLINE sell #-}
  
  instance Bizarre (Indexed Int) Mafic where
    bazaar (pafb :: Indexed Int a (f b)) (Mafic _ k) = go (k 0) where
      go :: Magma Int t b a -> f t
      go (MagmaAp x y)   = go x <*> go y
      go (MagmaFmap f x) = f <$> go x
      go (MagmaPure x)   = pure x
      go (Magma i a) = indexed pafb (i :: Int) a
    {-# INLINE bazaar #-}
  
  instance IndexedFunctor Mafic where
    ifmap f (Mafic w k) = Mafic w (MagmaFmap f . k)
    {-# INLINE ifmap #-}
  
  ------------------------------------------------------------------------------
  -- TakingWhile
  ------------------------------------------------------------------------------
  
  -- | This is used to generate an indexed magma from an unindexed source
  --
  -- By constructing it this way we avoid infinite reassociations where possible.
  --
  -- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant',
  -- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma'
  data TakingWhile p (g :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a))
  #if __GLASGOW_HASKELL__ >= 707
  type role TakingWhile nominal nominal nominal nominal nominal
  #endif
  
  -- | Generate a 'Magma' with leaves only while the predicate holds from left to right.
  runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a)
  runTakingWhile (TakingWhile _ _ k) = k True
  
  instance Functor (TakingWhile p f a b) where
    fmap f (TakingWhile w t k) = let ft = f t in TakingWhile w ft $ \b -> if b then MagmaFmap f (k b) else MagmaPure ft
    {-# INLINE fmap #-}
  
  instance Apply (TakingWhile p f a b) where
    TakingWhile wf tf mf <.> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o ->
      if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta)
    {-# INLINE (<.>) #-}
  
  instance Applicative (TakingWhile p f a b) where
    pure a = TakingWhile True a $ \_ -> MagmaPure a
    {-# INLINE pure #-}
    TakingWhile wf tf mf <*> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o ->
      if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta)
    {-# INLINE (<*>) #-}
  
  instance Corepresentable p => Bizarre p (TakingWhile p g) where
    bazaar (pafb :: p a (f b)) ~(TakingWhile _ _ k) = go (k True) where
      go :: Magma () t b (Corep p a) -> f t
      go (MagmaAp x y)  = go x <*> go y
      go (MagmaFmap f x)  = f <$> go x
      go (MagmaPure x)    = pure x
      go (Magma _ wa) = cosieve pafb wa
    {-# INLINE bazaar #-}
  
  -- This constraint is unused intentionally, it protects TakingWhile
  instance Contravariant f => Contravariant (TakingWhile p f a b) where
    contramap _ = (<$) (error "contramap: TakingWhile")
    {-# INLINE contramap #-}
  
  instance IndexedFunctor (TakingWhile p f) where
    ifmap = fmap
    {-# INLINE ifmap #-}
  