From 89c65679dc2448222f7e7de9f742489d0a271a2a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 20 Jan 2024 00:11:26 +0100 Subject: [PATCH] iface: remove `satisfyOrFail` --- src/Symantic/Parser/Grammar/Combinators.hs | 155 +++----------------- src/Symantic/Parser/Grammar/Optimize.hs | 24 +-- src/Symantic/Parser/Grammar/View.hs | 2 +- src/Symantic/Parser/Grammar/Write.hs | 2 +- src/Symantic/Parser/Machine/Instructions.hs | 45 ++++-- src/Symantic/Parser/Machine/Optimize.hs | 8 +- src/Symantic/Parser/Machine/Program.hs | 2 +- 7 files changed, 65 insertions(+), 173 deletions(-) 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 -- 2.47.0