diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## 0.2.0 (2024-04-19) +* add two more combinators: `End`, `Literal` +* remove some old code (`Data.Type.Symbol`, `Data.Type.Symbol.Natural`) +* fix base lower bound (at least base-4.16, == GHC 9.2) +* style: don't tick promoted constructors unless necessary for disambiguation + ## 0.1.0 (2024-04-17) Initial release. diff --git a/src/Data/Type/Char/Digits.hs b/src/Data/Type/Char/Digits.hs --- a/src/Data/Type/Char/Digits.hs +++ b/src/Data/Type/Char/Digits.hs @@ -2,66 +2,67 @@ 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 + 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 + 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 + 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 + 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 diff --git a/src/Data/Type/Symbol.hs b/src/Data/Type/Symbol.hs deleted file mode 100644 --- a/src/Data/Type/Symbol.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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) diff --git a/src/Data/Type/Symbol/Natural.hs b/src/Data/Type/Symbol/Natural.hs deleted file mode 100644 --- a/src/Data/Type/Symbol/Natural.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# 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 diff --git a/src/Data/Type/Symbol/Parser.hs b/src/Data/Type/Symbol/Parser.hs --- a/src/Data/Type/Symbol/Parser.hs +++ b/src/Data/Type/Symbol/Parser.hs @@ -13,6 +13,8 @@ -- ** Primitives , Drop + , Literal + , End -- *** Naturals , NatDec @@ -29,7 +31,17 @@ 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 +-- | Sequence parsers, returning both values in a tuple. type pl :<*>: pr = Then pl pr + +-- | Sequence parsers, discarding the return value of the left parser type pl :*>: pr = ThenVL pl pr + +-- | Sequence parsers, discarding the return value of the right parser. +-- +-- Consider using ':*>:' instead, which is simpler and potentially faster since +-- we parse L->R. type pl :<*: pr = ThenVR pl pr diff --git a/src/Data/Type/Symbol/Parser/Drop.hs b/src/Data/Type/Symbol/Parser/Drop.hs --- a/src/Data/Type/Symbol/Parser/Drop.hs +++ b/src/Data/Type/Symbol/Parser/Drop.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- for natural subtraction module Data.Type.Symbol.Parser.Drop ( type Drop ) where @@ -11,16 +11,16 @@ 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) + 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") + DropEnd 0 = Right '() + DropEnd n = Left + ( Text "tried to drop " + :<>: ShowType n :<>: Text " chars from empty symbol") type DropChSym :: ParserChSym Natural () data DropChSym f diff --git a/src/Data/Type/Symbol/Parser/End.hs b/src/Data/Type/Symbol/Parser/End.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Symbol/Parser/End.hs @@ -0,0 +1,29 @@ +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 '() diff --git a/src/Data/Type/Symbol/Parser/Internal.hs b/src/Data/Type/Symbol/Parser/Internal.hs --- a/src/Data/Type/Symbol/Parser/Internal.hs +++ b/src/Data/Type/Symbol/Parser/Internal.hs @@ -20,19 +20,19 @@ -- 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 = + RunParser' pCh pEnd idx s Nothing = RunParserEnd idx (pEnd @@ s) - RunParser' pCh pEnd idx s ('Just '(ch, sym)) = + 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, "") + 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 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 diff --git a/src/Data/Type/Symbol/Parser/Isolate.hs b/src/Data/Type/Symbol/Parser/Isolate.hs --- a/src/Data/Type/Symbol/Parser/Isolate.hs +++ b/src/Data/Type/Symbol/Parser/Isolate.hs @@ -18,7 +18,7 @@ -> 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") + 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) @@ -26,29 +26,29 @@ --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) + 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 + 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 _) = + 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) + 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 '(0, s) = Right '(0, s) IsolateEnd '(n, s) = -- TODO - 'Left ('Text "isolate wanted more than was there") + Left (Text "isolate wanted more than was there") type IsolateChSym :: ParserChSym s r diff --git a/src/Data/Type/Symbol/Parser/Literal.hs b/src/Data/Type/Symbol/Parser/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Symbol/Parser/Literal.hs @@ -0,0 +1,36 @@ +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 diff --git a/src/Data/Type/Symbol/Parser/Natural.hs b/src/Data/Type/Symbol/Parser/Natural.hs --- a/src/Data/Type/Symbol/Parser/Natural.hs +++ b/src/Data/Type/Symbol/Parser/Natural.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- for natural multiplication etc. module Data.Type.Symbol.Parser.Natural where @@ -26,12 +26,12 @@ 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) + 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 NatBaseEnd n = Right n type NatBaseChSym :: Natural @@ -69,4 +69,3 @@ type ParseHexDigitSym :: Char ~> Maybe Natural data ParseHexDigitSym a type instance App ParseHexDigitSym a = ParseHexDigit a - diff --git a/src/Data/Type/Symbol/Parser/Then.hs b/src/Data/Type/Symbol/Parser/Then.hs --- a/src/Data/Type/Symbol/Parser/Then.hs +++ b/src/Data/Type/Symbol/Parser/Then.hs @@ -12,7 +12,7 @@ -> 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) + '(ThenChSym plCh prCh sr, ThenEndSym prEnd, Left sl) type ThenCh :: ParserChSym sl rl @@ -20,29 +20,29 @@ -> sr -> ParserCh (Either sl (rl, sr)) (rl, rr) type family ThenCh plCh prCh sr ch s where - ThenCh plCh prCh sr ch ('Left sl) = + ThenCh plCh prCh sr ch (Left sl) = ThenL sr (plCh @@ ch @@ sl) - ThenCh plCh prCh _ ch ('Right '(rl, sr)) = + 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)) + 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) + 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 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) + ThenEnd' rl (Left er) = Left (Text "then: right end error" :$$: er) + ThenEnd' rl (Right rr) = Right '(rl, rr) type ThenChSym :: ParserChSym sl rl diff --git a/src/Data/Type/Symbol/Parser/Then/VoidLeft.hs b/src/Data/Type/Symbol/Parser/Then/VoidLeft.hs --- a/src/Data/Type/Symbol/Parser/Then/VoidLeft.hs +++ b/src/Data/Type/Symbol/Parser/Then/VoidLeft.hs @@ -12,7 +12,7 @@ -> 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) + '(ThenVLChSym plCh prCh sr, ThenVLEndSym prEnd, Left sl) type ThenVLCh :: ParserChSym sl rl @@ -20,28 +20,28 @@ -> sr -> ParserCh (Either sl sr) rr type family ThenVLCh plCh prCh sr ch s where - ThenVLCh plCh prCh sr ch ('Left sl) = + ThenVLCh plCh prCh sr ch (Left sl) = ThenVLL sr (plCh @@ ch @@ sl) - ThenVLCh plCh prCh _ ch ('Right sr) = + 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) + 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 + 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) + 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 + ThenVLEnd' (Left er) = Left (Text "thenvl: right end error" :$$: er) + ThenVLEnd' (Right rr) = Right rr type ThenVLChSym :: ParserChSym sl rl diff --git a/src/Data/Type/Symbol/Parser/Then/VoidRight.hs b/src/Data/Type/Symbol/Parser/Then/VoidRight.hs --- a/src/Data/Type/Symbol/Parser/Then/VoidRight.hs +++ b/src/Data/Type/Symbol/Parser/Then/VoidRight.hs @@ -12,7 +12,7 @@ -> 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) + '(ThenVRChSym plCh prCh sr, ThenVREndSym prEnd, Left sl) type ThenVRCh :: ParserChSym sl rl @@ -20,29 +20,29 @@ -> sr -> ParserCh (Either sl (rl, sr)) rl type family ThenVRCh plCh prCh sr ch s where - ThenVRCh plCh prCh sr ch ('Left sl) = + ThenVRCh plCh prCh sr ch (Left sl) = ThenVRL sr (plCh @@ ch @@ sl) - ThenVRCh plCh prCh _ ch ('Right '(rl, sr)) = + 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)) + 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 + 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 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 + ThenVREnd' rl (Left er) = Left (Text "thenvr: right end error" :$$: er) + ThenVREnd' rl (Right rr) = Right rl type ThenVRChSym :: ParserChSym sl rl diff --git a/symbol-parser.cabal b/symbol-parser.cabal --- a/symbol-parser.cabal +++ b/symbol-parser.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: symbol-parser -version: 0.1.0 +version: 0.2.0 synopsis: Type level string parser combinators description: Please see README.md. category: Types, Data @@ -16,6 +16,11 @@ license: MIT license-file: LICENSE build-type: Simple +tested-with: + GHC==9.8 + , GHC==9.6 + , GHC==9.4 + , GHC==9.2 extra-source-files: README.md CHANGELOG.md @@ -27,12 +32,12 @@ 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.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 @@ -52,8 +57,8 @@ TypeFamilies DataKinds MagicHash - ghc-options: -Wall + ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: - base >=4.14 && <5 + base >=4.16 && <5 , defun-core ==0.1.* default-language: GHC2021