-- -------------------------------------------------------------------------
-- 　　　　　　ﾊ,,ﾊ
-- 　　　　　（ ﾟωﾟ )　　WAお断りします
-- 　　　　／　　 　＼
-- 　 ((⊂ 　） 　 ﾉ＼つ))
-- 　　　　　（＿⌒ヽ
-- 　　　　　　ヽ ﾍ　}
-- 　　　ε≡Ξ　ﾉノ ｀J
-- ------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
-- {-# LANGUAGE NegativeLiterals #-}
-- {-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -O0 #-}
{-# OPTIONS_GHC -O2 #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
{-# OPTIONS_GHC -Wno-missing-import-lists #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE UndecidableInstances#-}

module Main where
import Data.Bool
import Control.Applicative
import Data.Ord
import Control.Monad.State
import qualified Control.Monad                 as CM
import qualified Control.Monad.Primitive       as Prim
import qualified Control.Monad.ST              as ST
import qualified Data.Array             as A
import qualified Data.Array.IO                 as AIO
import qualified Data.Array.ST                 as AST
import qualified Data.Array.Unboxed            as AU
import qualified Data.Bits                     as Bits
import qualified Data.ByteString.Char8         as BS
import qualified Data.ByteString.Builder       as BI
import qualified Data.Char                     as Char
import qualified Data.Complex                  as Comp
import qualified Data.Foldable                 as Foldable
import qualified Data.Function                 as Func
import qualified Data.Heap                     as Heap
import qualified Data.IORef                    as IO
import qualified Data.IntPSQ                   as PSQ
import qualified Data.Ix                       as Ix
import qualified Data.List                     as L
import qualified Data.Map.Strict               as Map
import qualified Data.IntMap                   as MI
import qualified Data.Maybe                    as May
import qualified Data.Primitive.MutVar         as MutVar
import qualified Data.Proxy                    as Proxy
import qualified Data.Ratio                    as Ratio
import qualified Data.STRef                    as STRef
import qualified Data.Sequence                 as Seq
import qualified Data.Set                      as Set
import qualified Data.Tree                     as Tree
import qualified Data.Vector                   as V
import qualified Data.Vector.Algorithms.Merge  as VAM
import qualified Data.Vector.Algorithms.Radix  as VAR
import qualified Data.Vector.Algorithms.Search as VAS
import qualified Data.Vector.Algorithms.Intro  as VAI
import           Data.Vector.Generic           ((!))
import qualified Data.Vector.Generic           as VG
import qualified Data.Vector.Generic.Mutable   as VGM
import qualified Data.Vector.Mutable           as VM
import qualified Data.Vector.Unboxed.Base      as VUB
import qualified Data.Vector.Unboxing          as VU
import qualified Data.Vector.Unboxing.Mutable  as VUM
import qualified Debug.Trace                   as Trace
import qualified GHC.TypeNats                  as TypeNats
import qualified Test.QuickCheck               as QC
import qualified Data.Vector.Fusion.Bundle     as VFB
import System.IO

mod' = 1000000007

readInt = BS.readInt . BS.dropWhile Char.isSpace
readIntList = map readInt . BS.words
-- getInt = readInt <$> BS.getLine
getIntList = readIntList <$> BS.getLine

getIntLists n = CM.replicateM n getIntList

getIntVec n = VU.unfoldrN n (BS.readInt . BS.dropWhile Char.isSpace) <$> BS.getLine

getIntVecs n m = CM.replicateM m (getIntVec n)

getVecStr =VU.fromList<$>getLine
getInt = readLn @Int
getIntsPair n = map (\[a,b] -> (a,b)) <$> CM.replicateM n getIntList

getVector f = VU.unfoldr f <$> BS.getLine

getIntVector = getVector readInt
getBSVector = getVector BS.uncons
getInt2Tuple = (\vec -> (vec VU.! 0, vec VU.! 1)) <$> getIntVector
getInt3Tuple = (\vec -> (vec VU.! 0, vec VU.! 1, vec VU.! 2)) <$> getIntVector

ggg s= May.fromJust$L.uncons s

gs :: IO String
gs=getLine

gn=map (read . BS.unpack) . BS.words <$> BS.getLine ::IO[Int]

gg :: Int -> IO (V.Vector (LV Int))
gg n=V.replicateM n (g @(LV Int))

-- | ex) getLn @Int @VU.Vector n, getLn @[Int] @V.Vector n
gl :: (ReadBS a, VG.Vector v a) => Int -> IO (v a)
gl n = VG.replicateM n g

-- | ex) get @Int, get @(VU.Vector) ..
g:: ReadBS a => IO a
g = readBS <$> BS.getLine

fix :: (a -> a) -> a
fix f = let x = f x in x

---------------------------------------------------------

main = do
  putStr "yeah"
---------------------------------------------------------

each :: (t1 -> a) -> (t2 -> b) -> (t1, t2) -> (a, b)
each f g (x,y)=(f x,g y)
digSum k=sum[read[c]|c<-k]

replaceAt :: Int -> a -> [a] -> [a]
replaceAt _ _ []     = []
replaceAt 0 y (_:xs) = y : xs
replaceAt n y (x:xs) = x : replaceAt (n - 1) y xs

{-# INLINE vLength #-}
vLength :: (VG.Vector v e) => v e -> Int
vLength = VFB.length . VG.stream

type Moji = BS.ByteString
type LV   = V.Vector
type SV   = VU.Vector

---------------
-- Read/Show --
---------------

class ReadBS a where
  readBS :: BS.ByteString -> a

  {-# MINIMAL readBS #-}
-- ^ ByteString版Read

class ShowBS a where
  showBS :: a -> BS.ByteString

  {-# MINIMAL showBS #-}

instance ReadBS Int where
  readBS s = case BS.readInt s of
    Just (x, _) -> x
    Nothing     -> error "readBS :: ByteString -> Int"

instance ReadBS Integer where
  readBS = fromInteger . readBS

instance ReadBS Double where
  readBS = read . BS.unpack

instance ReadBS BS.ByteString where
  readBS = id

instance (ReadBS a, VU.Unboxable a) => ReadBS (VU.Vector a) where
  readBS s = VG.fromList . map readBS . BS.words $ s

instance (ReadBS a) => ReadBS (V.Vector a) where
  readBS s = VG.fromList . map readBS . BS.words $ s

instance ReadBS a => ReadBS [a] where
  readBS s = map readBS . BS.words $ s

instance (ReadBS a, ReadBS b) => ReadBS (a, b) where
  readBS (BS.words -> [a, b]) = (readBS a, readBS b)
  readBS _ = error "Invalid Format :: readBS :: ByteString -> (a, b)"

instance (ReadBS a, ReadBS b, ReadBS c) => ReadBS (a, b, c) where
  readBS (BS.words -> [a, b, c]) = (readBS a, readBS b, readBS c)
  readBS _ = error "Invalid Format :: readBS :: ByteString -> (a, b)"

instance ShowBS Int where
  showBS = BS.pack . show

instance ShowBS Integer where
  showBS = BS.pack . show

instance ShowBS Double where
  showBS = BS.pack . show

instance ShowBS BS.ByteString where
  showBS = id

instance (ShowBS a, VU.Unboxable a) => ShowBS (VU.Vector a) where
  showBS = showVec

instance (ShowBS a) => ShowBS (V.Vector a) where
  showBS = showVec

instance ShowBS a => ShowBS [a] where
  showBS = BS.pack . unwords . map (BS.unpack . showBS)

instance (ShowBS a, ShowBS b) => ShowBS (a, b) where
  showBS (a, b) = showBS a `BS.append` " " `BS.append` showBS b

instance (ShowBS a, ShowBS b, ShowBS c) => ShowBS (a, b, c) where
  showBS (a, b, c) = showBS a `BS.append` " " `BS.append` showBS b
    `BS.append` showBS c

showVec :: (VG.Vector v a, ShowBS a) => v a -> BS.ByteString
showVec xs
  | VG.null xs = ""
  | otherwise = BS.concat [f i | i <- [0 .. 2 * VG.length xs - 2]]
  where
  f i
    | even i = showBS $ xs ! (i `div` 2)
    | otherwise = " "

while :: Monad m => m Bool -> m ()
while f = f >>= \frag -> CM.when frag $ while f


{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-}

-- |
-- Module:  Control.DeepSeq
-- Copyright:   (c) 2012, Maxime Henrion
-- License:     BSD-style (see the LICENSE file)
--
-- Maintainer:  Maxime Henrion <mhenrion@gmail.com>
-- Stability:   stable
-- Portability: portable
--
-- This module provides a 'deepseq' function for fully evaluating data
-- structures (that is, evaluating to \"Normal Form\", and not just up to
-- \"Head Normal Form\" like 'seq' does).
--
-- It uses the "GHC.Generics" framework so that you can generate instances
-- for your datatypes without having to provide an implementation.
--
module Control.DeepSeq
  ( DeepSeq(..)
  , deepseq
  , ($!!)
  , force
  ) where

import Data.Int
import Data.Word
import Data.Complex
import Data.Ratio
import GHC.Generics

class DeepSeq a where
  -- | Evaluate its argument to normal form, and then return '()'.
  rnf :: a -> ()
  default rnf :: (Generic a, GDeepSeq (Rep a)) => a -> ()
  rnf = grnf . from

-- Instances for primitive types.
instance DeepSeq Bool     where rnf x = x `seq` ()
instance DeepSeq Char     where rnf x = x `seq` ()
instance DeepSeq Double   where rnf x = x `seq` ()
instance DeepSeq Float    where rnf x = x `seq` ()
instance DeepSeq Int      where rnf x = x `seq` ()
instance DeepSeq Word     where rnf x = x `seq` ()
instance DeepSeq Integer  where rnf x = x `seq` ()
instance DeepSeq Ordering where rnf x = x `seq` ()
instance DeepSeq ()       where rnf x = x `seq` ()

instance DeepSeq Int8     where rnf x = x `seq` ()
instance DeepSeq Int16    where rnf x = x `seq` ()
instance DeepSeq Int32    where rnf x = x `seq` ()
instance DeepSeq Int64    where rnf x = x `seq` ()

instance DeepSeq Word8    where rnf x = x `seq` ()
instance DeepSeq Word16   where rnf x = x `seq` ()
instance DeepSeq Word32   where rnf x = x `seq` ()
instance DeepSeq Word64   where rnf x = x `seq` ()

instance DeepSeq (a -> b) where rnf x = x `seq` ()

instance (DeepSeq a, DeepSeq b) => DeepSeq (a,b)
instance (DeepSeq a, DeepSeq b, DeepSeq c) => DeepSeq (a,b,c)
instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d) => DeepSeq (a,b,c,d)
instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d, DeepSeq e) =>
          DeepSeq (a,b,c,d,e)
instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d, DeepSeq e, DeepSeq f) =>
          DeepSeq (a,b,c,d,e,f)
instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d, DeepSeq e, DeepSeq f,
          DeepSeq g) => DeepSeq (a,b,c,d,e,f,g)

instance DeepSeq a => DeepSeq [a]
instance DeepSeq a => DeepSeq (Maybe a)
instance (DeepSeq a, DeepSeq b) => DeepSeq (Either a b)

-- We cannot derive an instance for Ratio automatically, because it is an
-- abstract datatype (it doesn't export its constructors), and doesn't provide
-- a Generic instance either.
instance (Integral a, DeepSeq a) => DeepSeq (Ratio a) where
  rnf x = rnf (denominator x) `seq` rnf (numerator x)

-- We should be able to derive an instance for Complex a automatically, but it
-- turns out GHC 7.4.1 panics if we do that, so we provide an explicit instance
-- for now.
instance DeepSeq a => DeepSeq (Complex a) where
  rnf (x :+ y) = rnf x `seq` rnf y

class GDeepSeq f where
  grnf :: f a -> ()

instance GDeepSeq V1 where
  grnf _  = undefined

instance GDeepSeq U1 where
  -- It is important to pattern match on the U1 constructor here. If we didn't
  -- and used an underscore pattern, the following equality wouldn't hold:
  --   x `deepseq` () = x `seq` () = _|_
  --     where x = undefined :: T
  -- with T being some unit-shaped type with a DeepSeq instance.
  grnf U1 = ()

instance DeepSeq a => GDeepSeq (K1 i a) where
  grnf = rnf . unK1

instance GDeepSeq a => GDeepSeq (M1 i c a) where
  grnf = grnf . unM1

instance (GDeepSeq a, GDeepSeq b) => GDeepSeq (a :*: b) where
  grnf (x :*: y) = grnf x `seq` grnf y

instance (GDeepSeq a, GDeepSeq b) => GDeepSeq (a :+: b) where
  grnf (L1 x) = grnf x
  grnf (R1 x) = grnf x

infixr 0 $!!

-- | The deep analogue of '$!'.
($!!) :: DeepSeq a => (a -> b) -> a -> b
f $!! x = x `deepseq` f x

-- | Evaluates its first argument to normal form, and then returns its
-- second argument as the result.
deepseq :: DeepSeq a => a -> b -> b
deepseq x y = rnf x `seq` y

-- | Evaluates its argument to normal form, and then return it.
force :: DeepSeq a => a -> a
force x = x `deepseq` x


{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

-- | Primitive Feldspar expressions

module Feldspar.Primitive.Representation where

import Data.Array
import Data.Bits
import Data.Complex
import Data.Int
import Data.Typeable
import Data.Word

import Data.Constraint (Dict (..))

import Language.Embedded.Expression
import Language.Embedded.Imperative.CMD (IArr (..))

import Language.Syntactic
import Language.Syntactic.TH
import Language.Syntactic.Functional

--------------------------------------------------------------------------------
-- * Types
--------------------------------------------------------------------------------

type Length = Word32
type Index  = Word32

-- | Representation of primitive supported types
data PrimTypeRep a
  where
    BoolT          :: PrimTypeRep Bool
    Int8T          :: PrimTypeRep Int8
    Int16T         :: PrimTypeRep Int16
    Int32T         :: PrimTypeRep Int32
    Int64T         :: PrimTypeRep Int64
    Word8T         :: PrimTypeRep Word8
    Word16T        :: PrimTypeRep Word16
    Word32T        :: PrimTypeRep Word32
    Word64T        :: PrimTypeRep Word64
    FloatT         :: PrimTypeRep Float
    DoubleT        :: PrimTypeRep Double
    ComplexFloatT  :: PrimTypeRep (Complex Float)
    ComplexDoubleT :: PrimTypeRep (Complex Double)

data IntTypeRep a
  where
    Int8Type  :: IntTypeRep Int8
    Int16Type :: IntTypeRep Int16
    Int32Type :: IntTypeRep Int32
    Int64Type :: IntTypeRep Int64

data WordTypeRep a
  where
    Word8Type  :: WordTypeRep Word8
    Word16Type :: WordTypeRep Word16
    Word32Type :: WordTypeRep Word32
    Word64Type :: WordTypeRep Word64

data IntWordTypeRep a
  where
    IntType  :: IntTypeRep a -> IntWordTypeRep a
    WordType :: WordTypeRep a -> IntWordTypeRep a

data FloatingTypeRep a
  where
    FloatType  :: FloatingTypeRep Float
    DoubleType :: FloatingTypeRep Double

data ComplexTypeRep a
  where
    ComplexFloatType  :: ComplexTypeRep (Complex Float)
    ComplexDoubleType :: ComplexTypeRep (Complex Double)

-- | A different view of 'PrimTypeRep' that allows matching on similar types
data PrimTypeView a
  where
    PrimTypeBool     :: PrimTypeView Bool
    PrimTypeIntWord  :: IntWordTypeRep a -> PrimTypeView a
    PrimTypeFloating :: FloatingTypeRep a -> PrimTypeView a
    PrimTypeComplex  :: ComplexTypeRep a -> PrimTypeView a

deriving instance Show (PrimTypeRep a)
deriving instance Show (IntTypeRep a)
deriving instance Show (WordTypeRep a)
deriving instance Show (IntWordTypeRep a)
deriving instance Show (FloatingTypeRep a)
deriving instance Show (ComplexTypeRep a)
deriving instance Show (PrimTypeView a)

viewPrimTypeRep :: PrimTypeRep a -> PrimTypeView a
viewPrimTypeRep BoolT          = PrimTypeBool
viewPrimTypeRep Int8T          = PrimTypeIntWord $ IntType $ Int8Type
viewPrimTypeRep Int16T         = PrimTypeIntWord $ IntType $ Int16Type
viewPrimTypeRep Int32T         = PrimTypeIntWord $ IntType $ Int32Type
viewPrimTypeRep Int64T         = PrimTypeIntWord $ IntType $ Int64Type
viewPrimTypeRep Word8T         = PrimTypeIntWord $ WordType $ Word8Type
viewPrimTypeRep Word16T        = PrimTypeIntWord $ WordType $ Word16Type
viewPrimTypeRep Word32T        = PrimTypeIntWord $ WordType $ Word32Type
viewPrimTypeRep Word64T        = PrimTypeIntWord $ WordType $ Word64Type
viewPrimTypeRep FloatT         = PrimTypeFloating FloatType
viewPrimTypeRep DoubleT        = PrimTypeFloating DoubleType
viewPrimTypeRep ComplexFloatT  = PrimTypeComplex ComplexFloatType
viewPrimTypeRep ComplexDoubleT = PrimTypeComplex ComplexDoubleType

unviewPrimTypeRep :: PrimTypeView a -> PrimTypeRep a
unviewPrimTypeRep PrimTypeBool                            = BoolT
unviewPrimTypeRep (PrimTypeIntWord (IntType Int8Type))    = Int8T
unviewPrimTypeRep (PrimTypeIntWord (IntType Int16Type))   = Int16T
unviewPrimTypeRep (PrimTypeIntWord (IntType Int32Type))   = Int32T
unviewPrimTypeRep (PrimTypeIntWord (IntType Int64Type))   = Int64T
unviewPrimTypeRep (PrimTypeIntWord (WordType Word8Type))  = Word8T
unviewPrimTypeRep (PrimTypeIntWord (WordType Word16Type)) = Word16T
unviewPrimTypeRep (PrimTypeIntWord (WordType Word32Type)) = Word32T
unviewPrimTypeRep (PrimTypeIntWord (WordType Word64Type)) = Word64T
unviewPrimTypeRep (PrimTypeFloating FloatType)            = FloatT
unviewPrimTypeRep (PrimTypeFloating DoubleType)           = DoubleT
unviewPrimTypeRep (PrimTypeComplex ComplexFloatType)      = ComplexFloatT
unviewPrimTypeRep (PrimTypeComplex ComplexDoubleType)     = ComplexDoubleT

primTypeIntWidth :: PrimTypeRep a -> Maybe Int
primTypeIntWidth Int8T   = Just 8
primTypeIntWidth Int16T  = Just 16
primTypeIntWidth Int32T  = Just 32
primTypeIntWidth Int64T  = Just 64
primTypeIntWidth Word8T  = Just 8
primTypeIntWidth Word16T = Just 16
primTypeIntWidth Word32T = Just 32
primTypeIntWidth Word64T = Just 64
primTypeIntWidth _       = Nothing

-- | Primitive supported types
class (Eq a, Show a, Typeable a) => PrimType' a
  where
    -- | Reify a primitive type
    primTypeRep :: PrimTypeRep a

instance PrimType' Bool             where primTypeRep = BoolT
instance PrimType' Int8             where primTypeRep = Int8T
instance PrimType' Int16            where primTypeRep = Int16T
instance PrimType' Int32            where primTypeRep = Int32T
instance PrimType' Int64            where primTypeRep = Int64T
instance PrimType' Word8            where primTypeRep = Word8T
instance PrimType' Word16           where primTypeRep = Word16T
instance PrimType' Word32           where primTypeRep = Word32T
instance PrimType' Word64           where primTypeRep = Word64T
instance PrimType' Float            where primTypeRep = FloatT
instance PrimType' Double           where primTypeRep = DoubleT
instance PrimType' (Complex Float)  where primTypeRep = ComplexFloatT
instance PrimType' (Complex Double) where primTypeRep = ComplexDoubleT

-- | Convenience function; like 'primTypeRep' but with an extra argument to
-- constrain the type parameter. The extra argument is ignored.
primTypeOf :: PrimType' a => a -> PrimTypeRep a
primTypeOf _ = primTypeRep

-- | Check whether two type representations are equal
primTypeEq :: PrimTypeRep a -> PrimTypeRep b -> Maybe (Dict (a ~ b))
primTypeEq BoolT          BoolT          = Just Dict
primTypeEq Int8T          Int8T          = Just Dict
primTypeEq Int16T         Int16T         = Just Dict
primTypeEq Int32T         Int32T         = Just Dict
primTypeEq Int64T         Int64T         = Just Dict
primTypeEq Word8T         Word8T         = Just Dict
primTypeEq Word16T        Word16T        = Just Dict
primTypeEq Word32T        Word32T        = Just Dict
primTypeEq Word64T        Word64T        = Just Dict
primTypeEq FloatT         FloatT         = Just Dict
primTypeEq DoubleT        DoubleT        = Just Dict
primTypeEq ComplexFloatT  ComplexFloatT  = Just Dict
primTypeEq ComplexDoubleT ComplexDoubleT = Just Dict
primTypeEq _ _ = Nothing

-- | Reflect a 'PrimTypeRep' to a 'PrimType'' constraint
witPrimType :: PrimTypeRep a -> Dict (PrimType' a)
witPrimType BoolT          = Dict
witPrimType Int8T          = Dict
witPrimType Int16T         = Dict
witPrimType Int32T         = Dict
witPrimType Int64T         = Dict
witPrimType Word8T         = Dict
witPrimType Word16T        = Dict
witPrimType Word32T        = Dict
witPrimType Word64T        = Dict
witPrimType FloatT         = Dict
witPrimType DoubleT        = Dict
witPrimType ComplexFloatT  = Dict
witPrimType ComplexDoubleT = Dict

--------------------------------------------------------------------------------
-- * Expressions
--------------------------------------------------------------------------------

-- | Primitive operations
data Primitive sig
  where
    FreeVar :: PrimType' a => String -> Primitive (Full a)
    Lit     :: (Eq a, Show a) => a -> Primitive (Full a)

    Add  :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a)
    Sub  :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a)
    Mul  :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a)
    Neg  :: (Num a, PrimType' a) => Primitive (a :-> Full a)
    Abs  :: (Num a, PrimType' a) => Primitive (a :-> Full a)
    Sign :: (Num a, PrimType' a) => Primitive (a :-> Full a)

    Quot :: (Integral a, PrimType' a)   => Primitive (a :-> a :-> Full a)
    Rem  :: (Integral a, PrimType' a)   => Primitive (a :-> a :-> Full a)
    Div  :: (Integral a, PrimType' a)   => Primitive (a :-> a :-> Full a)
    Mod  :: (Integral a, PrimType' a)   => Primitive (a :-> a :-> Full a)
    FDiv :: (Fractional a, PrimType' a) => Primitive (a :-> a :-> Full a)

    Pi    :: (Floating a, PrimType' a) => Primitive (Full a)
    Exp   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Log   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Sqrt  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Pow   :: (Floating a, PrimType' a) => Primitive (a :-> a :-> Full a)
    Sin   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Cos   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Tan   :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Asin  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Acos  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Atan  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Sinh  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Cosh  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Tanh  :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Asinh :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Acosh :: (Floating a, PrimType' a) => Primitive (a :-> Full a)
    Atanh :: (Floating a, PrimType' a) => Primitive (a :-> Full a)

    Complex   :: (Num a, PrimType' a, PrimType' (Complex a))       => Primitive (a :-> a :-> Full (Complex a))
    Polar     :: (Floating a, PrimType' a, PrimType' (Complex a))  => Primitive (a :-> a :-> Full (Complex a))
    Real      :: (PrimType' a, PrimType' (Complex a))              => Primitive (Complex a :-> Full a)
    Imag      :: (PrimType' a, PrimType' (Complex a))              => Primitive (Complex a :-> Full a)
    Magnitude :: (RealFloat a, PrimType' a, PrimType' (Complex a)) => Primitive (Complex a :-> Full a)
    Phase     :: (RealFloat a, PrimType' a, PrimType' (Complex a)) => Primitive (Complex a :-> Full a)
    Conjugate :: (Num a, PrimType' (Complex a))                    => Primitive (Complex a :-> Full (Complex a))

    I2N   :: (Integral a, Num b, PrimType' a, PrimType' b)      => Primitive (a :-> Full b)
    I2B   :: (Integral a, PrimType' a)                          => Primitive (a :-> Full Bool)
    B2I   :: (Integral a, PrimType' a)                          => Primitive (Bool :-> Full a)
    Round :: (RealFrac a, Num b, PrimType' a, PrimType' b) => Primitive (a :-> Full b)

    Not :: Primitive (Bool :-> Full Bool)
    And :: Primitive (Bool :-> Bool :-> Full Bool)
    Or  :: Primitive (Bool :-> Bool :-> Full Bool)
    Eq  :: (Eq a, PrimType' a)  => Primitive (a :-> a :-> Full Bool)
    NEq :: (Eq a, PrimType' a)  => Primitive (a :-> a :-> Full Bool)
    Lt  :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool)
    Gt  :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool)
    Le  :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool)
    Ge  :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool)

    BitAnd   :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a)
    BitOr    :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a)
    BitXor   :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a)
    BitCompl :: (Bits a, PrimType' a) => Primitive (a :-> Full a)
    ShiftL   :: (Bits a, PrimType' a, Integral b, PrimType' b) => Primitive (a :-> b :-> Full a)
    ShiftR   :: (Bits a, PrimType' a, Integral b, PrimType' b) => Primitive (a :-> b :-> Full a)

    ArrIx :: PrimType' a => IArr Index a -> Primitive (Index :-> Full a)

    Cond :: Primitive (Bool :-> a :-> a :-> Full a)

deriving instance Show (Primitive a)

-- The `PrimType'` constraints on certain symbols require an explanation: The
-- constraints are actually not needed for anything in the modules in
-- `Feldspar.Primitive.*`, but they are needed by `Feldspar.Run.Compile`. They
-- guarantee to the compiler that these symbols don't operate on tuples.
--
-- It would seem more consistent to have a `PrimType'` constraint on all
-- polymorphic symbols. However, this would prevent using some symbols for
-- non-primitive types in `Feldspar.Representation`. For example, `Lit` and
-- `Cond` are used `Feldspar.Representation`, and there they can also be used
-- for tuple types. The current design was chosen because it "just works".

deriveSymbol ''Primitive

instance Render Primitive
  where
    renderSym (FreeVar v) = v
    renderSym (Lit a)     = show a
    renderSym (ArrIx (IArrComp arr)) = "ArrIx " ++ arr
    renderSym (ArrIx _)              = "ArrIx ..."
    renderSym s = show s

    renderArgs = renderArgsSmart

instance StringTree Primitive

instance Eval Primitive
  where
    evalSym (FreeVar v) = error $ "evaluating free variable " ++ show v
    evalSym (Lit a)     = a
    evalSym Add         = (+)
    evalSym Sub         = (-)
    evalSym Mul         = (*)
    evalSym Neg         = negate
    evalSym Abs         = abs
    evalSym Sign        = signum
    evalSym Quot        = quot
    evalSym Rem         = rem
    evalSym Div         = div
    evalSym Mod         = mod
    evalSym FDiv        = (/)
    evalSym Pi          = pi
    evalSym Exp         = exp
    evalSym Log         = log
    evalSym Sqrt        = sqrt
    evalSym Pow         = (**)
    evalSym Sin         = sin
    evalSym Cos         = cos
    evalSym Tan         = tan
    evalSym Asin        = asin
    evalSym Acos        = acos
    evalSym Atan        = atan
    evalSym Sinh        = sinh
    evalSym Cosh        = cosh
    evalSym Tanh        = tanh
    evalSym Asinh       = asinh
    evalSym Acosh       = acosh
    evalSym Atanh       = atanh
    evalSym Complex     = (:+)
    evalSym Polar       = mkPolar
    evalSym Real        = realPart
    evalSym Imag        = imagPart
    evalSym Magnitude   = magnitude
    evalSym Phase       = phase
    evalSym Conjugate   = conjugate
    evalSym I2N         = fromInteger . toInteger
    evalSym I2B         = (/=0)
    evalSym B2I         = \a -> if a then 1 else 0
    evalSym Round       = fromInteger . round
    evalSym Not         = not
    evalSym And         = (&&)
    evalSym Or          = (||)
    evalSym Eq          = (==)
    evalSym NEq         = (/=)
    evalSym Lt          = (<)
    evalSym Gt          = (>)
    evalSym Le          = (<=)
    evalSym Ge          = (>=)
    evalSym BitAnd      = (.&.)
    evalSym BitOr       = (.|.)
    evalSym BitXor      = xor
    evalSym BitCompl    = complement
    evalSym ShiftL      = \a -> shiftL a . fromIntegral
    evalSym ShiftR      = \a -> shiftR a . fromIntegral
    evalSym Cond        = \c t f -> if c then t else f
    evalSym (ArrIx (IArrRun arr)) = \i ->
        if i<l || i>h
          then error $ "ArrIx: index "
                    ++ show (toInteger i)
                    ++ " out of bounds "
                    ++ show (toInteger l, toInteger h)
          else arr!i
      where
        (l,h) = bounds arr
    evalSym (ArrIx (IArrComp arr)) = error $ "evaluating symbolic array " ++ arr

-- | Assumes no occurrences of 'FreeVar' and concrete representation of arrays
instance EvalEnv Primitive env

instance Equality Primitive
  where
    equal s1 s2 = show s1 == show s2
      -- NOTE: It is very important not to use `renderSym` here, because it will
      -- render all concrete arrays equal.

      -- This method uses string comparison. It is probably slightly more
      -- efficient to pattern match directly on the constructors. Unfortunately
      -- `deriveEquality ''Primitive` doesn't work, so it gets quite tedious to
      -- write it with pattern matching.

type PrimDomain = Primitive :&: PrimTypeRep

-- | Primitive expressions
newtype Prim a = Prim { unPrim :: ASTF PrimDomain a }

instance Syntactic (Prim a)
  where
    type Domain (Prim a)   = PrimDomain
    type Internal (Prim a) = a
    desugar = unPrim
    sugar   = Prim

-- | Evaluate a closed expression
evalPrim :: Prim a -> a
evalPrim = go . unPrim
  where
    go :: AST PrimDomain sig -> Denotation sig
    go (Sym (s :&: _)) = evalSym s
    go (f :$ a) = go f $ go a

sugarSymPrim
    :: ( Signature sig
       , fi  ~ SmartFun dom sig
       , sig ~ SmartSig fi
       , dom ~ SmartSym fi
       , dom ~ PrimDomain
       , SyntacticN f fi
       , sub :<: Primitive
       , PrimType' (DenResult sig)
       )
    => sub sig -> f
sugarSymPrim = sugarSymDecor primTypeRep

instance FreeExp Prim
  where
    type FreePred Prim = PrimType'
    constExp = sugarSymPrim . Lit
    varExp   = sugarSymPrim . FreeVar

instance EvalExp Prim
  where
    evalExp = evalPrim

--------------------------------------------------------------------------------
-- * Interface
--------------------------------------------------------------------------------

instance (Num a, PrimType' a) => Num (Prim a)
  where
    fromInteger = constExp . fromInteger
    (+)         = sugarSymPrim Add
    (-)         = sugarSymPrim Sub
    (*)         = sugarSymPrim Mul
    negate      = sugarSymPrim Neg
    abs         = sugarSymPrim Abs
    signum      = sugarSymPrim Sign


{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

#if __GLASGOW_HASKELL__ < 708
{-# LANGUAGE Trustworthy #-}
#endif

#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 'R_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
-------------------------------------------------------------------------------
-- |
-- Module      :  Silica.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 @'R_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 'R_Getter' s a = forall r. 'Getting' r s a@
--
-- However, for 'R_Getter' (but not for 'Getting') we actually permit any
-- functor @f@ which is an instance of both 'Functor' and 'Contravariant':
--
-- @type 'R_Getter' s a = forall f. ('Contravariant' f, 'Functor' f) => (a -> f a) -> s -> f s@
--
-- Everything you can do with a function, you can do with a 'R_Getter', but
-- note that because of the continuation passing style ('.') composes them
-- in the opposite order.
--
-- Since it is only a function, every 'R_Getter' obviously only retrieves a
-- single value for a given input.
--
-- A common question is whether you can combine multiple 'R_Getter's to
-- retrieve multiple values. Recall that all 'R_Getter's are 'R_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 'R_Fold's
-- together:
--
-- >>> import Data.Monoid
-- >>> (1, 2, 3, 4, 5) ^.. (_2 <> _3 <> _5)
-- [2,3,5]
--
-------------------------------------------------------------------------------
module Silica.Getter
  (
  -- * R_Getters
    R_Getter, R_IndexedGetter
  , Getting, IndexedGetting
  , Accessing
  -- * Building R_Getters
  , to
  , uto
  , xto
  , ito
  , like
  , ilike
  -- * Combinators for R_Getters and R_Folds
  , (^.)
  , view, views
  , use, uses
  , listening, listenings
  -- * Indexed R_Getters
  -- ** Indexed R_Getter Combinators
  , (^@.)
  , iview, iviews
  , iuse, iuses
  , ilistening, ilistenings
  -- * Implementation Details
  , Contravariant(..)
  , pgetting
  , Const(..)
  ) where

import Control.Applicative
import Silica.Internal.Indexed
import Silica.Type
import Control.Monad.Reader.Class as Reader
import Control.Monad.State        as State
import Control.Monad.Writer       as Writer
import Data.Functor.Contravariant
import Data.Profunctor
import Data.Profunctor.Unsafe

-- $setup
-- >>> :set -XNoR_OverloadedStrings
-- >>> import Silica
-- >>> 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 ^., ^@.

asGetter :: AsGetter k => Optic' k s a -> Getter s a
asGetter = sub

asGetting :: AsGetting r k => Optic' k s a -> Getting r s a
asGetting = sub

asIndexedGetter :: AsIndexedGetter i k => Optic' k s a -> IndexedGetter i s a
asIndexedGetter = sub

asIndexedGetting :: AsIndexedGetting i r k => Optic' k s a -> IndexedGetting i r s a
asIndexedGetting = sub

runGetter :: AsGetter k => Optic' k s a -> R_Getter s a
runGetter = runOptic . asGetter

runGetting :: AsGetting r k => Optic' k s a -> R_Getting r s a
runGetting = runOptic . asGetting

-- runIndexedGetter :: AsIndexedGetter i k => Optic' k s a -> R_IndexedGetter i s a
-- runIndexedGetter = runOptic . asIndexedGetter

-------------------------------------------------------------------------------
-- R_Getters
-------------------------------------------------------------------------------

-- | Build an (index-preserving) 'R_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) -> 'R_IndexPreservingGetter' s a
-- @
to :: (s -> a) -> IndexPreservingGetter s a
to = xto
{-# INLINE to #-}

-- | Index-preserving 'to', for consistency
xto :: (s -> a) -> IndexPreservingGetter s a
xto k = Optic (rto k)
{-# INLINE xto #-}

-- | Unindexed 'to'
uto :: (s -> a) -> Getter s a
uto k = Optic (rto k)
{-# INLINE uto #-}

-- | General 'to'.
gto :: (Profunctor p, Contravariant f) => (s -> a) -> Proptic' p f s a
gto k = Optic (rto k)
{-# INLINE gto #-}

-- | Raw 'to'
rto :: (Profunctor p, Contravariant f) => (s -> a) -> R_Optic' p f s a
rto k = dimap k (contramap k)
{-# INLINE rto #-}

-- pto :: (Profunctor p, Contravariant f, AsProptic p f k) => (s -> a) -> Optic' k s a
-- pto k = Optic (rto k)
-- {-# INLINE pto #-}

ito :: (s -> (i, a)) -> IndexedGetter i s a
ito k = Optic (rito k)
{-# INLINE ito #-}

gito :: (Indexable i p, Contravariant f) => (s -> (i, a)) -> Over' p f s a
gito k = Optic (rito k)
{-# INLINE gito #-}

rito :: (Indexable i p, Contravariant f) => (s -> (i, a)) -> R_Over' p f s a
rito k = dimap k (contramap (snd . k)) . uncurry . indexed
{-# INLINE rito #-}

-- | Build an constant-valued (index-preserving) 'R_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 'R_Fold'
-- e.g. @foo `failing` 'like' 0@
--
-- @
-- 'like' :: a -> 'R_IndexPreservingGetter' s a
-- like :: (Profunctor p, Contravariant f, Functor f) => a -> R_Optic' p f s a
-- @
like :: a -> IndexPreservingGetter s a
like = xlike
{-# INLINE like #-}

xlike :: a -> IndexPreservingGetter s a
xlike a = xto (const a)
{-# INLINE xlike #-}

ulike :: a -> Getter s a
ulike a = uto (const a)
{-# INLINE ulike #-}

glike :: (Profunctor p, Contravariant f) => a -> Proptic' p f s a
glike a = gto (const a)
{-# INLINE glike #-}

ilike :: i -> a -> IndexedGetter i s a
ilike i a = ito (const (i, a))
{-# INLINE ilike #-}

gilike :: (Indexable i p, Contravariant f) => i -> a -> Over' p f s a
gilike i a = gito (const (i, a))
{-# INLINE gilike #-}

-- | When you see this in a type signature it indicates that you can
-- pass the function a 'R_Lens', 'R_Getter',
-- 'Control.R_Lens.R_Traversal.R_Traversal', 'Control.R_Lens.R_Fold.R_Fold',
-- 'Control.R_Lens.R_Prism.R_Prism', 'Control.R_Lens.R_Iso.R_Iso', or one of
-- the indexed variants, and it will just \"do the right thing\".
--
-- Most 'R_Getter' combinators are able to be used with both a 'R_Getter' or a
-- 'Control.R_Lens.R_Fold.R_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 'R_Lens', 'Control.R_Lens.R_Traversal.R_Traversal' and
-- 'Control.R_Lens.R_Iso.R_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.R_Lens.R_Fold.R_Fold' (or
-- 'Control.R_Lens.R_Traversal.R_Traversal'), otherwise you can only pass this a
-- 'R_Getter' or 'R_Lens'.
type R_Getting r s a = (a -> Const r a) -> s -> Const r s

-- | Used to consume an 'Control.R_Lens.R_Fold.R_IndexedFold'.
type R_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 'R_Getter', 'Control.R_Lens.R_Iso.R_Iso' or
-- 'R_Lens' or the result of folding over all the results of a
-- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_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"
--
--
-- R_As 'view' is commonly used to access the target of a 'R_Getter' or obtain a monoidal summary of the targets of a 'R_Fold',
-- It may be useful to think of it as having one of these more restricted signatures:
--
-- @
-- 'view' ::             'R_Getter' s a     -> s -> a
-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Fold.R_Fold' s m       -> s -> m
-- 'view' ::             'Control.R_Lens.R_Iso.R_Iso'' s a       -> s -> a
-- 'view' ::             'R_Lens'' s a      -> s -> a
-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Traversal.R_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             => 'R_Getter' s a     -> m a
-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.R_Lens.R_Fold.R_Fold' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.R_Lens.R_Iso.R_Iso'' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'R_Lens'' s a      -> m a
-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.R_Lens.R_Traversal.R_Traversal'' s a -> m a
-- @
view :: (MonadReader s m, AsGetting a k) => Optic' k s a -> m a
view l = Reader.asks (getConst #. runGetting l Const)
{-# INLINE view #-}

-- | View a function of the value pointed to by a 'R_Getter' or 'R_Lens' or the result of
-- folding over the result of mapping the targets of a 'Control.R_Lens.R_Fold.R_Fold' or
-- 'Control.R_Lens.R_Traversal.R_Traversal'.
--
-- @
-- 'views' l f ≡ 'view' (l '.' 'to' f)
-- @
--
-- >>> views (to f) g a
-- g (f a)
--
-- >>> views _2 length (1,"hello")
-- 5
--
-- R_As 'views' is commonly used to access the target of a 'R_Getter' or obtain a monoidal summary of the targets of a 'R_Fold',
-- It may be useful to think of it as having one of these more restricted signatures:
--
-- @
-- 'views' ::             'R_Getter' s a     -> (a -> r) -> s -> r
-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Fold.R_Fold' s a       -> (a -> m) -> s -> m
-- 'views' ::             'Control.R_Lens.R_Iso.R_Iso'' s a       -> (a -> r) -> s -> r
-- 'views' ::             'R_Lens'' s a      -> (a -> r) -> s -> r
-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Traversal.R_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             => 'R_Getter' s a     -> (a -> r) -> m r
-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s a       -> (a -> r) -> m r
-- 'views' :: 'MonadReader' s m             => 'Control.R_Lens.R_Iso.R_Iso'' s a       -> (a -> r) -> m r
-- 'views' :: 'MonadReader' s m             => 'R_Lens'' s a      -> (a -> r) -> m r
-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_Traversal'' s a -> (a -> r) -> m r
-- @
--
-- @
-- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r
-- @
views :: (MonadReader s m, AsLensLike (Const r) k) => Optic' k s a -> (a -> r) -> m r
views l f = Reader.asks (getConst #. runLensLike l (Const #. f))
{-# INLINE views #-}

-- | View the value pointed to by a 'R_Getter' or 'R_Lens' or the
-- result of folding over all the results of a 'Control.R_Lens.R_Fold.R_Fold' or
-- 'Control.R_Lens.R_Traversal.R_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 -> 'R_Getter' s a     -> a
-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.R_Lens.R_Fold.R_Fold' s m       -> m
-- ('^.') ::             s -> 'Control.R_Lens.R_Iso.R_Iso'' s a       -> a
-- ('^.') ::             s -> 'R_Lens'' s a      -> a
-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.R_Lens.R_Traversal.R_Traversal'' s m -> m
-- @
(^.) :: AsGetting a k => s -> Optic' k s a -> a
s ^. l = getConst (runGetting l Const s)
{-# INLINE (^.) #-}

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

-- | Use the target of a 'R_Lens', 'Control.R_Lens.R_Iso.R_Iso', or
-- 'R_Getter' in the current state, or use a summary of a
-- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_Traversal' that points
-- to a monoidal value.
--
-- >>> evalState (use _1) (a,b)
-- a
--
-- >>> evalState (use _1) ("hello","world")
-- "hello"
--
-- @
-- 'use' :: 'MonadState' s m             => 'R_Getter' s a     -> m a
-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s r       -> m r
-- 'use' :: 'MonadState' s m             => 'Control.R_Lens.R_Iso.R_Iso'' s a       -> m a
-- 'use' :: 'MonadState' s m             => 'R_Lens'' s a      -> m a
-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_Traversal'' s r -> m r
-- @
use :: (MonadState s m, AsGetting a k) => Optic' k s a -> m a
use l = State.gets (view l)
{-# INLINE use #-}

-- | Use the target of a 'R_Lens', 'Control.R_Lens.R_Iso.R_Iso' or
-- 'R_Getter' in the current state, or use a summary of a
-- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_Traversal' that
-- points to a monoidal value.
--
-- >>> evalState (uses _1 length) ("hello","world")
-- 5
--
-- @
-- 'uses' :: 'MonadState' s m             => 'R_Getter' s a     -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s a       -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'R_Lens'' s a      -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Control.R_Lens.R_Iso.R_Iso'' s a       -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_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, AsLensLike (Const r) k) => Optic' k 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 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'listening' :: 'MonadWriter' w m             => 'R_Getter' w u     -> m a -> m (a, u)
-- 'listening' :: 'MonadWriter' w m             => 'R_Lens'' w u      -> m a -> m (a, u)
-- 'listening' :: 'MonadWriter' w m             => 'R_Iso'' w u       -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Fold' w u       -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Traversal'' w u -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Prism'' w u     -> m a -> m (a, u)
-- @
listening :: (MonadWriter w m, AsGetting u k) => Optic' k 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 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'ilistening' :: 'MonadWriter' w m             => 'R_IndexedGetter' i w u     -> m a -> m (a, (i, u))
-- 'ilistening' :: 'MonadWriter' w m             => 'R_IndexedLens'' i w u      -> m a -> m (a, (i, u))
-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_IndexedFold' i w u       -> m a -> m (a, (i, u))
-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_IndexedTraversal'' i w u -> m a -> m (a, (i, u))
-- @
ilistening :: (MonadWriter w m, AsIndexedGetting i (i, u) k) => Optic' k 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 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'listenings' :: 'MonadWriter' w m             => 'R_Getter' w u     -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: 'MonadWriter' w m             => 'R_Lens'' w u      -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: 'MonadWriter' w m             => 'R_Iso'' w u       -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Fold' w u       -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Traversal'' w u -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Prism'' w u     -> (u -> v) -> m a -> m (a, v)
-- @
listenings :: forall u v w m k a. (MonadWriter w m, AsGetting v k) => Optic' k w u -> (u -> v) -> m a -> m (a, v)
listenings l uv m = do
  (a, w) <- listen m
  return (a, views (asLensLike (asGetting l :: Getting v w u)) 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 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'ilistenings' :: 'MonadWriter' w m             => 'R_IndexedGetter' w u     -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: 'MonadWriter' w m             => 'R_IndexedLens'' w u      -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_IndexedFold' w u       -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_IndexedTraversal'' w u -> (i -> u -> v) -> m a -> m (a, v)
-- @
ilistenings :: (MonadWriter w m, AsIndexedGetting i v k) => Optic' k 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 R_Getters
------------------------------------------------------------------------------

-- | View the index and value of an 'R_IndexedGetter' into the current environment as a pair.
--
-- When applied to an 'R_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, AsIndexedGetting i (i, a) k) => Optic' k s a -> m (i,a)
iview l = asks (getConst #. runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i))
{-# INLINE iview #-}

-- | View a function of the index and value of an 'R_IndexedGetter' into the current environment.
--
-- When applied to an 'R_IndexedFold' the result will be a monoidal summary instead of a single answer.
--
-- @
-- 'iviews' ≡ 'Control.R_Lens.R_Fold.ifoldMapOf'
-- @
iviews :: (MonadReader s m, AsIndexedGetting i r k) => Optic' k s a -> (i -> a -> r) -> m r
iviews l f = asks (getConst #. runOptic (asIndexedGetting l) (Const #. Indexed f))
{-# INLINE iviews #-}

-- | Use the index and value of an 'R_IndexedGetter' into the current state as a pair.
--
-- When applied to an 'R_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, AsIndexedGetting i (i,a) k) => Optic' k s a -> m (i,a)
iuse l = gets (getConst #. runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i))
{-# INLINE iuse #-}

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

-- | View the index and value of an 'R_IndexedGetter' or 'R_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 -> 'R_IndexedGetter' i s a -> (i, a)
-- ('^@.') :: s -> 'R_IndexedLens'' i s a  -> (i, a)
-- @
--
-- The result probably doesn't have much meaning when applied to an 'R_IndexedFold'.
(^@.) :: AsIndexedGetting i (i, a) k => s -> Optic' k s a -> (i, a)
s ^@. l = getConst $ runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i) s
{-# INLINE (^@.) #-}

-- | Coerce a 'R_Getter'-compatible 'R_Optical' to an 'R_Optical''. This
-- is useful when using a 'R_Traversal' that is not simple as a 'R_Getter' or a
-- 'R_Fold'.
--
-- @
-- 'getting' :: 'R_Traversal' s t a b          -> 'R_Fold' s a
-- 'getting' :: 'R_Lens' s t a b               -> 'R_Getter' s a
-- 'getting' :: 'R_IndexedTraversal' i s t a b -> 'R_IndexedFold' i s a
-- 'getting' :: 'R_IndexedLens' i s t a b      -> 'R_IndexedGetter' i s a
-- @
rgetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f)
        => R_Optical p q f s t a b -> R_Optical' p q f s a
rgetting l f = rmap phantom . l $ rmap phantom f

asOptical :: AsOptical p q f k => Optic k s t a b -> Optical p q f s t a b
asOptical = sub

ggetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f, k <: A_Optical p q f)
         => Optic k s t a b -> Optical' p q f s a
ggetting l = Optic (rgetting (runOptic (asOptical l)))

pgetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f)
        => Optical p q f s t a b -> Optical' p q f s a
pgetting l = Optic (rgetting (runOptic l))


{-# LANGUAGE QuasiQuotes, TemplateHaskell, ExplicitForAll, ScopedTypeVariables #-}
module AlgebraicDataTypes where

import Language.Rust.Inline
import Language.Rust.Inline.TH
import Language.Rust.Quote
import Test.Hspec

import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable

import Data.Bifunctor ( Bifunctor(..) )
import Data.Char      ( toUpper )
import Data.Complex   ( Complex(..) )
import Data.Foldable  ( for_ )
import Data.Int       ( Int8, Int16, Int32, Int64 )

-- | A struct-like ADT where the fields have different sizes
data StructLike = StructLike  Int16 Int64 deriving (Show, Eq)
mkStorable [t| Storable StructLike |]

-- | A struct-like newtype ADT where the field is compound
newtype StructLike2 = StructLike2 (Int16, Int64) deriving (Show, Eq)
mkStorable [t| Storable StructLike2 |]

-- | An ADT where:
--
--   * Different variants have different alignment
--   * Variants have other complex structures
--
data Foo
  = Bar
  | Baz Char Int
  | Qux (Complex Float) Char
  deriving (Show, Eq)
mkStorable [t| Storable Foo |]

-- | An ADT where fields are nested ADTs
data Croc
  = Lob (Maybe Foo) Int
  | Boo Int8 Int8
  deriving (Show, Eq)
mkStorable [t| Storable Croc |]

-- | A polymorphic ADT. (From the @these@ package).
data These a b
  = This a
  | That b
  | Both a b
  deriving (Show, Eq)
mkStorable [t| forall a b. (Storable a, Storable b) => Storable (These a b) |]

-- | An ADT that needs more that a 'Word8' to store the tag
data Big a
  = C000 | C001 | C002 | C003 | C004 | C005 | C006 | C007 | C008 | C009
  | C010 | C011 | C012 | C013 | C014 | C015 | C016 | C017 | C018 | C019
  | C020 | C021 | C022 | C023 | C024 | C025 | C026 | C027 | C028 | C029
  | C030 | C031 | C032 | C033 | C034 | C035 | C036 | C037 | C038 | C039
  | C040 | C041 | C042 | C043 | C044 | C045 | C046 | C047 | C048 | C049
  | C050 | C051 | C052 | C053 | C054 | C055 | C056 | C057 | C058 | C059
  | C060 | C061 | C062 | C063 | C064 | C065 | C066 | C067 | C068 | C069
  | C070 | C071 | C072 | C073 | C074 | C075 | C076 | C077 | C078 | C079
  | C080 | C081 | C082 | C083 | C084 | C085 | C086 | C087 | C088 | C089
  | C090 | C091 | C092 | C093 | C094 | C095 | C096 | C097 | C098 | C099
  | C100 | C101 | C102 | C103 | C104 | C105 | C106 | C107 | C108 | C109
  | C110 | C111 | C112 | C113 | C114 | C115 | C116 | C117 | C118 | C119
  | C120 | C121 | C122 | C123 | C124 | C125 | C126 | C127 | C128 | C129
  | C130 | C131 | C132 | C133 | C134 | C135 | C136 | C137 | C138 | C139
  | C140 | C141 | C142 | C143 | C144 | C145 | C146 | C147 | C148 | C149
  | C150 | C151 | C152 | C153 | C154 | C155 | C156 | C157 | C158 | C159
  | C160 | C161 | C162 | C163 | C164 | C165 | C166 | C167 | C168 | C169
  | C170 | C171 | C172 | C173 | C174 | C175 | C176 | C177 | C178 | C179
  | C180 | C181 | C182 | C183 | C184 | C185 | C186 | C187 | C188 | C189
  | C190 | C191 | C192 | C193 | C194 | C195 | C196 | C197 | C198 | C199
  | C200 | C201 | C202 | C203 | C204 | C205 | C206 | C207 | C208 | C209
  | C210 | C211 | C212 | C213 | C214 | C215 | C216 | C217 | C218 | C219
  | C220 | C221 | C222 | C223 | C224 | C225 | C226 | C227 | C228 | C229
  | C230 | C231 | C232 | C233 | C234 | C235 | C236 | C237 | C238 | C239
  | C240 | C241 | C242 | C243 | C244 | C245 | C246 | C247 | C248 | C249
  | C250 | C251 | C252 | C253 | C254 | C255 | C256 | C257 | C258 | C259
  | C260 | C261 | C262 | C263 | C264 | C265 | C266 | C267 | C268 | C269
  | C270 | C271 | C272 | C273 | C274 | C275 | C276 | C277 | C278 | C279
  | C280 | C281 | C282 | C283 | C284 | C285 | C286 | C287 | C288 | C289
  | C290 | C291 | C292 | C293 | C294 | C295 | C296 | C297 | C298 | C299 a
  deriving (Show, Eq)
mkStorable [t| forall a. Storable a => Storable (Big a) |]

-- | An ADT with a mixture of polymorphism and not.
data Foo2 a
  = Bar2
  | Baz2 Word
  | Qux2 a a
  | Quux2 Int a
  deriving (Show, Eq)
mkStorable [t| forall a. Storable a => Storable (Foo2 a) |]

-- Set the context
extendContext basic
extendContext prelude
extendContext (singleton [ty| Cpx<f32> |] [t| Complex Float |])
extendContext (rustTyCtx [t| Foo |])
extendContext (rustTyCtx [t| StructLike |])
extendContext (rustTyCtx [t| StructLike2 |])
extendContext (rustTyCtx [t| Croc |])
extendContext (rustTyCtx [t| forall a b. These a b |])
extendContext (rustTyCtx [t| forall a. Big a |])
extendContext (rustTyCtx [t| forall a. Foo2 a |])
setCrateModule

[rust|
#[derive(Copy,Clone)]
#[repr(C)]
pub struct Cpx<T> { re: T, im: T }

use std::ops::Add;
impl<T: Add<Output=T>> Add for Cpx<T> {
  type Output = Cpx<T>;

  fn add(self, rhs: Self) -> Self {
    Cpx {
      re: self.re + rhs.re,
      im: self.im + rhs.im,
    }
  }
}
|]

-- | Function on 'Foo'
quux :: Foo -> Foo
quux (Baz 'a' 0) = Bar
quux (Baz c i) = Baz 'l' (i+1)
quux (Qux (_ :+ im) c) = Qux (9.0 :+ im) c
quux f = f

[rust|
impl Foo {
  pub fn quux(self) -> Self {
    match self {
      Foo::Baz('a', 0) => Foo::Bar,
      Foo::Baz(c, i) => Foo::Baz('l', i+1),
      Foo::Qux(Cpx { im, .. }, c) => Foo::Qux(Cpx { re: 9f32, im }, c),
      f => f,
    }
  }
}
|]

-- | Function on 'Croc'
croc :: Croc -> Croc
croc (Lob mfoo i) = Lob (fmap quux mfoo) (i + 4)
croc (Boo i1 i2) = Boo (negate i1) (abs i2)

[rust|
impl Croc {
  pub fn croc(self) -> Self {
    match self {
      Croc::Lob(mfoo, i) => Croc::Lob(mfoo.map(|x| x.quux()), i + 4),
      Croc::Boo(i1, i2) => Croc::Boo(-i1, i2.abs()),
    }
  }
}
|]

-- | Function 1 on 'StructLike'/'StructLike2'
in2 :: StructLike -> StructLike2
in2 (StructLike f i) = StructLike2 (f * 2, i * 3 - 8)

-- | Function 2 on 'StructLike'/'StructLike2'
out2 :: StructLike2 -> StructLike
out2 (StructLike2 (f, i)) = StructLike (f `quot` 2) ((i + 8) `quot` 3)

[rust|
impl StructLike {
  pub fn in2(self) -> StructLike2 {
    let StructLike(f,i) = self;
    StructLike2((f * 2, i * 3 - 8))
  }
}

impl StructLike2 {
  pub fn out2(self) -> StructLike {
    let StructLike2((f,i)) = self;
    StructLike(f / 2, (i + 8) / 3)
  }
}
|]

instance Bifunctor These where
  bimap f _ (This x) = This (f x)
  bimap _ g (That y) = That (g y)
  bimap f g (Both x y) = Both (f x) (g y)

[rust|
impl<A, B> These<A, B> {
  pub fn bimap<C, D, F, G>(self, f: F, g: G) -> These<C, D>
  where
    F: FnOnce(A) -> C,
    G: FnOnce(B) -> D,
  {
    match self {
      These::This(x) => These::This(f(x)),
      These::That(y) => These::That(g(y)),
      These::Both(x, y) => These::Both(f(x), g(y)),
    }
  }
}
|]

algebraicDataTypes :: Spec
algebraicDataTypes = describe "Algebraic data types" $ do
  it "Can marshal a `Complex Float` argument/return" $ do
    let z1, z2 :: Complex Float
        z1 = 1.3 :+ 4.5
        z2 = 6.7 :+ 8.9
    [rust| Cpx<f32> { $(z1: Cpx<f32>) + $(z2: Cpx<f32>) } |] `shouldBe` z1 + z2

  it "Can marshal a custom single-constructor ADT argument/return" $ do
    let s1 = StructLike 78 (negate 267)
        s2 = StructLike 92 45223
        s3 = StructLike2 (34, -92391)
        s4 = StructLike2 (576, 1234)

    for_ [s1,s2] $ \si ->
        [rust| StructLike2 { $(si: StructLike).in2() } |] `shouldBe` in2 si
    for_ [s3,s4] $ \si ->
        [rust| StructLike { $(si: StructLike2).out2() } |] `shouldBe` out2 si

  it "Can marshal a custom monomorphic ADT argument/return" $ do
    let f1, f2, f3, f4 :: Foo
        f1 = Baz 'a' 0
        f2 = Baz 'b' 2
        f3 = Qux (7.1 :+ 3.4) 'f'
        f4 = Bar

    for_ [f1,f2,f3,f4] $ \fi ->
      [rust| Foo { $(fi: Foo).quux() } |] `shouldBe` quux fi

  it "Can marshal nested monomorphic ADT arguments/returns" $ do
    let c1, c2, c3, c4, c5, c6, c7 :: Croc
        c1 = Lob (Just (Baz 'a' 0)) 2
        c2 = Lob (Just (Baz 'b' 2)) 6
        c3 = Lob (Just (Qux (7.1 :+ 3.4) 'f')) 8
        c4 = Lob (Just Bar) 9
        c5 = Lob Nothing 3
        c6 = Boo 3 (-2)
        c7 = Boo (-4) 2

    for_ [c1,c2,c3,c4,c5,c6,c7] $ \ci ->
      [rust| Croc { $(ci: Croc).croc() } |] `shouldBe` croc ci

  it "Can marshal polymorphic ADT arguments/returns" $ do
    let t1, t2, t3 :: These Int8 Int64
        t1 = This maxBound
        t2 = That 432442
        t3 = Both (maxBound - 3) 879

    for_ [t1,t2,t3] $ \ti ->
      let v1 = [rust| These<i16,i64> {
                 $(ti: These<i8,i64>).bimap(|x| x as i16 * 2, |y| y + 2)
               } |]
          v2 = bimap (\x -> fromIntegral x * 2) (+ 2) ti
      in v1 `shouldBe` v2

  it "Can marshal nested polymorphic ADT arguments/returns" $ do
    let t1, t2, t3 :: These (Maybe Int) (These Int8 Int8)
        t1 = This (Just 6)
        t2 = This Nothing
        t3 = That (This 8)
        t4 = That (That 9)
        t5 = That (Both 1 2)
        t6 = Both (Just 3) (That 8)
        t7 = Both Nothing (Both 3 5)
        t8 = Both (Just 213) (Both 78 98)

    for_ [t1,t2,t3,t4,t5,t6,t7,t8] $ \ti ->
      let v1 = [rust| These<Option<isize>,These<i8,i8>> {
                 $(ti: These<Option<isize>,These<i8,i8>>).bimap(
                    |oi| oi.map(|i| i + 5),
                    |t| t.bimap(|i| i + 2, |j| j * 3),
                 )
               } |]
          v2 = bimap (fmap (+5)) (bimap (+2) (*3)) ti
      in v1 `shouldBe` v2

  it "Can marshal a big ADT whose tag needs more than a `Word8`" $ do
    let b1, b2, b3, b4 :: Big Int64
        b1 = C000
        b2 = C160
        b3 = C298
        b4 = C299 89

    for_ [b1,b2,b3,b4] $ \bi ->
      let v1 = [rust| Big<i64> {
                  match $(bi: Big<i64>) {
                    Big::C160 => Big::C161,
                    Big::C299(i) => Big::C299(i+1),
                    b => b,
                  }
               } |]
          v2 = case bi of
                 C160 -> C161
                 C299 i -> C299 (i + 1)
                 b -> b
      in v1 `shouldBe` v2

  it "Can marshal a custom `Foo2 Int` and `Foo2 (Foo2 Int)` return" $ do
    let f1, f2, f3, f4 :: Foo2 Int
        f1 = Bar2
        f2 = Baz2 3
        f3 = Qux2 (-1) 2
        f4 = Quux2 (-8) 3

    let fooed f = case f of
                    Qux2 x y -> Qux2 (Qux2 x y) (Qux2 y x)
                    Quux2 i x -> Quux2 (i + 1) (Qux2 x x)
                    Bar2 -> Bar2
                    Baz2 w -> Baz2 w

    let fooed' f = [rust| Foo2<Foo2<isize>> {
      match $(f: Foo2<isize>) {
        Foo2::Qux2(x,y) => Foo2::Qux2(Foo2::Qux2(x,y), Foo2::Qux2(y,x)),
        Foo2::Quux2(i,x) => Foo2::Quux2(i+1, Foo2::Qux2(x,x)),
        Foo2::Bar2 => Foo2::Bar2,
        Foo2::Baz2(w) => Foo2::Baz2(w),
      }
    } |]

    fooed f1 `shouldBe` fooed' f1
    fooed f2 `shouldBe` fooed' f2
    fooed f3 `shouldBe` fooed' f3
    fooed f4 `shouldBe` fooed' f4


{-# LANGUAGE CPP #-}

{-# LANGUAGE MultiParamTypeClasses  #-} -- for 'Bind' class.
{-# LANGUAGE ConstraintKinds        #-} -- for 'Bind' class.
{-# LANGUAGE TypeFamilies           #-} -- for 'Bind' class.

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE UndecidableInstances #-}

{-# LANGUAGE TypeOperators #-} -- For ':*:' instance and others.

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
-- Some of the constraints may be unnecessary, but they are intentional.
-- This is especially true for the 'Fail' instances.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif

-- | Representation of supermonads in Haskell.
module Control.Super.Monad
  ( -- * Supermonads
    Bind(..), Return(..), Fail(..)
    -- * Super-Applicatives
  , Applicative(..), pure
  , Functor(..)
    -- * Conveniences
  , Monad
  ) where

import Prelude
  ( String
  , Maybe(..), Either(..)
  , Functor(..)
  , (.), ($), const, id
  )
import qualified Prelude as P

import Data.Functor.Identity ( Identity )

import GHC.Exts ( Constraint )

-- To define standard instances:
import qualified Data.Monoid as Mon
import qualified Data.Proxy as Proxy
import qualified Data.Functor.Product as Product
import qualified Data.Functor.Compose as Compose
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
import qualified Data.Complex as Complex
import qualified Data.Semigroup as Semigroup
import qualified Data.List.NonEmpty as NonEmpty
#endif

import qualified Control.Arrow as Arrow
import qualified Control.Applicative as App
import qualified Control.Monad.ST as ST
import qualified Control.Monad.ST.Lazy as STL

import qualified Text.ParserCombinators.ReadP as Read
import qualified Text.ParserCombinators.ReadPrec as Read

import qualified GHC.Conc as STM
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
import qualified GHC.Generics as Generics
#endif

-- To define "transformers" instances:
import qualified Control.Monad.Trans.Cont     as Cont
import qualified Control.Monad.Trans.Except   as Except
import qualified Control.Monad.Trans.Identity as Identity
import qualified Control.Monad.Trans.Maybe    as Maybe
import qualified Control.Monad.Trans.RWS.Lazy      as RWSL
import qualified Control.Monad.Trans.RWS.Strict    as RWSS
import qualified Control.Monad.Trans.Reader        as Reader
import qualified Control.Monad.Trans.State.Lazy    as StateL
import qualified Control.Monad.Trans.State.Strict  as StateS
import qualified Control.Monad.Trans.Writer.Lazy   as WriterL
import qualified Control.Monad.Trans.Writer.Strict as WriterS

-- -----------------------------------------------------------------------------
-- Super-Applicative Type Class
-- -----------------------------------------------------------------------------

infixl 4 <*>, <*, *>

-- | TODO
class (Functor m, Functor n, Functor p) => Applicative m n p where
  type ApplicativeCts m n p :: Constraint
  type ApplicativeCts m n p = ()

  (<*>) :: (ApplicativeCts m n p) => m (a -> b) -> n a -> p b

  (*>) :: (ApplicativeCts m n p) => m a -> n b -> p b
  ma *> nb = (id <$ ma) <*> nb
  (<*) :: (ApplicativeCts m n p) => m a -> n b -> p a
  ma <* nb = fmap const ma <*> nb

-- | 'pure' is defined in terms of return.
pure :: (Return f, ReturnCts f) => a -> f a
pure = return

-- Standard Instances ----------------------------------------------------------

instance Applicative ((->) r) ((->) r) ((->) r) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Identity Identity Identity where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative [] [] [] where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Maybe Maybe Maybe where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative P.IO P.IO P.IO where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative (Either e) (Either e) (Either e) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance Applicative Mon.First Mon.First Mon.First where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Last Mon.Last Mon.Last where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Mon.Sum Mon.Sum Mon.Sum where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Product Mon.Product Mon.Product where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Dual Mon.Dual Mon.Dual where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif
instance (Applicative m n p) => Applicative (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) where
  type ApplicativeCts (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) = ApplicativeCts m n p
  mf <*> na = Mon.Alt $ (Mon.getAlt mf) <*> (Mon.getAlt na)
  mf *> na = Mon.Alt $ (Mon.getAlt mf) *> (Mon.getAlt na)
  mf <* na = Mon.Alt $ (Mon.getAlt mf) <* (Mon.getAlt na)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Semigroup.Min Semigroup.Min Semigroup.Min where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Max Semigroup.Max Semigroup.Max where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Option Semigroup.Option Semigroup.Option where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.First Semigroup.First Semigroup.First where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Last Semigroup.Last Semigroup.Last where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif

instance Applicative Proxy.Proxy Proxy.Proxy Proxy.Proxy where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Complex.Complex Complex.Complex Complex.Complex where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative NonEmpty.NonEmpty NonEmpty.NonEmpty NonEmpty.NonEmpty where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif
instance (Applicative m1 n1 p1, Applicative m2 n2 p2) => Applicative (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) where
  type ApplicativeCts (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) = (ApplicativeCts m1 n1 p1, ApplicativeCts m2 n2 p2)
  Product.Pair m1 m2 <*> Product.Pair n1 n2 = Product.Pair (m1 <*> n1) (m2 <*> n2)
  Product.Pair m1 m2  *> Product.Pair n1 n2 = Product.Pair (m1  *> n1) (m2  *> n2)
  Product.Pair m1 m2 <*  Product.Pair n1 n2 = Product.Pair (m1 <*  n1) (m2 <*  n2)

instance (Applicative f g h, Applicative f' g' h') => Applicative (Compose.Compose f f') (Compose.Compose g g') (Compose.Compose h h') where
  type ApplicativeCts (Compose.Compose f f') (Compose.Compose g g') (Compose.Compose h h') = (ApplicativeCts f g h, ApplicativeCts f' g' h')
  Compose.Compose f <*> Compose.Compose x = Compose.Compose $ fmap (<*>) f <*> x
  Compose.Compose f  *> Compose.Compose x = Compose.Compose $ fmap ( *>) f <*> x
  Compose.Compose f <*  Compose.Compose x = Compose.Compose $ fmap (<* ) f <*> x

instance Applicative Read.ReadP Read.ReadP Read.ReadP where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Read.ReadPrec Read.ReadPrec Read.ReadPrec where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance Applicative (ST.ST s) (ST.ST s) (ST.ST s) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative (STL.ST s) (STL.ST s) (STL.ST s) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance (Arrow.Arrow a) => Applicative (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
-- | TODO / FIXME: The wrapped monad instances for 'Functor' and 'P.Monad' are both
--   based on @m@ being a monad, although the functor instance should only be
--   dependend on @m@ being a functor (as can be seen below). This can only be
--   fixed by either giving a custom version of 'App.WrappedMonad' here or by fixing
--   the version of 'App.WrappedMonad' in base.
--   Once this issue is fixed we can replace the 'P.Monad' constraint
--   with a 'Functor' constraint.
--
--   > instance (Functor m) => Functor (App.WrappedMonad m) where
--   >   fmap f m = App.WrapMonad $ fmap (App.unwrapMonad m) f
--
instance (Applicative m m m, P.Monad m) => Applicative (App.WrappedMonad m) (App.WrappedMonad m) (App.WrappedMonad m) where
  type ApplicativeCts (App.WrappedMonad m) (App.WrappedMonad m) (App.WrappedMonad m) = ApplicativeCts m m m
  mf <*> na = App.WrapMonad $ (App.unwrapMonad mf) <*> (App.unwrapMonad na)
  mf  *> na = App.WrapMonad $ (App.unwrapMonad mf)  *> (App.unwrapMonad na)
  mf <*  na = App.WrapMonad $ (App.unwrapMonad mf) <*  (App.unwrapMonad na)

instance Applicative STM.STM STM.STM STM.STM where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Generics.U1 Generics.U1 Generics.U1 where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance (Applicative f g h) => Applicative (Generics.Rec1 f) (Generics.Rec1 g) (Generics.Rec1 h) where
  type ApplicativeCts (Generics.Rec1 f) (Generics.Rec1 g) (Generics.Rec1 h) = ApplicativeCts f g h
  (Generics.Rec1 mf) <*> (Generics.Rec1 ma) = Generics.Rec1 $ mf <*> ma
  (Generics.Rec1 mf)  *> (Generics.Rec1 ma) = Generics.Rec1 $ mf  *> ma
  (Generics.Rec1 mf) <*  (Generics.Rec1 ma) = Generics.Rec1 $ mf <*  ma
instance (Applicative f g h, Applicative f' g' h') => Applicative (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') where
  type ApplicativeCts (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') = (ApplicativeCts f g h, ApplicativeCts f' g' h')
  (f Generics.:*: g) <*> (f' Generics.:*: g') = (f <*> f') Generics.:*: (g <*> g')
  (f Generics.:*: g)  *> (f' Generics.:*: g') = (f  *> f') Generics.:*: (g  *> g')
  (f Generics.:*: g) <*  (f' Generics.:*: g') = (f <*  f') Generics.:*: (g <*  g')
instance (Applicative f g h, Applicative f' g' h') => Applicative (f Generics.:.: f') (g Generics.:.: g') (h Generics.:.: h') where
  type ApplicativeCts (f Generics.:.: f') (g Generics.:.: g') (h Generics.:.: h') = (ApplicativeCts f g h, ApplicativeCts f' g' h')
  (Generics.Comp1 mf) <*> (Generics.Comp1 ma) = Generics.Comp1 $ fmap (<*>) mf <*> ma
instance Applicative f g h => Applicative (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) where
  type ApplicativeCts  (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) = ApplicativeCts  f g h
  (Generics.M1 mf) <*> (Generics.M1 ma) = Generics.M1 $ mf <*> ma
  (Generics.M1 mf)  *> (Generics.M1 ma) = Generics.M1 $ mf  *> ma
  (Generics.M1 mf) <*  (Generics.M1 ma) = Generics.M1 $ mf <*  ma
#endif

-- "transformers" package instances: -------------------------------------------

-- Continuations are so wierd...
-- | TODO / FIXME: Still need to figure out how and if we can generalize the continuation implementation.
instance Applicative (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) where
  type ApplicativeCts (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) = ()
  f <*> a = Cont.ContT $ \ c -> Cont.runContT f $ \ g -> Cont.runContT a (c . g)
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) where
  type ApplicativeCts (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) = (ApplicativeCts m n p)
  Except.ExceptT f <*> Except.ExceptT v = Except.ExceptT $ fmap (<*>) f <*> v
  {-# INLINEABLE (<*>) #-}

instance (Applicative m n p) => Applicative (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) where
  type ApplicativeCts (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) = (ApplicativeCts m n p)
  Identity.IdentityT m <*> Identity.IdentityT k = Identity.IdentityT $ m <*> k
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) where
  type ApplicativeCts (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) = (ApplicativeCts m n p)
  Maybe.MaybeT f <*> Maybe.MaybeT x = Maybe.MaybeT $ fmap (<*>) f <*> x
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Bind m n p) => Applicative (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) where
  type ApplicativeCts (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) = (BindCts m n p)
  RWSL.RWST mf <*> RWSL.RWST ma  = RWSL.RWST $ \r s -> mf r s >>= \ ~(f, s', w) -> fmap (\ ~(a, s'', w') -> (f a, s'', P.mappend w w')) (ma r s')
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Bind m n p) => Applicative (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) where
  type ApplicativeCts (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) = (BindCts m n p)
  RWSS.RWST mf <*> RWSS.RWST ma = RWSS.RWST $ \r s -> mf r s >>= \ (f, s', w) -> fmap (\ (a, s'', w') -> (f a, s'', P.mappend w w')) (ma r s')
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) where
  type ApplicativeCts (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) = (ApplicativeCts m n p)
  Reader.ReaderT mf <*> Reader.ReaderT ma  = Reader.ReaderT $ \r -> mf r <*> ma r
  {-# INLINE (<*>) #-}

instance (Bind m n p) => Applicative (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) where
  type ApplicativeCts (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) = (BindCts m n p)
  StateL.StateT mf <*> StateL.StateT ma = StateL.StateT $ \s -> mf s >>= \ ~(f, s') -> fmap (\ ~(a, s'') -> (f a, s'')) (ma s')
  {-# INLINE (<*>) #-}

instance (Bind m n p) => Applicative (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) where
  type ApplicativeCts (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) = (BindCts m n p)
  StateS.StateT mf <*> StateS.StateT ma = StateS.StateT $ \s -> mf s >>= \ (f, s') -> fmap (\ (a, s'') -> (f a, s'')) (ma s')
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Applicative m n p) => Applicative (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) where
  type ApplicativeCts (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) = (ApplicativeCts m n p)
  WriterL.WriterT mf <*> WriterL.WriterT ma = WriterL.WriterT $ fmap (\ ~(f, w) ~(a, w') -> (f a, P.mappend w w')) mf <*> ma
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Applicative m n p) => Applicative (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) where
  type ApplicativeCts (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) = (ApplicativeCts m n p)
  WriterS.WriterT mf <*> WriterS.WriterT ma = WriterS.WriterT $ fmap (\ (f, w) (a, w') -> (f a, P.mappend w w')) mf <*> ma
  {-# INLINE (<*>) #-}

-- -----------------------------------------------------------------------------
-- Supermonad Type Class - Bind
-- -----------------------------------------------------------------------------

infixl 1 >>, >>=

-- | Representation of bind operations for supermonads.
--   A proper supermonad consists of an instance
--   for 'Bind', 'Return' and optionally 'Fail'.
--
--   The instances are required to follow a certain scheme.
--   If the type constructor of your supermonad is @M@ there
--   may only be exactly one 'Bind' and one 'Return' instance
--   that look as follows:
--
-- > instance Bind (M ...) (M ...) (M ...) where
-- >   ...
-- > instance Return (M ...) where
-- >   ...
--
--   This is enforced by the plugin. A compilation error will
--   result from either instance missing or multiple instances
--   for @M@.
--
--   For supermonads we expect the usual monad laws to hold:
--
--   * @'return' a '>>=' k  =  k a@
--   * @m '>>=' 'return'  =  m@
--   * @m '>>=' (\\x -> k x '>>=' h)  =  (m '>>=' k) '>>=' h@
--   * @'fmap' f xs  =  xs '>>=' 'return' . f@
--
class (Functor m, Functor n, Functor p) => Bind m n p where
  type BindCts m n p :: Constraint
  type BindCts m n p = ()
  (>>=) :: (BindCts m n p) => m a -> (a -> n b) -> p b
  (>>)  :: (BindCts m n p) => m a -> n b -> p b
  ma >> mb = ma >>= const mb

instance Bind ((->) r) ((->) r) ((->) r) where
  (>>=) = (P.>>=)
instance Bind Identity Identity Identity where
  (>>=) = (P.>>=)
instance Bind [] [] [] where
  (>>=) = (P.>>=)
instance Bind P.Maybe P.Maybe P.Maybe where
  (>>=) = (P.>>=)
instance Bind P.IO P.IO P.IO where
  (>>=) = (P.>>=)
instance Bind (P.Either e) (P.Either e) (P.Either e) where
  (>>=) = (P.>>=)

instance Bind Mon.First Mon.First Mon.First where
  (>>=) = (P.>>=)
instance Bind Mon.Last Mon.Last Mon.Last where
  (>>=) = (P.>>=)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Mon.Sum Mon.Sum Mon.Sum where
  (>>=) = (P.>>=)
instance Bind Mon.Product Mon.Product Mon.Product where
  (>>=) = (P.>>=)
instance Bind Mon.Dual Mon.Dual Mon.Dual where
  (>>=) = (P.>>=)
#endif
instance (Bind m n p) => Bind (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) where
  type BindCts (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) = BindCts m n p
  m >>= f = Mon.Alt $ (Mon.getAlt m) >>= (Mon.getAlt . f)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Semigroup.Min Semigroup.Min Semigroup.Min where
  (>>=) = (P.>>=)
instance Bind Semigroup.Max Semigroup.Max Semigroup.Max where
  (>>=) = (P.>>=)
instance Bind Semigroup.Option Semigroup.Option Semigroup.Option where
  (>>=) = (P.>>=)
instance Bind Semigroup.First Semigroup.First Semigroup.First where
  (>>=) = (P.>>=)
instance Bind Semigroup.Last Semigroup.Last Semigroup.Last where
  (>>=) = (P.>>=)
#endif

instance Bind Proxy.Proxy Proxy.Proxy Proxy.Proxy where
  (>>=) = (P.>>=)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Complex.Complex Complex.Complex Complex.Complex where
  (>>=) = (P.>>=)
instance Bind NonEmpty.NonEmpty NonEmpty.NonEmpty NonEmpty.NonEmpty where
  (>>=) = (P.>>=)
#endif
instance (Bind m1 n1 p1, Bind m2 n2 p2) => Bind (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) where
  type BindCts (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) = (BindCts m1 n1 p1, BindCts m2 n2 p2)
  Product.Pair m1 m2 >>= f = Product.Pair (m1 >>= (fstP . f)) (m2 >>= (sndP . f))
    where fstP (Product.Pair a _) = a
          sndP (Product.Pair _ b) = b

instance Bind Read.ReadP Read.ReadP Read.ReadP where
  (>>=) = (P.>>=)
instance Bind Read.ReadPrec Read.ReadPrec Read.ReadPrec where
  (>>=) = (P.>>=)

instance Bind (ST.ST s) (ST.ST s) (ST.ST s) where
  (>>=) = (P.>>=)
instance Bind (STL.ST s) (STL.ST s) (STL.ST s) where
  (>>=) = (P.>>=)
instance (Arrow.ArrowApply a) => Bind (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) where
  (>>=) = (P.>>=)
-- | TODO / FIXME: The wrapped monad instances for 'Functor' and 'P.Monad' are both
--   based on @m@ being a monad, although the functor instance should only be
--   dependend on @m@ being a functor (as can be seen below). This can only be
--   fixed by either giving a custom version of 'App.WrappedMonad' here or by fixing
--   the version of 'App.WrappedMonad' in base.
--   Once this issue is fixed we can replace the 'P.Monad' constraint
--   with a 'Functor' constraint.
--
--   > instance (Functor m) => Functor (App.WrappedMonad m) where
--   >   fmap f m = App.WrapMonad $ fmap (App.unwrapMonad m) f
--
instance (Bind m m m, P.Monad m) => Bind (App.WrappedMonad m) (App.WrappedMonad m) (App.WrappedMonad m) where
  type BindCts (App.WrappedMonad m) (App.WrappedMonad m) (App.WrappedMonad m) = BindCts m m m
  m >>= f = App.WrapMonad $ (App.unwrapMonad m) >>= (App.unwrapMonad . f)

instance Bind STM.STM STM.STM STM.STM where
  (>>=) = (P.>>=)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Generics.U1 Generics.U1 Generics.U1 where
  (>>=) = (P.>>=)
instance (Bind m n p) => Bind (Generics.Rec1 m) (Generics.Rec1 n) (Generics.Rec1 p) where
  type BindCts (Generics.Rec1 m) (Generics.Rec1 n) (Generics.Rec1 p) = BindCts m n p
  (Generics.Rec1 mf) >>= f = Generics.Rec1 $ mf >>= (Generics.unRec1 . f)
instance (Bind f g h, Bind f' g' h') => Bind (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') where
  type BindCts (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') = (BindCts f g h, BindCts f' g' h')
  (f Generics.:*: g) >>= m = (f >>= \a -> let (f' Generics.:*: _g') = m a in f') Generics.:*: (g >>= \a -> let (_f' Generics.:*: g') = m a in g')
instance Bind f g h => Bind (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) where
  type BindCts  (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) = BindCts  f g h
  (Generics.M1 ma) >>= f = Generics.M1 $ ma >>= Generics.unM1 . f
#endif

-- "transformers" package instances: -------------------------------------------

-- Continuations are so wierd...
-- | TODO / FIXME: Still need to figure out how and if we can generalize the continuation implementation.
instance {- (Bind m n p) => -} Bind (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) where
  type BindCts (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) = () -- (BindCts m n p)
  m >>= k = Cont.ContT $ \ c -> Cont.runContT m (\ x -> Cont.runContT (k x) c)
  {-# INLINE (>>=) #-}

instance (Bind m n p, Return n) => Bind (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) where
  type BindCts (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) = (BindCts m n p, ReturnCts n)
  m >>= k = Except.ExceptT $
      Except.runExceptT m >>=
      \ a -> case a of
          Left e -> return (Left e)
          Right x -> Except.runExceptT (k x)
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) where
  type BindCts (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) = (BindCts m n p)
  m >>= k = Identity.IdentityT $ Identity.runIdentityT m >>= (Identity.runIdentityT . k)
  {-# INLINE (>>=) #-}

instance (Return n, Bind m n p) => Bind (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) where
  type BindCts (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) = (ReturnCts n, BindCts m n p)
  x >>= f = Maybe.MaybeT $
    Maybe.runMaybeT x >>=
    \v -> case v of
      Nothing -> return Nothing
      Just y  -> Maybe.runMaybeT (f y)
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) where
  type BindCts (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) = (BindCts m n p)
  m >>= k  = RWSL.RWST $
    \ r s -> RWSL.runRWST m r s >>=
    \ ~(a, s', w) -> fmap (\ ~(b, s'',w') -> (b, s'', w `P.mappend` w')) $ RWSL.runRWST (k a) r s'
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) where
  type BindCts (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) = (BindCts m n p)
  m >>= k  = RWSS.RWST $
    \ r s -> RWSS.runRWST m r s >>=
    \ (a, s', w) -> fmap (\(b, s'',w') -> (b, s'', w `P.mappend` w')) $ RWSS.runRWST (k a) r s'
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) where
  type BindCts (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) = (BindCts m n p)
  m >>= k  = Reader.ReaderT $
      \ r -> Reader.runReaderT m r >>=
      \ a -> Reader.runReaderT (k a) r
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) where
  type BindCts (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) = (BindCts m n p)
  m >>= k = StateL.StateT
          $ \ s -> StateL.runStateT m s >>=
            \ ~(a, s') -> StateL.runStateT (k a) s'
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) where
  type BindCts (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) = (BindCts m n p)
  m >>= k = StateS.StateT
          $ \ s -> StateS.runStateT m s >>=
            \ (a, s') -> StateS.runStateT (k a) s'
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) where
  type BindCts (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) = (BindCts m n p)
  m >>= k  = WriterL.WriterT $
      WriterL.runWriterT m >>=
      \ ~(a, w) -> fmap (\ ~(b, w') -> (b, w `P.mappend` w')) $ WriterL.runWriterT (k a)
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) where
  type BindCts (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) = (BindCts m n p)
  m >>= k  = WriterS.WriterT $
      WriterS.runWriterT m >>=
      \ (a, w) -> fmap (\ (b, w') -> (b, w `P.mappend` w')) $ WriterS.runWriterT (k a)
  {-# INLINE (>>=) #-}

-- -----------------------------------------------------------------------------
-- Return Type Class
-- -----------------------------------------------------------------------------

-- | See 'Bind' or 'Ap' for details on laws and requirements.
class (Functor m) => Return m where
  type ReturnCts m :: Constraint
  type ReturnCts m = ()
  return :: (ReturnCts m) => a -> m a

instance Return ((->) r) where
  return = P.return
instance Return Identity where
  return = P.return
instance Return [] where
  return = P.return
instance Return P.Maybe where
  return = P.return
instance Return P.IO where
  return = P.return
instance Return (P.Either e) where
  return = P.return

instance Return Mon.First where
  return = P.return
instance Return Mon.Last where
  return = P.return
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Mon.Sum where
  return = P.return
instance Return Mon.Product where
  return = P.return
instance Return Mon.Dual where
  return = P.return
#endif
instance (Return a) => Return (Mon.Alt a) where
  type ReturnCts (Mon.Alt a) = ReturnCts a
  return a = Mon.Alt $ return a

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Semigroup.Min where
  return = P.return
instance Return Semigroup.Max where
  return = P.return
instance Return Semigroup.Option where
  return = P.return
instance Return Semigroup.First where
  return = P.return
instance Return Semigroup.Last where
  return = P.return
#endif

instance Return Proxy.Proxy where
  return = P.return
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Complex.Complex where
  return = P.return
instance Return NonEmpty.NonEmpty where
  return = P.return
#endif

instance (Return m1, Return m2) => Return (Product.Product m1 m2) where
  type ReturnCts (Product.Product m1 m2) = (ReturnCts m1, ReturnCts m2)
  return a = Product.Pair (return a) (return a)

instance (Return f, Return f') => Return (Compose.Compose f f') where
  type ReturnCts (Compose.Compose f f') = (ReturnCts f, ReturnCts f')
  return = Compose.Compose . return . return

instance Return Read.ReadP where
  return = P.return
instance Return Read.ReadPrec where
  return = P.return

instance Return (ST.ST s) where
  return = P.return
instance Return (STL.ST s) where
  return = P.return
instance (Arrow.ArrowApply a) => Return (Arrow.ArrowMonad a) where
  return = P.return
-- | TODO / FIXME: This has the same issue as the 'Bind' instance for 'App.WrappedMonad'.
instance (Return m, P.Monad m) => Return (App.WrappedMonad m) where
  type ReturnCts (App.WrappedMonad m) = ReturnCts m
  return a = App.WrapMonad $ return a

instance Return STM.STM where
  return = P.return

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Generics.U1 where
  return = P.return
instance (Return m) => Return (Generics.Rec1 m) where
  type ReturnCts (Generics.Rec1 m) = ReturnCts m
  return = Generics.Rec1 . return
instance (Return f, Return g) => Return (f Generics.:*: g) where
  type ReturnCts (f Generics.:*: g) = (ReturnCts f, ReturnCts g)
  return a = return a Generics.:*: return a
instance (Return f, Return g) => Return (f Generics.:.: g) where
  type ReturnCts (f Generics.:.: g) = (ReturnCts f, ReturnCts g)
  return = Generics.Comp1 . return . return
instance Return f => Return (Generics.M1 i c f) where
  type ReturnCts (Generics.M1 i c f) = ReturnCts f
  return = Generics.M1 . return
#endif

-- "transformers" package instances: -------------------------------------------

-- Continuations are so weird...
instance {- (Return m) => -} Return (Cont.ContT r m) where
  type ReturnCts (Cont.ContT r m) = () -- ReturnCts m
  return x = Cont.ContT ($ x)
  {-# INLINE return #-}

instance (Return m) => Return (Except.ExceptT e m) where
  type ReturnCts (Except.ExceptT e m) = ReturnCts m
  return = Except.ExceptT . return . Right
  {-# INLINE return #-}

instance (Return m) => Return (Identity.IdentityT m) where
  type ReturnCts (Identity.IdentityT m) = ReturnCts m
  return = (Identity.IdentityT) . return
  {-# INLINE return #-}

instance (Return m) => Return (Maybe.MaybeT m) where
  type ReturnCts (Maybe.MaybeT m) = ReturnCts m
  return = Maybe.MaybeT . return . Just
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (RWSL.RWST r w s m) where
  type ReturnCts (RWSL.RWST r w s m) = ReturnCts m
  return a = RWSL.RWST $ \ _ s -> return (a, s, P.mempty)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (RWSS.RWST r w s m) where
  type ReturnCts (RWSS.RWST r w s m) = ReturnCts m
  return a = RWSS.RWST $ \ _ s -> return (a, s, P.mempty)
  {-# INLINE return #-}

instance (Return m) => Return (Reader.ReaderT r m) where
  type ReturnCts (Reader.ReaderT r m) = ReturnCts m
  return = Reader.ReaderT . const . return
  {-# INLINE return #-}

instance (Return m) => Return (StateL.StateT s m) where
  type ReturnCts (StateL.StateT s m) = ReturnCts m
  return x = StateL.StateT $ \s -> return (x, s)
  {-# INLINE return #-}

instance (Return m) => Return (StateS.StateT s m) where
  type ReturnCts (StateS.StateT s m) = ReturnCts m
  return x = StateS.StateT $ \s -> return (x, s)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (WriterL.WriterT w m) where
  type ReturnCts (WriterL.WriterT w m) = ReturnCts m
  return a = WriterL.WriterT $ return (a, P.mempty)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (WriterS.WriterT w m) where
  type ReturnCts (WriterS.WriterT w m) = ReturnCts m
  return a = WriterS.WriterT $ return (a, P.mempty)
  {-# INLINE return #-}

-- -----------------------------------------------------------------------------
-- Fail Type Class
-- -----------------------------------------------------------------------------

-- | See 'Bind' for details on laws and requirements.
class Fail m where
  type FailCts m :: Constraint
  type FailCts m = ()
  fail :: (FailCts m) => String -> m a

instance Fail ((->) r) where
  fail = P.fail
instance Fail Identity where
  fail = P.fail
instance Fail [] where
  fail = P.fail
instance Fail P.Maybe where
  fail = P.fail
instance Fail P.IO where
  fail = P.fail
instance Fail (P.Either e) where
  fail = P.fail

instance Fail Mon.First where
  fail = P.fail
instance Fail Mon.Last where
  fail = P.fail
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Mon.Sum where
  fail = P.fail
instance Fail Mon.Product where
  fail = P.fail
instance Fail Mon.Dual where
  fail = P.fail
#endif
instance (Fail a) => Fail (Mon.Alt a) where
  type FailCts (Mon.Alt a) = (FailCts a)
  fail a = Mon.Alt $ fail a

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Semigroup.Min where
  fail = P.fail
instance Fail Semigroup.Max where
  fail = P.fail
instance Fail Semigroup.Option where
  fail = P.fail
instance Fail Semigroup.First where
  fail = P.fail
instance Fail Semigroup.Last where
  fail = P.fail
#endif

instance Fail Proxy.Proxy where
  fail = P.fail
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Complex.Complex where
  fail = P.fail
instance Fail NonEmpty.NonEmpty where
  fail = P.fail
#endif
instance (Fail m1, Fail m2) => Fail (Product.Product m1 m2) where
  type FailCts (Product.Product m1 m2) = (FailCts m1, FailCts m2)
  fail a = Product.Pair (fail a) (fail a)

instance Fail Read.ReadP where
  fail = P.fail
instance Fail Read.ReadPrec where
  fail = P.fail

instance Fail (ST.ST s) where
  fail = P.fail
instance Fail (STL.ST s) where
  fail = P.fail
instance (Arrow.ArrowApply a) => Fail (Arrow.ArrowMonad a) where
  fail = P.fail
-- | TODO / FIXME: This has the same issue as the 'Bind' instance for 'App.WrappedMonad'.
instance (Fail m, P.Monad m) => Fail (App.WrappedMonad m) where
  type FailCts (App.WrappedMonad m) = (FailCts m)
  fail a = App.WrapMonad $ fail a

instance Fail STM.STM where
  fail = P.fail

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Generics.U1 where
  fail = P.fail
instance (Fail m) => Fail (Generics.Rec1 m) where
  type FailCts (Generics.Rec1 m) = FailCts m
  fail = Generics.Rec1 . fail
instance (Fail f, Fail g) => Fail (f Generics.:*: g) where
  type FailCts (f Generics.:*: g) = (FailCts f, FailCts g)
  fail a = fail a Generics.:*: fail a
instance Fail f => Fail (Generics.M1 i c f) where
  type FailCts (Generics.M1 i c f) = FailCts f
  fail = Generics.M1 . fail
#endif

-- "transformers" package instances: -------------------------------------------

instance (Fail m) => Fail (Cont.ContT r m) where
  type FailCts (Cont.ContT r m) = (FailCts m)
  fail = (Cont.ContT) . const . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (Except.ExceptT e m) where
  type FailCts (Except.ExceptT e m) = (FailCts m)
  fail = Except.ExceptT . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (Identity.IdentityT m) where
  type FailCts (Identity.IdentityT m) = (FailCts m)
  fail msg = Identity.IdentityT $ fail msg
  {-# INLINE fail #-}

instance (Return m) => Fail (Maybe.MaybeT m) where
  type FailCts (Maybe.MaybeT m) = (ReturnCts m)
  fail _ = Maybe.MaybeT (return Nothing)
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (RWSL.RWST r w s m) where
  type FailCts (RWSL.RWST r w s m) = (FailCts m)
  fail msg = RWSL.RWST $ \ _ _ -> fail msg
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (RWSS.RWST r w s m) where
  type FailCts (RWSS.RWST r w s m) = (FailCts m)
  fail msg = RWSS.RWST $ \ _ _ -> fail msg
  {-# INLINE fail #-}

instance (Fail m) => Fail (Reader.ReaderT r m) where
  type FailCts (Reader.ReaderT r m) = (FailCts m)
  fail = Reader.ReaderT . const . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (StateL.StateT s m) where
  type FailCts (StateL.StateT s m) = (FailCts m)
  fail = StateL.StateT . const . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (StateS.StateT s m) where
  type FailCts (StateS.StateT s m) = (FailCts m)
  fail = StateS.StateT . const . fail
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (WriterL.WriterT w m) where
  type FailCts (WriterL.WriterT w m) = (FailCts m)
  fail msg = WriterL.WriterT $ fail msg
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (WriterS.WriterT w m) where
  type FailCts (WriterS.WriterT w m) = (FailCts m)
  fail msg = WriterS.WriterT $ fail msg
  {-# INLINE fail #-}

-- -----------------------------------------------------------------------------
-- Convenient type synonyms
-- -----------------------------------------------------------------------------

-- | A short-hand for writing polymorphic standard monad functions.
type family Monad m :: Constraint where
  Monad m = (Bind m m m, Return m, Fail m)