packages feed

symbol-parser 0.2.0 → 0.3.0

raw patch · 28 files changed

+1028/−520 lines, 28 filesdep +symbol-parserdep +type-spec

Dependencies added: symbol-parser, type-spec

Files

CHANGELOG.md view
@@ -1,3 +1,8 @@+## 0.3.0 (2024-04-20)+* add new parsers: `Take`, `:<|>:`+* tons of cleanup, renaming (`RunParser` -> `Run`)+* add handful of tests (via type-spec)+ ## 0.2.0 (2024-04-19) * add two more combinators: `End`, `Literal` * remove some old code (`Data.Type.Symbol`, `Data.Type.Symbol.Natural`)
README.md view
@@ -1,42 +1,118 @@ # symbol-parser-Type level string (`Symbol`) parser combinators with nice error messages.+Type-level string (`Symbol`) parser combinators. -This library is effectively made possible by `UnconsSymbol :: Symbol -> Maybe-(Char, Symbol)` introduced in GHC 9.2. A big thank you to all GHC developers!!!+## Features+* Define parsers compositionally, largely as you would on the term level.+* Pretty parse errors.+* Hopefully decent performance.+* No runtime cost (you shall find no term-level code here).  ## Examples ```haskell ghci> import Data.Type.Symbol.Parser-ghci> :k! RunParser (Drop 3 :*>: Isolate 2 NatDec :<*>: (Drop 3 :*>: NatHex)) "___10___FF"+ghci> :k! Run (Drop 3 :*>: Isolate 2 NatDec :<*>: (Drop 3 :*>: NatHex)) "___10___FF" ... = Right '( '(10, 255), "") ``` +## Why?+Via `GHC.Generics`, we may inspect Haskell data types on the type level.+Constructor names are `Symbols`. Ever reify these, then perform some sort of+checking or parsing on the term level? symbol-parser does the parsing on the+term level instead. Catch bugs earlier, get faster runtime.+ ## Design-[defun-core-hackage]: https://hackage.haskell.org/package/defun-core+### Parser basics+[hackage-defun-core]: https://hackage.haskell.org/package/defun-core+[hackage-symbols]: https://hackage.haskell.org/package/symbols +_(Note that I may omit "type-level" when referring to type-level operations.)_++Until GHC 9.2, `Symbol`s were largely opaque. You could get them, but you+couldn't _decompose_ them like you could `String`s with `uncons :: [a] -> Maybe+(a, [a])`. Some Haskellers took this as a challenge (see+[symbols][hackage-symbols]). But realistically, we needed a bit more compiler+support.++As of GHC 9.2, `Symbol`s may be decomposed via `UnconsSymbol :: Symbol -> Maybe+(Char, Symbol)`. We thus design a `Char`-based parser:+ ```haskell-type Parser s r = Char -> s -> Result s r-data Result s r = Cont s | Done r | Err ErrorMessage+type ParserCh s r = Char -> s -> Result s r+data Result   s r = Cont s | Done r | Err E ``` -`Symbol`s are parsed `Char` by `Char`. For each `Char`, the parser is called-with the `Char` in question and the current parser state. Parsing continues-based on the result.+A parser is a function which takes a `Char`, the current state `s`, and returns+some result: -We pass parsers around via defunctionalization symbols. The plumbing here is-provided by Oleg's fantastic [defun-core][hackage-defun-core].+* `Cont s`: keep going, here's the next state `s`+* `Done r`: parse successful with value `r`+* `Err  E`: parse error, details in the `E` (a structured error) -I try to keep the internals as simple as possible. Hopefully, this library looks-like any other parser combinator, except reflected up to the type level.+`Run` handles calling the parser `Char` by `Char`, threading the state through,+and does some bookkeeping for nice errors. -## Why?-Via `GHC.Generics`, we may inspect Haskell data types on the type level.-Constructor names are `Symbols`. Ever reify these, then perform some sort of-checking or parsing on the term level? Now you can do it on the type level-instead. Catch bugs earlier, get faster runtime.+This is a good first step, but we have some outstanding issues: -## I want to help+* What do we do when we reach the end of the string?+* How do we initialize parser state?+* How do we pass parsers around? (As of 2024-04-20, GHC HEAD does not support+  unsaturated type families.)++As always, types are our salvation.++```haskell+type ParserEnd s r = s -> Either E r+type Parser s r = (ParserChSym s r, ParserEndSym s r, s)++type ParserChSym s r = Char ~> s ~> Result s r+type ParserEndSym s r = s ~> Either E r+```++We define a parser as a tuple of a character parser, an end handler, and an+initial state. The types ending in `Sym` are _defunctionalization symbols_,+which enable us to pass our parsers around as type-level functions. The plumbing+is provided Oleg's fantastic library [defun-core][hackage-defun-core].++### Example: `NatDec`+Let's write a parser that parses a natural decimal.++```haskell+type NatDec = '(NatDecChSym, NatDecEndSym, 0)++type NatDecCh ch acc = NatDecCh' acc (ParseDecimalDigitSym @@ ch)+type family NatDecCh' acc mDigit where+    NatDecCh' acc (Just digit) = Cont (acc * 10 + digit)+    NatDecCh' acc Nothing      = Err -- ...++type NatDecEnd acc = Right acc++-- boring defunctionalization symbol definitions+```++At each `Char`, we attempt to parse as a digit. If it's valid, we multiply the+current accumulator by 10 (a left shift) and add the digit value. At the end of+the string, we simply emit the current accumulator.++It can be that easy to define a parser with symbol-parser! But it isn't always.+Combinators get weird thanks to state handling. Take a look at `Isolate`, then+`Then`.++### Pitfall: Character parsers always consume+There is no backtracking or lookahead, that you do not implement yourself. This+keeps the parser execution extremely simple, but breaks null parsers such as+`Drop 0`, so these must be handled specially (unless you don't getting mind+stuck type families on misuse).++For concrete examples, see the implementation of `Drop` and `Literal`.++### Pitfall: Not all parsers are definable+* No changing parser state. Thus, parsers such as `Try :: Parser s r -> Parser+  (s, [Char]) r` are not definable. _Parsers may not backtrack._+  * Combinators such as `<|>` can emulate backtracking, but they are complex and+    hard to reason about (they may have bugs!).++## Contributing I would gladly accept further combinators or other suggestions. Please add an issue or pull request, or contact me via email or whatever (I'm raehik everywhere).
+ src/Data/Type/List.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.List where++-- | Reverse a type level list.+type Reverse as = Reverse' as '[]+type family Reverse' (as :: [k]) (acc :: [k]) :: [k] where+  Reverse' '[]      acc = acc+  Reverse' (a : as) acc = Reverse' as (a : acc)
src/Data/Type/Symbol/Parser.hs view
@@ -2,7 +2,7 @@   (   -- * Base definitions     Parser-  , RunParser+  , Run    -- * Parsers   -- ** Combinators@@ -10,8 +10,10 @@   , (:<*>:)   ,  (:*>:)   , (:<*:)+  , (:<|>:)    -- ** Primitives+  , Take   , Drop   , Literal   , End@@ -24,15 +26,18 @@   , NatBase   ) where -import Data.Type.Symbol.Parser.Internal-import Data.Type.Symbol.Parser.Isolate-import Data.Type.Symbol.Parser.Drop-import Data.Type.Symbol.Parser.Natural-import Data.Type.Symbol.Parser.Then-import Data.Type.Symbol.Parser.Then.VoidLeft-import Data.Type.Symbol.Parser.Then.VoidRight-import Data.Type.Symbol.Parser.Literal-import Data.Type.Symbol.Parser.End+import Data.Type.Symbol.Parser.Run+import Data.Type.Symbol.Parser.Types+import Data.Type.Symbol.Parser.Parser.Isolate+import Data.Type.Symbol.Parser.Parser.Drop+import Data.Type.Symbol.Parser.Parser.Natural+import Data.Type.Symbol.Parser.Parser.Then+import Data.Type.Symbol.Parser.Parser.Then.VoidLeft+import Data.Type.Symbol.Parser.Parser.Then.VoidRight+import Data.Type.Symbol.Parser.Parser.Literal+import Data.Type.Symbol.Parser.Parser.End+import Data.Type.Symbol.Parser.Parser.Take+import Data.Type.Symbol.Parser.Parser.Or  -- | Sequence parsers, returning both values in a tuple. type pl :<*>: pr = Then   pl pr@@ -45,3 +50,5 @@ -- Consider using ':*>:' instead, which is simpler and potentially faster since -- we parse L->R. type pl :<*:  pr = ThenVR pl pr++type pl :<|>: pr = Or pl pr
+ src/Data/Type/Symbol/Parser/Common.hs view
@@ -0,0 +1,30 @@+module Data.Type.Symbol.Parser.Common+  ( FailChSym+  , FailEndSym+  , EmitEndSym+  , ErrParserLimitation+  ) where++import Data.Type.Symbol.Parser.Types+import GHC.TypeLits+import DeFun.Core ( type App, type (~>) )++type FailChSym :: Symbol -> ErrorMessage -> ParserChSym s r+data FailChSym name e f+type instance App (FailChSym name e) f = FailChSym1 name e f++type FailChSym1 :: Symbol -> ErrorMessage -> Char -> s ~> Result s r+data FailChSym1 name e ch s+type instance App (FailChSym1 name e ch) s = Err (EBase name e)++type FailEndSym :: Symbol -> ErrorMessage -> ParserEndSym s r+data FailEndSym name e s+type instance App (FailEndSym name e) s = Left (EBase name e)++-- | Emit state directly on end of input.+type EmitEndSym :: ParserEndSym r r+data EmitEndSym r+type instance App EmitEndSym r = Right r++type ErrParserLimitation :: Symbol -> ErrorMessage+type ErrParserLimitation msg = Text "parser limitation: " :<>: Text msg
− src/Data/Type/Symbol/Parser/Drop.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE UndecidableInstances #-} -- for natural subtraction--module Data.Type.Symbol.Parser.Drop ( type Drop ) where--import Data.Type.Symbol.Parser.Internal-import GHC.TypeLits-import DeFun.Core ( type (~>), type App )--type Drop :: Natural -> Parser Natural ()-type Drop n = '(DropChSym, DropEndSym, n)--type DropCh :: ParserCh Natural ()-type family DropCh _ch n where-    DropCh _ 0 = Err (Text "can't drop 0 due to parser limitations. sorry")-    DropCh _ 1 = Done '()-    DropCh _ n = Cont (n-1)--type DropEnd :: ParserEnd Natural ()-type family DropEnd n where-    DropEnd 0 = Right '()-    DropEnd n = Left-      ( Text "tried to drop "-        :<>: ShowType n :<>: Text " chars from empty symbol")--type DropChSym :: ParserChSym Natural ()-data DropChSym f-type instance App DropChSym f = DropChSym1 f--type DropChSym1 :: Char -> Natural ~> Result Natural ()-data DropChSym1 ch n-type instance App (DropChSym1 ch) n = DropCh ch n--type DropEndSym :: ParserEndSym Natural ()-data DropEndSym n-type instance App DropEndSym n = DropEnd n
− src/Data/Type/Symbol/Parser/End.hs 
@@ -1,29 +0,0 @@-module Data.Type.Symbol.Parser.End ( type End ) where--import Data.Type.Symbol.Parser.Internal-import GHC.TypeLits-import DeFun.Core ( type (~>), type App )--type End :: Parser () ()-type End = '(EndChSym, EndEndSym, '())--type EndCh :: ParserCh () ()-type family EndCh ch u where-    EndCh _ '() = Err (Text "expected end of string")--type EndEnd :: ParserEnd () ()-type family EndEnd u where-    EndEnd '() = Right '()--type EndChSym :: ParserChSym () ()-data EndChSym f-type instance App EndChSym f = EndChSym1 f--type EndChSym1-    :: Char -> () ~> Result () ()-data EndChSym1 ch n-type instance App (EndChSym1 ch) n = EndCh ch n--type EndEndSym :: ParserEndSym () ()-data EndEndSym msym-type instance App EndEndSym '() = EndEnd '()
− src/Data/Type/Symbol/Parser/Internal.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Data.Type.Symbol.Parser.Internal where--import GHC.TypeLits-import DeFun.Core ( type (~>), type (@@) )--type ParserCh s r = Char -> s -> Result s r-type ParserEnd s r = s -> Either ErrorMessage r-data Result s r = Cont s | Done r | Err ErrorMessage--type ParserChSym s r = Char ~> s ~> Result s r-type ParserEndSym s r = s ~> Either ErrorMessage r--type Parser s r = (ParserChSym s r, ParserEndSym s r, s)--type family RunParser p sym where-    RunParser '(pCh, pEnd, s) sym =-        RunParser' pCh pEnd 0 s (UnconsSymbol sym)---- TODO maybe take an mch? Nothing at start, Just otherwise-type family RunParser' pCh pEnd idx s msym where-    RunParser' pCh pEnd idx s Nothing =-        RunParserEnd idx (pEnd @@ s)-    RunParser' pCh pEnd idx s (Just '(ch, sym)) =-        RunParser'' pCh pEnd idx ch (pCh @@ ch @@ s) sym--type family RunParserEnd idx end where-    RunParserEnd idx (Left  e) = Left e-    RunParserEnd idx (Right r) = Right '(r, "")--type family RunParser'' pCh pEnd idx ch res sym where-    RunParser'' pCh pEnd idx ch (Err  e) sym = Left e -- TODO annotate error-    RunParser'' pCh pEnd idx ch (Done r) sym = Right '(r, sym)-    RunParser'' pCh pEnd idx ch (Cont s) sym =-        RunParser' pCh pEnd (idx+1) s (UnconsSymbol sym)---- TODO could do this if more parsers end up storing state which they emit--- precisely (NatBase does this)---type ParserEndEmit :: ParserEnd r r
− src/Data/Type/Symbol/Parser/Isolate.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}---- TODO improve errors (I was lazy)--module Data.Type.Symbol.Parser.Isolate where--import Data.Type.Symbol.Parser.Internal-import GHC.TypeLits-import DeFun.Core ( type (~>), type (@@), type App )--type Isolate :: Natural -> Parser s r -> Parser (Natural, s) r-type family Isolate n p where-    Isolate n '(pCh, pEnd, s) = '(IsolateChSym pCh pEnd, IsolateEndSym, '(n, s))--type IsolateCh-    :: ParserChSym s r-    -> ParserEndSym s r-    -> ParserCh (Natural, s) r-type family IsolateCh pCh pEnd ch s where-    IsolateCh pCh pEnd ch '(0, s) =-        Err (Text "cannot isolate 0 due to parser limitations")-    IsolateCh pCh pEnd ch '(1, s) = IsolateInnerEnd' pEnd (pCh @@ ch @@ s)-    IsolateCh pCh pEnd ch '(n, s) = IsolateInner n (pCh @@ ch @@ s)---- TODO clean up names here----type IsolateInnerEnd' :: Either ErrorMessage r -> Result (Natural, s) r-type family IsolateInnerEnd' pEnd res where-    IsolateInnerEnd' pEnd (Err  e) = Err  e-    IsolateInnerEnd' pEnd (Done r) = Done r-    IsolateInnerEnd' pEnd (Cont s) = IsolateInnerEnd (pEnd @@ s)--type IsolateInnerEnd :: Either ErrorMessage r -> Result (Natural, s) r-type family IsolateInnerEnd a where-    IsolateInnerEnd (Left  e) = Err  e-    IsolateInnerEnd (Right r) = Done r--type IsolateInner :: Natural -> Result s r -> Result (Natural, s) r-type family IsolateInner n a where-    IsolateInner _ (Err  e) = Err  e-    IsolateInner _ (Done _) =-        -- TODO put n in that error too plz-        Err (Text "isolated parser ended without consuming all input")-    IsolateInner n (Cont s) = Cont '(n-1, s)--type IsolateEnd :: ParserEnd (Natural, s) r-type family IsolateEnd s where-    IsolateEnd '(0, s) = Right '(0, s)-    IsolateEnd '(n, s) =-        -- TODO-        Left (Text "isolate wanted more than was there")--type IsolateChSym-    :: ParserChSym s r-    -> ParserEndSym s r-    -> ParserChSym (Natural, s) r-data IsolateChSym pCh pEnd f-type instance App (IsolateChSym pCh pEnd) f = IsolateChSym1 pCh pEnd f--type IsolateChSym1-    :: ParserChSym s r-    -> ParserEndSym s r-    -> Char -> (Natural, s) ~> Result (Natural, s) r-data IsolateChSym1 pCh pEnd ch s-type instance App (IsolateChSym1 pCh pEnd ch) s = IsolateCh pCh pEnd ch s--type IsolateEndSym :: ParserEndSym (Natural, s) r-data IsolateEndSym s-type instance App IsolateEndSym s = IsolateEnd s
− src/Data/Type/Symbol/Parser/Literal.hs 
@@ -1,36 +0,0 @@-module Data.Type.Symbol.Parser.Literal ( type Literal ) where--import Data.Type.Symbol.Parser.Internal-import GHC.TypeLits-import DeFun.Core ( type (~>), type App )--type Literal :: Symbol -> Parser (Maybe (Char, Symbol)) ()-type Literal sym = '(LiteralChSym, LiteralEndSym, UnconsSymbol sym)--type LiteralCh :: ParserCh (Maybe (Char, Symbol)) ()-type family LiteralCh ch msym where-    LiteralCh ch Nothing = Err-        (Text "can't parse the empty literal due to parser limitations")-    LiteralCh ch (Just '(ch,  ""))  = Done '()-    LiteralCh ch (Just '(ch,  sym)) = Cont (UnconsSymbol sym)-    LiteralCh ch (Just '(ch', sym)) = Err-        (Text "expected " :<>: ShowType ch :<>: Text ", got " :<>: ShowType ch')--type LiteralEnd :: ParserEnd (Maybe (Char, Symbol)) ()-type family LiteralEnd msym where-    LiteralEnd Nothing = Right '()-    LiteralEnd (Just '(ch, sym)) = Left-      ( Text "still parsing literal: " :<>: Text (ConsSymbol ch sym))--type LiteralChSym :: ParserChSym (Maybe (Char, Symbol)) ()-data LiteralChSym f-type instance App LiteralChSym f = LiteralChSym1 f--type LiteralChSym1-    :: Char -> Maybe (Char, Symbol) ~> Result (Maybe (Char, Symbol)) ()-data LiteralChSym1 ch n-type instance App (LiteralChSym1 ch) n = LiteralCh ch n--type LiteralEndSym :: ParserEndSym (Maybe (Char, Symbol)) ()-data LiteralEndSym msym-type instance App LiteralEndSym msym = LiteralEnd msym
− src/Data/Type/Symbol/Parser/Natural.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE UndecidableInstances #-} -- for natural multiplication etc.--module Data.Type.Symbol.Parser.Natural where--import Data.Type.Symbol.Parser.Internal-import GHC.TypeLits-import DeFun.Core ( type (~>), type App, type (@@) )-import Data.Type.Char.Digits--type NatBin = NatBase  2 ParseBinaryDigitSym-type NatOct = NatBase  8 ParseOctalDigitSym-type NatDec = NatBase 10 ParseDecimalDigitSym-type NatHex = NatBase 16 ParseHexDigitSym--type NatBase-    :: Natural -> (Char ~> Maybe Natural) -> Parser Natural Natural-type NatBase base parseDigit =-    '(NatBaseChSym base parseDigit, NatBaseEndSym, 0)--type NatBaseCh-    :: Natural-    -> (Char ~> Maybe Natural)-    -> ParserCh Natural Natural-type family NatBaseCh base parseDigit ch n where-    NatBaseCh base parseDigit ch n =-        NatBaseCh' base n (parseDigit @@ ch)--type family NatBaseCh' base n mDigit where-    NatBaseCh' base n Nothing      =-        Err (Text "not a base " :<>: ShowType base :<>: Text " digit")-    NatBaseCh' base n (Just digit) = Cont (n * base + digit)--type NatBaseEnd :: ParserEnd Natural Natural-type NatBaseEnd n = Right n--type NatBaseChSym-    :: Natural-    -> (Char ~> Maybe Natural)-    -> ParserChSym Natural Natural-data NatBaseChSym base parseDigit f-type instance App (NatBaseChSym base parseDigit) f =-    NatBaseChSym1 base parseDigit f--type NatBaseChSym1-    :: Natural-    -> (Char ~> Maybe Natural)-    -> Char -> Natural-    ~> Result Natural Natural-data NatBaseChSym1 base parseDigit ch n-type instance App (NatBaseChSym1 base parseDigit ch) n =-    NatBaseCh base parseDigit ch n--type NatBaseEndSym :: ParserEndSym Natural Natural-data NatBaseEndSym n-type instance App NatBaseEndSym s = NatBaseEnd s--type ParseBinaryDigitSym :: Char ~> Maybe Natural-data ParseBinaryDigitSym a-type instance App ParseBinaryDigitSym a = ParseBinaryDigit a--type ParseOctalDigitSym :: Char ~> Maybe Natural-data ParseOctalDigitSym a-type instance App ParseOctalDigitSym a = ParseOctalDigit a--type ParseDecimalDigitSym :: Char ~> Maybe Natural-data ParseDecimalDigitSym a-type instance App ParseDecimalDigitSym a = ParseDecimalDigit a--type ParseHexDigitSym :: Char ~> Maybe Natural-data ParseHexDigitSym a-type instance App ParseHexDigitSym a = ParseHexDigit a
+ src/Data/Type/Symbol/Parser/Parser/Drop.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE UndecidableInstances #-} -- for natural subtraction++module Data.Type.Symbol.Parser.Parser.Drop ( Drop, Drop' ) where++import Data.Type.Symbol.Parser.Types+import Data.Type.Symbol.Parser.Common+import GHC.TypeLits+import DeFun.Core ( type (~>), type App )++type Drop :: Natural -> Parser Natural ()+type family Drop n where+    Drop 0 =+        '(FailChSym "Drop" (ErrParserLimitation "can't drop 0"), DropEndSym, 0)+    Drop n = Drop' n++-- | Unsafe 'Drop' which doesn't check for 0. May get stuck.+type Drop' :: Natural -> Parser Natural ()+type Drop' n = '(DropChSym, DropEndSym, n)++type DropCh :: ParserCh Natural ()+type family DropCh ch n where+    DropCh _ 1 = Done '()+    DropCh _ n = Cont (n-1)++type DropEnd :: ParserEnd Natural ()+type family DropEnd n where+    DropEnd 0 = Right '()+    DropEnd n = Left (EBase "Drop"+      ( Text "tried to drop "+        :<>: ShowType n :<>: Text " chars from empty symbol"))++type DropChSym :: ParserChSym Natural ()+data DropChSym f+type instance App DropChSym f = DropChSym1 f++type DropChSym1 :: Char -> Natural ~> Result Natural ()+data DropChSym1 ch n+type instance App (DropChSym1 ch) n = DropCh ch n++type DropEndSym :: ParserEndSym Natural ()+data DropEndSym n+type instance App DropEndSym n = DropEnd n
+ src/Data/Type/Symbol/Parser/Parser/End.hs view
@@ -0,0 +1,22 @@+module Data.Type.Symbol.Parser.Parser.End ( End ) where++import Data.Type.Symbol.Parser.Types+import Data.Type.Symbol.Parser.Common ( EmitEndSym )+import GHC.TypeLits+import DeFun.Core ( type (~>), type App )++type End :: Parser () ()+type End = '(EndChSym, EmitEndSym, '())++type EndCh :: ParserCh () ()+type family EndCh ch u where+    EndCh _ '() = Err (EBase "End" (Text "expected end of string"))++type EndChSym :: ParserChSym () ()+data EndChSym f+type instance App EndChSym f = EndChSym1 f++type EndChSym1+    :: Char -> () ~> Result () ()+data EndChSym1 ch n+type instance App (EndChSym1 ch) n = EndCh ch n
+ src/Data/Type/Symbol/Parser/Parser/Isolate.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.Symbol.Parser.Parser.Isolate ( Isolate ) where++import Data.Type.Symbol.Parser.Types+import Data.Type.Symbol.Parser.Common+import GHC.TypeLits+import DeFun.Core ( type (~>), type (@@), type App )++type Isolate :: Natural -> Parser s r -> Parser (Natural, s) r+type family Isolate n p where+    Isolate 0 '(pCh, pEnd, s) =+        '( FailChSym "Isolate" (ErrParserLimitation "cannot isolate 0")+         , IsolateEndSym, '(0, s))+    Isolate n '(pCh, pEnd, s) = '(IsolateChSym pCh pEnd, IsolateEndSym, '(n-1, s))++type IsolateCh+    :: ParserChSym s r+    -> ParserEndSym s r+    -> ParserCh (Natural, s) r+type family IsolateCh pCh pEnd ch s where+    IsolateCh pCh pEnd ch '(0, s) = IsolateInnerEnd' pEnd (pCh @@ ch @@ s)+    IsolateCh pCh pEnd ch '(n, s) = IsolateInner n (pCh @@ ch @@ s)++-- TODO clean up names here++--type IsolateInnerEnd' :: Either ErrorMessage r -> Result (Natural, s) r+type family IsolateInnerEnd' pEnd res where+    IsolateInnerEnd' pEnd (Err  e) = Err  (EIn "Isolate" e)+    IsolateInnerEnd' pEnd (Done r) = Done r+    IsolateInnerEnd' pEnd (Cont s) = IsolateInnerEnd (pEnd @@ s)++type IsolateInnerEnd :: Either E r -> Result (Natural, s) r+type family IsolateInnerEnd a where+    IsolateInnerEnd (Left  e) = Err  (EIn "Isolate" e)+    IsolateInnerEnd (Right r) = Done r++type IsolateInner :: Natural -> Result s r -> Result (Natural, s) r+type family IsolateInner n a where+    IsolateInner n (Cont s) = Cont '(n-1, s)+    IsolateInner _ (Err  e) = Err  e+    IsolateInner n (Done _) = Err (EBase "Isolate"+        (      Text "isolated parser ended without consuming all input ("+          :<>: ShowType n :<>: Text " remaining)" ))++type IsolateEnd :: ParserEnd (Natural, s) r+type family IsolateEnd s where+    IsolateEnd '(0, s) = Right '(0, s)+    IsolateEnd '(n, s) = Left (EBase "Isolate"+        (      Text "tried to isolate more than present (needed "+          :<>: ShowType n :<>: Text " more)" ))++type IsolateChSym+    :: ParserChSym s r+    -> ParserEndSym s r+    -> ParserChSym (Natural, s) r+data IsolateChSym pCh pEnd f+type instance App (IsolateChSym pCh pEnd) f = IsolateChSym1 pCh pEnd f++type IsolateChSym1+    :: ParserChSym s r+    -> ParserEndSym s r+    -> Char -> (Natural, s) ~> Result (Natural, s) r+data IsolateChSym1 pCh pEnd ch s+type instance App (IsolateChSym1 pCh pEnd ch) s = IsolateCh pCh pEnd ch s++type IsolateEndSym :: ParserEndSym (Natural, s) r+data IsolateEndSym s+type instance App IsolateEndSym s = IsolateEnd s
+ src/Data/Type/Symbol/Parser/Parser/Literal.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.Symbol.Parser.Parser.Literal ( Literal ) where++import Data.Type.Symbol.Parser.Types+import Data.Type.Symbol.Parser.Common+import GHC.TypeLits+import DeFun.Core ( type (~>), type App )++type Literal :: Symbol -> Parser (Char, Maybe (Char, Symbol)) ()+type Literal sym = Literal' (UnconsSymbol sym)++type EEmptyLit = ErrParserLimitation "cannot parse empty literal"++type family Literal' msym where+    Literal' Nothing           =+        '( FailChSym "Literal" EEmptyLit+         , FailEndSym "Literal" EEmptyLit, '( '\0', Nothing))+    Literal' (Just '(ch, sym)) =+        '(LiteralChSym, LiteralEndSym, '(ch, UnconsSymbol sym))++type family LiteralCh ch s where+    LiteralCh ch0 '(ch0, Just '(ch1, sym)) = Cont '(ch1, UnconsSymbol sym)+    LiteralCh ch0 '(ch0, Nothing)          = Done '()+    LiteralCh ch  '(ch0, msym)             = Err (EBase "Literal"+        (      Text "expected " :<>: ShowType ch0+          :<>: Text ", got " :<>: ShowType ch))++type LiteralEnd :: ParserEnd (Char, Maybe (Char, Symbol)) ()+type family LiteralEnd s where+    LiteralEnd '(ch0, msym) = Left (EBase "Literal"+      (      Text "still parsing literal: "+        :<>: Text (ConsSymbol ch0 (ReconsSymbol msym))))++type family ReconsSymbol msym where+    ReconsSymbol Nothing           = ""+    ReconsSymbol (Just '(ch, sym)) = ConsSymbol ch sym++type LiteralChSym :: ParserChSym (Char, Maybe (Char, Symbol)) ()+data LiteralChSym f+type instance App LiteralChSym f = LiteralChSym1 f++type LiteralChSym1+    :: Char+    -> (Char, Maybe (Char, Symbol))+    ~> Result (Char, Maybe (Char, Symbol)) ()+data LiteralChSym1 ch s+type instance App (LiteralChSym1 ch) s = LiteralCh ch s++type LiteralEndSym :: ParserEndSym (Char, Maybe (Char, Symbol)) ()+data LiteralEndSym s+type instance App LiteralEndSym s = LiteralEnd s
+ src/Data/Type/Symbol/Parser/Parser/Natural.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE UndecidableInstances #-} -- for natural multiplication etc.++module Data.Type.Symbol.Parser.Parser.Natural+  ( NatBin, NatOct, NatDec, NatHex+  , NatBase+  ) where++import Data.Type.Symbol.Parser.Types+import Data.Type.Symbol.Parser.Common ( EmitEndSym )+import GHC.TypeLits+import DeFun.Core ( type (~>), type App, type (@@) )+import Data.Type.Char.Digits++type NatBin = NatBase  2 ParseBinaryDigitSym+type NatOct = NatBase  8 ParseOctalDigitSym+type NatDec = NatBase 10 ParseDecimalDigitSym+type NatHex = NatBase 16 ParseHexDigitSym++type NatBase+    :: Natural -> (Char ~> Maybe Natural) -> Parser Natural Natural+type NatBase base parseDigit =+    '(NatBaseChSym base parseDigit, EmitEndSym, 0)++type NatBaseCh+    :: Natural+    -> (Char ~> Maybe Natural)+    -> ParserCh Natural Natural+type NatBaseCh base parseDigit ch n = NatBaseCh' base n (parseDigit @@ ch)++type family NatBaseCh' base n mDigit where+    NatBaseCh' base n (Just digit) = Cont (n * base + digit)+    NatBaseCh' base n Nothing      = Err (EBase "NatBase"+        (Text "not a base " :<>: ShowType base :<>: Text " digit"))++type NatBaseChSym+    :: Natural+    -> (Char ~> Maybe Natural)+    -> ParserChSym Natural Natural+data NatBaseChSym base parseDigit f+type instance App (NatBaseChSym base parseDigit) f =+    NatBaseChSym1 base parseDigit f++type NatBaseChSym1+    :: Natural+    -> (Char ~> Maybe Natural)+    -> Char -> Natural+    ~> Result Natural Natural+data NatBaseChSym1 base parseDigit ch n+type instance App (NatBaseChSym1 base parseDigit ch) n =+    NatBaseCh base parseDigit ch n++type ParseBinaryDigitSym :: Char ~> Maybe Natural+data ParseBinaryDigitSym a+type instance App ParseBinaryDigitSym a = ParseBinaryDigit a++type ParseOctalDigitSym :: Char ~> Maybe Natural+data ParseOctalDigitSym a+type instance App ParseOctalDigitSym a = ParseOctalDigit a++type ParseDecimalDigitSym :: Char ~> Maybe Natural+data ParseDecimalDigitSym a+type instance App ParseDecimalDigitSym a = ParseDecimalDigit a++type ParseHexDigitSym :: Char ~> Maybe Natural+data ParseHexDigitSym a+type instance App ParseHexDigitSym a = ParseHexDigit a
+ src/Data/Type/Symbol/Parser/Parser/Or.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE UndecidableInstances #-}++{- | Choice operator. Try left; if it fails, try right.++This is a problematic combinator:++  * Implementation is clumsy due to internal parser state being untouchable.+    We must record seen characters, in order to replay them on the right parser+    in case the left parser fails.+  * Errors degrade due to left parser errors being discarded. Perhaps your+    string was one character off a successful left parse; but if it fails, you+    won't see that error.+  * It's hard to reason aobut. It might break in certain situations.+-}+++module Data.Type.Symbol.Parser.Parser.Or ( Or ) where++import Data.Type.Symbol.Parser.Types+import DeFun.Core ( type (@@), type App )+import Data.Type.List ( Reverse )++type Or+    :: Parser sl rl+    -> Parser sr rr+    -> Parser (Either (sl, [Char]) sr) (Either rl rr)+type family Or pl pr where+    Or '(plCh, plEnd, sl) '(prCh, prEnd, sr) =+        '(OrChSym plCh prCh sr, OrEndSym plEnd prCh prEnd sr, Left '(sl, '[]))++type OrCh+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> ParserCh (Either (sl, [Char]) sr) (Either rl rr)+type family OrCh plCh prCh sr ch s where+    -- | Parsing left+    OrCh plCh prCh sr ch (Left  '(sl, chs)) =+        OrChL prCh sr (ch : chs) (plCh @@ ch @@ sl)++    -- | Parsing right (left failed and was successfully replayed)+    OrCh plCh prCh _  ch (Right sr) =+        OrChR (prCh @@ ch @@ sr)++-- TODO [Char] is actually nonempty, but it's awkward because we need to reverse+-- it and place the known char at the end. we _can_ fix this, but it's just+-- annoying lol+type OrChL+    :: ParserChSym sr rr+    -> sr+    -> [Char]+    -> Result sl rl+    -> Result (Either (sl, [Char]) sr) (Either rl rr)+type family OrChL prCh sr chs resl where+    -- | Left parser OK, continue+    OrChL _    _  chs (Cont sl) = Cont (Left  '(sl, chs))++    -- | Left parser OK, done+    OrChL _    _  chs (Done rl) = Done (Left  rl)++    -- | Left parser failed: ignore, replay consumed characters on right parser+    OrChL prCh sr chs (Err  _ ) =+        OrChLReplay prCh (Reverse chs) (Cont sr)++-- TODO [Char] is nonempty, see 'OrChL'. also if we fix that, we can get better+-- equation ordering!+type OrChLReplay+    :: ParserChSym sr rr+    -> [Char]+    -> Result sr rr+    -> Result (Either (sl, [Char]) sr) (Either rl rr)+type family OrChLReplay prCh chs resr where+    -- | Right parser OK, last char+    OrChLReplay prCh (ch : '[]) (Cont sr) = OrChR (prCh @@ ch @@ sr)++    -- | Right parser OK, keep replaying+    OrChLReplay prCh (ch : chs) (Cont sr) =+        OrChLReplay prCh chs (prCh @@ ch @@ sr)++    -- | Right parser fail: wrap error+    --+    -- TODO error behaviour here?+    OrChLReplay prCh chs        (Err  er) = Err (EIn "Or(R)" er)++    -- | Right parser done: early success+    --+    -- If this matches before we finish replaying, any remaining replay+    -- characters are lost. This _should_ break certain parses. Or, maybe it+    -- only breaks return symbol..? In which case, we can fix by returning+    -- the extra replayed chars in our return type???? TODO+    OrChLReplay prCh chs        (Done rr) = Done (Right rr)+        -- (EBase "Or" (ErrParserLimitation "cannot parse less on right of Or"))++type family OrChR resr where+    OrChR (Cont sr) = Cont (Right sr)+    OrChR (Done rr) = Done (Right rr)+    OrChR (Err  er) = Err (EIn "Or(R)" er)++type OrEnd+    :: ParserEndSym sl rl+    -> ParserChSym  sr rr+    -> ParserEndSym sr rr+    -> sr+    -> ParserEnd (Either (sl, [Char]) sr) (Either rl rr)+type family OrEnd plEnd prCh prEnd sr res where+    -- | Input ended on L.+    OrEnd plEnd prCh prEnd sr (Left  '(sl, chs)) =+        OrEndL prCh prEnd sr chs (plEnd @@ sl)++    -- | Input ended on R.+    OrEnd plEnd prCh prEnd _  (Right sr)         = OrEndR (prEnd @@ sr)++type OrEndR+    :: Either E rr+    -> Either E (Either rl rr)+type family OrEndR s where+    OrEndR (Left  er) = Left (EIn "Or(R)" er)+    OrEndR (Right rr) = Right (Right rr)++type OrEndL+    :: ParserChSym  sr rr+    -> ParserEndSym sr rr+    -> sr+    -> [Char]+    -> Either E rl+    -> Either E (Either rl rr)+type family OrEndL prCh prEnd sr chs res where+    OrEndL prCh prEnd sr chs (Right rl) = Right (Left rl)+    OrEndL prCh prEnd sr chs (Left  el) =+        OrChLReplay' prCh prEnd (Reverse chs) (Cont sr)++type OrChLReplay'+    :: ParserChSym  sr rr+    -> ParserEndSym sr rr+    -> [Char]+    -> Result sr rr+    -> Either E (Either rl rr)+type family OrChLReplay' prCh prEnd chs resr where+    OrChLReplay' prCh prEnd (ch : '[]) (Cont sr) =+        OrEndR' prEnd (prCh @@ ch @@ sr)+    OrChLReplay' prCh prEnd (ch : chs) (Cont sr) =+        OrChLReplay' prCh prEnd chs (prCh @@ ch @@ sr)+    OrChLReplay' prCh prEnd chs        (Err  er) = Left (EIn "Or(R)" er)++    -- TODO Here, we successfully ended while replaying left-consumed chars.+    -- This may not work if it's wrapped in further combinators, I'm unsure.+    OrChLReplay' prCh prEnd chs        (Done rr) = Right (Right rr)+        -- (EBase "Or" (ErrParserLimitation "cannot parse less on right of Or"))++type family OrEndR' prEnd s where+    OrEndR' prEnd (Err  er) = Left (EIn "Or(R)" er)+    OrEndR' prEnd (Done rr) = Right (Right rr)+    OrEndR' prEnd (Cont sr) = OrEndR (prEnd @@ sr)++data OrChSym plCh prCh sr f+type instance App (OrChSym plCh prCh sr) f = OrChSym1 plCh prCh sr f++data OrChSym1 plCh prCh sr ch s+type instance App (OrChSym1 plCh prCh sr ch) s = OrCh plCh prCh sr ch s++type OrEndSym+    :: ParserEndSym sl rl+    -> ParserChSym  sr rr+    -> ParserEndSym sr rr+    -> sr+    -> ParserEndSym (Either (sl, [Char]) sr) (Either rl rr)+data OrEndSym plEnd prCh prEnd sr s+type instance App (OrEndSym plEnd prCh prEnd sr) s = OrEnd plEnd prCh prEnd sr s
+ src/Data/Type/Symbol/Parser/Parser/Take.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.Symbol.Parser.Parser.Take ( Take ) where++import Data.Type.Symbol.Parser.Types+import Data.Type.Symbol.Parser.Common+import GHC.TypeLits+import DeFun.Core ( type (~>), type App )++type Take :: Natural -> Parser (Natural, [Char]) Symbol+type family Take n where+    Take 0 =+        '( FailChSym "Take" (ErrParserLimitation "can't take 0")+         , TakeEndSym, '(0, '[]))+    Take n = '(TakeChSym, TakeEndSym, '(n, '[]))++type TakeCh :: ParserCh (Natural, [Char]) Symbol+type family TakeCh ch s where+    TakeCh ch '(1, chs) = Done (RevCharsToSymbol (ch : chs))+    TakeCh ch '(n, chs) = Cont '(n-1, ch : chs)++type TakeEnd :: ParserEnd (Natural, [Char]) Symbol+type family TakeEnd s where+    TakeEnd '(0, chs) = Right (RevCharsToSymbol chs)+    TakeEnd '(n, _)   = Left (EBase "Take"+      ( Text "tried to take "+        :<>: ShowType n :<>: Text " chars from empty symbol"))++type RevCharsToSymbol chs = RevCharsToSymbol' "" chs+type family RevCharsToSymbol' sym chs where+    RevCharsToSymbol' sym '[]        = sym+    RevCharsToSymbol' sym (ch : chs) = RevCharsToSymbol' (ConsSymbol ch sym) chs++type TakeChSym :: ParserChSym (Natural, [Char]) Symbol+data TakeChSym f+type instance App TakeChSym f = TakeChSym1 f++type TakeChSym1 :: Char -> (Natural, [Char]) ~> Result (Natural, [Char]) Symbol+data TakeChSym1 ch s+type instance App (TakeChSym1 ch) s = TakeCh ch s++type TakeEndSym :: ParserEndSym (Natural, [Char]) Symbol+data TakeEndSym s+type instance App TakeEndSym s = TakeEnd s
+ src/Data/Type/Symbol/Parser/Parser/Then.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.Symbol.Parser.Parser.Then ( Then ) where++import Data.Type.Symbol.Parser.Types+import GHC.TypeLits+import DeFun.Core ( type (~>), type (@@), type App )++type Then+    :: Parser sl rl+    -> Parser sr rr+    -> Parser (Either sl (rl, sr)) (rl, rr)+type family Then pl pr where+    Then '(plCh, plEnd, sl) '(prCh, prEnd, sr) =+        '(ThenChSym plCh prCh sr, ThenEndSym prEnd, Left sl)++type ThenCh+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> ParserCh (Either sl (rl, sr)) (rl, rr)+type family ThenCh plCh prCh sr ch s where+    ThenCh plCh prCh sr ch (Left  sl) =+        ThenL sr (plCh @@ ch @@ sl)+    ThenCh plCh prCh _  ch (Right '(rl, sr)) =+        ThenR rl (prCh @@ ch @@ sr)++type family ThenL sr resl where+    ThenL sr (Err  el) = Err  (EIn "Then(L)" el)+    ThenL sr (Cont sl) = Cont (Left  sl)+    ThenL sr (Done rl) = Cont (Right '(rl, sr))++type family ThenR rl resr where+    ThenR rl (Err  er) = Err  (EIn "Then(R)" er)+    ThenR rl (Cont sr) = Cont (Right '(rl, sr))+    ThenR rl (Done rr) = Done '(rl, rr)++type family ThenEnd prEnd s where+    ThenEnd prEnd (Left sl) = Left (EBase "Then" (Text "ended during left"))+    ThenEnd prEnd (Right '(rl, sr)) =+        ThenEnd' rl (prEnd @@ sr)++type family ThenEnd' rl s where+    ThenEnd' rl (Left  er) = Left  (EIn "Then(R)" er)+    ThenEnd' rl (Right rr) = Right '(rl, rr)++type ThenChSym+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> ParserChSym (Either sl (rl, sr)) (rl, rr)+data ThenChSym plCh prCh sr f+type instance App (ThenChSym plCh prCh sr) f = ThenChSym1 plCh prCh sr f++type ThenChSym1+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> Char -> Either sl (rl, sr) ~> Result (Either sl (rl, sr)) (rl, rr)+data ThenChSym1 plCh prCh sr ch s+type instance App (ThenChSym1 plCh prCh sr ch) s = ThenCh plCh prCh sr ch s++type ThenEndSym+    :: ParserEndSym sr rr+    -> ParserEndSym (Either sl (rl, sr)) (rl, rr)+data ThenEndSym prEnd s+type instance App (ThenEndSym prEnd) s = ThenEnd prEnd s
+ src/Data/Type/Symbol/Parser/Parser/Then/VoidLeft.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.Symbol.Parser.Parser.Then.VoidLeft ( ThenVL ) where++import Data.Type.Symbol.Parser.Types+import GHC.TypeLits+import DeFun.Core ( type (~>), type (@@), type App )++type ThenVL+    :: Parser sl rl+    -> Parser sr rr+    -> Parser (Either sl sr) rr+type family ThenVL pl pr where+    ThenVL '(plCh, plEnd, sl) '(prCh, prEnd, sr) =+        '(ThenVLChSym plCh prCh sr, ThenVLEndSym prEnd, Left sl)++type ThenVLCh+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> ParserCh (Either sl sr) rr+type family ThenVLCh plCh prCh sr ch s where+    ThenVLCh plCh prCh sr ch (Left  sl) =+        ThenVLL sr (plCh @@ ch @@ sl)+    ThenVLCh plCh prCh _  ch (Right sr) =+        ThenVLR (prCh @@ ch @@ sr)++type family ThenVLL sr resl where+    ThenVLL sr (Err  el) = Err  (EIn "ThenVL(L)" el)+    ThenVLL sr (Cont sl) = Cont (Left  sl)+    ThenVLL sr (Done rl) = Cont (Right sr)++type family ThenVLR resr where+    ThenVLR (Err  er) = Err  (EIn "ThenVL(R)" er)+    ThenVLR (Cont sr) = Cont (Right sr)+    ThenVLR (Done rr) = Done rr++type family ThenVLEnd prEnd s where+    ThenVLEnd prEnd (Left  sl) =+        Left (EBase "ThenVL" (Text "ended during left"))+    ThenVLEnd prEnd (Right sr) = ThenVLEnd' (prEnd @@ sr)++type family ThenVLEnd' s where+    ThenVLEnd' (Left  er) = Left  (EIn "ThenVL(R)" er)+    ThenVLEnd' (Right rr) = Right rr++type ThenVLChSym+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> ParserChSym (Either sl sr) rr+data ThenVLChSym plCh prCh sr f+type instance App (ThenVLChSym plCh prCh sr) f = ThenVLChSym1 plCh prCh sr f++type ThenVLChSym1+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> Char -> Either sl sr ~> Result (Either sl sr) rr+data ThenVLChSym1 plCh prCh sr ch s+type instance App (ThenVLChSym1 plCh prCh sr ch) s = ThenVLCh plCh prCh sr ch s++type ThenVLEndSym+    :: ParserEndSym sr rr+    -> ParserEndSym (Either sl sr) rr+data ThenVLEndSym prEnd s+type instance App (ThenVLEndSym prEnd) s = ThenVLEnd prEnd s
+ src/Data/Type/Symbol/Parser/Parser/Then/VoidRight.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.Symbol.Parser.Parser.Then.VoidRight ( ThenVR ) where++import Data.Type.Symbol.Parser.Types+import GHC.TypeLits+import DeFun.Core ( type (~>), type (@@), type App )++type ThenVR+    :: Parser sl rl+    -> Parser sr rr+    -> Parser (Either sl (rl, sr)) rl+type family ThenVR pl pr where+    ThenVR '(plCh, plEnd, sl) '(prCh, prEnd, sr) =+        '(ThenVRChSym plCh prCh sr, ThenVREndSym prEnd, Left sl)++type ThenVRCh+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> ParserCh (Either sl (rl, sr)) rl+type family ThenVRCh plCh prCh sr ch s where+    ThenVRCh plCh prCh sr ch (Left  sl) =+        ThenVRL sr (plCh @@ ch @@ sl)+    ThenVRCh plCh prCh _  ch (Right '(rl, sr)) =+        ThenVRR rl (prCh @@ ch @@ sr)++type family ThenVRL sr resl where+    ThenVRL sr (Err  el) = Err  (EIn "ThenVR(L)" el)+    ThenVRL sr (Cont sl) = Cont (Left  sl)+    ThenVRL sr (Done rl) = Cont (Right '(rl, sr))++type family ThenVRR rl resr where+    ThenVRR rl (Err  er) = Err  (EIn "ThenVR(R)" er)+    ThenVRR rl (Cont sr) = Cont (Right '(rl, sr))+    ThenVRR rl (Done rr) = Done rl++type family ThenVREnd prEnd s where+    ThenVREnd prEnd (Left  sl) =+        Left (EBase "ThenVR" (Text "ended during left"))+    ThenVREnd prEnd (Right '(rl, sr)) =+        ThenVREnd' rl (prEnd @@ sr)++type family ThenVREnd' rl s where+    ThenVREnd' rl (Left  er) = Left  (EIn "ThenVR(R)" er)+    ThenVREnd' rl (Right rr) = Right rl++type ThenVRChSym+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> ParserChSym (Either sl (rl, sr)) rl+data ThenVRChSym plCh prCh sr f+type instance App (ThenVRChSym plCh prCh sr) f = ThenVRChSym1 plCh prCh sr f++type ThenVRChSym1+    :: ParserChSym sl rl+    -> ParserChSym sr rr+    -> sr+    -> Char -> Either sl (rl, sr) ~> Result (Either sl (rl, sr)) rl+data ThenVRChSym1 plCh prCh sr ch s+type instance App (ThenVRChSym1 plCh prCh sr ch) s = ThenVRCh plCh prCh sr ch s++type ThenVREndSym+    :: ParserEndSym sr rr+    -> ParserEndSym (Either sl (rl, sr)) rl+data ThenVREndSym prEnd s+type instance App (ThenVREndSym prEnd) s = ThenVREnd prEnd s
+ src/Data/Type/Symbol/Parser/Run.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.Symbol.Parser.Run ( Run ) where++import Data.Type.Symbol.Parser.Types+import GHC.TypeLits+import DeFun.Core ( type (@@) )++-- | Run the given parser on the given 'Symbol'.+type Run :: Parser s r -> Symbol -> Either ErrorMessage (r, Symbol)+type family Run p sym where+    Run '(pCh, pEnd, s) sym =+        MapLeftPrettyERun (RunStart pCh pEnd s (UnconsSymbol sym))++type family RunStart pCh pEnd s msym where+    -- | Parsing non-empty string: call main loop+    RunStart pCh pEnd s (Just '(ch, sym)) =+        RunCh pCh pEnd 0 ch (UnconsSymbol sym) (pCh @@ ch @@ s)++    -- | Parsing empty string: call special early exit+    RunStart pCh pEnd s Nothing           = RunEnd0 (pEnd @@ s)++-- | Inspect character parser result.+--+-- This is purposely written so that the main case is at the top, and a single+-- equation (we parse, prepare next character and inspect character parser+-- result at the same time). My hope is that this keeps GHC fast.+type family RunCh pCh pEnd idx ch' msym res where+    -- | OK, and more to come: parse next character+    RunCh pCh pEnd idx ch' (Just '(ch, sym)) (Cont s) =+        RunCh pCh pEnd (idx+1) ch (UnconsSymbol sym) (pCh @@ ch @@ s)++    -- | OK, and we're at the end of the string: run end parser+    RunCh pCh pEnd idx ch' Nothing           (Cont s) =+        RunEnd idx ch' (pEnd @@ s)++    -- | OK, and we're finished early: return value and remaining string+    RunCh pCh pEnd idx ch' msym              (Done r) =+        Right '(r, ReconsSymbol msym)++    -- | Parse error: return error+    RunCh pCh pEnd idx ch' msym              (Err  e) =+        Left ('ERun idx ch' e)++-- | Inspect end parser result.+type RunEnd :: Natural -> Char -> Either E r -> Either ERun (r, Symbol)+type family RunEnd idx ch res where+    RunEnd idx ch (Right r) = Right '(r, "")+    RunEnd idx ch (Left  e) = Left ('ERun idx ch e)++-- | Inspect end parser result for the empty string, where we have no previous+--   character or (meaningful) index.+type family RunEnd0 res where+    RunEnd0 (Right r) = Right '(r, "")+    RunEnd0 (Left  e) = Left (ERun0 e)++type PrettyERun :: ERun -> ErrorMessage+type family PrettyERun e where+    PrettyERun (ERun0 e) = Text "parse error on empty string" :$$: PrettyE e+    PrettyERun ('ERun idx ch e) =+             Text "parse error at index " :<>: ShowType idx+        :<>: Text ", char " :<>: ShowType ch :$$: PrettyE e++type family PrettyE e where+    PrettyE (EBase name emsg)  = Text name :<>: Text ": " :<>: emsg+    PrettyE (EIn   name e) = Text name :<>: Text ": " :<>: PrettyE e++type family MapLeftPrettyERun eea where+    MapLeftPrettyERun (Left  e) = Left (PrettyERun e)+    MapLeftPrettyERun (Right a) = Right a++-- | Re-construct the output from 'UnconsSymbol'.+type family ReconsSymbol msym where+    ReconsSymbol Nothing           = ""+    ReconsSymbol (Just '(ch, sym)) = ConsSymbol ch sym++-- | Error while running parser.+data ERun+  -- | Parser error at index X, character C.+  = ERun Natural Char E++  -- | Parser error on the empty string.+  | ERun0 E
− src/Data/Type/Symbol/Parser/Then.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Data.Type.Symbol.Parser.Then where--import Data.Type.Symbol.Parser.Internal-import GHC.TypeLits-import DeFun.Core ( type (~>), type (@@), type App )--type Then-    :: Parser sl rl-    -> Parser sr rr-    -> Parser (Either sl (rl, sr)) (rl, rr)-type family Then pl pr where-    Then '(plCh, plEnd, sl) '(prCh, prEnd, sr) =-        '(ThenChSym plCh prCh sr, ThenEndSym prEnd, Left sl)--type ThenCh-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> ParserCh (Either sl (rl, sr)) (rl, rr)-type family ThenCh plCh prCh sr ch s where-    ThenCh plCh prCh sr ch (Left  sl) =-        ThenL sr (plCh @@ ch @@ sl)-    ThenCh plCh prCh _  ch (Right '(rl, sr)) =-        ThenR rl (prCh @@ ch @@ sr)--type family ThenL sr resl where-    ThenL sr (Err  el) = Err  (Text "then: left error" :$$: el)-    ThenL sr (Cont sl) = Cont (Left  sl)-    ThenL sr (Done rl) = Cont (Right '(rl, sr))--type family ThenR rl resr where-    ThenR rl (Err  er) = Err  (Text "then: right error" :$$: er)-    ThenR rl (Cont sr) = Cont (Right '(rl, sr))-    ThenR rl (Done rr) = Done '(rl, rr)--type family ThenEnd prEnd s where-    ThenEnd prEnd (Left sl) = Left (Text "then: ended during left")-    ThenEnd prEnd (Right '(rl, sr)) =-        ThenEnd' rl (prEnd @@ sr)--type family ThenEnd' rl s where-    ThenEnd' rl (Left  er) = Left  (Text "then: right end error" :$$: er)-    ThenEnd' rl (Right rr) = Right '(rl, rr)--type ThenChSym-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> ParserChSym (Either sl (rl, sr)) (rl, rr)-data ThenChSym plCh prCh sr f-type instance App (ThenChSym plCh prCh sr) f = ThenChSym1 plCh prCh sr f--type ThenChSym1-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> Char -> Either sl (rl, sr) ~> Result (Either sl (rl, sr)) (rl, rr)-data ThenChSym1 plCh prCh sr ch s-type instance App (ThenChSym1 plCh prCh sr ch) s = ThenCh plCh prCh sr ch s--type ThenEndSym-    :: ParserEndSym sr rr-    -> ParserEndSym (Either sl (rl, sr)) (rl, rr)-data ThenEndSym prEnd s-type instance App (ThenEndSym prEnd) s = ThenEnd prEnd s
− src/Data/Type/Symbol/Parser/Then/VoidLeft.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Data.Type.Symbol.Parser.Then.VoidLeft where--import Data.Type.Symbol.Parser.Internal-import GHC.TypeLits-import DeFun.Core ( type (~>), type (@@), type App )--type ThenVL-    :: Parser sl rl-    -> Parser sr rr-    -> Parser (Either sl sr) rr-type family ThenVL pl pr where-    ThenVL '(plCh, plEnd, sl) '(prCh, prEnd, sr) =-        '(ThenVLChSym plCh prCh sr, ThenVLEndSym prEnd, Left sl)--type ThenVLCh-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> ParserCh (Either sl sr) rr-type family ThenVLCh plCh prCh sr ch s where-    ThenVLCh plCh prCh sr ch (Left  sl) =-        ThenVLL sr (plCh @@ ch @@ sl)-    ThenVLCh plCh prCh _  ch (Right sr) =-        ThenVLR (prCh @@ ch @@ sr)--type family ThenVLL sr resl where-    ThenVLL sr (Err  el) = Err  (Text "thenvl: left error" :$$: el)-    ThenVLL sr (Cont sl) = Cont (Left  sl)-    ThenVLL sr (Done rl) = Cont (Right sr)--type family ThenVLR resr where-    ThenVLR (Err  er) = Err  (Text "thenvl: right error" :$$: er)-    ThenVLR (Cont sr) = Cont (Right sr)-    ThenVLR (Done rr) = Done rr--type family ThenVLEnd prEnd s where-    ThenVLEnd prEnd (Left  sl) = Left (Text "thenvl: ended during left")-    ThenVLEnd prEnd (Right sr) = ThenVLEnd' (prEnd @@ sr)--type family ThenVLEnd' s where-    ThenVLEnd' (Left  er) = Left  (Text "thenvl: right end error" :$$: er)-    ThenVLEnd' (Right rr) = Right rr--type ThenVLChSym-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> ParserChSym (Either sl sr) rr-data ThenVLChSym plCh prCh sr f-type instance App (ThenVLChSym plCh prCh sr) f = ThenVLChSym1 plCh prCh sr f--type ThenVLChSym1-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> Char -> Either sl sr ~> Result (Either sl sr) rr-data ThenVLChSym1 plCh prCh sr ch s-type instance App (ThenVLChSym1 plCh prCh sr ch) s = ThenVLCh plCh prCh sr ch s--type ThenVLEndSym-    :: ParserEndSym sr rr-    -> ParserEndSym (Either sl sr) rr-data ThenVLEndSym prEnd s-type instance App (ThenVLEndSym prEnd) s = ThenVLEnd prEnd s
− src/Data/Type/Symbol/Parser/Then/VoidRight.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Data.Type.Symbol.Parser.Then.VoidRight where--import Data.Type.Symbol.Parser.Internal-import GHC.TypeLits-import DeFun.Core ( type (~>), type (@@), type App )--type ThenVR-    :: Parser sl rl-    -> Parser sr rr-    -> Parser (Either sl (rl, sr)) rl-type family ThenVR pl pr where-    ThenVR '(plCh, plEnd, sl) '(prCh, prEnd, sr) =-        '(ThenVRChSym plCh prCh sr, ThenVREndSym prEnd, Left sl)--type ThenVRCh-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> ParserCh (Either sl (rl, sr)) rl-type family ThenVRCh plCh prCh sr ch s where-    ThenVRCh plCh prCh sr ch (Left  sl) =-        ThenVRL sr (plCh @@ ch @@ sl)-    ThenVRCh plCh prCh _  ch (Right '(rl, sr)) =-        ThenVRR rl (prCh @@ ch @@ sr)--type family ThenVRL sr resl where-    ThenVRL sr (Err  el) = Err  (Text "then: left error" :$$: el)-    ThenVRL sr (Cont sl) = Cont (Left  sl)-    ThenVRL sr (Done rl) = Cont (Right '(rl, sr))--type family ThenVRR rl resr where-    ThenVRR rl (Err  er) = Err  (Text "then: right error" :$$: er)-    ThenVRR rl (Cont sr) = Cont (Right '(rl, sr))-    ThenVRR rl (Done rr) = Done rl--type family ThenVREnd prEnd s where-    ThenVREnd prEnd (Left  sl) = Left (Text "thenvr: ended during left")-    ThenVREnd prEnd (Right '(rl, sr)) =-        ThenVREnd' rl (prEnd @@ sr)--type family ThenVREnd' rl s where-    ThenVREnd' rl (Left  er) = Left  (Text "thenvr: right end error" :$$: er)-    ThenVREnd' rl (Right rr) = Right rl--type ThenVRChSym-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> ParserChSym (Either sl (rl, sr)) rl-data ThenVRChSym plCh prCh sr f-type instance App (ThenVRChSym plCh prCh sr) f = ThenVRChSym1 plCh prCh sr f--type ThenVRChSym1-    :: ParserChSym sl rl-    -> ParserChSym sr rr-    -> sr-    -> Char -> Either sl (rl, sr) ~> Result (Either sl (rl, sr)) rl-data ThenVRChSym1 plCh prCh sr ch s-type instance App (ThenVRChSym1 plCh prCh sr ch) s = ThenVRCh plCh prCh sr ch s--type ThenVREndSym-    :: ParserEndSym sr rr-    -> ParserEndSym (Either sl (rl, sr)) rl-data ThenVREndSym prEnd s-type instance App (ThenVREndSym prEnd) s = ThenVREnd prEnd s
+ src/Data/Type/Symbol/Parser/Types.hs view
@@ -0,0 +1,59 @@+-- | Data types and type synonyms for parsers and their defun symbols.++module Data.Type.Symbol.Parser.Types+  (+  -- * Parsers+    ParserCh+  , Result(..)+  , ParserEnd+  , E(..)++  -- * Defun symbols+  , Parser+  , ParserChSym+  , ParserEndSym+  ) where++import GHC.TypeLits+import DeFun.Core ( type (~>) )++-- | Parse a 'Char' with the given state.+--+-- The action is always consuming. For this reason, you may need to look ahead+-- for the final case, so as to not consume an extra 'Char'. This prevents many+-- zero-length parsers. It's a bit weird. See+-- 'Data.Type.Symbol.Parser.Parser.Drop' for an example.+type ParserCh  s r = Char -> s -> Result s r++-- | The result of a single step of a parser.+data Result s r+  = Cont s -- ^ OK, continue with the given state+  | Done r -- ^ OK, parse successful with result @r@+  | Err  E -- ^ parse error++-- | What a parser should do at the end of a 'Symbol'.+type ParserEnd s r = s -> Either E r++-- | Parser error.+data E+  -- | Base parser error.+  = EBase+        Symbol       -- ^ parser name+        ErrorMessage -- ^ error message++  -- | Inner parser error inside combinator.+  | EIn+        Symbol -- ^ combinator name+        E      -- ^ inner error++-- | A parser you can pass (heh) around.+--+-- Parsers are defined by the product of a 'ParserCh' character parser,+-- 'ParserEnd' end handler, and 's' starting state.+type Parser s r = (ParserChSym s r, ParserEndSym s r, s)++-- | A defunctionalization symbol for a 'ParserCh'.+type ParserChSym s r = Char ~> s ~> Result s r++-- | A defunctionalization symbol for a 'ParserEnd'.+type ParserEndSym s r = s ~> Either E r
symbol-parser.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           symbol-parser-version:        0.2.0+version:        0.3.0 synopsis:       Type level string parser combinators description:    Please see README.md. category:       Types, Data@@ -32,16 +32,21 @@ library   exposed-modules:       Data.Type.Char.Digits+      Data.Type.List       Data.Type.Symbol.Parser-      Data.Type.Symbol.Parser.Drop-      Data.Type.Symbol.Parser.End-      Data.Type.Symbol.Parser.Internal-      Data.Type.Symbol.Parser.Isolate-      Data.Type.Symbol.Parser.Literal-      Data.Type.Symbol.Parser.Natural-      Data.Type.Symbol.Parser.Then-      Data.Type.Symbol.Parser.Then.VoidLeft-      Data.Type.Symbol.Parser.Then.VoidRight+      Data.Type.Symbol.Parser.Common+      Data.Type.Symbol.Parser.Parser.Drop+      Data.Type.Symbol.Parser.Parser.End+      Data.Type.Symbol.Parser.Parser.Isolate+      Data.Type.Symbol.Parser.Parser.Literal+      Data.Type.Symbol.Parser.Parser.Natural+      Data.Type.Symbol.Parser.Parser.Or+      Data.Type.Symbol.Parser.Parser.Take+      Data.Type.Symbol.Parser.Parser.Then+      Data.Type.Symbol.Parser.Parser.Then.VoidLeft+      Data.Type.Symbol.Parser.Parser.Then.VoidRight+      Data.Type.Symbol.Parser.Run+      Data.Type.Symbol.Parser.Types   other-modules:       Paths_symbol_parser   hs-source-dirs:@@ -61,4 +66,30 @@   build-depends:       base >=4.16 && <5     , defun-core ==0.1.*+  default-language: GHC2021++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_symbol_parser+  hs-source-dirs:+      test+  default-extensions:+      LambdaCase+      NoStarIsType+      DerivingVia+      DeriveAnyClass+      GADTs+      RoleAnnotations+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+  ghc-options: -Wall -Wno-unticked-promoted-constructors+  build-depends:+      base >=4.16 && <5+    , defun-core ==0.1.*+    , symbol-parser+    , type-spec >=0.4.0.0 && <0.5   default-language: GHC2021
+ test/Main.hs view
@@ -0,0 +1,23 @@+module Main where++import Test.TypeSpec+import Data.Type.Symbol.Parser++main :: IO ()+main = print spec++-- The type errors for failures are HILARIOUS if you're into that sort of thing.+-- Try messing with a test or two and see mad GHC gets!++type CstrX_Y =+          (Literal "Cstr" :*>: Isolate 2 NatDec)+    :<*>: (Literal "_"    :*>: Isolate 2 NatHex)++spec :: Expect+    '[ Run (Literal "raehik") "raehik" `Is` Right '( '(), "")+     , Run (Literal "raeh") "raehraeh" `Is` Right '( '(), "raeh")+     , Run (Drop 3 :*>: Literal "HI") "...HI" `Is` Right '( '(), "")+     , Run (Literal "0x" :*>: NatHex) "0xfF" `Is` Right '( 255, "")+     , Run CstrX_Y "Cstr12_AB" `Is` Right '( '(12, 0xAB), "")+     ]+spec = Valid