symbol-parser (empty) → 0.1.0
raw patch · 15 files changed
+779/−0 lines, 15 filesdep +basedep +defun-core
Dependencies added: base, defun-core
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- README.md +45/−0
- src/Data/Type/Char/Digits.hs +67/−0
- src/Data/Type/Symbol.hs +12/−0
- src/Data/Type/Symbol/Natural.hs +120/−0
- src/Data/Type/Symbol/Parser.hs +35/−0
- src/Data/Type/Symbol/Parser/Drop.hs +35/−0
- src/Data/Type/Symbol/Parser/Internal.hs +40/−0
- src/Data/Type/Symbol/Parser/Isolate.hs +69/−0
- src/Data/Type/Symbol/Parser/Natural.hs +72/−0
- src/Data/Type/Symbol/Parser/Then.hs +67/−0
- src/Data/Type/Symbol/Parser/Then/VoidLeft.hs +66/−0
- src/Data/Type/Symbol/Parser/Then/VoidRight.hs +67/−0
- symbol-parser.cabal +59/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## 0.1.0 (2024-04-17)+Initial release.++ * basic combinators: `Drop`, `Isolate`, `NatHex` (etc.), sequencing+ * acceptable error messages
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2024 Ben Orchard (@raehik) <thefirstmuffinman@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,45 @@+# symbol-parser+Type level string (`Symbol`) parser combinators with nice error messages.++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!!!++## Examples+```haskell+ghci> import Data.Type.Symbol.Parser+ghci> :k! RunParser (Drop 3 :*>: Isolate 2 NatDec :<*>: (Drop 3 :*>: NatHex)) "___10___FF"+...+= Right '( '(10, 255), "")+```++## Design+[defun-core-hackage]: https://hackage.haskell.org/package/defun-core++```haskell+type Parser s r = Char -> s -> Result s r+data Result s r = Cont s | Done r | Err ErrorMessage+```++`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.++We pass parsers around via defunctionalization symbols. The plumbing here is+provided by Oleg's fantastic [defun-core][hackage-defun-core].++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.++## 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.++## I want to help+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).++## License+Provided under the MIT license. See `LICENSE` for license text.
+ src/Data/Type/Char/Digits.hs view
@@ -0,0 +1,67 @@+{- | Parse digits from type-level 'Char's.++A 'Nothing' indicates the given 'Char' was not a valid digit for the given base.+-}+module Data.Type.Char.Digits where++import GHC.TypeLits++-- | Parse a binary digit (0 or 1).+type family ParseBinaryDigit (ch :: Char) :: Maybe Natural where+ ParseBinaryDigit '0' = 'Just 0+ ParseBinaryDigit '1' = 'Just 1+ ParseBinaryDigit _ = 'Nothing++-- | Parse an octal digit (0-7).+type family ParseOctalDigit (ch :: Char) :: Maybe Natural where+ ParseOctalDigit '0' = 'Just 0+ ParseOctalDigit '1' = 'Just 1+ ParseOctalDigit '2' = 'Just 2+ ParseOctalDigit '3' = 'Just 3+ ParseOctalDigit '4' = 'Just 4+ ParseOctalDigit '5' = 'Just 5+ ParseOctalDigit '6' = 'Just 6+ ParseOctalDigit '7' = 'Just 7+ ParseOctalDigit _ = 'Nothing++-- | Parse a decimal digit (0-9).+type family ParseDecimalDigit (ch :: Char) :: Maybe Natural where+ ParseDecimalDigit '0' = 'Just 0+ ParseDecimalDigit '1' = 'Just 1+ ParseDecimalDigit '2' = 'Just 2+ ParseDecimalDigit '3' = 'Just 3+ ParseDecimalDigit '4' = 'Just 4+ ParseDecimalDigit '5' = 'Just 5+ ParseDecimalDigit '6' = 'Just 6+ ParseDecimalDigit '7' = 'Just 7+ ParseDecimalDigit '8' = 'Just 8+ ParseDecimalDigit '9' = 'Just 9+ ParseDecimalDigit _ = 'Nothing++-- | Parse a hexadecimal digit (0-9A-Fa-f).+--+-- Both upper and lower case are permitted.+type family ParseHexDigit (ch :: Char) :: Maybe Natural where+ ParseHexDigit '0' = 'Just 0+ ParseHexDigit '1' = 'Just 1+ ParseHexDigit '2' = 'Just 2+ ParseHexDigit '3' = 'Just 3+ ParseHexDigit '4' = 'Just 4+ ParseHexDigit '5' = 'Just 5+ ParseHexDigit '6' = 'Just 6+ ParseHexDigit '7' = 'Just 7+ ParseHexDigit '8' = 'Just 8+ ParseHexDigit '9' = 'Just 9+ ParseHexDigit 'a' = 'Just 10+ ParseHexDigit 'A' = 'Just 10+ ParseHexDigit 'b' = 'Just 11+ ParseHexDigit 'B' = 'Just 11+ ParseHexDigit 'c' = 'Just 12+ ParseHexDigit 'C' = 'Just 12+ ParseHexDigit 'd' = 'Just 13+ ParseHexDigit 'D' = 'Just 13+ ParseHexDigit 'e' = 'Just 14+ ParseHexDigit 'E' = 'Just 14+ ParseHexDigit 'f' = 'Just 15+ ParseHexDigit 'F' = 'Just 15+ ParseHexDigit _ = 'Nothing
+ src/Data/Type/Symbol.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE UndecidableInstances #-}++module Data.Type.Symbol where++import GHC.TypeLits++-- | Get the length of a symbol.+type Length sym = Length' 0 (UnconsSymbol sym)++type family Length' len mchsym where+ Length' len 'Nothing = len+ Length' len ('Just '(_, sym)) = Length' (len+1) (UnconsSymbol sym)
+ src/Data/Type/Symbol/Natural.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE UndecidableInstances #-}++{- | Parse 'Natural's from type-level 'Symbol's.++The type functions here may return errors. Use the provided and throw with+'TypeError', or wrap in your own error handling.++TODO++ * Oh dear. Oh dear. Oh dear. If I want to get proper working composition with+ meaningful errors, where the index pays attention to what we Drop... then I+ need to write a type-level parser monad. That's it. These parsers need to+ take in parser state (well, just character index is OK), and emit that state+ on success. Oh dear. Oh no.+-}++module Data.Type.Symbol.Natural where++import Data.Type.Char.Digits+import GHC.TypeLits+import Data.Type.Bool ( type If )+import Data.Type.Equality ( type (==) )+import DeFun.Core ( type (~>), type App, type (@@) )+import Data.Type.Symbol ( type Length )++-- | Parse a 'Symbol' describing a binary (base 2) natural+-- to its 'Natural' value.+type ParseBinarySymbol sym = ParseSymbolDigits 2 ParseBinaryDigitSym sym++-- | Parse a 'Symbol' describing an octal (base 8) natural+-- to its 'Natural' value.+type ParseOctalSymbol sym = ParseSymbolDigits 8 ParseOctalDigitSym sym++-- | Parse a 'Symbol' describing a decimal (base 10) natural+-- to its 'Natural' value.+type ParseDecimalSymbol sym = ParseSymbolDigits 10 ParseDecimalDigitSym sym++-- | Parse a 'Symbol' describing a hexadecimal (base 16) natural+-- to its 'Natural' value.+type ParseHexSymbol sym = ParseSymbolDigits 16 ParseHexDigitSym sym++type family PrettyE e where+ PrettyE 'EEmptySymbol = 'Text "empty symbol"+ PrettyE ('EBadDigit base ch idx) = PrettyEBadDigit base ch idx++type family MapLeftPrettyE e where+ MapLeftPrettyE ('Right a) = 'Right a+ MapLeftPrettyE ('Left e) = 'Left (PrettyE e)++type family FromRightParseResult sym eab where+ FromRightParseResult _ ('Right a) = a+ FromRightParseResult sym ('Left e) = TypeError+ ( 'Text "error while parsing symbol: " :<>: 'Text sym+ :$$: PrettyE e+ )++data E = EBadDigit Natural Char Natural | EEmptySymbol++type PrettyEBadDigit base ch idx =+ 'Text "could not parse character as base "+ :<>: 'ShowType base :<>: 'Text " digit"+ :$$: 'ShowType ch :<>: 'Text " at index " :<>: 'ShowType idx++-- | Parse a symbol to a 'Natural' using the given base and digit parser.+type ParseSymbolDigits base tfDigitValue sym =+ If (Length sym == 0) ('Left 'EEmptySymbol)+ (WrapEBadDigit base+ (ParseSymbolDigits' base tfDigitValue ('Just 0) '\0' 0 (Length sym - 1) (UnconsSymbol sym)))++type family WrapEBadDigit base eab where+ WrapEBadDigit _ ('Right b) = 'Right b+ WrapEBadDigit base ('Left '(ch, sym)) = 'Left ('EBadDigit base ch sym)++type ParseSymbolDigits'+ :: Natural {- ^ base -}+ -> (Char ~> Maybe Natural) {- ^ digit parser (defun symbol) -}+ -> Maybe Natural {- ^ accumulator (Nothing means failure) -}+ -> Char {- ^ previous parsed character -}+ -> Natural {- ^ index in symbol -}+ -> Natural {- ^ current exponent -}+ -> Maybe (Char, Symbol) {- ^ remaining symbol -}+ -> Either (Char, Natural) Natural+type family ParseSymbolDigits' base tfParseDigit mn prevCh idx expo mchsym where+ ParseSymbolDigits' base tfParseDigit ('Just n) prevCh idx expo 'Nothing =+ -- previous digit parsed, no more characters: all done+ 'Right n+ -- note that the above will return 0 for empty symbols!+ -- we could add an equation for that... but it would be inefficient, since+ -- we only need to check once. instead, we handle that outside.+ ParseSymbolDigits' base tfParseDigit 'Nothing prevCh idx expo mchsym =+ -- digit parse error: emit problematic 'Char' and its index+ -- the -1 is clumsy but the easiest way to achieve zero-indexing+ -- safe: we always start with 'Just, so if we get here we're at least 1+ 'Left '(prevCh, idx-1)+ ParseSymbolDigits' base tfParseDigit ('Just n) prevCh idx expo ('Just '(ch, sym)) =+ -- previous digit parsed, characters remaining: parse next digit+ ParseSymbolDigits' base tfParseDigit+ (ParseSymbolDigits'Inc (base^expo) n (tfParseDigit @@ ch))+ ch (idx+1) (expo-1) (UnconsSymbol sym)++-- little helper for incrementing accumulator, or failing to 'Nothing'+type family ParseSymbolDigits'Inc mult n mDigit where+ ParseSymbolDigits'Inc mult n 'Nothing = 'Nothing+ ParseSymbolDigits'Inc mult n ('Just digit) = 'Just (n + digit*mult)++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.hs view
@@ -0,0 +1,35 @@+module Data.Type.Symbol.Parser+ (+ -- * Base definitions+ Parser+ , RunParser++ -- * Parsers+ -- ** Combinators+ , Isolate+ , (:<*>:)+ , (:*>:)+ , (:<*:)++ -- ** Primitives+ , Drop++ -- *** Naturals+ , NatDec+ , NatHex+ , NatBin+ , NatOct+ , 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++type pl :<*>: pr = Then pl pr+type pl :*>: pr = ThenVL pl pr+type pl :<*: pr = ThenVR pl pr
+ src/Data/Type/Symbol/Parser/Drop.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE UndecidableInstances #-}++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/Internal.hs view
@@ -0,0 +1,40 @@+{-# 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 view
@@ -0,0 +1,69 @@+{-# 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/Natural.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE UndecidableInstances #-}++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/Then.hs view
@@ -0,0 +1,67 @@+{-# 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 view
@@ -0,0 +1,66 @@+{-# 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 view
@@ -0,0 +1,67 @@+{-# 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
+ symbol-parser.cabal view
@@ -0,0 +1,59 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name: symbol-parser+version: 0.1.0+synopsis: Type level string parser combinators+description: Please see README.md.+category: Types, Data+homepage: https://github.com/raehik/symbol-parser#readme+bug-reports: https://github.com/raehik/symbol-parser/issues+author: Ben Orchard+maintainer: Ben Orchard <thefirstmuffinman@gmail.com>+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/raehik/symbol-parser++library+ exposed-modules:+ Data.Type.Char.Digits+ Data.Type.Symbol+ Data.Type.Symbol.Natural+ Data.Type.Symbol.Parser+ Data.Type.Symbol.Parser.Drop+ Data.Type.Symbol.Parser.Internal+ Data.Type.Symbol.Parser.Isolate+ Data.Type.Symbol.Parser.Natural+ Data.Type.Symbol.Parser.Then+ Data.Type.Symbol.Parser.Then.VoidLeft+ Data.Type.Symbol.Parser.Then.VoidRight+ other-modules:+ Paths_symbol_parser+ hs-source-dirs:+ src+ default-extensions:+ LambdaCase+ NoStarIsType+ DerivingVia+ DeriveAnyClass+ GADTs+ RoleAnnotations+ DefaultSignatures+ TypeFamilies+ DataKinds+ MagicHash+ ghc-options: -Wall+ build-depends:+ base >=4.14 && <5+ , defun-core ==0.1.*+ default-language: GHC2021