doc: clarify the scope of HideName instances
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Combinators.hs
index 327db0926ab3ab314f049b174723c508c5997968..9282027edb864bb464fceb227cf4bfef8bc42934 100644 (file)
 -- The default type signature of type class methods are changed
--- to introduce a Liftable constraint and the same type class but on the 'Output' repr,
+-- to introduce a 'LiftDerived'* constraint and the same type class but on the 'Derived' repr,
 -- this setup avoids to define the method with boilerplate code when its default
--- definition with lift* and 'trans' does what is expected by an instance
+-- definition with 'liftDerived'* and 'derive' does what is expected by an instance
 -- of the type class. This is almost as explained in:
 -- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveLift #-} -- For TH.Lift (ErrorItem tok)
-{-# LANGUAGE StandaloneDeriving #-} -- For Show (ErrorItem (InputToken inp))
+{-# LANGUAGE DeriveGeneric #-} -- For NFData instances
+{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
+{-# LANGUAGE DeriveLift #-} -- For TH.Lift (Exception tok)
+{-# LANGUAGE DerivingStrategies #-} -- For UnscopedRegister
+{-# LANGUAGE PatternSynonyms #-} -- For Failure
+{-# LANGUAGE StandaloneDeriving #-} -- For Show (Exception (InputToken inp))
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-} -- For unSomeFailure
+-- | Semantic of the grammar combinators used to express parsers,
+-- in the convenient tagless-final encoding.
 module Symantic.Parser.Grammar.Combinators where
 
+import Data.Proxy (Proxy(..))
+import Control.Monad (Monad(..))
+import Control.DeepSeq (NFData(..))
+import GHC.Generics (Generic)
+-- import Data.Set (Set)
+-- import GHC.TypeLits (KnownSymbol)
+import Data.Bifunctor (second)
 import Data.Bool (Bool(..), not, (||))
 import Data.Char (Char)
 import Data.Either (Either(..))
 import Data.Eq (Eq(..))
-import Data.Function ((.), flip, const)
+import Data.Function ((.), flip, const, fix)
+import Data.Ord (Ord(..), Ordering(..))
 import Data.Int (Int)
+import Data.Kind (Type, Constraint)
 import Data.Maybe (Maybe(..))
-import Data.Ord (Ord)
+import Data.Set (Set)
 import Data.String (String)
 import Text.Show (Show(..))
+import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..), SomeTypeRep(..))
 import qualified Data.Functor as Functor
 import qualified Data.List as List
+import qualified Data.Set as Set
 import qualified Language.Haskell.TH as TH
 import qualified Language.Haskell.TH.Syntax as TH
 
-import qualified Symantic.Univariant.Trans as Sym
-import qualified Symantic.Parser.Haskell as H
+import Symantic.Syntaxes.Derive
+import qualified Symantic.Syntaxes.Classes as Prod
+import Symantic.Parser.Grammar.Production
+
+-- * Type 'ReprComb'
+type ReprComb = Type -> Type
+
+-- * Class 'CombAlternable'
+class CombAlternable repr where
+  -- | @('alt' es l r)@ parses @(l)@ and return its return value or,
+  -- if it fails with an 'Exception' within @(es)@,
+  -- parses @(r)@ from where @(l)@ has left the input stream,
+  -- and returns its return value,
+  -- otherwise throw the 'Exception' again.
+  alt :: Exception -> repr a -> repr a -> repr a
+  throw :: ExceptionLabel -> repr a
+  -- | @('try' ra)@ records the input stream position,
+  -- then parses like @(ra)@ and either returns its value it it succeeds or fails
+  -- if it fails but with a reset of the input stream to the recorded position.
+  -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
+  try :: repr a -> repr a
+  default alt ::
+    FromDerived2 CombAlternable repr =>
+    Exception -> repr a -> repr a -> repr a
+  default throw ::
+    FromDerived CombAlternable repr =>
+    ExceptionLabel -> repr a
+  default try ::
+    FromDerived1 CombAlternable repr =>
+    repr a -> repr a
+  alt = liftDerived2 . alt
+  throw = liftDerived . throw
+  try = liftDerived1 try
+
+  failure :: SomeFailure -> repr a
+  default failure ::
+    FromDerived CombAlternable repr =>
+    SomeFailure -> repr a
+  failure = liftDerived . failure
+
+  -- | @(empty)@ parses nothing, always failing to return a value.
+  empty :: repr a
+  empty = failure (SomeFailure FailureEmpty)
+
+data instance Failure CombAlternable
+  = FailureEmpty
+  deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
+
+-- ** Data family 'Failure'
+-- | 'Failure's of the 'Grammar'.
+-- This is an extensible data-type.
+data family Failure
+  (comb :: ReprComb -> Constraint)
+  :: Type
+
+{-
+-- | Convenient utility to pattern-match a 'SomeFailure'.
+pattern Failure :: Typeable comb => Failure comb -> SomeFailure
+pattern Failure x <- (unSomeFailure -> Just x)
+-}
+
+-- ** Type 'SomeFailure'
+data SomeFailure =
+  forall comb.
+  ( Eq (Failure comb)
+  , Ord (Failure comb)
+  , Show (Failure comb)
+  , TH.Lift (Failure comb)
+  , NFData (Failure comb)
+  , Typeable comb
+  ) => SomeFailure (Failure comb {-repr a-})
+instance Eq SomeFailure where
+  SomeFailure (x::Failure x) == SomeFailure (y::Failure y) =
+    case typeRep @x `eqTypeRep` typeRep @y of
+      Just HRefl -> x == y
+      Nothing -> False
+instance Ord SomeFailure where
+  SomeFailure (x::Failure x) `compare` SomeFailure (y::Failure y) =
+    -- WARNING: this ordering is convenient to make a 'Set' of 'SomeFailure's
+    -- but it is based upon a hash which changes with packages' ABI
+    -- and also if the install is "inplace" or not.
+    -- Therefore this 'Ord' is not stable enough to put 'SomeFailure'
+    -- in golden tests.
+    let xT = typeRep @x in
+    let yT = typeRep @y in
+    case SomeTypeRep xT `compare` SomeTypeRep yT of
+      EQ | Just HRefl <- xT `eqTypeRep` yT -> compare x y
+      o -> o
+instance Show SomeFailure where
+  showsPrec p (SomeFailure x) = showsPrec p x
+instance TH.Lift SomeFailure where
+  liftTyped (SomeFailure x) = [|| SomeFailure $$(TH.liftTyped x) ||]
+instance NFData SomeFailure where
+  rnf (SomeFailure x) = rnf x
+
+{-
+instance Derivable (SomeFailure repr) where
+  derive (SomeFailure x) = derive x
+-}
+
+-- | @(unSomeFailure c :: 'Maybe' ('Failure' comb repr a))@
+-- extract the data-constructor from the given 'SomeFailure'
+-- iif. it belongs to the @('Failure' comb repr a)@ data-instance.
+unSomeFailure :: forall comb.  Typeable comb => SomeFailure -> Maybe (Failure comb)
+unSomeFailure (SomeFailure (c::Failure c)) =
+  case typeRep @comb `eqTypeRep` typeRep @c of
+    Just HRefl -> Just c
+    Nothing -> Nothing
+
+-- ** Type 'Exception'
+data Exception
+  =  ExceptionLabel ExceptionLabel
+  |  ExceptionFailure
+  -- |  ExceptionEnd
+  deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
+type ExceptionLabel = String
+-- type Exceptions = Set Exception
+
+-- | Like @('<|>')@ but with different returning types for the alternatives,
+-- and a return value wrapped in an 'Either' accordingly.
+(<+>) :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr (Either a b)
+p <+> q = Prod.left <$> p <|> Prod.right <$> q
+
+(<|>) :: CombAlternable repr => repr a -> repr a -> repr a
+(<|>) = alt ExceptionFailure
+
+infixl 3 <|>, <+>
+
+optionally :: CombApplicable repr => CombAlternable repr => repr a -> Production '[] b -> repr b
+optionally p x = p $> x <|> pure x
+
+optional :: CombApplicable repr => CombAlternable repr => repr a -> repr ()
+optional = flip optionally (Prod.constant ())
+
+option :: CombApplicable repr => CombAlternable repr => Production '[] a -> repr a -> repr a
+option x p = p <|> pure x
+
+choice :: CombAlternable repr => [repr a] -> repr a
+choice = List.foldr (<|>) empty
+ -- FIXME: Here hlint suggests to use Data.Foldable.asum,
+ -- but at this point there is no asum for our own (<|>)
 
--- * Type 'TermGrammar'
-type TermGrammar = H.Term H.ValueCode
+maybeP :: CombApplicable repr => CombAlternable repr => repr a -> repr (Maybe a)
+maybeP p = option Prod.nothing (Prod.just <$> p)
 
--- * Class 'Applicable'
+manyTill :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr [a]
+manyTill p end = let go = end $> Prod.nil <|> p <:> go in go
+
+-- * Class 'CombApplicable'
 -- | This is like the usual 'Functor' and 'Applicative' type classes
--- from the @base@ package, but using @('TermGrammar' a)@ instead of just @(a)@
--- to be able to use and pattern match on some usual terms of type @(a)@ (like 'H.id')
+-- from the @base@ package, but using @('Production' vs a)@ instead of just @(a)@
+-- to be able to use and pattern match on some usual terms of type @(a)@ (like 'Prod.id')
 -- and thus apply some optimizations.
 -- @(repr)@, for "representation", is the usual tagless-final abstraction
 -- over the many semantics that this syntax (formed by the methods
 -- of type class like this one) will be interpreted.
-class Applicable repr where
+class CombApplicable repr where
   -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
-  (<$>) :: TermGrammar (a -> b) -> repr a -> repr b
+  (<$>) :: Production '[] (a -> b) -> repr a -> repr b
   (<$>) f = (pure f <*>)
+  (<$>%) :: (Production '[] a -> Production '[] b) -> repr a -> repr b
+  a2b <$>% ma = Prod.lam a2b <$> ma
 
   -- | Like '<$>' but with its arguments 'flip'-ped.
-  (<&>) :: repr a -> TermGrammar (a -> b) -> repr b
+  (<&>) :: repr a -> Production '[] (a -> b) -> repr b
   (<&>) = flip (<$>)
 
   -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
-  (<$) :: TermGrammar a -> repr b -> repr a
+  (<$) :: Production '[] a -> repr b -> repr a
   (<$) x = (pure x <*)
 
   -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
-  ($>) :: repr a -> TermGrammar b -> repr b
+  ($>) :: repr a -> Production '[] b -> repr b
   ($>) = flip (<$)
 
   -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
-  pure :: TermGrammar a -> repr a
+  pure :: Production '[] a -> repr a
   default pure ::
-    Sym.Liftable repr => Applicable (Sym.Output repr) =>
-    TermGrammar a -> repr a
-  pure = Sym.lift . pure
+    FromDerived CombApplicable repr =>
+    Production '[] a -> repr a
+  pure = liftDerived . pure
 
   -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
   -- and returns the application of the function returned by @(ra2b)@
   -- to the value returned by @(ra)@.
   (<*>) :: repr (a -> b) -> repr a -> repr b
   default (<*>) ::
-    Sym.Liftable2 repr => Applicable (Sym.Output repr) =>
+    FromDerived2 CombApplicable repr =>
     repr (a -> b) -> repr a -> repr b
-  (<*>) = Sym.lift2 (<*>)
-
-  -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
-  -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
-  liftA2 :: TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
-  liftA2 f x = (<*>) (f <$> x)
+  (<*>) = liftDerived2 (<*>)
 
   -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
   -- and returns like @(ra)@, discarding the return value of @(rb)@.
   (<*) :: repr a -> repr b -> repr a
-  (<*) = liftA2 H.const
+  (<*) = liftA2 Prod.const
 
   -- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@,
   -- and returns like @(rb)@, discarding the return value of @(ra)@.
   (*>) :: repr a -> repr b -> repr b
-  x *> y = (H.id <$ x) <*> y
+  x *> y = (Prod.id <$ x) <*> y
 
   -- | Like '<*>' but with its arguments 'flip'-ped.
   (<**>) :: repr a -> repr (a -> b) -> repr b
-  (<**>) = liftA2 (H.flip H..@ (H.$))
+  (<**>) = liftA2 (Prod.flip Prod..@ (Prod.$))
   {-
   (<**>) :: repr a -> repr (a -> b) -> repr b
   (<**>) = liftA2 (\a f -> f a)
   -}
-infixl 4 <$>, <&>, <$, $>, <*>, <*, *>, <**>
-
--- * Class 'Alternable'
-class Alternable repr where
-  -- | @(rl '<|>' rr)@ parses @(rl)@ and return its return value or,
-  -- if it fails, parses @(rr)@ from where @(rl)@ has left the input stream,
-  -- and returns its return value.
-  (<|>) :: repr a -> repr a -> repr a
-  -- | @(empty)@ parses nothing, always failing to return a value.
-  empty :: repr a
-  -- | @('try' ra)@ records the input stream position,
-  -- then parses like @(ra)@ and either returns its value it it succeeds or fails
-  -- if it fails but with a reset of the input stream to the recorded position.
-  -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
-  try :: repr a -> repr a
-  default (<|>) ::
-    Sym.Liftable2 repr => Alternable (Sym.Output repr) =>
-    repr a -> repr a -> repr a
-  default empty ::
-    Sym.Liftable repr => Alternable (Sym.Output repr) =>
-    repr a
-  default try ::
-    Sym.Liftable1 repr => Alternable (Sym.Output repr) =>
-    repr a -> repr a
-  (<|>) = Sym.lift2 (<|>)
-  empty = Sym.lift empty
-  try = Sym.lift1 try
-  -- | Like @('<|>')@ but with different returning types for the alternatives,
-  -- and a return value wrapped in an 'Either' accordingly.
-  (<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
-  p <+> q = H.left <$> p <|> H.right <$> q
-infixl 3 <|>, <+>
+  -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
+  -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
+  liftA2 :: Production '[] (a -> b -> c) -> repr a -> repr b -> repr c
+  liftA2 f x = (<*>) (f <$> x)
 
-optionally :: Applicable repr => Alternable repr => repr a -> TermGrammar b -> repr b
-optionally p x = p $> x <|> pure x
+infixl 4 <*>, <*, *>, <**>
+data instance Failure CombApplicable
 
-optional :: Applicable repr => Alternable repr => repr a -> repr ()
-optional = flip optionally H.unit
 
-option :: Applicable repr => Alternable repr => TermGrammar a -> repr a -> repr a
-option x p = p <|> pure x
+{-# INLINE (<:>) #-}
+infixl 4 <:>
+(<:>) :: CombApplicable repr => repr a -> repr [a] -> repr [a]
+(<:>) = liftA2 Prod.cons
 
-choice :: Alternable repr => [repr a] -> repr a
-choice = List.foldr (<|>) empty
- -- FIXME: Here hlint suggests to use Data.Foldable.asum,
- -- but at this point there is no asum for our own (<|>)
+sequence :: CombApplicable repr => [repr a] -> repr [a]
+sequence = List.foldr (<:>) (pure Prod.nil)
 
-maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
-maybeP p = option H.nothing (H.just <$> p)
+traverse :: CombApplicable repr => (a -> repr b) -> [a] -> repr [b]
+traverse f = sequence . List.map f
+ -- FIXME: Here hlint suggests to use Control.Monad.mapM,
+ -- but at this point there is no mapM for our own sequence
 
-manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
-manyTill p end = let go = end $> H.nil <|> p <:> go in go
+repeat :: CombApplicable repr => Int -> repr a -> repr [a]
+repeat n p = traverse (const p) [1..n]
 
--- * Class 'Selectable'
-class Selectable repr where
-  branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
-  default branch ::
-    Sym.Liftable3 repr => Selectable (Sym.Output repr) =>
-    repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
-  branch = Sym.lift3 branch
+between :: CombApplicable repr => repr o -> repr c -> repr a -> repr a
+between open close p = open *> p <* close
 
--- * Class 'Matchable'
-class Matchable repr where
-  conditional ::
-    Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
-  default conditional ::
-    Sym.Unliftable repr => Sym.Liftable1 repr => Matchable (Sym.Output repr) =>
-    Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
-  conditional a ps bs = Sym.lift1 (conditional (Sym.trans a) ps (Sym.trans Functor.<$> bs))
+void :: CombApplicable repr => repr a -> repr ()
+void p = p *> unit
 
-  match :: Eq a => repr a -> [TermGrammar a] -> (TermGrammar a -> repr b) -> repr b -> repr b
-  match a as a2b = conditional a ((H.eq H..@) Functor.<$> as) (a2b Functor.<$> as)
-  -- match a as a2b = conditional a (((H.eq H..@ H.qual) H..@) Functor.<$> as) (a2b Functor.<$> as)
+unit :: CombApplicable repr => repr ()
+unit = pure (Prod.constant ())
 
--- * Class 'Foldable'
-class Foldable repr where
-  chainPre :: repr (a -> a) -> repr a -> repr a
+-- * Class 'CombFoldable'
+class CombFoldable repr where
+  chainPre  :: repr (a -> a) -> repr a -> repr a
   chainPost :: repr a -> repr (a -> a) -> repr a
-  {-
+  chainPre  = liftDerived2 chainPre
+  chainPost = liftDerived2 chainPost
   default chainPre ::
-    Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
+    FromDerived2 CombFoldable repr =>
     repr (a -> a) -> repr a -> repr a
   default chainPost ::
-    Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
+    FromDerived2 CombFoldable repr =>
     repr a -> repr (a -> a) -> repr a
-  chainPre = Sym.lift2 chainPre
-  chainPost = Sym.lift2 chainPost
-  -}
+  {-
   default chainPre ::
-    Applicable repr =>
-    Alternable repr =>
+    CombApplicable repr =>
+    CombAlternable repr =>
     repr (a -> a) -> repr a -> repr a
   default chainPost ::
-    Applicable repr =>
-    Alternable repr =>
+    CombApplicable repr =>
+    CombAlternable repr =>
     repr a -> repr (a -> a) -> repr a
-  chainPre op p = go <*> p
-    where go = (H..) <$> op <*> go <|> pure H.id
-  chainPost p op = p <**> go
-    where go = (H..) <$> op <*> go <|> pure H.id
+  chainPre op p = go <*> p where go = (Prod..) <$> op <*> go <|> pure Prod.id
+  chainPost p op = p <**> go where go = (Prod..) <$> op <*> go <|> pure Prod.id
+  -}
+  {-
+  chainPre op p = flip (foldr ($)) <$> many op <*> p
+  chainPost p op = foldl' (flip ($)) <$> p <*> many op
+  -}
+data instance Failure CombFoldable
 
 {-
-conditional :: Selectable repr => [(TermGrammar (a -> Bool), repr b)] -> repr a -> repr b -> repr b
+conditional :: CombSelectable repr => [(Production '[] (a -> Bool), repr b)] -> repr a -> repr b -> repr b
 conditional cs p def = match p fs qs def
   where (fs, qs) = List.unzip cs
 -}
 
--- * Class 'Satisfiable'
-class Satisfiable tok repr where
-  satisfy :: [ErrorItem tok] -> TermGrammar (tok -> Bool) -> repr tok
-  default satisfy ::
-    Sym.Liftable repr => Satisfiable tok (Sym.Output repr) =>
-    [ErrorItem tok] ->
-    TermGrammar (tok -> Bool) -> repr tok
-  satisfy es = Sym.lift . satisfy es
-
-  item :: repr tok
-  item = satisfy [] (H.const H..@ H.bool True)
-
--- ** Type 'ErrorItem'
-data ErrorItem tok
-  =  ErrorItemToken tok
-  |  ErrorItemLabel String
-  |  ErrorItemHorizon Int
-  |  ErrorItemEnd
-deriving instance Eq tok => Eq (ErrorItem tok)
-deriving instance Ord tok => Ord (ErrorItem tok)
-deriving instance Show tok => Show (ErrorItem tok)
-deriving instance TH.Lift tok => TH.Lift (ErrorItem tok)
-
--- * Class 'Lookable'
-class Lookable repr where
-  look :: repr a -> repr a
-  negLook :: repr a -> repr ()
-  default look :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr a
-  default negLook :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr ()
-  look = Sym.lift1 look
-  negLook = Sym.lift1 negLook
-
-  eof :: repr ()
-  eof = Sym.lift eof
-  default eof :: Sym.Liftable repr => Lookable (Sym.Output repr) => repr ()
-  -- eof = negLook (satisfy @Char [ErrorItemAny] (H.const H..@ H.bool True))
-             -- (item @Char)
-
-{-# INLINE (<:>) #-}
-infixl 4 <:>
-(<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
-(<:>) = liftA2 H.cons
-
-sequence :: Applicable repr => [repr a] -> repr [a]
-sequence = List.foldr (<:>) (pure H.nil)
-
-traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
-traverse f = sequence . List.map f
- -- FIXME: Here hlint suggests to use Control.Monad.mapM,
- -- but at this point there is no mapM for our own sequence
-
-repeat :: Applicable repr => Int -> repr a -> repr [a]
-repeat n p = traverse (const p) [1..n]
-
-between :: Applicable repr => repr o -> repr c -> repr a -> repr a
-between open close p = open *> p <* close
-
-string ::
-  Applicable repr => Alternable repr =>
-  Satisfiable Char repr =>
-  [Char] -> repr [Char]
-string = try . traverse char
-
-oneOf ::
-  TH.Lift tok => Eq tok =>
-  Satisfiable tok repr =>
-  [tok] -> repr tok
-oneOf ts = satisfy [ErrorItemLabel "oneOf"]
-  (Sym.trans H.ValueCode
-    { value = (`List.elem` ts)
-    , code = [||\t -> $$(ofChars ts [||t||])||] })
-
-noneOf ::
-  TH.Lift tok => Eq tok =>
-  Satisfiable tok repr =>
-  [tok] -> repr tok
-noneOf cs = satisfy (ErrorItemToken Functor.<$> cs) (Sym.trans H.ValueCode
-  { value = not . (`List.elem` cs)
-  , code = [||\c -> not $$(ofChars cs [||c||])||]
-  })
-
-ofChars ::
-  TH.Lift tok => Eq tok =>
-  {-alternatives-}[tok] ->
-  {-input-}TH.CodeQ tok ->
-  TH.CodeQ Bool
-ofChars = List.foldr (\alt acc ->
-  \inp -> [|| alt == $$inp || $$(acc inp) ||])
-  (const [||False||])
-
-more :: Applicable repr => Satisfiable Char repr => Lookable repr => repr ()
-more = look (void (item @Char))
-
-char ::
-  Applicable repr => Satisfiable Char repr =>
-  Char -> repr Char
-char c = satisfy [ErrorItemToken c] (H.eq H..@ H.char c) $> H.char c
--- char c = satisfy [ErrorItemToken c] (H.eq H..@ H.qual H..@ H.char c) $> H.char c
-
-anyChar :: Satisfiable Char repr => repr Char
-anyChar = satisfy [] (H.const H..@ H.bool True)
-
-token ::
-  TH.Lift tok => Show tok => Eq tok =>
-  Applicable repr => Satisfiable tok repr =>
-  tok -> repr tok
-token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.char tok) $> H.char tok
--- token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char tok
-
-tokens ::
-  TH.Lift tok => Eq tok => Show tok =>
-  Applicable repr => Alternable repr =>
-  Satisfiable tok repr => [tok] -> repr [tok]
-tokens = try . traverse token
-
--- Composite Combinators
--- someTill :: repr a -> repr b -> repr [a]
--- someTill p end = negLook end *> (p <:> manyTill p end)
-
-void :: Applicable repr => repr a -> repr ()
-void p = p *> unit
-
-unit :: Applicable repr => repr ()
-unit = pure H.unit
-
-{-
-constp :: Applicable repr => repr a -> repr (b -> a)
-constp = (H.const <$>)
-
-
--- Alias Operations
-infixl 1 >>
-(>>) :: Applicable repr => repr a -> repr b -> repr b
-(>>) = (*>)
-
--- Monoidal Operations
-
-infixl 4 <~>
-(<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
-(<~>) = liftA2 (H.runtime (,))
-
-infixl 4 <~
-(<~) :: Applicable repr => repr a -> repr b -> repr a
-(<~) = (<*)
-
-infixl 4 ~>
-(~>) :: Applicable repr => repr a -> repr b -> repr b
-(~>) = (*>)
-
--- Lift Operations
-liftA2 ::
- Applicable repr =>
- TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
-liftA2 f x = (<*>) (fmap f x)
-
-liftA3 ::
- Applicable repr =>
- TermGrammar (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
-liftA3 f a b c = liftA2 f a b <*> c
-
--}
-
 -- Parser Folds
 pfoldr ::
Applicable repr => Foldable repr =>
TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
CombApplicable repr => CombFoldable repr =>
Production '[] (a -> b -> b) -> Production '[] b -> repr a -> repr b
 pfoldr f k p = chainPre (f <$> p) (pure k)
 
 pfoldr1 ::
Applicable repr => Foldable repr =>
TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
CombApplicable repr => CombFoldable repr =>
Production '[] (a -> b -> b) -> Production '[] b -> repr a -> repr b
 pfoldr1 f k p = f <$> p <*> pfoldr f k p
 
 pfoldl ::
Applicable repr => Foldable repr =>
TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
-pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)
CombApplicable repr => CombFoldable repr =>
Production '[] (b -> a -> b) -> Production '[] b -> repr a -> repr b
+pfoldl f k p = chainPost (pure k) ((Prod.flip <$> pure f) <*> p)
 
 pfoldl1 ::
Applicable repr => Foldable repr =>
TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
-pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)
CombApplicable repr => CombFoldable repr =>
Production '[] (b -> a -> b) -> Production '[] b -> repr a -> repr b
+pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Prod.flip <$> pure f) <*> p)
 
 -- Chain Combinators
 chainl1' ::
Applicable repr => Foldable repr =>
TermGrammar (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
-chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)
CombApplicable repr => CombFoldable repr =>
Production '[] (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
+chainl1' f p op = chainPost (f <$> p) (Prod.flip <$> op <*> p)
 
 chainl1 ::
Applicable repr => Foldable repr =>
CombApplicable repr => CombFoldable repr =>
  repr a -> repr (a -> a -> a) -> repr a
-chainl1 = chainl1' H.id
+chainl1 = chainl1' Prod.id
 
 {-
 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
-chainr1' f p op = newRegister_ H.id $ \acc ->
+chainr1' f p op = newRegister_ Prod.id $ \acc ->
   let go = bind p $ \x ->
-           modify acc (H.flip (H..@) <$> (op <*> x)) *> go
+           modify acc (Prod.flip (Prod..@) <$> (op <*> x)) *> go
        <|> f <$> x
   in go <**> get acc
 
 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
-chainr1 = chainr1' H.id
+chainr1 = chainr1' Prod.id
 
-chainr :: repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
+chainr :: repr a -> repr (a -> a -> a) -> Production '[] a -> repr a
 chainr p op x = option x (chainr1 p op)
 -}
 
 chainl ::
Applicable repr => Alternable repr => Foldable repr =>
- repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
+ repr a -> repr (a -> a -> a) -> Production '[] a -> repr a
 chainl p op x = option x (chainl1 p op)
 
 -- Derived Combinators
 many ::
Applicable repr => Foldable repr =>
CombApplicable repr => CombFoldable repr =>
  repr a -> repr [a]
-many = pfoldr H.cons H.nil
+many = pfoldr Prod.cons Prod.nil
 
 manyN ::
Applicable repr => Foldable repr =>
CombApplicable repr => CombFoldable repr =>
  Int -> repr a -> repr [a]
 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
 
 some ::
Applicable repr => Foldable repr =>
CombApplicable repr => CombFoldable repr =>
  repr a -> repr [a]
 some = manyN 1
 
 skipMany ::
Applicable repr => Foldable repr =>
CombApplicable repr => CombFoldable repr =>
  repr a -> repr ()
 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
-skipMany = void . pfoldl H.const H.unit -- the void here will encourage the optimiser to recognise that the register is unused
+skipMany = void . pfoldl Prod.const Prod.unit -- the void here will encourage the optimiser to recognise that the register is unused
 
 skipManyN ::
Applicable repr => Foldable repr =>
CombApplicable repr => CombFoldable repr =>
  Int -> repr a -> repr ()
 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
 
 skipSome ::
Applicable repr => Foldable repr =>
CombApplicable repr => CombFoldable repr =>
  repr a -> repr ()
 skipSome = skipManyN 1
 
 sepBy ::
Applicable repr => Alternable repr => Foldable repr =>
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
  repr a -> repr b -> repr [a]
-sepBy p sep = option H.nil (sepBy1 p sep)
+sepBy p sep = option Prod.nil (sepBy1 p sep)
 
 sepBy1 ::
Applicable repr => Alternable repr => Foldable repr =>
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
  repr a -> repr b -> repr [a]
 sepBy1 p sep = p <:> many (sep *> p)
 
 endBy ::
Applicable repr => Alternable repr => Foldable repr =>
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
  repr a -> repr b -> repr [a]
 endBy p sep = many (p <* sep)
 
 endBy1 ::
Applicable repr => Alternable repr => Foldable repr =>
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
  repr a -> repr b -> repr [a]
 endBy1 p sep = some (p <* sep)
 
 sepEndBy ::
Applicable repr => Alternable repr => Foldable repr =>
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
  repr a -> repr b -> repr [a]
-sepEndBy p sep = option H.nil (sepEndBy1 p sep)
+sepEndBy p sep = option Prod.nil (sepEndBy1 p sep)
 
 sepEndBy1 ::
Applicable repr => Alternable repr => Foldable repr =>
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
  repr a -> repr b -> repr [a]
 sepEndBy1 p sep =
-  let seb1 = p <**> (sep *> (H.flip H..@ H.cons <$> option H.nil seb1)
-                 <|> pure (H.flip H..@ H.cons H..@ H.nil))
+  let seb1 = p <**> (sep *> (Prod.flip Prod..@ Prod.cons <$> option Prod.nil seb1)
+                 <|> pure (Prod.flip Prod..@ Prod.cons Prod..@ Prod.nil))
   in seb1
 
 {-
 sepEndBy1 :: repr a -> repr b -> repr [a]
-sepEndBy1 p sep = newRegister_ H.id $ \acc ->
-  let go = modify acc ((H.flip (H..)) H..@ H.cons <$> p)
+sepEndBy1 p sep = newRegister_ Prod.id $ \acc ->
+  let go = modify acc ((Prod.flip (Prod..)) Prod..@ Prod.cons <$> p)
          *> (sep *> (go <|> get acc) <|> get acc)
-  in go <*> pure H.nil
+  in go <*> pure Prod.nil
+-}
+
+-- * Class 'CombMatchable'
+class CombMatchable repr where
+  conditional ::
+    repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
+  conditional a bs = liftDerived1
+    (conditional (derive a) (second derive Functor.<$> bs))
+  default conditional ::
+    FromDerived1 CombMatchable repr => Derivable repr =>
+    repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
+data instance Failure CombMatchable
+
+match ::
+  CombMatchable repr =>
+  Eq a => TH.Lift a =>
+  repr a -> [Production '[] a] -> (Production '[] a -> repr b) -> repr b -> repr b
+match a as p = conditional a
+  ((\v ->
+    ( Prod.lam (v Prod.==)
+    , p v
+    )
+  ) Functor.<$> as)
+
+predicate ::
+  CombMatchable repr =>
+  Production '[] (a -> Bool) -> repr a -> repr b -> repr b -> repr b
+predicate p a b = conditional a [(p, b)]
+
+infixl 4 <?:>
+(<?:>) ::
+  CombMatchable repr =>
+  repr Bool -> (repr a, repr a) -> repr a
+cond <?:> (p, q) = predicate Prod.id cond p q
+
+-- * Class 'CombSatisfiable'
+class CombSatisfiable tok repr where
+  -- | Like 'satisfyOrFail' but with no custom failure.
+  satisfy :: Production '[] (tok -> Bool) -> repr tok
+  satisfy = satisfyOrFail Set.empty
+  -- | Like 'satisfy' but with a custom set of 'SomeFailure's.
+  satisfyOrFail ::
+    Set SomeFailure ->
+    Production '[] (tok -> Bool) -> repr tok
+  default satisfyOrFail ::
+    FromDerived (CombSatisfiable tok) repr =>
+    Set SomeFailure ->
+    Production '[] (tok -> Bool) -> repr tok
+  satisfyOrFail fs = liftDerived . satisfyOrFail fs
+
+data instance Failure (CombSatisfiable tok)
+  =  FailureAny
+     -- FIXME: this 'Failure' is a bit special since multiple ones
+     -- with different 'Horizon's makes no sense.
+     -- This should likely be treated separately in 'ParsingError'.
+  |  FailureHorizon Int -- FIXME: use Natural?
+  |  FailureLabel String
+  |  FailureToken tok
+  deriving (Eq, Ord, Show, Typeable, Generic, NFData)
+-- | Global 'TH.Name' to refer to the @(InputToken inp)@ type
+-- from TemplateHaskell code.
+inputTokenProxy :: TH.Name
+inputTokenProxy = TH.mkName "inputToken"
+instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
+  liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
+  liftTyped x = [||
+    case
+      $$(let inputToken :: TH.Code m (Proxy tok) =
+              TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
+      in inputToken) of
+      (Proxy :: Proxy tok') ->
+        $$(case x of
+          FailureAny -> [|| FailureAny @tok' ||]
+          FailureHorizon h -> [|| FailureHorizon @tok' h ||]
+          FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
+          FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
+        )
+    ||]
+
+char ::
+  CombApplicable repr =>
+  CombSatisfiable Char repr =>
+  Char -> repr Char
+char c = satisfyOrFail
+           (Set.singleton (SomeFailure (FailureToken c)))
+           (Prod.equal Prod..@ Prod.constant c)
+         $> Prod.constant c
+
+item :: forall tok repr.
+  Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
+  CombSatisfiable tok repr => repr tok
+item = satisfyOrFail
+        (Set.singleton (SomeFailure (FailureAny @tok)))
+        (Prod.const Prod..@ Prod.constant True)
+
+anyChar ::
+  CombAlternable repr =>
+  CombSatisfiable Char repr =>
+  repr Char
+anyChar = item
+
+string ::
+  CombApplicable repr => CombAlternable repr =>
+  CombSatisfiable Char repr =>
+  [Char] -> repr [Char]
+string = try . traverse char
+
+oneOf ::
+  Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
+  CombSatisfiable tok repr =>
+  [tok] -> repr tok
+oneOf ts = satisfyOrFail
+  (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
+  (production
+    (`List.elem` ts)
+    [||\t -> $$(ofChars ts [||t||])||])
+
+noneOf ::
+  TH.Lift tok => Eq tok =>
+  CombSatisfiable tok repr =>
+  [tok] -> repr tok
+noneOf cs = satisfy (production
+  (not . (`List.elem` cs))
+  [||\c -> not $$(ofChars cs [||c||])||])
+
+ofChars ::
+  TH.Lift tok => Eq tok =>
+  {-alternatives-}[tok] ->
+  {-input-}TH.CodeQ tok ->
+  TH.CodeQ Bool
+ofChars = List.foldr
+  (\tok acc inp -> [|| tok == $$inp || $$(acc inp) ||])
+  (const [||False||])
+
+more ::
+  CombAlternable repr =>
+  CombApplicable repr =>
+  CombSatisfiable Char repr =>
+  CombLookable repr => repr ()
+more = look (void (item @Char))
+
+token ::
+  TH.Lift tok => Show tok => Eq tok => Typeable tok =>
+  CombAlternable repr =>
+  CombApplicable repr =>
+  CombSatisfiable tok repr =>
+  tok -> repr tok
+token tok = satisfy (Prod.equal Prod..@ Prod.constant tok) $> Prod.constant tok
+-- token tok = satisfy [ExceptionToken tok] (Prod.eq Prod..@ Prod.qual Prod..@ Prod.char tok) $> Prod.char tok
+
+tokens ::
+  TH.Lift tok => Eq tok => Show tok => Typeable tok =>
+  CombApplicable repr => CombAlternable repr =>
+  CombSatisfiable tok repr => [tok] -> repr [tok]
+tokens = try . traverse token
+
+-- * Class 'CombSelectable'
+class CombSelectable repr where
+  branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
+  default branch ::
+    FromDerived3 CombSelectable repr =>
+    repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
+  branch = liftDerived3 branch
+data instance Failure CombSelectable
+
+when ::
+  CombMatchable repr =>
+  CombSelectable repr =>
+  Prod.Constantable () repr =>
+  repr Bool -> repr () -> repr ()
+when p q = p <?:> (q, Prod.constant ())
+
+while ::
+  CombMatchable repr =>
+  CombSelectable repr =>
+  Prod.Constantable () repr =>
+  repr Bool -> repr ()
+while x = fix (when x)
+
+-- * Class 'CombLookable'
+class CombLookable repr where
+  look :: repr a -> repr a
+  negLook :: repr a -> repr ()
+  default look ::
+    FromDerived1 CombLookable repr =>
+    repr a -> repr a
+  default negLook ::
+    FromDerived1 CombLookable repr =>
+    repr a -> repr ()
+  look = liftDerived1 look
+  negLook = liftDerived1 negLook
+
+  eof :: repr ()
+  eof = liftDerived eof
+  default eof ::
+    FromDerived CombLookable repr =>
+    repr ()
+  -- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
+             -- (item @Char)
+data instance Failure CombLookable
+  = FailureEnd
+  deriving (Eq, Ord, Show, Typeable, TH.Lift, Generic, NFData)
+
+-- Composite Combinators
+-- someTill :: repr a -> repr b -> repr [a]
+-- someTill p end = negLook end *> (p <:> manyTill p end)
+
+{-
+constp :: CombApplicable repr => repr a -> repr (b -> a)
+constp = (Prod.const <$>)
+
+
+-- Alias Operations
+infixl 1 >>
+(>>) :: CombApplicable repr => repr a -> repr b -> repr b
+(>>) = (*>)
+
+-- Monoidal Operations
+
+infixl 4 <~>
+(<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
+(<~>) = liftA2 (Prod.runtime (,))
+
+infixl 4 <~
+(<~) :: CombApplicable repr => repr a -> repr b -> repr a
+(<~) = (<*)
+
+infixl 4 ~>
+(~>) :: CombApplicable repr => repr a -> repr b -> repr b
+(~>) = (*>)
+
+-- Lift Operations
+liftA2 ::
+ CombApplicable repr =>
+ Production '[] (a -> b -> c) -> repr a -> repr b -> repr c
+liftA2 f x = (<*>) (fmap f x)
+
+liftA3 ::
+ CombApplicable repr =>
+ Production '[] (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
+liftA3 f a b c = liftA2 f a b <*> c
+
 -}
 
 {-
 -- Combinators interpreters for 'Sym.Any'.
-instance Applicable repr => Applicable (Sym.Any repr)
-instance Satisfiable repr => Satisfiable (Sym.Any repr)
-instance Alternable repr => Alternable (Sym.Any repr)
-instance Selectable repr => Selectable (Sym.Any repr)
-instance Matchable repr => Matchable (Sym.Any repr)
-instance Lookable repr => Lookable (Sym.Any repr)
-instance Foldable repr => Foldable (Sym.Any repr)
+instance CombApplicable repr => CombApplicable (Sym.Any repr)
+instance CombSatisfiable repr => CombSatisfiable (Sym.Any repr)
+instance CombAlternable repr => CombAlternable (Sym.Any repr)
+instance CombSelectable repr => CombSelectable (Sym.Any repr)
+instance CombMatchable repr => CombMatchable (Sym.Any repr)
+instance CombLookable repr => CombLookable (Sym.Any repr)
+instance CombFoldable repr => CombFoldable (Sym.Any repr)
+-}
+
+-- * Type 'Register'
+newtype Register r a = Register { unRegister :: UnscopedRegister a }
+  deriving (Eq, Show)
+
+-- ** Type 'UnscopedRegister'
+newtype UnscopedRegister r = UnscopedRegister { unUnscopedRegister :: TH.Name }
+  deriving (Eq)
+  deriving newtype Show
+
+
+{-
+put_ :: ParserOps rep => Register r a -> rep a -> Parser ()
+put_ r = put r . pure
+
+gets_ :: ParserOps rep => Register r a -> rep (a -> b) -> Parser b
+gets_ r = gets r . pure
+
+modify_ :: ParserOps rep => Register r a -> rep (a -> a) -> Parser ()
+modify_ r = modify r . pure
 -}
+
+gets ::
+  CombApplicable repr =>
+  CombRegisterable repr =>
+  Register r a -> repr (a -> b) -> repr b
+gets r p = p <*> get r
+
+modify ::
+  CombApplicable repr =>
+  CombRegisterable repr =>
+  Register r a -> repr (a -> a) -> repr ()
+modify r p = put r (gets r p)
+
+move ::
+  CombRegisterable repr =>
+  Register r1 a -> Register r2 a -> repr ()
+move dst src = put dst (get src)
+
+bind ::
+  CombRegisterable repr =>
+  repr a -> (repr a -> repr b) -> repr b
+bind p f = new p (f . get)
+
+local ::
+  CombApplicable repr =>
+  CombRegisterable repr =>
+  Register r a -> repr a -> repr b -> repr b
+local r p q = bind (get r) (\x -> put r p *> q <* put r x)
+
+swap ::
+  CombApplicable repr =>
+  CombRegisterable repr =>
+  Register r1 a -> Register r2 a -> repr ()
+swap r1 r2 = bind (get r1) (\x -> move r1 r2 *> put r2 x)
+
+rollback ::
+  CombAlternable repr =>
+  CombApplicable repr =>
+  CombRegisterable repr =>
+  Register r a -> repr b -> repr b
+rollback r p = bind (get r) (\x -> p <|> put r x *> empty)
+
+for ::
+  CombApplicable repr =>
+  CombMatchable repr =>
+  CombSelectable repr =>
+  CombRegisterable repr =>
+  Prod.Constantable () repr =>
+  repr a -> repr (a -> Bool) -> repr (a -> a) -> repr () -> repr ()
+for init cond step body =
+  new init (\i ->
+    let cond' = gets i cond in
+    when cond' (while (body *> modify i step *> cond'))
+  )
+
+
+-- ** Class 'CombRegisterable'
+class CombRegisterable (repr::ReprComb) where
+  new :: repr a -> (forall r. Register r a -> repr b) -> repr b
+  get :: Register r a -> repr a
+  put :: Register r a -> repr a -> repr ()
+  default new ::
+    FromDerived CombRegisterable repr => Derivable repr =>
+    repr a -> (forall r. Register r a -> repr b) -> repr b
+  default get ::
+    FromDerived CombRegisterable repr =>
+    Register r a -> repr a
+  default put ::
+    FromDerived1 CombRegisterable repr =>
+    Register r a -> repr a -> repr ()
+  new ini f = liftDerived (new (derive ini) (derive . f))
+  get = liftDerived . get
+  put = liftDerived1 . put