module Control.Applicative (
Applicative(..),
Alternative(..),
Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
(<$>), (<$), (<**>),
liftA, liftA2, liftA3,
optional,
) where
import Control.Category hiding ((.), id)
import Control.Arrow
import Data.Maybe
import Data.Tuple
import Data.Eq
import Data.Ord
import Data.Foldable (Foldable(..))
import Data.Functor ((<$>))
import GHC.Base
import GHC.Generics
import GHC.List (repeat, zipWith)
import GHC.Read (Read(readsPrec), readParen, lex)
import GHC.Show (Show(showsPrec), showParen, showString)
newtype Const a b = Const { getConst :: a }
deriving (Generic, Generic1, Monoid, Eq, Ord)
instance Read a => Read (Const a b) where
readsPrec d = readParen (d > 10)
$ \r -> [(Const x,t) | ("Const", s) <- lex r, (x, t) <- readsPrec 11 s]
instance Show a => Show (Const a b) where
showsPrec d (Const x) = showParen (d > 10) $
showString "Const " . showsPrec 11 x
instance Foldable (Const m) where
foldMap _ _ = mempty
instance Functor (Const m) where
fmap _ (Const v) = Const v
instance Monoid m => Applicative (Const m) where
pure _ = Const mempty
(<*>) = coerce (mappend :: m -> m -> m)
newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
deriving (Generic, Generic1, Monad)
instance Monad m => Functor (WrappedMonad m) where
fmap f (WrapMonad v) = WrapMonad (liftM f v)
instance Monad m => Applicative (WrappedMonad m) where
pure = WrapMonad . return
WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
instance MonadPlus m => Alternative (WrappedMonad m) where
empty = WrapMonad mzero
WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)
newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }
deriving (Generic, Generic1)
instance Arrow a => Functor (WrappedArrow a b) where
fmap f (WrapArrow a) = WrapArrow (a >>> arr f)
instance Arrow a => Applicative (WrappedArrow a b) where
pure x = WrapArrow (arr (const x))
WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id))
instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
empty = WrapArrow zeroArrow
WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)
newtype ZipList a = ZipList { getZipList :: [a] }
deriving (Show, Eq, Ord, Read, Functor, Generic, Generic1)
instance Applicative ZipList where
pure x = ZipList (repeat x)
ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
optional :: Alternative f => f a -> f (Maybe a)
optional v = Just <$> v <|> pure Nothing