WIP big parser refactor with better typing

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 (<|>>)