diff options
author | Tom Smeding <tom@tomsmeding.com> | 2024-02-18 21:55:46 +0100 |
---|---|---|
committer | Tom Smeding <tom@tomsmeding.com> | 2024-02-18 21:55:46 +0100 |
commit | d744fa7ae5e638c1ca16f400a49633a705208ce4 (patch) | |
tree | f5fe6a6aa6ed8f7ff00a6c4024dc7aa6777a892c /src/Control | |
parent | 78ffb5ed5fbda230675310b37f798c500a13ef11 (diff) |
WIP big parser refactor with better typing
Diffstat (limited to 'src/Control')
-rw-r--r-- | src/Control/FAlternative.hs | 53 |
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 (<|>>) |