aboutsummaryrefslogtreecommitdiff
path: root/src/Control
diff options
context:
space:
mode:
authorTom Smeding <tom@tomsmeding.com>2024-02-18 21:55:46 +0100
committerTom Smeding <tom@tomsmeding.com>2024-02-18 21:55:46 +0100
commitd744fa7ae5e638c1ca16f400a49633a705208ce4 (patch)
treef5fe6a6aa6ed8f7ff00a6c4024dc7aa6777a892c /src/Control
parent78ffb5ed5fbda230675310b37f798c500a13ef11 (diff)
WIP big parser refactor with better typing
Diffstat (limited to 'src/Control')
-rw-r--r--src/Control/FAlternative.hs53
1 files changed, 53 insertions, 0 deletions
diff --git a/src/Control/FAlternative.hs b/src/Control/FAlternative.hs
new file mode 100644
index 0000000..473b3df
--- /dev/null
+++ b/src/Control/FAlternative.hs
@@ -0,0 +1,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 (<|>>)