From: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
Date: Fri, 19 Jan 2024 23:11:26 +0000 (+0100)
Subject: iface: remove `satisfyOrFail`
X-Git-Url: https://git.sourcephile.fr/haskell/symantic-parser.git/commitdiff_plain

iface: remove `satisfyOrFail`
---

diff --git a/src/Symantic/Parser/Grammar/Combinators.hs b/src/Symantic/Parser/Grammar/Combinators.hs
index 9282027..52b8e68 100644
--- a/src/Symantic/Parser/Grammar/Combinators.hs
+++ b/src/Symantic/Parser/Grammar/Combinators.hs
@@ -9,11 +9,9 @@
 {-# 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
@@ -34,13 +32,12 @@ import Data.Ord (Ord(..), Ordering(..))
 import Data.Int (Int)
 import Data.Kind (Type, Constraint)
 import Data.Maybe (Maybe(..))
-import Data.Set (Set)
 import Data.String (String)
+import Data.Semigroup (Semigroup(..))
 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
 
@@ -78,80 +75,12 @@ class CombAlternable repr where
   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
+  default empty ::
+    FromDerived CombAlternable repr =>
+    repr a
+  empty = liftDerived empty
 
 -- ** Type 'Exception'
 data Exception
@@ -258,7 +187,6 @@ class CombApplicable repr where
   liftA2 f x = (<*>) (f <$> x)
 
 infixl 4 <*>, <*, *>, <**>
-data instance Failure CombApplicable
 
 
 {-# INLINE (<:>) #-}
@@ -314,7 +242,6 @@ class CombFoldable repr where
   chainPre op p = flip (foldr ($)) <$> many op <*> p
   chainPost p op = foldl' (flip ($)) <$> p <*> many op
   -}
-data instance Failure CombFoldable
 
 {-
 conditional :: CombSelectable repr => [(Production '[] (a -> Bool), repr b)] -> repr a -> repr b -> repr b
@@ -456,7 +383,6 @@ class CombMatchable repr where
   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 =>
@@ -482,63 +408,27 @@ 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 ::
+  default satisfy ::
     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)
+  satisfy = liftDerived . satisfy
+
 -- | 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
+char c = satisfy (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)
+item = satisfy (Prod.const Prod..@ Prod.constant True)
 
 anyChar ::
   CombAlternable repr =>
@@ -556,19 +446,13 @@ 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||])||])
+oneOf ts = satisfy (production (`List.elem` ts) [||\t -> $$(ofChars ts [||t||])||])
 
 noneOf ::
-  TH.Lift tok => Eq tok =>
+  (Ord tok, Show tok, TH.Lift tok, NFData tok, Typeable tok) =>
   CombSatisfiable tok repr =>
   [tok] -> repr tok
-noneOf cs = satisfy (production
-  (not . (`List.elem` cs))
-  [||\c -> not $$(ofChars cs [||c||])||])
+noneOf ts = satisfy (production (not . (`List.elem` ts)) [||\c -> not $$(ofChars ts [||c||])||])
 
 ofChars ::
   TH.Lift tok => Eq tok =>
@@ -587,7 +471,7 @@ more ::
 more = look (void (item @Char))
 
 token ::
-  TH.Lift tok => Show tok => Eq tok => Typeable tok =>
+  (Ord tok, Show tok, TH.Lift tok, NFData tok, Typeable tok) =>
   CombAlternable repr =>
   CombApplicable repr =>
   CombSatisfiable tok repr =>
@@ -596,7 +480,7 @@ 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 =>
+  (Ord tok, Show tok, TH.Lift tok, NFData tok, Typeable tok) =>
   CombApplicable repr => CombAlternable repr =>
   CombSatisfiable tok repr => [tok] -> repr [tok]
 tokens = try . traverse token
@@ -608,7 +492,6 @@ class CombSelectable repr where
     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 =>
@@ -627,6 +510,11 @@ while x = fix (when x)
 -- * Class 'CombLookable'
 class CombLookable repr where
   look :: repr a -> repr a
+  -- |
+  -- Note: following [Error Reporting in Parsing Expression Grammars](https://arxiv.org/abs/1405.6646v3)
+  -- what happens inside a 'negLook' does not take part in error reporting at
+  -- all, which is the simplest approach, and also gives a consistent result
+  -- for: @(negLook . negLook)@.
   negLook :: repr a -> repr ()
   default look ::
     FromDerived1 CombLookable repr =>
@@ -644,9 +532,6 @@ class CombLookable repr where
     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]
diff --git a/src/Symantic/Parser/Grammar/Optimize.hs b/src/Symantic/Parser/Grammar/Optimize.hs
index b1b36ae..46e4d5b 100644
--- a/src/Symantic/Parser/Grammar/Optimize.hs
+++ b/src/Symantic/Parser/Grammar/Optimize.hs
@@ -13,7 +13,6 @@ import Data.Eq (Eq(..))
 import Data.Function (($), (.))
 import Data.Kind (Constraint)
 import Data.Maybe (Maybe(..))
-import Data.Set (Set)
 import Data.Functor.Identity (Identity(..))
 import Unsafe.Coerce (unsafeCoerce)
 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
@@ -184,14 +183,12 @@ unSimplComb SimplComb{ combData = c :: Comb c repr a } =
 data instance Comb CombAlternable repr a where
   Alt :: Exception -> SimplComb repr a -> SimplComb repr a -> Comb CombAlternable repr a
   Empty :: Comb CombAlternable repr a
-  Failure :: SomeFailure -> Comb CombAlternable repr a
   Throw :: ExceptionLabel -> Comb CombAlternable repr a
   Try :: SimplComb repr a -> Comb CombAlternable repr a
 instance CombAlternable repr => Derivable (Comb CombAlternable repr) where
   derive = \case
     Alt exn x y -> alt exn (derive x) (derive y)
     Empty -> empty
-    Failure sf -> failure sf
     Throw exn -> throw exn
     Try x -> try (derive x)
 instance
@@ -206,11 +203,6 @@ instance
     , combInline = True
     , combRefs = HS.empty
     }
-  failure sf = SimplComb
-    { combData = Failure sf
-    , combInline = True
-    , combRefs = HS.empty
-    }
 
   alt _exn p@(Comb Pure{}) _ = p
     -- & trace "Left Catch Law"
@@ -536,28 +528,20 @@ instance
 
 -- CombSatisfiable
 data instance Comb (CombSatisfiable tok) repr a where
-  -- | To include the @('Set' 'SomeFailure')@ is a little kludge
-  -- it would be cleaner to be able to pattern-match
-  -- on @(alt exn (Comb 'Satisfy'{}) (Failure{}))@
-  -- when generating 'Program', but this is not easily possible then
-  -- because data types have already been converted back to class methods,
-  -- hence pattern-matching is no longer possible
-  -- (at least not without reintroducing data types).
-  SatisfyOrFail ::
+  Satisfy ::
     CombSatisfiable tok repr =>
-    Set SomeFailure ->
     Production '[] (tok -> Bool) ->
     Comb (CombSatisfiable tok) repr tok
 instance
   CombSatisfiable tok repr =>
   Derivable (Comb (CombSatisfiable tok) repr) where
   derive = \case
-    SatisfyOrFail fs p -> satisfyOrFail fs p
+    Satisfy p -> satisfy p
 instance
   (CombSatisfiable tok repr, Typeable tok) =>
   CombSatisfiable tok (SimplComb repr) where
-  satisfyOrFail fs p = SimplComb
-    { combData = SatisfyOrFail fs p
+  satisfy p = SimplComb
+    { combData = Satisfy p
     , combInline = False -- TODO: True? depending on p?
     , combRefs = HS.empty
     }
diff --git a/src/Symantic/Parser/Grammar/View.hs b/src/Symantic/Parser/Grammar/View.hs
index 40d6a57..7b73e60 100644
--- a/src/Symantic/Parser/Grammar/View.hs
+++ b/src/Symantic/Parser/Grammar/View.hs
@@ -95,7 +95,7 @@ instance CombMatchable (ViewGrammar sN) where
     : Tree.Node ("default", "") [unViewGrammar d]
     : ((\(p,b) -> Tree.Node ("branch "<>show p, "") [unViewGrammar b]) Functor.<$> bs)
 instance CombSatisfiable tok (ViewGrammar sN) where
-  satisfyOrFail p = ViewGrammar $ Tree.Node ("satisfy "<>show p, "") []
+  satisfy p = ViewGrammar $ Tree.Node ("satisfy "<>show p, "") []
 instance CombSelectable (ViewGrammar sN) where
   branch lr l r = ViewGrammar $ Tree.Node ("branch", "")
     [ unViewGrammar lr, unViewGrammar l, unViewGrammar r ]
diff --git a/src/Symantic/Parser/Grammar/Write.hs b/src/Symantic/Parser/Grammar/Write.hs
index 9e8bdc0..a5298d6 100644
--- a/src/Symantic/Parser/Grammar/Write.hs
+++ b/src/Symantic/Parser/Grammar/Write.hs
@@ -149,7 +149,7 @@ instance CombMatchable (WriteGrammar sN) where
         })) <>
     Just "] "
 instance CombSatisfiable tok (WriteGrammar sN) where
-  satisfyOrFail p = writeGrammarPair (infixN 9) $ \env ->
+  satisfy p = writeGrammarPair (infixN 9) $ \env ->
     Just "satisfy " <>
     Just (fromString (showsPrec 10 p ""))
 instance CombSelectable (WriteGrammar sN) where
diff --git a/src/Symantic/Parser/Machine/Instructions.hs b/src/Symantic/Parser/Machine/Instructions.hs
index 80a9f47..cee98b3 100644
--- a/src/Symantic/Parser/Machine/Instructions.hs
+++ b/src/Symantic/Parser/Machine/Instructions.hs
@@ -1,30 +1,35 @@
 {-# LANGUAGE ConstraintKinds #-} -- For Machine
 {-# LANGUAGE DeriveLift #-} -- For TH.Lift (Failure tok)
 {-# LANGUAGE DerivingStrategies #-} -- For Show (LetName a)
+{-# LANGUAGE DeriveAnyClass #-} -- For NFData
+{-# LANGUAGE DeriveGeneric #-} -- For Generic
+{-# LANGUAGE TemplateHaskell #-} -- For TH.Lift
 -- | Semantic of the parsing instructions used
 -- to make the parsing control-flow explicit,
 -- in the convenient tagless-final encoding.
 module Symantic.Parser.Machine.Instructions where
 
+import Control.DeepSeq (NFData(..))
 import Data.Bool (Bool(..))
 import Data.Either (Either)
 import Data.Eq (Eq(..))
 import Data.Function ((.))
+import Data.Int (Int)
 import Data.Kind (Type)
-import Data.Set (Set)
-import Text.Show (Show(..))
+import Data.Ord (Ord(..))
 import Data.String (String)
-import qualified Language.Haskell.TH as TH
+import Text.Show (Show(..), showParen, showString, shows)
 
 import Symantic.Parser.Grammar
 import Symantic.Parser.Machine.Input
 import qualified Symantic.Syntaxes.Classes as Prod
 import qualified Symantic.Semantics.Data as Sym
+import qualified Language.Haskell.TH as TH
 
 -- * Type 'Splice'
 type Splice = Sym.SomeData TH.CodeQ
 
--- | Lift a 'TH.CodeQ' into a 'Sym.SomeData'.
+-- | Lift a 'TH.CodeQ' into an opaque 'Sym.SomeData'.
 splice :: TH.CodeQ a -> Splice a
 splice x = Sym.SomeData (Sym.Var x)
 
@@ -80,15 +85,36 @@ class InstrValuable (repr::ReprInstr) where
     repr inp (x ': (x -> y) ': vs) a
   applyValue = lift2Value (Prod.$)
 
+-- ** Type 'FailMode'
+data FailMode
+   = FailModePreserve
+    -- ^ Fail preserving any current farthest error.
+    -- Useful in 'alt' or 'try'.
+   | FailModeNewFailure (TH.CodeQ SomeFailure)
+    -- ^ Fail preserving, merging or replacing any current farthest error,
+    -- depending on its input position and the current input position.
+
+data SomeFailure
+  = forall a. SomeFailure (WriteGrammar 'True a)
+  | SomeFailureHorizon Int
+instance NFData SomeFailure where
+  rnf (SomeFailure x) = rnf x
+  rnf (SomeFailureHorizon x) = rnf x
+instance Show SomeFailure where
+  showsPrec p (SomeFailure x) = showsPrec p x
+  showsPrec p (SomeFailureHorizon x) = showParen (p > 10) (showString "SomeFailureHorizon " . shows x)
+--instance TH.Lift SomeFailure where
+--  liftTyped (SomeFailure x) = [|| SomeFailure $$(TH.liftTyped x) ||]
+--instance Semigroup SomeFailure where
+--  x <> y = SomeFailure (FailureOr x y)
+
 -- ** Class 'InstrExceptionable'
 class InstrExceptionable (repr::ReprInstr) where
   -- | @('raise' exn)@ raises 'ExceptionLabel' @(exn)@.
   raise :: ExceptionLabel -> repr inp vs a
-  -- | @('fail' fs)@ raises 'ExceptionFailure' @(exn)@.
-  -- As a special case, giving an empty 'Set' of failures
-  -- raises 'ExceptionFailure' without using the current position
-  -- to update the farthest error.
-  fail :: Set SomeFailure -> repr inp vs a
+  -- | @('fail' fs)@ raises 'ExceptionFailure'.
+  -- As a special case, giving 'Left'
+  fail :: FailMode -> repr inp vs a
   -- | @('commit' exn k)@ removes the 'OnException'
   -- from the 'onExceptionStackByLabel' for the given 'Exception' @(exn)@,
   -- and continues with the next 'Instr'uction @(k)@.
@@ -179,7 +205,6 @@ class InstrReadable (tok::Type) (repr::ReprInstr) where
   -- otherwise 'fail'.
   read ::
     tok ~ InputToken inp =>
-    Set SomeFailure ->
     Splice (tok -> Bool) ->
     repr inp (tok ': vs) a ->
     repr inp vs a
diff --git a/src/Symantic/Parser/Machine/Optimize.hs b/src/Symantic/Parser/Machine/Optimize.hs
index 9f71142..dcd9a08 100644
--- a/src/Symantic/Parser/Machine/Optimize.hs
+++ b/src/Symantic/Parser/Machine/Optimize.hs
@@ -13,7 +13,6 @@ import Data.Either (Either)
 import Data.Function ((.))
 import Data.Kind (Constraint)
 import Data.Maybe (Maybe(..))
-import Data.Set (Set)
 import Data.String (String)
 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
 import qualified Data.Functor as Functor
@@ -124,7 +123,7 @@ data instance Instr InstrExceptionable repr inp vs a where
     ExceptionLabel ->
     Instr InstrExceptionable repr inp vs a
   Fail ::
-    Set SomeFailure ->
+    FailMode ->
     Instr InstrExceptionable repr inp vs a
   Commit ::
     Exception ->
@@ -231,7 +230,6 @@ instance InstrInputable repr => InstrInputable (SomeInstr repr) where
 -- InstrReadable
 data instance Instr (InstrReadable tok) repr inp vs a where
   Read ::
-    Set SomeFailure ->
     Splice (InputToken inp -> Bool) ->
     SomeInstr repr inp (InputToken inp ': vs) a ->
     Instr (InstrReadable tok) repr inp vs a
@@ -239,11 +237,11 @@ instance
   ( InstrReadable tok repr, tok ~ InputToken inp ) =>
   Derivable (Instr (InstrReadable tok) repr inp vs) where
   derive = \case
-    Read fs p k -> read fs p (derive k)
+    Read p k -> read p (derive k)
 instance
   ( InstrReadable tok repr, Typeable tok ) =>
   InstrReadable tok (SomeInstr repr) where
-  read fs p = SomeInstr . Read fs p
+  read p = SomeInstr . Read p
 
 -- InstrIterable
 data instance Instr InstrIterable repr inp vs a where
diff --git a/src/Symantic/Parser/Machine/Program.hs b/src/Symantic/Parser/Machine/Program.hs
index a822231..b772a70 100644
--- a/src/Symantic/Parser/Machine/Program.hs
+++ b/src/Symantic/Parser/Machine/Program.hs
@@ -302,7 +302,7 @@ instance
   , InstrComment repr
   , Typeable tok
   ) => CombSatisfiable tok (Program repr inp) where
-  satisfyOrFail pred = Program (satisfyOrFail pred) $ \next ->
+  satisfy pred = Program (satisfy pred) $ \next ->
     return $
       comment ("satisfy "<>showsPrec 11 (prodCode pred) "") $
       read (prodCode pred) next