iface: remove `satisfyOrFail`

diff --git a/src/Symantic/Parser/Grammar/Combinators.hs b/src/Symantic/Parser/Grammar/Combinators.hs
index 9282027edb864bb464fceb227cf4bfef8bc42934..52b8e6868f29278105be0c0df08e59eb35c36735 100644 (file)
--- 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 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 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
 -- | 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.Int (Int)
 import Data.Kind (Type, Constraint)
 import Data.Maybe (Maybe(..))

-import Data.Set (Set)

 import Data.String (String)
 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 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 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
 
   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)@ 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
 
 -- ** Type 'Exception'
 data Exception


@@ -258,7 +187,6 @@ class CombApplicable repr where
   liftA2 f x = (<*>) (f <$> x)
 
 infixl 4 <*>, <*, *>, <**>
   liftA2 f x = (<*>) (f <$> x)
 
 infixl 4 <*>, <*, *>, <**>

-data instance Failure CombApplicable

 
 
 {-# INLINE (<:>) #-}
 
 
 {-# 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
   -}
   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
 
 {-
 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
   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 =>
 
 match ::
   CombMatchable repr =>


@@ -482,63 +408,27 @@ cond <?:> (p, q) = predicate Prod.id cond p q
 
 -- * Class 'CombSatisfiable'
 class CombSatisfiable tok repr where
 
 -- * Class 'CombSatisfiable'
 class CombSatisfiable tok repr where

-  -- | Like 'satisfyOrFail' but with no custom failure.

   satisfy :: Production '[] (tok -> Bool) -> repr tok
   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 =>
     FromDerived (CombSatisfiable tok) repr =>

-    Set SomeFailure ->

     Production '[] (tok -> Bool) -> repr tok
     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"
 -- | 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 ::
   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 :: 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 =>
 
 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
   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 ::
 
 noneOf ::

-  TH.Lift tok => Eq tok =>
+  (Ord tok, Show tok, TH.Lift tok, NFData tok, Typeable tok) =>

   CombSatisfiable tok repr =>
   [tok] -> repr 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 =>
 
 ofChars ::
   TH.Lift tok => Eq tok =>


@@ -587,7 +471,7 @@ more ::
 more = look (void (item @Char))
 
 token ::
 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 =>
   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 ::
 -- 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
   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
     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 =>
 
 when ::
   CombMatchable repr =>


@@ -627,6 +510,11 @@ while x = fix (when x)
 -- * Class 'CombLookable'
 class CombLookable repr where
   look :: repr a -> repr a
 -- * 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 =>
   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)
     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]
 
 -- 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 b1b36ae0dcf32648655681092c6bf9fe7db39354..46e4d5be88f1e481cfc55219a994ff4b0520834d 100644 (file)
--- 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.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, (:~~:)(..))
 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
 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
   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
     Throw exn -> throw exn
     Try x -> try (derive x)
 instance


@@ -206,11 +203,6 @@ instance
     , combInline = True
     , combRefs = HS.empty
     }
     , 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"
 
   alt _exn p@(Comb Pure{}) _ = p
     -- & trace "Left Catch Law"


@@ -536,28 +528,20 @@ instance
 
 -- CombSatisfiable
 data instance Comb (CombSatisfiable tok) repr a where
 
 -- 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 =>
     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
     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
 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
     }
     , 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 40d6a572163c80c787f37f50e785eefb3a8a5698..7b73e60a205c12a168737271fbbe388a42819b14 100644 (file)
--- 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
     : 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 ]
 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 9e8bdc0006a739fbdad003fcd6beee6b6c4b8b75..a5298d6a7ece49ee38c459c06b6d0b3129a8f1fb 100644 (file)
--- 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
         })) <>
     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
     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 80a9f47e68451b830e0bcca5e4e64a824157d49c..cee98b3aeae91b6fd8d40ee0f8851fa4cdd1a4cf 100644 (file)
--- 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 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
 
 -- | 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.Bool (Bool(..))
 import Data.Either (Either)
 import Data.Eq (Eq(..))
 import Data.Function ((.))

+import Data.Int (Int)

 import Data.Kind (Type)
 import Data.Kind (Type)

-import Data.Set (Set)
-import Text.Show (Show(..))
+import Data.Ord (Ord(..))

 import Data.String (String)
 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 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
 
 
 -- * 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)
 
 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.$)
 
     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
 -- ** 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)@.
   -- | @('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 =>
   -- otherwise 'fail'.
   read ::
     tok ~ InputToken inp =>

-    Set SomeFailure ->

     Splice (tok -> Bool) ->
     repr inp (tok ': vs) a ->
     repr inp vs a
     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 9f71142b3bbaba8751e33cfe5c0f0f158100fb57..dcd9a08b7acd1e1c2e291a1c1359bfb2e157e3d6 100644 (file)
--- 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.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
 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 ::
     ExceptionLabel ->
     Instr InstrExceptionable repr inp vs a
   Fail ::

-    Set SomeFailure ->
+    FailMode ->

     Instr InstrExceptionable repr inp vs a
   Commit ::
     Exception ->
     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 ::
 -- 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
     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
   ( 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
 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
 
 -- 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 a8222312ce87f2a5a05c8513626ec6d748a63b75..b772a7020935a95d23ddbe263ea2df58a4112b2f 100644 (file)
--- 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
   , 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
     return $
       comment ("satisfy "<>showsPrec 11 (prodCode pred) "") $
       read (prodCode pred) next