diff --git a/src/Symparsec/Parser/Satisfy.hs b/src/Symparsec/Parser/Satisfy.hs new file mode 100644 index 0000000..12269c2 --- /dev/null +++ b/src/Symparsec/Parser/Satisfy.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Symparsec.Parser.Satisfy ( type Satisfy, type OneOf ) where + +import Symparsec.Parser.Common + +-- may also be defined using @Token@ +type Satisfy :: (Char ~> Bool) -> PParser Char +data Satisfy chPred ps +type instance App (Satisfy chPred) ps = SatisfyStart chPred ps (UnconsState ps) + +type family SatisfyStart chPred psPrev mps where + SatisfyStart chPred psPrev '(Just ch, ps) = SatisfyValidate psPrev ps ch (chPred @@ ch) + SatisfyStart chPred psPrev '(Nothing, ps) = + 'Reply (Err (Error1 "expected at least 1 char")) ps + +type family SatisfyValidate psPrev ps ch res where + SatisfyValidate psPrev ps ch True = 'Reply (OK ch) ps + SatisfyValidate psPrev ps ch False = + 'Reply (Err (Error1 "satisfy: char failed predicate")) psPrev + +type OneOf :: [Char] -> PParser Char +type OneOf chs = Satisfy (ElemSym chs) + +-- TODO put in singleraeh +type Elem :: a -> [a] -> Bool +type family Elem a as where + Elem _ '[] = False + Elem a (a:_) = True + Elem a (_:as) = Elem a as + +-- NOTE: flipped from "normal" Elem +type ElemSym :: [a] -> a ~> Bool +data ElemSym as a +type instance App (ElemSym as) a = Elem a as diff --git a/src/Symparsec/Parser/Token.hs b/src/Symparsec/Parser/Token.hs new file mode 100644 index 0000000..4b3f6d6 --- /dev/null +++ b/src/Symparsec/Parser/Token.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Symparsec.Parser.Token ( type Token ) where + +import Symparsec.Parser.Common + +-- | Should match @token@ from megaparsec. Backtracks. +type Token :: (Char ~> Maybe a) -> PParser a +data Token chParse ps +type instance App (Token chParse) ps = TokenStart chParse ps (UnconsState ps) +type family TokenStart chParse psPrev mps where + TokenStart chParse psPrev '(Just ch, ps) = TokenParse psPrev ps (chParse @@ ch) + TokenStart chParse psPrev '(Nothing, ps) = + 'Reply (Err (Error1 "expected at least 1 char")) ps +type family TokenParse psPrev ps res where + TokenParse psPrev ps (Just a) = 'Reply (OK a) ps + TokenParse psPrev ps Nothing = + 'Reply (Err (Error1 "token: char failed parse (TODO print char here)")) psPrev diff --git a/src/Symparsec/Parsers.hs b/src/Symparsec/Parsers.hs index 7d047a5..afa9997 100644 --- a/src/Symparsec/Parsers.hs +++ b/src/Symparsec/Parsers.hs @@ -28,6 +28,9 @@ module Symparsec.Parsers , type While , type TakeWhile , type Count + , type Token + , type Satisfy + , type OneOf -- * Common non-combinator -- $noncomb-common @@ -58,10 +61,12 @@ import Symparsec.Parser.Isolate import Symparsec.Parser.Literal import Symparsec.Parser.Monad import Symparsec.Parser.Natural +import Symparsec.Parser.Satisfy import Symparsec.Parser.Skip import Symparsec.Parser.Take import Symparsec.Parser.TakeRest import Symparsec.Parser.TakeWhile +import Symparsec.Parser.Token import Symparsec.Parser.Try import Symparsec.Parser.While import DeFun.Core diff --git a/symparsec.cabal b/symparsec.cabal index 0d85445..6467d40 100644 --- a/symparsec.cabal +++ b/symparsec.cabal @@ -45,10 +45,12 @@ library Symparsec.Parser.Monad Symparsec.Parser.Natural Symparsec.Parser.Natural.Digits + Symparsec.Parser.Satisfy Symparsec.Parser.Skip Symparsec.Parser.Take Symparsec.Parser.TakeRest Symparsec.Parser.TakeWhile + Symparsec.Parser.Token Symparsec.Parser.Try Symparsec.Parser.While Symparsec.Parser.While.Predicates