blob: 473b3df5cfdf89cf694095092d95ddb7765eac73 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuantifiedConstraints #-}
module Control.FAlternative where
import Data.List.NonEmpty (NonEmpty(..))
data Fallible = Fallible | Infallible
deriving (Show)
data SFallible fail where
SFallible :: SFallible 'Fallible
SInfallible :: SFallible 'Infallible
class KnownFallible fail where knownFallible :: SFallible fail
instance KnownFallible 'Fallible where knownFallible = SFallible
instance KnownFallible 'Infallible where knownFallible = SInfallible
infixr 3 <|>>
class (forall fail. Applicative (f fail)) => FAlternative f where
faempty :: f 'Fallible a
(<|>>) :: f 'Fallible a -> f fail a -> f fail a
noFail :: f 'Infallible a -> f fail a
toFallible :: KnownFallible fail => f fail a -> f 'Fallible a
faasum :: FAlternative f => [f 'Fallible a] -> f fail a -> f fail a
faasum l p = foldr (<|>>) p l
faasum' :: FAlternative f => [f 'Fallible a] -> f 'Fallible a
faasum' l = faasum l faempty
famany :: FAlternative f => f 'Fallible a -> f 'Infallible [a]
famany p = ((:) <$> p <*> noFail (famany p)) <|>> pure []
fasome :: FAlternative f => f 'Fallible a -> f 'Fallible (NonEmpty a)
fasome p = (:|) <$> p <*> noFail (famany p)
faguard :: FAlternative f => Bool -> f 'Fallible ()
faguard True = pure ()
faguard False = faempty
faguardM :: (FAlternative f, Monad (f 'Fallible), KnownFallible fail)
=> f fail Bool -> f 'Fallible ()
faguardM p = toFallible p >>= faguard
faoptional :: FAlternative f => f 'Fallible a -> f 'Infallible (Maybe a)
faoptional p = (Just <$> p) <|>> pure Nothing
facatch :: FAlternative f => f fail a -> f 'Fallible a -> f fail a
facatch = flip (<|>>)
|
