{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Control.Applicative.ListF (
ListF(..), mapListF
, NonEmptyF(.., ProdNonEmpty, nonEmptyProd), mapNonEmptyF
, toListF, fromListF
, MaybeF(..), mapMaybeF
, listToMaybeF, maybeToListF
, MapF(..)
, NEMapF(..)
) where
import Control.Applicative
import Control.Natural
import Data.Coerce
import Data.Data
import Data.Deriving
import Data.Foldable
import Data.Functor.Bind
import Data.Functor.Classes
import Data.Functor.Plus
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import Data.Pointed
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import GHC.Generics
import qualified Data.Map as M
import qualified Data.Map.NonEmpty as NEM
newtype ListF f a = ListF { runListF :: [f a] }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''ListF
deriveRead1 ''ListF
deriveEq1 ''ListF
deriveOrd1 ''ListF
instance Apply f => Apply (ListF f) where
ListF fs <.> ListF xs = ListF $ liftF2 (<.>) fs xs
instance Applicative f => Applicative (ListF f) where
pure = ListF . (:[]) . pure
ListF fs <*> ListF xs = ListF $ liftA2 (<*>) fs xs
instance Functor f => Alt (ListF f) where
(<!>) = (<>)
instance Functor f => Plus (ListF f) where
zero = mempty
instance Applicative f => Alternative (ListF f) where
empty = zero
(<|>) = (<!>)
instance Semigroup (ListF f a) where
ListF xs <> ListF ys = ListF (xs ++ ys)
instance Monoid (ListF f a) where
mempty = ListF []
instance Pointed f => Pointed (ListF f) where
point = ListF . (: []) . point
mapListF
:: ([f a] -> [g b])
-> ListF f a
-> ListF g b
mapListF = coerce
newtype NonEmptyF f a = NonEmptyF { runNonEmptyF :: NonEmpty (f a) }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''NonEmptyF
deriveRead1 ''NonEmptyF
deriveEq1 ''NonEmptyF
deriveOrd1 ''NonEmptyF
instance Applicative f => Applicative (NonEmptyF f) where
pure = NonEmptyF . (:| []) . pure
NonEmptyF fs <*> NonEmptyF xs = NonEmptyF $ liftA2 (<*>) fs xs
instance Functor f => Alt (NonEmptyF f) where
(<!>) = (<>)
instance Semigroup (NonEmptyF f a) where
NonEmptyF xs <> NonEmptyF ys = NonEmptyF (xs <> ys)
instance Pointed f => Pointed (NonEmptyF f) where
point = NonEmptyF . (:| []) . point
mapNonEmptyF
:: (NonEmpty (f a) -> NonEmpty (g b))
-> NonEmptyF f a
-> NonEmptyF g b
mapNonEmptyF = coerce
toListF :: NonEmptyF f ~> ListF f
toListF (NonEmptyF xs) = ListF (toList xs)
fromListF :: ListF f ~> (Proxy :+: NonEmptyF f)
fromListF (ListF xs) = case xs of
[] -> L1 Proxy
y:ys -> R1 $ NonEmptyF (y :| ys)
pattern ProdNonEmpty :: (f :*: ListF f) a -> NonEmptyF f a
pattern ProdNonEmpty { nonEmptyProd
}
<- ((\case NonEmptyF (x :| xs) -> x :*: ListF xs) -> nonEmptyProd)
where
ProdNonEmpty (x :*: ListF xs) = NonEmptyF (x :| xs)
{-# COMPLETE ProdNonEmpty #-}
newtype MaybeF f a = MaybeF { runMaybeF :: Maybe (f a) }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''MaybeF
deriveRead1 ''MaybeF
deriveEq1 ''MaybeF
deriveOrd1 ''MaybeF
instance Applicative f => Applicative (MaybeF f) where
pure = MaybeF . Just . pure
MaybeF f <*> MaybeF x = MaybeF $ liftA2 (<*>) f x
instance Functor f => Alt (MaybeF f) where
(<!>) = (<>)
instance Functor f => Plus (MaybeF f) where
zero = mempty
instance Applicative f => Alternative (MaybeF f) where
empty = zero
(<|>) = (<!>)
instance Semigroup (MaybeF f a) where
MaybeF xs <> MaybeF ys = MaybeF (xs <!> ys)
instance Monoid (MaybeF f a) where
mempty = MaybeF Nothing
instance Pointed f => Pointed (MaybeF f) where
point = MaybeF . Just . point
mapMaybeF
:: (Maybe (f a) -> Maybe (g b))
-> MaybeF f a
-> MaybeF g b
mapMaybeF = coerce
maybeToListF :: MaybeF f ~> ListF f
maybeToListF (MaybeF x) = ListF (maybeToList x)
listToMaybeF :: ListF f ~> MaybeF f
listToMaybeF (ListF xs) = MaybeF (listToMaybe xs)
newtype MapF k f a = MapF { runMapF :: M.Map k (f a) }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''MapF
deriveEq1 ''MapF
deriveOrd1 ''MapF
instance (Ord k, Read k, Read1 f) => Read1 (MapF k f) where
liftReadsPrec = $(makeLiftReadsPrec ''MapF)
instance (Ord k, Alt f) => Semigroup (MapF k f a) where
MapF xs <> MapF ys = MapF $ M.unionWith (<!>) xs ys
instance (Ord k, Alt f) => Monoid (MapF k f a) where
mempty = MapF M.empty
instance (Functor f, Ord k) => Alt (MapF k f) where
MapF xs <!> MapF ys = MapF $ M.union xs ys
instance (Functor f, Ord k) => Plus (MapF k f) where
zero = MapF M.empty
instance (Monoid k, Pointed f) => Pointed (MapF k f) where
point = MapF . M.singleton mempty . point
newtype NEMapF k f a = NEMapF { runNEMapF :: NEM.NEMap k (f a) }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''NEMapF
deriveEq1 ''NEMapF
deriveOrd1 ''NEMapF
instance (Ord k, Read k, Read1 f) => Read1 (NEMapF k f) where
liftReadsPrec = $(makeLiftReadsPrec ''NEMapF)
instance Foldable1 f => Foldable1 (NEMapF k f) where
fold1 = foldMap1 fold1 . runNEMapF
foldMap1 f = (foldMap1 . foldMap1) f . runNEMapF
toNonEmpty = foldMap1 toNonEmpty . runNEMapF
instance Traversable1 f => Traversable1 (NEMapF k f) where
traverse1 f = fmap NEMapF . (traverse1 . traverse1) f . runNEMapF
sequence1 = fmap NEMapF . traverse1 sequence1 . runNEMapF
instance (Ord k, Alt f) => Semigroup (NEMapF k f a) where
NEMapF xs <> NEMapF ys = NEMapF $ NEM.unionWith (<!>) xs ys
instance (Functor f, Ord k) => Alt (NEMapF k f) where
NEMapF xs <!> NEMapF ys = NEMapF $ NEM.union xs ys
instance (Monoid k, Pointed f) => Pointed (NEMapF k f) where
point = NEMapF . NEM.singleton mempty . point