{-# LANGUAGE CPP             #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RankNTypes      #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns    #-}

module Data.Singletons.Dict
       (
         mkTotalDictGetter
       , mkPartialDictGetter
       ) where

import Data.Bifunctor (bimap, first, second)
import Data.Bool (bool)
import Data.Char (toLower)
import Data.Constraint (Dict (..))
import Data.Foldable (traverse_)
import Data.Typeable (Typeable)
import Language.Haskell.TH


-- | Generates 'Dict' getters for the promoted nullary data constructors corresponding to
-- a @singletons@-like type.
--
-- __All the promoted data constructors must be instances of the given type class.__
--
-- The names of the getters result from the concatenation of:
--
-- * the camel-cased name of the base type,
-- * the name of the type class,
-- * the "'Dict'" keyword,
-- * the \"A\" suffix, for the contextual getter.
--
-- /Example:/
--
-- Given this type:
--
-- @
-- data Example = Foo | Bar | Baz
-- @
--
-- and the corresponding @singletons@-like type:
--
-- @
-- data SExample (example :: Example) where
--     SFoo :: SExample 'Foo
--     SBar :: SExample 'Bar
--     SBaz :: SExample 'Baz
-- @
--
-- this line:
--
-- @
-- \$(mkTotalDictGetter ''SExample '''Typeable')
-- @
--
-- generates those getters:
--
-- @
-- exampleTypeableDict :: SExample example -> 'Dict' ('Typeable' example)
-- exampleTypeableDict sing =
--     case sing of
--         SFoo -> 'Dict'
--         SBar -> 'Dict'
--         SBaz -> 'Dict'
--
-- exampleTypeableDictA :: 'Applicative' f => SExample example -> f ('Dict' ('Typeable' example))
-- exampleTypeableDictA sing =
--     case sing of
--         SFoo -> 'pure' 'Dict'
--         SBar -> 'pure' 'Dict'
--         SBaz -> 'pure' 'Dict'
-- @
mkTotalDictGetter
    :: Name
    -- ^ The 'Name' of a @singletons@-like type.
    -> Name
    -- ^ The 'Name' of a type class.
    -> Q [Dec]
mkTotalDictGetter :: Name -> Name -> Q [Dec]
mkTotalDictGetter Name
singTypeName Name
className = Name -> Q Info
reify Name
singTypeName Q Info -> (Info -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
#if MIN_VERSION_template_haskell(2,17,0)
    TyConI (DataD [] _ [ KindedTV _ _ (ConT baseTypeName) ] Nothing cons []) -> do
#else
    TyConI (DataD [] Name
_ [ KindedTV Name
_   (ConT Name
baseTypeName) ] Maybe Pred
Nothing [Con]
cons []) -> do
#endif
        Name -> Q ()
checkSingleParamClassName Name
className
        ([Name]
conSingNames, [Pred]
conTypes) <- [(Name, Pred)] -> ([Name], [Pred])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Name, Pred)] -> ([Name], [Pred]))
-> Q [(Name, Pred)] -> Q ([Name], [Pred])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q (Name, Pred)) -> [Con] -> Q [(Name, Pred)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Con -> Q (Name, Pred)
singConData [Con]
cons
        (Pred -> Q ()) -> [Pred] -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Pred -> Q ()
checkConTypeInstance [Pred]
conTypes

        let singType :: TypeQ
singType      = Name -> TypeQ
conT Name
singTypeName
        let classType :: TypeQ
classType     = Name -> TypeQ
conT Name
className
        let baseFunName :: Name
baseFunName   = Name -> Name -> String -> Name
mkGetterName Name
baseTypeName Name
className String
"Dict"
        let liftedFunName :: Name
liftedFunName = Name -> Name -> String -> Name
mkGetterName Name
baseTypeName Name
className String
"DictA"

        [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            [ Name -> TypeQ -> Q Dec
sigD
                Name
baseFunName
                [t| forall a. $singType a -> Dict ($classType a) |]
            , Name -> [(Name, BodyQ)] -> Q Dec
mkGetterBody
                Name
baseFunName
                ([Name] -> [BodyQ] -> [(Name, BodyQ)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
conSingNames ([BodyQ] -> [(Name, BodyQ)]) -> [BodyQ] -> [(Name, BodyQ)]
forall a b. (a -> b) -> a -> b
$ BodyQ -> [BodyQ]
forall a. a -> [a]
repeat (ExpQ -> BodyQ
normalB [e| Dict |]))
            , Name -> TypeQ -> Q Dec
sigD
                Name
liftedFunName
                 [t| forall a f. Applicative f => $singType a -> f (Dict ($classType a)) |]
            , Name -> [(Name, BodyQ)] -> Q Dec
mkGetterBody
                Name
liftedFunName
                ([Name] -> [BodyQ] -> [(Name, BodyQ)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
conSingNames ([BodyQ] -> [(Name, BodyQ)]) -> [BodyQ] -> [(Name, BodyQ)]
forall a b. (a -> b) -> a -> b
$ BodyQ -> [BodyQ]
forall a. a -> [a]
repeat (ExpQ -> BodyQ
normalB [e| pure Dict |]))
            ]

    Info
invalid -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Info -> String
invalidTypeError Name
singTypeName Info
invalid
  where
    checkConTypeInstance :: Type -> Q ()
    checkConTypeInstance :: Pred -> Q ()
checkConTypeInstance Pred
conType
        = Q Bool -> Q () -> Q ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Name -> Pred -> Q Bool
isInstance' Name
className Pred
conType)
        (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
        (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
typeName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not an instance of `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
className String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'."
      where
        typeName :: String
typeName = case Pred
conType of
            ConT Name
name      -> Name -> String
quotedName Name
name
            PromotedT Name
name -> Name -> String
quotedName Name
name
            Pred
_              -> Pred -> String
forall a. Show a => a -> String
show Pred
conType

-- | Generates 'Dict' getters for the promoted nullary data constructors corresponding to
-- a @singletons@-like type.
--
-- __Not all the promoted data constructors must be instances of the given type class.__
--
-- The name of the getters results from the concatenation of:
--
-- * the camel-cased name of the base type,
-- * the name of the type class,
-- * the "'Dict'" keyword,
-- * the \"A\" suffix, for the contextual getter.
--
-- /Example:/
--
-- Given this type:
--
-- @
-- data Example = Foo | Bar | Baz
-- @
--
-- the corresponding @singletons@-like type:
--
-- @
-- data SExample (example :: Example) where
--     SFoo :: SExample 'Foo
--     SBar :: SExample 'Bar
--     SBaz :: SExample 'Baz
-- @
--
-- and this type class and instance:
--
-- @
-- class IsBar (a :: k) where
--
-- instance IsBar 'Bar where
-- @
--
-- this line:
--
-- @
-- \$(mkPartialDictGetter ''SExample ''IsBar)
-- @
--
-- generates those getters:
--
-- @
-- exampleIsBarDict :: SExample example -> 'Maybe' ('Dict' (IsBar example))
-- exampleIsBarDict sing =
--     case sing of
--         SFoo -> 'Nothing'
--         SBar -> 'Just' 'Dict'
--         SBaz -> 'Nothing'
--
-- exampleIsBarDictA :: 'Applicative' f => SExample example -> f ('Maybe' ('Dict' (IsBar example)))
-- exampleIsBarDictA sing =
--     case sing of
--         SFoo -> 'pure' 'Nothing'
--         SBar -> 'pure' ('Just' 'Dict')
--         SBaz -> 'pure' 'Nothing'
-- @
mkPartialDictGetter
    :: Name
    -- ^ The 'Name' of a @singletons@-like type.
    -> Name
    -- ^ The 'Name' of a type class.
    -> Q [Dec]
mkPartialDictGetter :: Name -> Name -> Q [Dec]
mkPartialDictGetter Name
singTypeName Name
className = Name -> Q Info
reify Name
singTypeName Q Info -> (Info -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
#if MIN_VERSION_template_haskell(2,17,0)
    TyConI (DataD [] _ [ KindedTV _ _ (ConT baseTypeName) ] Nothing cons []) -> do
#else
    TyConI (DataD [] Name
_ [ KindedTV Name
_   (ConT Name
baseTypeName) ] Maybe Pred
Nothing [Con]
cons []) -> do
#endif
        Name -> Q ()
checkSingleParamClassName Name
className
        ([(Name, Pred)], [(Name, Pred)])
cons' <- (Con -> Q (Name, Pred)) -> [Con] -> Q [(Name, Pred)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Con -> Q (Name, Pred)
singConData [Con]
cons Q [(Name, Pred)]
-> ([(Name, Pred)] -> Q ([(Name, Pred)], [(Name, Pred)]))
-> Q ([(Name, Pred)], [(Name, Pred)])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Name, Pred) -> Q Bool)
-> [(Name, Pred)] -> Q ([(Name, Pred)], [(Name, Pred)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM (Name -> Pred -> Q Bool
isInstance' Name
className (Pred -> Q Bool)
-> ((Name, Pred) -> Pred) -> (Name, Pred) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Pred) -> Pred
forall a b. (a, b) -> b
snd)

        let singType :: TypeQ
singType      = Name -> TypeQ
conT Name
singTypeName
        let classType :: TypeQ
classType     = Name -> TypeQ
conT Name
className
        let baseFunName :: Name
baseFunName   = Name -> Name -> String -> Name
mkGetterName Name
baseTypeName Name
className String
"Dict"
        let liftedFunName :: Name
liftedFunName = Name -> Name -> String -> Name
mkGetterName Name
baseTypeName Name
className String
"DictA"
        let ([Name]
dictSingNames, [Name]
voidSingNames) = ([(Name, Pred)] -> [Name])
-> ([(Name, Pred)] -> [Name])
-> ([(Name, Pred)], [(Name, Pred)])
-> ([Name], [Name])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (((Name, Pred) -> Name) -> [(Name, Pred)] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, Pred) -> Name
forall a b. (a, b) -> a
fst) (((Name, Pred) -> Name) -> [(Name, Pred)] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, Pred) -> Name
forall a b. (a, b) -> a
fst) ([(Name, Pred)], [(Name, Pred)])
cons'

        [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            [ Name -> TypeQ -> Q Dec
sigD
                Name
baseFunName
                [t| forall a. $singType a -> Maybe (Dict ($classType a)) |]
            , Name -> [(Name, BodyQ)] -> Q Dec
mkGetterBody
                Name
baseFunName
                ( [Name] -> [BodyQ] -> [(Name, BodyQ)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
voidSingNames (BodyQ -> [BodyQ]
forall a. a -> [a]
repeat (ExpQ -> BodyQ
normalB [e| Nothing |])) [(Name, BodyQ)] -> [(Name, BodyQ)] -> [(Name, BodyQ)]
forall a. Semigroup a => a -> a -> a
<>
                  [Name] -> [BodyQ] -> [(Name, BodyQ)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
dictSingNames (BodyQ -> [BodyQ]
forall a. a -> [a]
repeat (ExpQ -> BodyQ
normalB [e| Just Dict |]))
                )
            , Name -> TypeQ -> Q Dec
sigD
                Name
liftedFunName
                [t| forall a f. Applicative f => $singType a -> f (Maybe (Dict ($classType a))) |]
            , Name -> [(Name, BodyQ)] -> Q Dec
mkGetterBody
                Name
liftedFunName
                ( [Name] -> [BodyQ] -> [(Name, BodyQ)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
voidSingNames (BodyQ -> [BodyQ]
forall a. a -> [a]
repeat (ExpQ -> BodyQ
normalB [e| pure Nothing |])) [(Name, BodyQ)] -> [(Name, BodyQ)] -> [(Name, BodyQ)]
forall a. Semigroup a => a -> a -> a
<>
                  [Name] -> [BodyQ] -> [(Name, BodyQ)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
dictSingNames (BodyQ -> [BodyQ]
forall a. a -> [a]
repeat (ExpQ -> BodyQ
normalB [e| pure (Just Dict) |]))
                )
            ]

    Info
invalid -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Info -> String
invalidTypeError Name
singTypeName Info
invalid


mkGetterName :: Name -> Name -> String -> Name
mkGetterName :: Name -> Name -> String -> Name
mkGetterName (Name -> String
nameBase -> String
baseTypeName) (Name -> String
nameBase -> String
className) String
suffix
     = String -> Name
mkName
     (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower (String -> Char
forall a. [a] -> a
head String
baseTypeName)
     Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
forall a. [a] -> [a]
tail String
baseTypeName
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
className
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffix

mkGetterBody :: Name -> [(Name, BodyQ)] -> DecQ
mkGetterBody :: Name -> [(Name, BodyQ)] -> Q Dec
mkGetterBody Name
name [(Name, BodyQ)]
matches
    = Name -> [ClauseQ] -> Q Dec
funD Name
name
    [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
        [ Name -> PatQ
varP Name
paramName ]
        (ExpQ -> BodyQ
normalB (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
paramName) ((Name, BodyQ) -> MatchQ
mkCaseMatch ((Name, BodyQ) -> MatchQ) -> [(Name, BodyQ)] -> [MatchQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, BodyQ)]
matches)))
        []
    ]
  where
    paramName :: Name
    paramName :: Name
paramName = String -> Name
mkName String
"sing"

    mkCaseMatch :: (Name, BodyQ) -> MatchQ
    mkCaseMatch :: (Name, BodyQ) -> MatchQ
mkCaseMatch (Name
singName, BodyQ
body) = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
singName []) BodyQ
body []


singConData :: Con -> Q (Name, Type)
singConData :: Con -> Q (Name, Pred)
singConData Con
con = case Con
con of
    GadtC [ Name
singName ] [] (AppT Pred
_ Pred
baseType) -> (Name, Pred) -> Q (Name, Pred)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
singName, Pred
baseType)
    Con
_ -> String -> Q (Name, Pred)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, Pred)) -> String -> Q (Name, Pred)
forall a b. (a -> b) -> a -> b
$ String -> String -> String
expectationError String
"nullary GADT data constructor" (Con -> String
conLabel Con
con)

checkSingleParamClassName :: Name -> Q ()
checkSingleParamClassName :: Name -> Q ()
checkSingleParamClassName Name
name = Name -> Q Info
reify Name
name Q Info -> (Info -> Q ()) -> Q ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ClassI (ClassD [Pred]
_ Name
_ [ TyVarBndr
_ ] [FunDep]
_ [Dec]
_) [Dec]
_ -> () -> Q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Info
invalid -> String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ Name -> Info -> String
invalidClassError Name
name Info
invalid

isInstance' :: Name ->  Type -> Q Bool
isInstance' :: Name -> Pred -> Q Bool
isInstance' Name
className
    | Name
className Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Typeable
    = Q Bool -> Pred -> Q Bool
forall a b. a -> b -> a
const (Q Bool -> Pred -> Q Bool) -> Q Bool -> Pred -> Q Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    | Bool
otherwise
    = Name -> [Pred] -> Q Bool
isInstance Name
className ([Pred] -> Q Bool) -> (Pred -> [Pred]) -> Pred -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> [Pred]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

infoValueLabel :: Info -> String
infoValueLabel :: Info -> String
infoValueLabel = \case
    ClassI Dec
_ [Dec]
_       -> String
"type class"
    ClassOpI Name
_ Pred
_ Name
_   -> String
"type class method"
    DataConI Name
_ Pred
_ Name
_   -> String
"data constructor"
    FamilyI Dec
_ [Dec]
_      -> String
"type or data family"
    PatSynI Name
_ Pred
_      -> String
"pattern synonym"
    PrimTyConI Name
_ Arity
_ Bool
_ -> String
"primitive type constructor"
    TyConI Dec
_         -> String
"type constructor"
    TyVarI Name
_ Pred
_       -> String
"type variable"
    VarI Name
_ Pred
_ Maybe Dec
_       -> String
"value variable"

conLabel :: Con -> String
conLabel :: Con -> String
conLabel Con
con = String
shapeLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
conName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
  where
    conName, shapeLabel :: String
    (Name -> String
quotedName -> String
conName, String
shapeLabel) = Con -> (Name, String)
conData Con
con

    conData :: Con -> (Name, String)
    conData :: Con -> (Name, String)
conData = \case
        ForallC [TyVarBndr]
_ [Pred]
_ Con
con'       -> Con -> (Name, String)
conData Con
con'
        GadtC (Name
name : [Name]
_) [] Pred
_  -> (Name
name, String
"nullary GADT data constructor")
        GadtC (Name
name : [Name]
_) [BangType]
_ Pred
_   -> (Name
name, String
"non-nullary GADT data constructor")
        InfixC BangType
_ Name
name BangType
_        -> (Name
name, String
"infix data constructor")
        NormalC Name
name [BangType]
_         -> (Name
name, String
"normal data constructor")
        RecC Name
name [VarBangType]
_            -> (Name
name, String
"recursive normal data constructor")
        RecGadtC (Name
name :[Name]
_) [VarBangType]
_ Pred
_ -> (Name
name, String
"recursive GADT data constructor")

quotedName :: Name -> String
quotedName :: Name -> String
quotedName Name
name = String
"`" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"


invalidTypeError :: Name -> Info -> String
invalidTypeError :: Name -> Info -> String
invalidTypeError Name
name Info
invalid
    = String -> String -> String
expectationError
        String
"singletons-like type constructor"
        (String
invalidLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
quotedName Name
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")")
  where
    invalidLabel :: String
    invalidLabel :: String
invalidLabel = case Info
invalid of
        TyConI Dec
_ -> String
"non singletons-like type constructor"
        Info
_        -> Info -> String
infoValueLabel Info
invalid

invalidClassError :: Name -> Info -> String
invalidClassError :: Name -> Info -> String
invalidClassError Name
name Info
invalid
    = String -> String -> String
expectationError
        String
"single-parameter type class"
        (String
invalidLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
quotedName Name
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")")
  where
    invalidLabel :: String
    invalidLabel :: String
invalidLabel = case Info
invalid of
        ClassI Dec
_ [Dec]
_ -> String
"multi-parameter type class"
        Info
_          -> Info -> String
infoValueLabel Info
invalid

expectationError :: String -> String -> String
expectationError :: String -> String -> String
expectationError String
expected String
got = [String] -> String
unlines
    [ String
""
    , String
"Expected:"
    , String
""
    , String
"    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
expected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
","
    , String
""
    , String
"Got:"
    , String
""
    , String
"    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
got String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
    , String
""
    ]


unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: m Bool -> m () -> m ()
unlessM m Bool
test m ()
action = m Bool
test m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> m () -> Bool -> m ()
forall a. a -> a -> Bool -> a
bool m ()
action (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: (a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f = \case
    []       -> ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
    (a
x : [a]
xs) -> do
        Bool
result <- a -> m Bool
f a
x
        (([a] -> [a]) -> ([a], [a]) -> ([a], [a]))
-> (([a] -> [a]) -> ([a], [a]) -> ([a], [a]))
-> Bool
-> ([a] -> [a])
-> ([a], [a])
-> ([a], [a])
forall a. a -> a -> Bool -> a
bool ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Bool
result (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], [a]) -> ([a], [a])) -> m ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m Bool) -> [a] -> m ([a], [a])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [a]
xs