packages feed

grammar-combinators 0.1 → 0.2

raw patch · 36 files changed

+794/−49 lines, 36 files

Files

Text/GrammarCombinators/Base/Domain.hs view
@@ -26,6 +26,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  module Text.GrammarCombinators.Base.Domain (     DomainMap(supIx, subIx),@@ -38,7 +39,11 @@     ShowFam(showIdx),     Domain,     memoFamilyK, toMemoK, fromMemoK,-    LiftFam(liftIdxE, liftIdxP)+    LiftFam(liftIdxE, liftIdxP),+    LeftIx, RightIx,+    MergeDomain (LeftIdx, RightIdx),+    EitherFunctor (LeftR, RightR),+    unLeftR, unRightR   ) where  import Generics.MultiRec.Base@@ -130,3 +135,52 @@ class LiftFam phi where   liftIdxE :: phi ix -> Exp   liftIdxP :: phi ix -> Pat++data LeftIx ix+data RightIx ix++data MergeDomain phiL phiR ix where+  LeftIdx :: phiL ix -> MergeDomain phiL phiR (LeftIx ix)+  RightIdx :: phiR ix -> MergeDomain phiL phiR (RightIx ix)++instance (MemoFam phiL, MemoFam phiR) => +         MemoFam (MergeDomain phiL phiR) where+           data Memo (MergeDomain phiL phiR) v = MemoMD (Memo phiL (SubVal LeftIx v)) (Memo phiR (SubVal RightIx v))+           fromMemo (MemoMD ml mr) (LeftIdx idx) = unSubVal $ fromMemo ml idx+           fromMemo (MemoMD ml mr) (RightIdx idx) = unSubVal $ fromMemo mr idx+           toMemo f = MemoMD (toMemo (MkSubVal . f . LeftIdx)) (toMemo (MkSubVal . f . RightIdx))++instance (ShowFam phiL, ShowFam phiR) => +         ShowFam (MergeDomain phiL phiR) where+           showIdx (LeftIdx idx) = concat ["LeftIdx (", (showIdx idx), ")"]+           showIdx (RightIdx idx) = concat ["RightIdx (", (showIdx idx), ")"]++instance (FoldFam phiL, FoldFam phiR) => +         FoldFam (MergeDomain phiL phiR) where+           foldFam f n = foldFam (f . LeftIdx) $ foldFam (f . RightIdx) n++instance (EqFam phiL, EqFam phiR) => +         EqFam (MergeDomain phiL phiR) where+           overrideIdx f (LeftIdx idx) v (LeftIdx idx') = unSubVal $ overrideIdx (MkSubVal . f . LeftIdx) idx (MkSubVal v) idx'+           overrideIdx f (RightIdx idx) v (RightIdx idx') = unSubVal $ overrideIdx (MkSubVal . f . RightIdx) idx (MkSubVal v) idx'+           overrideIdx f _ _ idx = f idx++instance (Domain phiL, Domain phiR) => Domain (MergeDomain phiL phiR) ++data EitherFunctor rL rR ix where+  LeftR :: rL ix -> EitherFunctor rL rR (LeftIx ix)+  RightR :: rR ix -> EitherFunctor rL rR (RightIx ix)++instance (Show (rL ix)) => Show (EitherFunctor rL rR (LeftIx ix)) where+  show (LeftR v) = show v++instance (Show (rR ix)) => Show (EitherFunctor rL rR (RightIx ix)) where+  show (RightR v) = show v++unLeftR :: EitherFunctor rL rR (LeftIx ix) -> rL ix+unLeftR (LeftR v) = v++unRightR :: EitherFunctor rL rR (RightIx ix) -> rR ix+unRightR (RightR v) = v++type instance PF (MergeDomain phiL phiR) = PF phiL :+: PF phiR
Text/GrammarCombinators/Base/Grammar.hs view
@@ -31,14 +31,50 @@   forall p. (ProductionRule p, EpsProductionRule p, TokenProductionRule p t) =>   p v +type PenaltyRegularRule phi r t v =+  forall p. (ProductionRule p, EpsProductionRule p, TokenProductionRule p t, PenaltyProductionRule p) =>+  p v++type BiasedRegularRule phi r t v =+  forall p. (ProductionRule p, EpsProductionRule p, TokenProductionRule p t, BiasedProductionRule p) =>+  p v+ type ContextFreeRule phi r t v =   forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t) =>   p v +type PenaltyContextFreeRule phi r t v =+  forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, PenaltyProductionRule p) =>+  p v++type BiasedContextFreeRule phi r t v =+  forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, BiasedProductionRule p) =>+  p v+ type ExtendedContextFreeRule phi r t v =   forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, LoopProductionRule p phi r) =>   p v +type PenaltyExtendedContextFreeRule phi r t v =+  forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, LoopProductionRule p phi r, PenaltyProductionRule p) =>+  p v++type BiasedExtendedContextFreeRule phi r t v =+  forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, LoopProductionRule p phi r, BiasedProductionRule p) =>+  p v++type BiasedExtendedLiftableContextFreeRule phi r t v =+  forall p. (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, LoopProductionRule p phi r, BiasedProductionRule p) =>+  p v++type AnyExtendedContextFreeRule phi r t v =+  forall p. (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, LoopProductionRule p phi r, PenaltyProductionRule p, BiasedProductionRule p) =>+  p v++type LAnyExtendedContextFreeRule phi r t v =+  forall p. (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, LoopProductionRule p phi r, PenaltyProductionRule p, BiasedProductionRule p) =>+  p v+ type LiftableContextFreeRule phi r t v =   forall p. (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r, TokenProductionRule p t) =>   p v@@ -55,16 +91,31 @@ type GRegularGrammar phi t r rr = GGrammar RegularRule phi t r rr type GContextFreeGrammar phi t r rr = GGrammar ContextFreeRule phi t r rr type GLContextFreeGrammar phi t r rr = GGrammar LiftableContextFreeRule phi t r rr+type GPenaltyContextFreeGrammar phi t r rr = GGrammar PenaltyContextFreeRule phi t r rr+type GBiasedContextFreeGrammar phi t r rr = GGrammar BiasedContextFreeRule phi t r rr type GExtendedContextFreeGrammar phi t r rr = GGrammar ExtendedContextFreeRule phi t r rr+type GPenaltyExtendedContextFreeGrammar phi t r rr = GGrammar PenaltyExtendedContextFreeRule phi t r rr+type GBiasedExtendedContextFreeGrammar phi t r rr = GGrammar BiasedExtendedContextFreeRule phi t r rr+type GAnyExtendedContextFreeGrammar phi t r rr = GGrammar AnyExtendedContextFreeRule phi t r rr+type GLAnyExtendedContextFreeGrammar phi t r rr = GGrammar LAnyExtendedContextFreeRule phi t r rr type GLExtendedContextFreeGrammar phi t r rr = GGrammar ExtendedLiftableContextFreeRule phi t r rr  type ContextFreeGrammar phi t = AGrammar ContextFreeRule phi t type LContextFreeGrammar phi t = AGrammar LiftableContextFreeRule phi t type ExtendedContextFreeGrammar phi t = AGrammar ExtendedContextFreeRule phi t+type PenaltyExtendedContextFreeGrammar phi t r rr = AGrammar PenaltyExtendedContextFreeRule phi t +type BiasedExtendedContextFreeGrammar phi t r rr = AGrammar BiasedExtendedContextFreeRule phi t  type LExtendedContextFreeGrammar phi t = AGrammar ExtendedLiftableContextFreeRule phi t  type ProcessingRegularGrammar phi t r = PGrammar RegularRule phi t r+type ProcessingPenaltyRegularGrammar phi t r = PGrammar PenaltyRegularRule phi t r+type ProcessingBiasedRegularGrammar phi t r = PGrammar BiasedRegularRule phi t r type ProcessingContextFreeGrammar phi t r = PGrammar ContextFreeRule phi t r type ProcessingLContextFreeGrammar phi t r = PGrammar LiftableContextFreeRule phi t r+type ProcessingPenaltyContextFreeGrammar phi t r = PGrammar PenaltyContextFreeRule phi t r+type ProcessingBiasedContextFreeGrammar phi t r = PGrammar BiasedContextFreeRule phi t r type ProcessingExtendedContextFreeGrammar phi t r = PGrammar ExtendedContextFreeRule phi t r+type ProcessingPenaltyExtendedContextFreeGrammar phi t r = PGrammar PenaltyExtendedContextFreeRule phi t r+type ProcessingBiasedExtendedContextFreeGrammar phi t r = PGrammar BiasedExtendedContextFreeRule phi t r type ProcessingLExtendedContextFreeGrammar phi t r = PGrammar ExtendedLiftableContextFreeRule phi t r+type ProcessingLBiasedExtendedContextFreeGrammar phi t r = PGrammar BiasedExtendedLiftableContextFreeRule phi t r
Text/GrammarCombinators/Base/Processor.hs view
@@ -26,6 +26,7 @@   Processor,   identityProcessor,   trivialProcessor,+  applyProcessor',   applyProcessor,   applyProcessorL,   applyProcessorLE,
Text/GrammarCombinators/Base/ProductionRule.hs view
@@ -81,7 +81,11 @@   -- | Match a given token of type 't' and produce its concrete   -- value (of type 'ConcreteToken' t).   token :: t -> p (ConcreteToken t)+  anyToken :: p (ConcreteToken t)  +class PenaltyProductionRule p where+  penalty :: Int -> p a -> p a+ -- | Sequence two rules, but drop the result of the first. (*>>>) :: (ProductionRule p, LiftableProductionRule p) => p a -> p b -> p b a *>>> b = epsilonL (flip const) [| flip const |] >>> a >>> b@@ -161,4 +165,16 @@ -- Prefer to use the 'manyRef' function whenever possible. many1Inf :: (ProductionRule p, LiftableProductionRule p) => p a -> p [a] many1Inf r = epsilonL (:) [|(:)|] >>> r >>> manyInf r+++class ProductionRuleWithLibrary p phi r | p -> phi, p -> r where+  lib :: phi ix -> p (r ix)++class BiasedProductionRule p where+  -- | Left-biased choice+  (>|||) :: p a -> p a -> p a+  (>|||) = flip (<|||)+  -- | Right-biased choice+  (<|||) :: p a -> p a -> p a+  (<|||) = flip (>|||)
Text/GrammarCombinators/Base/Token.hs view
@@ -54,8 +54,8 @@ -- use a token type with less token values than 'Char', at -- least if you will use algorithms that fold over the full new grammar's domain  -- (e.g. 'printGrammar' does, 'printReachableGrammar' doesn't).-class (Show (ConcreteToken t), Eq (ConcreteToken t), Eq t,-       Show t, Ord t, Lift t, Enumerable t) =>+class (Show (ConcreteToken t), Eq (ConcreteToken t), Lift (ConcreteToken t),+       Eq t, Show t, Ord t, Lift t, Enumerable t) =>       Token t where   type ConcreteToken t   -- | The 'classify' function classifies a given 'ConcreteToken' t into
Text/GrammarCombinators/Parser/LL1.hs view
@@ -38,6 +38,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe+import Data.Enumerable (enumerate)  import Control.Monad import Control.Monad.State@@ -81,6 +82,7 @@  instance (Token t, Domain phi) => TokenProductionRule (FSCalculator phi ixT r t) t where   token c = MkFSCalculator $ \_ -> [FS (singleton c) False False]+  anyToken = MkFSCalculator $ \_ -> [FS (Set.fromList enumerate) False False] instance (Domain phi, Token t) => RecProductionRule (FSCalculator phi ixT r t) phi r where   ref idx = MkFSCalculator $ \g -> [FS (unionL $ map firstSet $ g idx) (any canBeEmpty $ g idx) (any canBeEOI $ g idx)] @@ -157,6 +159,11 @@                           return c                   else fail $ errWrongToken c       errWrongToken c =  show c ++ " read when " ++ show t ++ " expected."+    in MkLLRule [rule]+  anyToken =+    let rule = do (c:r) <- MkNBR $ \_ -> get+                  MkNBR $ \_ -> put r+                  return c     in MkLLRule [rule]    instance RecProductionRule (LLRule phi ixT r t) phi r where
Text/GrammarCombinators/Parser/Packrat.hs view
@@ -129,6 +129,11 @@     case unPRResult$ unDerivs d PackratDomainPrimToken of       Parsed v' d' | classify (unPRPrimTokenValue v') == c -> Parsed (unPRPrimTokenValue v') d'       _ -> NoParse+  anyToken = PackratRule $ \_ _ _ d ->+    case unPRResult$ unDerivs d PackratDomainPrimToken of+      Parsed v' d' -> Parsed (unPRPrimTokenValue v') d'+      _ -> NoParse+      instance RecProductionRule (PackratRule phitop rtop phi ixT r t) phi r where   ref (idx :: phi ix) =
Text/GrammarCombinators/Parser/Parsec.hs view
@@ -25,11 +25,15 @@  -- | Compatibility component for the Parsec library. module Text.GrammarCombinators.Parser.Parsec (-  parseParsec+  parseParsec,+  parseParsecR,+  parseParsecBiased,+  WrapGenParser, unWGP   ) where  import Text.GrammarCombinators.Base import Text.GrammarCombinators.Transform.UnfoldRecursion+import Text.GrammarCombinators.Transform.IntroduceBias  import Text.Parsec import Text.Parsec.Pos@@ -44,31 +48,57 @@   endOfInput = WGP eof   die = WGP parserZero +instance BiasedProductionRule (WrapGenParser t) where+  a >||| b = WGP $ unWGP a <|> unWGP b+ instance (Token t) => EpsProductionRule (WrapGenParser t) where   epsilon v = WGP $ return v  instance (Token t) => LiftableProductionRule (WrapGenParser t) where   epsilonL v _ = epsilon v +nextPos :: SourcePos -> t -> t1 -> SourcePos+nextPos p _ _  = newPos (sourceName p) (sourceLine p) (sourceColumn p+1)+ instance (Token t) => TokenProductionRule (WrapGenParser t) t where   token tt = WGP $ tokenPrim show nextPos testToken     where       testToken t        = if classify t == tt then Just t else Nothing-      nextPos p _ _  = newPos (sourceName p) (sourceLine p) (sourceColumn p+1)+  anyToken = WGP $ tokenPrim show nextPos Just  -- | Parse a given string according to a given grammar, starting from a given start --   non-terminal, using the Parsec parser library. Currently uses backtracking for --   every branch.---  ---   It is probably possible to automatically approximate ---   branches where backtracking is required, which would be neat and really go beyond---   what is currently possible in Parsec. Help welcome! parseParsec :: forall phi t r ix.                (Token t) =>-               ProcessingContextFreeGrammar phi t r ->+               ProcessingBiasedContextFreeGrammar phi t r ->                phi ix -> SourceName -> [ConcreteToken t] -> Either ParseError (r ix) parseParsec gram idx =    let irule :: WrapGenParser t (r ix)-      irule = unfoldRecursion gram idx+      irule = unfoldRecursionB gram idx       parser = unWGP irule   in Parsec.parse parser++parseParsecR :: forall phi t r ix.+               (Token t) =>+               ProcessingBiasedRegularGrammar phi t r ->+               phi ix -> SourceName -> [ConcreteToken t] -> Either ParseError (r ix)+parseParsecR gram idx = +  let irule :: WrapGenParser t (r ix)+      irule = gram idx+      parser = unWGP irule+  in Parsec.parse parser++parseParsecBiased :: forall phi t r ix.+                      (Token t, EqFam phi) =>+                      ProcessingContextFreeGrammar phi t r ->+                      phi ix -> SourceName -> +                      [ConcreteToken t] -> Either ParseError (r ix)+parseParsecBiased gram idx = +  let gramB :: ProcessingBiasedContextFreeGrammar phi t r +      gramB = introduceBias gram+      irule :: WrapGenParser t (r ix)+      irule = unfoldRecursionB gramB idx+      parser = unWGP irule+  in Parsec.parse parser+
Text/GrammarCombinators/Parser/RealLL1.hs view
@@ -41,6 +41,7 @@ import Control.Monad.State  import Data.Set +import Data.Enumerable (enumerate)  import qualified Data.Set as Set  data (Token t) => FirstSet t = @@ -124,6 +125,8 @@ instance (Token t, Domain phi) => TokenProductionRule (BranchSelectorComputer phi r t) t where   token tt = MkBSC $ \_ ->      MkBD DefaultBranchSelectorMemo id $ FS (singleton tt) False False+  anyToken = MkBSC $ \_ -> +    MkBD DefaultBranchSelectorMemo id $ FS (fromList enumerate) False False  instance (Token t, Domain phi) => RecProductionRule (BranchSelectorComputer phi r t) phi r where   ref idx = MkBSC $ \g ->@@ -173,6 +176,9 @@           if classify c == tt             then put r >> return c             else fail $ errWrongToken c+  anyToken = MkRealLL1Rule $ \_ _ _ ->+    do (c:r) <- get+       put r >> return c  instance RecProductionRule (RealLL1Rule phi ixT r t) phi r where   ref idx = MkRealLL1Rule $ \_ selg g ->
Text/GrammarCombinators/Parser/RecursiveDescent.hs view
@@ -62,14 +62,13 @@  instance (Token t) => TokenProductionRule (RecDecRule t) t where   token c = -    let -      primToken = RecDecRule $ do (c':r) <- get-                                  put r-                                  return c'-    in do cr <- primToken-          if c == classify cr-            then return cr-            else fail $ "unexpected token " ++ show c ++ ", expecting " ++ show cr+    do cr <- anyToken+       if c == classify cr+         then return cr+         else fail $ "unexpected token " ++ show c ++ ", expecting " ++ show cr+  anyToken = RecDecRule $ do (c':r) <- get+                             put r+                             return c'  parseRecDecBase :: RecDecRule t a -> [ConcreteToken t] -> Maybe a parseRecDecBase parser s =
Text/GrammarCombinators/Parser/UUParse.hs view
@@ -37,6 +37,8 @@  import Text.ParserCombinators.UU hiding (Token) +import Data.Enumerable (enumerate)+ -- We just count tokens for now (not lines and colums with handling here for newlines etc),  -- locations cannot be used atm anyway... instance IsLocationUpdatedBy Int t where@@ -62,6 +64,7 @@       sat :: ConcreteToken t -> Bool       sat t = classify t == tt     in WP $ pSym (sat, show tt, head $ enumConcreteTokens tt)+  anyToken = WP $ pSym (const True :: ConcreteToken t -> Bool, "anyToken", head $ enumConcreteTokens (head enumerate :: t))  -- | Parse a given string according to a given regular grammar, starting from a given -- start symbol using the UUParse error-correcting parsing library (always@@ -88,7 +91,7 @@            RegularRule phi r t v ->            [ConcreteToken t] -> v parseUURule rule s = -  parse (unWP rule) $ listToStr s 0+  parse (unWP rule <* pEnd) $ listToStr s 0  -- | Parse a given string according to a given extended grammar, starting from a given -- start symbol using the UUParse error-correcting parsing library (always
Text/GrammarCombinators/Transform/CombineEpsilons.hs view
@@ -55,6 +55,7 @@ instance (TokenProductionRule p t) =>          TokenProductionRule (CombineEpsilonsRule p phi r t) t where   token = CERule id . token+  anyToken = CERule id anyToken  instance (RecProductionRule p phi r) =>          RecProductionRule (CombineEpsilonsRule p phi r t) phi r where
+ Text/GrammarCombinators/Transform/CombineGrammars.hs view
@@ -0,0 +1,129 @@+{-  Copyright 2010 Dominique Devriese++    This file is part of the grammar-combinators library.++    The grammar-combinators library is free software: you can+    redistribute it and/or modify it under the terms of the GNU+    Lesser General Public License as published by the Free+    Software Foundation, either version 3 of the License, or (at+    your option) any later version.++    Foobar is distributed in the hope that it will be useful, but+    WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+    GNU Lesser General Public License for more details.++    You should have received a copy of the GNU Lesser General+    Public License along with Foobar. If not, see+    <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Text.GrammarCombinators.Transform.CombineGrammars (+  combineGrammars+  ) where++import Text.GrammarCombinators.Base++newtype CGW p (phiL :: * -> *) (phiR :: * -> *) (rL :: * -> *) (rR :: * -> *) t v = MkCGW { unCGW :: p v }++instance (EpsProductionRule p, ProductionRule p,+          RecProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => +         RecProductionRule (CGW p phiL phiR rL rR t) phiL rL where+           ref idx = MkCGW $ unLeftR $>> ref (LeftIdx idx)++instance (EpsProductionRule p, ProductionRule p,+          LoopProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => +         LoopProductionRule (CGW p phiL phiR rL rR t) phiL rL where+           manyRef idx = MkCGW $ map unLeftR $>> manyRef (LeftIdx idx)++instance (EpsProductionRule p, ProductionRule p,+          RecProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => +         ProductionRuleWithLibrary (CGW p phiL phiR rL rR t) phiR rR where+           lib idx = MkCGW $ unRightR $>> ref (RightIdx idx)++instance (ProductionRule p) => +         ProductionRule (CGW p phiL phiR rL rR t) where+           (MkCGW pl) >>> (MkCGW pr) = MkCGW (pl >>> pr)+           (MkCGW pl) ||| (MkCGW pr) = MkCGW (pl ||| pr)+           endOfInput = MkCGW endOfInput+           die = MkCGW die++instance (LiftableProductionRule p) => +         LiftableProductionRule (CGW p phiL phiR rL rR t) where+           epsilonL q v = MkCGW (epsilonL q v)++instance (EpsProductionRule p) => +         EpsProductionRule (CGW p phiL phiR rL rR t) where+           epsilon v = MkCGW (epsilon v)++instance (TokenProductionRule p t) => +         TokenProductionRule (CGW p phiL phiR rL rR t) t where+           token tt = MkCGW (token tt)+           anyToken = MkCGW anyToken++newtype IGW p (phiL :: * -> *) (phiR :: * -> *) (rL :: * -> *) (rR :: * -> *) t v =+  IGW { unIGW :: p v }++instance (EpsProductionRule p) => EpsProductionRule (IGW p phiL phiR rL rR t) where+  epsilon v = IGW $ epsilon v++instance (LiftableProductionRule p) => LiftableProductionRule (IGW p phiL phiR rL rR t) where+  epsilonL q v = IGW $ epsilonL q v++instance (TokenProductionRule p t) => TokenProductionRule (IGW p phiL phiR rL rR t) t where+  token tt = IGW $ token tt+  anyToken = IGW anyToken++instance (ProductionRule p) => ProductionRule (IGW p phiL phiR rL rR t) where+  (IGW pl) >>> (IGW pr) = IGW (pl >>> pr)+  (IGW pl) ||| (IGW pr) = IGW (pl ||| pr)+  endOfInput = IGW endOfInput+  die = IGW die++instance (EpsProductionRule p, ProductionRule p, RecProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => +         RecProductionRule (IGW p phiL phiR rL rR t) (MergeDomain phiR phiL) (EitherFunctor rR rL) where+  ref (LeftIdx idx) = IGW $ (LeftR $>> (unRightR $>> ref (RightIdx idx)))+  ref (RightIdx idx) = IGW $ (RightR $>> (unLeftR $>> ref (LeftIdx idx)))++instance (EpsProductionRule p, ProductionRule p, LoopProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => +         LoopProductionRule (IGW p phiL phiR rL rR t) (MergeDomain phiR phiL) (EitherFunctor rR rL) where+  manyRef (LeftIdx idx) = IGW $ (map LeftR $>> (map unRightR $>> manyRef (RightIdx idx)))+  manyRef (RightIdx idx) = IGW $ (map RightR $>> (map unLeftR $>> manyRef (LeftIdx idx)))+  many1Ref (LeftIdx idx) = IGW $ (map LeftR $>> (map unRightR $>> many1Ref (RightIdx idx)))+  many1Ref (RightIdx idx) = IGW $ (map RightR $>> (map unLeftR $>> many1Ref (LeftIdx idx)))++invertGrammar :: +  (EpsProductionRule p, ProductionRule p) =>+  (forall ix'. MergeDomain phiL phiR ix' -> p (EitherFunctor rL rR ix')) ->+  MergeDomain phiR phiL ix -> p (EitherFunctor rR rL ix)+invertGrammar g (LeftIdx idx) = (LeftR . unRightR) $>> g (RightIdx idx)                 +invertGrammar g (RightIdx idx) = (RightR . unLeftR) $>> g (LeftIdx idx)                 ++-- | Combine two grammars into a single one. The argument grammars are over+--   different domains 'phiL' and 'phiR', but they are allowed to refer to +--   each other's non-terminals+--   using the 'lib' primitive from the 'ProductionRuleWithLibrary' type class.+--   The resulting grammar is over the combined domain 'MergeDomain phiL phiR'.+combineGrammars :: forall p phiL phiR rL rR rrL rrR t ix.+  (EpsProductionRule p, ProductionRule p, TokenProductionRule p t,+   RecProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR),+   LoopProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) =>+  (forall p' ix'. (ProductionRule p', EpsProductionRule p', TokenProductionRule p' t,+                  RecProductionRule p' phiL rL,+                  LoopProductionRule p' phiL rL,+                  ProductionRuleWithLibrary p' phiR rR) => phiL ix' -> p' (rrL ix')) -> +  (forall p' ix'. (ProductionRule p', EpsProductionRule p', TokenProductionRule p' t,+                  RecProductionRule p' phiR rR,+                  LoopProductionRule p' phiR rR,+                  ProductionRuleWithLibrary p' phiL rL) => phiR ix' -> p' (rrR ix')) ->+  MergeDomain phiL phiR ix -> p (EitherFunctor rrL rrR ix)+combineGrammars gL _ (LeftIdx idx) = LeftR $>> unCGW (gL idx)+combineGrammars gL gR (RightIdx idx) = unIGW (invertGrammar (combineGrammars gR gL) (RightIdx idx))
Text/GrammarCombinators/Transform/FilterDies.hs view
@@ -26,7 +26,9 @@  module Text.GrammarCombinators.Transform.FilterDies (   filterDies,+  filterDiesP,   filterDiesE,+  filterDiesPE,   filterDiesLE   ) where @@ -59,11 +61,17 @@ instance (TokenProductionRule p t) =>          TokenProductionRule (FilterDiesRule p phi r t) t where   token = FDBaseRule . token+  anyToken = FDBaseRule anyToken  instance (RecProductionRule p phi r) =>          RecProductionRule (FilterDiesRule p phi r t) phi r where   ref = FDBaseRule . ref +instance (PenaltyProductionRule p) =>+         PenaltyProductionRule (FilterDiesRule p phi r t) where+  penalty _ FDDieRule = FDDieRule+  penalty _ (FDBaseRule _)  = FDDieRule+ instance (LoopProductionRule p phi r) =>          LoopProductionRule (FilterDiesRule p phi r t) phi r where   manyRef = FDBaseRule . manyRef@@ -80,11 +88,23 @@   GContextFreeGrammar phi t r rr filterDies gram idx = runFDRule $ gram idx +-- | Filter dead branches from a given context-free grammar.+filterDiesP :: forall phi t r rr. +  GPenaltyContextFreeGrammar phi t r rr ->+  GPenaltyContextFreeGrammar phi t r rr+filterDiesP gram idx = runFDRule $ gram idx+ -- | Filter dead branches from a given extended context-free grammar. filterDiesE :: forall phi t r rr.    GExtendedContextFreeGrammar phi t r rr ->   GExtendedContextFreeGrammar phi t r rr filterDiesE gram idx = runFDRule $ gram idx++-- | Filter dead branches from a given context-free grammar.+filterDiesPE :: forall phi t r rr. +  GPenaltyExtendedContextFreeGrammar phi t r rr ->+  GPenaltyExtendedContextFreeGrammar phi t r rr+filterDiesPE gram idx = runFDRule $ gram idx  -- | Filter dead branches from a given extended context-free grammar. filterDiesLE :: forall phi t r rr.
Text/GrammarCombinators/Transform/FoldLoops.hs view
@@ -132,6 +132,7 @@ instance (TokenProductionRule p t) =>          TokenProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) t where   token = FLW . token+  anyToken = FLW anyToken  instance (RecProductionRule p (FoldLoopsDomain phi) (FoldLoopsValue r),           ProductionRule p, EpsProductionRule p) =>
+ Text/GrammarCombinators/Transform/IntroduceBias.hs view
@@ -0,0 +1,127 @@+{-  Copyright 2010 Dominique Devriese++    This file is part of the grammar-combinators library.++    The grammar-combinators library is free software: you can+    redistribute it and/or modify it under the terms of the GNU+    Lesser General Public License as published by the Free+    Software Foundation, either version 3 of the License, or (at+    your option) any later version.++    Foobar is distributed in the hope that it will be useful, but+    WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+    GNU Lesser General Public License for more details.++    You should have received a copy of the GNU Lesser General+    Public License along with Foobar. If not, see+    <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Compatibility component for the Parsec library.+module Text.GrammarCombinators.Transform.IntroduceBias (+    introduceBias+  , introduceBiasE+  , introduceBiasLE+  ) where++import Prelude hiding (null)++import Text.GrammarCombinators.Base+import Text.GrammarCombinators.Utils.CalcFirst++import Data.Set (intersection, null)++data IBW p phi (r :: * -> *) t rr v = MkIBW { +  firstSetRule :: FSCalculator phi r t rr v,+  unWrap :: FirstSetGrammar phi r t rr -> p v +  }++ambiguous :: (Token t) => FirstSet t -> FirstSet t -> Bool+ambiguous fsa fsb = (canBeEmpty fsa && canBeEmpty fsb) ||+                    (canBeEOI fsa && canBeEmpty fsb)++mutuallyExclusive :: Token t => FirstSet t -> FirstSet t -> Bool+mutuallyExclusive fsa fsb =  +  null $ firstSet fsa `intersection` firstSet fsb++instance (Token t, ProductionRule p, BiasedProductionRule p) => +         ProductionRule (IBW p phi r t rr) where+  (a :: IBW p phi r t rr (va -> vb)) >>> (b :: IBW p phi r t rr va) = +    let fs = firstSetRule a >>> firstSetRule b+        up :: FirstSetGrammar phi r t rr -> p vb +        up fsg = unWrap a fsg >>> unWrap b fsg+    in MkIBW fs up+  die = MkIBW die (const die)+  endOfInput = MkIBW endOfInput (const endOfInput)+  a ||| (b :: IBW p phi r t rr v) =+    let fs = firstSetRule a ||| firstSetRule b+        fsa :: FirstSetGrammar phi r t rr -> FirstSet t+        fsa = calcFS (firstSetRule a) +        fsb :: FirstSetGrammar phi r t rr -> FirstSet t+        fsb = calcFS (firstSetRule b) +        up :: FirstSetGrammar phi r t rr -> p v+        up fsg = if ambiguous (fsa fsg) (fsb fsg)+                 then error "can't introduce bias in ambiguous grammars"+                 else if mutuallyExclusive (fsa fsg) (fsb fsg)+                      then unWrap a fsg >||| unWrap b fsg+                      else unWrap a fsg ||| unWrap b fsg+    in MkIBW fs up++instance (Token t, LiftableProductionRule p, BiasedProductionRule p) =>+         LiftableProductionRule (IBW p phi r t rr) where+  epsilonL v q = MkIBW (epsilonL v q) (\_ -> epsilonL v q) ++instance (Token t, EpsProductionRule p, BiasedProductionRule p) =>+         EpsProductionRule (IBW p phi r t rr) where+  epsilon v = MkIBW (epsilon v) (\_ -> epsilon v) ++instance (Token t, TokenProductionRule p t) => +         TokenProductionRule (IBW p phi r t rr) t where+  token tt = MkIBW (token tt) (\_ -> token tt)+  anyToken = MkIBW anyToken (const anyToken)+   +instance (Token t, EqFam phi, RecProductionRule p phi r) =>+         RecProductionRule (IBW p phi r t rr) phi r where+  ref idx = MkIBW (ref idx) (\_ -> ref idx)++instance (Token t, EqFam phi, BiasedProductionRule p,+          LiftableProductionRule p, +          LoopProductionRule p phi r) =>+         LoopProductionRule (IBW p phi r t rr) phi r where+  manyRef idx = MkIBW (manyRef idx) (\_ -> manyRef idx)+  many1Ref idx = MkIBW (many1Ref idx) (\_ -> many1Ref idx)++introduceBias :: (Token t, EqFam phi) =>+                 ProcessingContextFreeGrammar phi t r ->+                 ProcessingBiasedContextFreeGrammar phi t r +introduceBias gram idx = unWrap (gram idx) gram++introduceBiasE :: (Token t, EqFam phi) =>+                 ProcessingExtendedContextFreeGrammar phi t r ->+                 ProcessingBiasedExtendedContextFreeGrammar phi t r +introduceBiasE gram idx = unWrap (gram idx) gram++introduceBiasLE :: (Token t, EqFam phi) =>+                 ProcessingLExtendedContextFreeGrammar phi t r ->+                 ProcessingLBiasedExtendedContextFreeGrammar phi t r +introduceBiasLE gram idx = unWrap (gram idx) gram++-- parseParsecBiased  :: forall phi t r ix.+--                       (Token t, EqFam phi) =>+--                       ProcessingContextFreeGrammar phi t r ->+--                       phi ix -> SourceName -> +--                       [ConcreteToken t] -> Either ParseError (r ix)+-- parseParsecBiased gram idx = +--   let irule :: WrapGenParser t (r ix)+--       irule = unWrap (unfoldRecursion gram idx) gram+--       parser = unWGP irule+--   in Parsec.parse parser+
Text/GrammarCombinators/Transform/LeftCorner.hs view
@@ -181,6 +181,9 @@   token tt =      let rNTMinT tt' = if tt == tt' then epsilonL id [|id|] else die     in MkTLCIR Nothing (token tt) (const die) rNTMinT +  anyToken =+    let rNTMinT _ =  epsilonL id [|id|]+    in MkTLCIR Nothing anyToken (const die) rNTMinT   newtype WrapNTMinNTP p r ix surrIx =   WNTMinNTP { unWNTMinNTP :: p (r surrIx -> r ix) }
+ Text/GrammarCombinators/Transform/PenalizeErrors.hs view
@@ -0,0 +1,121 @@+{-  Copyright 2010 Dominique Devriese++    This file is part of the grammar-combinators library.++    The grammar-combinators library is free software: you can+    redistribute it and/or modify it under the terms of the GNU+    Lesser General Public License as published by the Free+    Software Foundation, either version 3 of the License, or (at+    your option) any later version.++    Foobar is distributed in the hope that it will be useful, but+    WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+    GNU Lesser General Public License for more details.++    You should have received a copy of the GNU Lesser General+    Public License along with Foobar. If not, see+    <http://www.gnu.org/licenses/>.+-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Text.GrammarCombinators.Transform.PenalizeErrors where++import Text.GrammarCombinators.Base++import Language.Haskell.TH.Syntax (lift)++import Control.Applicative+import Data.Enumerable++data MaybeSemanticT r ix = JustV { fromJustV :: r ix } | NothingV deriving (Show)++isJustV :: MaybeSemanticT r ix -> Bool+isJustV (JustV _) = True+isJustV NothingV = False+  +newtype PBEHProductionRule p (phi :: * -> *) (unusedR :: * -> *) (r :: * -> *) t v = MkPBEH { unPBEH :: p v }++instance (ProductionRule p) => ProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) where+  a >>> b = MkPBEH $ unPBEH a >>> unPBEH b+  a ||| b = MkPBEH $ unPBEH a ||| unPBEH b+  die = MkPBEH die+  endOfInput = MkPBEH endOfInput+ +instance (LiftableProductionRule p) => LiftableProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) where+  epsilonL v q = MkPBEH $ epsilonL v q++instance (EpsProductionRule p) =>+         EpsProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) where+  epsilon v = MkPBEH $ epsilon v++instance (RecProductionRule p phi (MaybeSemanticT r), LiftableProductionRule p, PenaltyProductionRule p) =>+         RecProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) phi (MaybeSemanticT r) where+  ref idx = MkPBEH $+            ref idx+        ||| penalty 1 (epsilonL NothingV [| NothingV |])++instance (LoopProductionRule p phi (MaybeSemanticT r), LiftableProductionRule p, PenaltyProductionRule p) =>+         LoopProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) phi (MaybeSemanticT r) where+  manyRef idx = MkPBEH $ manyRef idx ++instance forall p t phi r.+         (PenaltyProductionRule p, LiftableProductionRule p, TokenProductionRule p t, Token t) =>+         TokenProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) t where+  token tt = +    let +      altT = head $ enumConcreteTokens tt+    in MkPBEH $     token tt+                ||| penalty 1 (epsilonL altT (lift altT))+                ||| penalty 1 ((altT, lift altT) $|>>* anyToken)+  anyToken =+    let +      altT :: ConcreteToken t+      altT = head $ enumConcreteTokens $ (head enumerate :: t)+    in MkPBEH $     anyToken+                ||| penalty 1 (epsilonL altT (lift altT))++newtype IsJustApp v = IJA { unIJA :: Bool }++instance Functor IsJustApp where+  fmap _ v = IJA $ unIJA v+instance Applicative IsJustApp where+  pure _ = IJA True+  IJA va <*> IJA vb = IJA $ va && vb++processPenalizedSimple ::+  forall phi r. (HFunctor phi (PF phi)) =>+  Processor phi r -> Processor phi (MaybeSemanticT r)+processPenalizedSimple proc idx pfv = +  let +    allJustVs :: phi ix -> PF phi (MaybeSemanticT r) ix -> Bool +    allJustVs idx' pfv' = unIJA $ hmapA (\_ v -> IJA $ isJustV v) idx' pfv'+    fromJustVs :: phi ix -> PF phi (MaybeSemanticT r) ix -> PF phi r ix+    fromJustVs = hmap (\_ (JustV v) -> v)+  in if allJustVs idx pfv+     then JustV $ proc idx $ fromJustVs idx pfv+     else NothingV++penalizeErrors' :: forall p phi r rr t ix.+                   (forall ix'. phi ix' -> PBEHProductionRule p phi (MaybeSemanticT r) r t (rr ix')) ->+                   phi ix -> p (rr ix)+penalizeErrors' g idx = unPBEH (g idx)++penalizeErrorsE :: +  forall phi t r rr. (Token t) =>+  GExtendedContextFreeGrammar phi t (MaybeSemanticT r) rr ->+  GPenaltyExtendedContextFreeGrammar phi t (MaybeSemanticT r) rr+penalizeErrorsE g idx = penalizeErrors' g idx++penalizeErrors :: +  forall phi t r rr. (Token t) =>+  GContextFreeGrammar phi t (MaybeSemanticT r) rr ->+  GPenaltyContextFreeGrammar phi t (MaybeSemanticT r) rr+penalizeErrors g idx = penalizeErrors' g idx
Text/GrammarCombinators/Transform/UnfoldChainNTs.hs view
@@ -73,6 +73,7 @@  instance (ProductionRule p) => TokenProductionRule (RuleToManyWrapper p phi r t) t where   token _ = RTMW die die+  anyToken = RTMW die die  instance (LoopProductionRule p phi r) =>          RecProductionRule (RuleToManyWrapper p phi r t) phi r where
Text/GrammarCombinators/Transform/UnfoldDead.hs view
@@ -55,6 +55,7 @@ instance (TokenProductionRule p t) =>          TokenProductionRule (UnfoldDeadRule p phi r t) t where   token t = UDRule $ \_ -> token t+  anyToken = UDRule $ \_ -> anyToken  instance (ProductionRule p,            RecProductionRule p phi r) =>
Text/GrammarCombinators/Transform/UnfoldLoops.hs view
@@ -27,6 +27,7 @@  module Text.GrammarCombinators.Transform.UnfoldLoops (   unfoldLoops,+  unfoldLoopsP,   unfoldLoopsRule,   replaceLoopsRule   ) where@@ -56,7 +57,12 @@ instance (TokenProductionRule p t) =>          TokenProductionRule (UnfoldLoopsWrapper p phi ixT r t) t where   token t = ULW $ \_ _ -> token t+  anyToken = ULW $ \_ _ -> anyToken +instance (PenaltyProductionRule p) =>+         PenaltyProductionRule (UnfoldLoopsWrapper p phi ixT r t) where+  penalty p r = ULW $ \gm gm1 -> penalty p $ runULW r gm gm1+ instance (RecProductionRule p phi r) =>          RecProductionRule (UnfoldLoopsWrapper p phi ixT r t) phi r where   ref idx = ULW $ \_ _ -> ref idx@@ -75,6 +81,15 @@ unfoldLoops gram idx =    unfoldLoopsRule (gram idx)  +-- | Unfold loops in a given grammar, replacing calls to+-- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise+-- for 'many1Ref'+unfoldLoopsP :: +  GPenaltyExtendedContextFreeGrammar phi t r rr ->+  GPenaltyContextFreeGrammar phi t r rr+unfoldLoopsP gram idx = +  unfoldLoopsRuleP (gram idx) + -- | Unfold loops in a given rule, replacing calls to -- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise -- for 'many1Ref'@@ -87,6 +102,17 @@     oneOrMoreGram idx = (:) $>> ref idx >>> manyGram idx   in replaceLoopsRule r manyGram oneOrMoreGram +-- | Unfold loops in a given rule, replacing calls to+-- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise+-- for 'many1Ref'+unfoldLoopsRuleP :: +  PenaltyExtendedContextFreeRule phi r t v ->+  PenaltyContextFreeRule phi r t v+unfoldLoopsRuleP r = +  let manyGram idx = manyInf $ ref idx+      oneOrMoreGram idx = (:) $>> ref idx >>> manyGram idx+  in replaceLoopsRuleP r manyGram oneOrMoreGram+ -- | Replace loops in a given rule by rules provided -- in two provided sets of rules, replacing calls to -- 'manyRef' by the corresponding rule from the first@@ -103,3 +129,10 @@ replaceLoopsRule r =    runULW r  +replaceLoopsRuleP :: +  (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, PenaltyProductionRule p) =>+  PenaltyExtendedContextFreeRule phi r t v ->+  (forall ix. phi ix -> p [r ix]) ->+  (forall ix. phi ix -> p [r ix]) ->+  p v+replaceLoopsRuleP r = runULW r
Text/GrammarCombinators/Transform/UnfoldRecursion.hs view
@@ -27,10 +27,15 @@ module Text.GrammarCombinators.Transform.UnfoldRecursion (   UnfoldDepth,   unfoldRecursion,+  unfoldRecursionP,+  unfoldRecursionB,   unfoldRecursionE,   selectNothing,   selectAllOnce,   selectNT,+  unselectNT,+  sumUD,+  scaleUD,   modifyUnfoldDepth,   unfoldSelective,   unfoldSelectiveE,@@ -55,6 +60,15 @@          LiftableProductionRule (RPWRule p phi ixT r t) where   epsilonL v q = RPWRule $ \_ -> epsilonL v q +instance (PenaltyProductionRule p) =>+         PenaltyProductionRule (RPWRule p phi ixT r t) where+  penalty p r = RPWRule $ \g -> penalty p $ unRPWRule r g++instance (BiasedProductionRule p) =>+         BiasedProductionRule (RPWRule p phi ixT r t) where+  a >||| b = RPWRule $ \g -> unRPWRule a g >||| unRPWRule b g+  a <||| b = RPWRule $ \g -> unRPWRule a g <||| unRPWRule b g+ instance (EpsProductionRule p) =>          EpsProductionRule (RPWRule p phi ixT r t) where   epsilon v = RPWRule $ \_ -> epsilon v@@ -62,6 +76,7 @@ instance (TokenProductionRule p t) =>          TokenProductionRule (RPWRule p phi ixT r t) t where   token c = RPWRule $ \_ -> token c+  anyToken = RPWRule $ \_ -> anyToken  instance (ProductionRule p) =>          RecProductionRule (RPWRule p phi ixT r t) phi r where@@ -84,6 +99,18 @@ unfoldRecursion gram idx =   unRPWRule (gram idx) $ unfoldRecursion gram +unfoldRecursionP ::+  ProcessingPenaltyContextFreeGrammar phi t r ->+  ProcessingPenaltyRegularGrammar phi t r+unfoldRecursionP gram idx =+  unRPWRule (gram idx) $ unfoldRecursionP gram++unfoldRecursionB ::+  ProcessingBiasedContextFreeGrammar phi t r ->+  ProcessingBiasedRegularGrammar phi t r+unfoldRecursionB gram idx =+  unRPWRule (gram idx) $ unfoldRecursionB gram+ -- | Unfold recursion in a given extended context-free grammar, -- replacing calls to -- 'ref' idx with the non-terminal's production rule. This produces@@ -126,6 +153,12 @@ selectAllOnce :: UnfoldDepth phi selectAllOnce _ = 1 +sumUD :: UnfoldDepth phi -> UnfoldDepth phi -> UnfoldDepth phi+(da `sumUD` db) idx = da idx + db idx++scaleUD :: Integer -> UnfoldDepth phi -> UnfoldDepth phi+(r `scaleUD` d) idx = r * d idx+ -- | A function modifying a given 'UnfoldDepth' phi by applying a given -- function to the depth for a given non-terminal. modifyUnfoldDepth :: (EqFam phi) => UnfoldDepth phi -> (Integer -> Integer) -> phi ix -> UnfoldDepth phi@@ -136,6 +169,11 @@ selectNT :: (EqFam phi) => UnfoldDepth phi -> phi ix -> UnfoldDepth phi selectNT base = modifyUnfoldDepth base (+1)  +-- | A function modifying a given 'UnfoldDepth' phi by decreasing +-- the depth for a given non-terminal by 1.+unselectNT :: (EqFam phi) => UnfoldDepth phi -> phi ix -> UnfoldDepth phi+unselectNT base = modifyUnfoldDepth base (flip (-) 1) + type RPWGrammar p phi ixT r v t =   forall ix. phi ix -> RPWRule p phi ixT r t (v ix) @@ -146,8 +184,8 @@ unfoldSelective' sel gram idx =   let     rg idx' = if sel idx' > 0-              then unfoldSelective' (modifyUnfoldDepth sel (flip (-) 1) idx) gram idx'-             else ref idx'+              then unfoldSelective' (modifyUnfoldDepth sel (flip (-) 1) idx') gram idx'+              else ref idx'   in unRPWRule (gram idx) rg  -- | Selectively unfold a given context-free grammar according to a @@ -165,11 +203,7 @@   ProcessingExtendedContextFreeGrammar phi t r ->   ProcessingExtendedContextFreeGrammar phi t r unfoldSelectiveE sel gram idx =-  let-    rg idx' = if sel idx' > 0-             then unfoldSelective' (modifyUnfoldDepth sel (flip (-) 1) idx') gram idx'-             else ref idx'-  in unRPWRule (gram idx) rg+  unfoldSelective' sel gram idx  -- | Unfold a given context-free rule by replacing all references to -- non-terminals with the production rule for that non-terminal in
Text/GrammarCombinators/Transform/UniformPaull.hs view
@@ -36,13 +36,14 @@   , UPValue ( UPBV, UPHV, UPTV )   , unUPBV, unUPHV, unUPTV   , transformUniformPaull+  , transformUniformPaullP   , transformUniformPaullE   , transformUniformPaullLE   ) where  import Text.GrammarCombinators.Base -import Control.Monad (ap, liftM2)+import Control.Monad (ap, liftM2, liftM)  import Data.Maybe (isJust, fromMaybe) @@ -181,9 +182,18 @@          LiftableProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) where   epsilonL = mkEpsLTUPW +instance (PenaltyProductionRule p) =>+         PenaltyProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) where+  penalty p r = MkTUPW $ \g ->+    let (MkTUPIR rla es h ts f) = tUPRuleForGrammar r g+        es' idx = liftM (penalty p) (es idx)+        h' idx = penalty p (h idx)+    in MkTUPIR rla es' h' ts $ penalty p f+ instance (TokenProductionRule p t, ProductionRule p) =>          TokenProductionRule (TransformUPWrapper p surrIx (UPDomain phi) (UPValue r) phi ixT r t) t where   token tt = mkSimpleTUPW $ token tt+  anyToken = mkSimpleTUPW anyToken   tlclTailRef :: (LiftableProductionRule p, LoopProductionRule p (UPDomain phi) (UPValue r)) =>                phi ix -> p ([r ix -> r ix])@@ -213,6 +223,11 @@       in (MkTUPIR rla es rh (\_ -> [(False, epsilonL id [|id|])]) rf)   in unWrapTUPW $ overrideIdx (WrapTUPW . g) idx (WrapTUPW nr) idx' +procTailRefs :: forall a. a -> [a -> a] -> a+procTailRefs = foldl $ flip ($)+-- procTailRefs z [] = z+-- procTailRefs z (x : xs) = procTailRefs (x z) xs+ instance (RecProductionRule p (UPDomain phi) (UPValue r),           LiftableProductionRule p,           EqFam phi,@@ -225,7 +240,7 @@         MkTUPIR rla eas ha tas _ = tUPRuleForGrammar (g idx) g'         h :: forall ix'. phi ix' -> p (r ix)         h idx' = if rla idx' -- use True to turn off optimization-                 then epsilonL (foldr ($)) [| foldr ($) |] >>>+                 then epsilonL procTailRefs [| procTailRefs |] >>>                       (hForEmptyHead idx' ||| ha idx') >>>                       tlclTailRef idx                  else f@@ -276,7 +291,7 @@ transformUniformPaull' _ (UPBase idx) =    let     ruleHead = epsilonL unUPHV [|unUPHV|] >>> ref (UPHead idx)-    br = epsilonL (foldr ($)) [|foldr ($)|] >>> ruleHead >>> tlclTailRef idx+    br = epsilonL procTailRefs [|procTailRefs|] >>> ruleHead >>> tlclTailRef idx   in epsilonL UPBV [|UPBV|] >>> br transformUniformPaull' bgram (UPHead (idx :: phi ix'')) =    let@@ -299,6 +314,12 @@   ProcessingContextFreeGrammar phi t r ->   ProcessingExtendedContextFreeGrammar (UPDomain phi) t (UPValue r) transformUniformPaull gram idx = transformUniformPaull' gram idx++transformUniformPaullP ::+  forall phi t r. Domain phi =>+  ProcessingPenaltyContextFreeGrammar phi t r ->+  ProcessingPenaltyExtendedContextFreeGrammar (UPDomain phi) t (UPValue r)+transformUniformPaullP gram idx = transformUniformPaull' gram idx  -- | Apply a uniform variant of the classic Paull transformation to a given extended grammar, -- removing direct and indirect left recursion.
Text/GrammarCombinators/Utils/AssessSize.hs view
@@ -48,6 +48,7 @@  instance (Token t) => TokenProductionRule (AssessSizeProductionRule phi r t) t where   token _ = ASPR 1+  anyToken = ASPR 1  instance RecProductionRule (AssessSizeProductionRule phi r t) phi r where   ref _ = ASPR 1
Text/GrammarCombinators/Utils/CalcFirst.hs view
@@ -24,10 +24,12 @@  module Text.GrammarCombinators.Utils.CalcFirst (   FirstSet (FS, firstSet, canBeEmpty, canBeEOI),+  FSCalculator, FirstSetGrammar, calcFS,   calcFirst   ) where  import Data.Set (Set, union, singleton)+import Data.Enumerable (enumerate) import qualified Data.Set as Set  import Text.GrammarCombinators.Base@@ -74,6 +76,9 @@  instance (Token t) => TokenProductionRule (FSCalculator phi r t rr) t where   token c = MkFSCalculator $ \_ -> FS (singleton c) False False+  anyToken = MkFSCalculator $ \_ -> FS allTokens False False+    where allTokens = Set.fromList enumerate +       instance (Token t, EqFam phi) => RecProductionRule (FSCalculator phi r t rr) phi r where   ref idx = MkFSCalculator $ \g -> calcFS (g idx) $ blockRecurse g idx instance (Token t, EqFam phi) => LoopProductionRule (FSCalculator phi r t rr) phi r where
+ Text/GrammarCombinators/Utils/CombineProcessors.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}++module Text.GrammarCombinators.Utils.CombineProcessors (+    CombineFam (Combine)+  , combineProcessors+  ) where++import Text.GrammarCombinators.Base++data CombineFam r1 r2 ix = Combine (r1 ix) (r2 ix)++-- | Combine two semantic processors into a single one that tuples+--   their respective values.+combineProcessors :: forall (phi :: * -> *) rr1 r1 rr2 r2. GProcessor phi rr1 r1 -> GProcessor phi rr2 r2 -> GProcessor phi (CombineFam rr1 rr2) (CombineFam r1 r2)+combineProcessors proc1 proc2 idx (Combine rrv1 rrv2) = Combine (proc1 idx rrv1) (proc2 idx rrv2)
Text/GrammarCombinators/Utils/EnumTokens.hs view
@@ -33,6 +33,7 @@ import Text.GrammarCombinators.Base import Text.GrammarCombinators.Utils.IsReachable +import Data.Enumerable (enumerate) newtype EnumTokensRule (phi :: * -> *) (r :: * -> *) t v = ETR {   unETR :: [t]   }@@ -51,6 +52,7 @@  instance (Token t) => TokenProductionRule (EnumTokensRule phi r t) t where   token t = ETR [t]+  anyToken = ETR enumerate  instance (ShowFam phi) => RecProductionRule (EnumTokensRule phi r t) phi r where   ref _ = ETR []
Text/GrammarCombinators/Utils/EnumerateGrammar.hs view
@@ -29,6 +29,8 @@ import Text.GrammarCombinators.Base import Text.GrammarCombinators.Transform.FoldLoops +import Data.Enumerable (enumerate)+ type EnumerateParserInternalGrammar phi t = forall ix . phi ix -> Int -> [[ConcreteToken t]]  newtype EnumerateProductionRule phi ixT r t v = IPP {@@ -51,6 +53,8 @@  instance (Token t) => TokenProductionRule (EnumerateProductionRule phi ixT r t) t where   token t = IPP $ \_ _ -> map (:[]) $ enumConcreteTokens t+  anyToken = IPP $ \_ _ -> [ enumConcreteTokens t | t <- enumerate :: [t] ]+                                instance RecProductionRule (EnumerateProductionRule phi ixT r t) phi r where   ref idx = IPP $ \g d -> if d > 0 then g idx $ d-1 else []
Text/GrammarCombinators/Utils/IsChainNT.hs view
@@ -55,6 +55,7 @@  instance TokenProductionRule (IsChainNT phi r t rr) t where   token _ = MkITR False False+  anyToken = MkITR False False  instance (EqFam phi) => RecProductionRule (IsChainNT phi r t rr) phi r where   ref _ = MkITR False True
Text/GrammarCombinators/Utils/IsDead.hs view
@@ -66,7 +66,15 @@   epsilonL _ _ = MkIDR $ return (False, False)  instance TokenProductionRule (IsDeadRule phi r t rr) t where-  token _ = MkIDR $ return (False, False)+  token _ = anyToken+  anyToken = MkIDR $ return (False, False)++instance PenaltyProductionRule (IsDeadRule phi r t rr) where+  penalty _ r = r++instance BiasedProductionRule (IsDeadRule phi r t rr) where+  (>|||) = (|||)+  (<|||) = (|||)  instance (EqFam phi, MemoFam phi) =>          SimpleRecProductionRule (IsDeadRule phi r t rr) phi r rr where
Text/GrammarCombinators/Utils/IsEpsilon.hs view
@@ -47,6 +47,7 @@  instance TokenProductionRule (IsEpsilonRule phi r t) t where   token _ = MkIER False+  anyToken = MkIER False    instance RecProductionRule (IsEpsilonRule phi r t) phi r where   ref _ = MkIER False
Text/GrammarCombinators/Utils/IsReachable.hs view
@@ -73,6 +73,13 @@   die = foldDeadEnd   endOfInput = foldDeadEnd +instance PenaltyProductionRule (FoldReachableIntRule phi r t rr n) where+  penalty _ r = MkFRIR $ foldRule r++instance BiasedProductionRule (FoldReachableIntRule phi r t rr n) where+  (>|||) = (|||)+  (<|||) = (|||)+ instance EpsProductionRule (FoldReachableIntRule phi r t rr n) where   epsilon _ = foldDeadEnd @@ -81,6 +88,7 @@  instance TokenProductionRule (FoldReachableIntRule phi r t rr n) t where   token _ = foldDeadEnd+  anyToken = foldDeadEnd  instance (EqFam phi) =>          SimpleRecProductionRule (FoldReachableIntRule phi r t rr n) phi r rr where@@ -98,7 +106,7 @@ -- from a given non-terminal. This function is limited to proper -- reachable rules (see 'isReachableProper' for what that means). foldReachableProper :: forall phi r t rr ix n. (Domain phi) => -                       GExtendedContextFreeGrammar phi t r rr ->+                       GAnyExtendedContextFreeGrammar phi t r rr ->                        phi ix ->                        (forall ix'. phi ix' -> n -> n) -> n -> n foldReachableProper grammar idx =@@ -108,7 +116,7 @@ -- from a given non-terminal. This function will at least fold over the -- given non-terminal itself. foldReachable :: forall phi r rr t ix n. (Domain phi) => -                 GExtendedContextFreeGrammar phi t r rr ->+                 GAnyExtendedContextFreeGrammar phi t r rr ->                  phi ix ->                  (forall ix'. phi ix' -> n -> n) -> n -> n foldReachable grammar idx =@@ -116,27 +124,27 @@  isReachable' :: forall phi r t rr ix ix'. (Domain phi) =>                 (forall n. -                GExtendedContextFreeGrammar phi t r rr -> phi ix ->+                GAnyExtendedContextFreeGrammar phi t r rr -> phi ix ->                 (forall ix''. phi ix'' -> n -> n) -> n -> n) ->-               GExtendedContextFreeGrammar phi t r rr ->+               GAnyExtendedContextFreeGrammar phi t r rr ->                phi ix -> phi ix' -> Bool isReachable' fold' g start end =   fold' g start ((||) . eqIdx end) False --- | Check if a given terminal is reachable from a given other grammar+-- | Check if a given non-terminal is reachable from a given other non-terminal -- in a given extended context-free grammar. This function assumes -- that all grammars are reachable from themselves. isReachable :: forall phi r t rr ix ix'. (Domain phi) => -               GExtendedContextFreeGrammar phi t r rr ->+               GAnyExtendedContextFreeGrammar phi t r rr ->                phi ix -> phi ix' -> Bool isReachable = isReachable' foldReachable --- | Check if a given terminal is reachable from a given other grammar+-- | Check if a given non-terminal is reachable from a given other non-terminal -- in a given extended context-free grammar. For this function, a non-  -- terminal is not automatically considered reachable from itself, but -- only if it has some production in which a submatch of itself is -- present. isReachableProper :: forall phi r t rr ix ix'. (Domain phi) => -                     GExtendedContextFreeGrammar phi t r rr ->+                     GAnyExtendedContextFreeGrammar phi t r rr ->                      phi ix -> phi ix' -> Bool isReachableProper = isReachable' foldReachableProper
Text/GrammarCombinators/Utils/PrintGrammar.hs view
@@ -55,14 +55,26 @@          else let t = printIPPSub d True False a ++ " " ++ printIPPSub d True False b               in if pc then "(" ++ t ++ ")" else t +instance BiasedProductionRule (PrintProductionRule phi r t) where+  a >||| b = IPP $ \pd _ d -> +    let t = printIPPSub d False True a ++ " >| " ++ printIPPSub d False True b+    in if pd then "(" ++ t ++ ")" else t+  a <||| b = IPP $ \pd _ d -> +    let t = printIPPSub d False True a ++ " <| " ++ printIPPSub d False True b+    in if pd then "(" ++ t ++ ")" else t+ instance EpsProductionRule (PrintProductionRule phi r t) where   epsilon _ = IPP $ \_ _ _ -> "epsilon" +instance PenaltyProductionRule (PrintProductionRule phi r t) where+  penalty p r = IPP $ \_ _ d -> "penalty " ++ show p ++ " ( " ++ printIPPSub d False False r ++ " )"+ instance LiftableProductionRule (PrintProductionRule phi r t) where   epsilonL _ _ = IPP $ \_ _ _ -> "epsilon"  instance (Token t) => TokenProductionRule (PrintProductionRule phi r t) t where   token t = IPP $ \_ _ _ -> show t+  anyToken = IPP $ \_ _ _ -> "anyToken"  instance (ShowFam phi) => RecProductionRule (PrintProductionRule phi r t) phi r where   ref idx = IPP $ \_ _ _ -> "<" ++ showIdx idx ++ ">"@@ -72,12 +84,12 @@   many1Ref idx = IPP $ \_ _ _ -> "<" ++ showIdx idx ++ ">" ++ "+"  -- | Print out a single production rule-printRule :: (Domain phi, Token t) => GExtendedContextFreeGrammar phi t r rr -> Integer -> phi ix -> String+printRule :: (Domain phi, Token t) => GAnyExtendedContextFreeGrammar phi t r rr -> Integer -> phi ix -> String printRule gram depth idx = "<" ++ showIdx idx ++ ">" ++ " ::= " ++ printIPP (gram idx) False False depth  printGrammar' :: forall phi t r rr. (Domain phi, Token t) =>                  (forall b. (forall ix. phi ix -> b -> b) -> b -> b) ->-                 GExtendedContextFreeGrammar phi t r rr -> Integer -> String+                 GAnyExtendedContextFreeGrammar phi t r rr -> Integer -> String printGrammar' fold' gram depth =   unlines $ fold' ((:) . printRule gram depth) [] @@ -87,19 +99,19 @@  -- | Print out a full grammar. printGrammar :: forall phi t r rr. (Domain phi, Token t) =>-                GExtendedContextFreeGrammar phi t r rr -> String+                GAnyExtendedContextFreeGrammar phi t r rr -> String printGrammar g = printGrammar' foldFam g infinity  -- | Print out a grammar with a depth limit. Intended for infinite grammars. printGrammarInf :: forall phi t r rr. (Domain phi, Token t) =>-                GExtendedContextFreeGrammar phi t r rr -> Integer -> String+                GAnyExtendedContextFreeGrammar phi t r rr -> Integer -> String printGrammarInf = printGrammar' foldFam   -- | Print out the part of a grammar that is reachable from a given non-terminal. printReachableGrammar ::   forall phi t r rr ix.   (Domain phi, Token t) =>-  GExtendedContextFreeGrammar phi t r rr ->+  GAnyExtendedContextFreeGrammar phi t r rr ->   phi ix -> String printReachableGrammar gram idx = printGrammar' (foldReachable gram idx) gram infinity
Text/GrammarCombinators/Utils/ToGraph.hs view
@@ -104,6 +104,7 @@ instance (Token t) =>           TokenProductionRule (GraphConstructor phi r t) t where   token tt = leafNode (show tt) False+  anyToken = leafNode "anyToken" False    instance (Domain phi) => RecProductionRule (GraphConstructor phi r t) phi r where   ref idx = leafNode ("<" ++ showIdx idx ++ ">") False
Text/GrammarCombinators/Utils/UnfoldDepthFirst.hs view
@@ -54,6 +54,10 @@   die = MkFRR $ \_ -> die   endOfInput = MkFRR $ \_ -> endOfInput +instance (BiasedProductionRule p) => BiasedProductionRule (UnfoldDepthFirstRule p phi r t rr) where+  ra >||| rb = MkFRR $ \g -> foldReachableFromRule ra g >|||  foldReachableFromRule rb g+  ra <||| rb = MkFRR $ \g -> foldReachableFromRule ra g <|||  foldReachableFromRule rb g+ instance (EpsProductionRule p) => EpsProductionRule (UnfoldDepthFirstRule p phi r t rr) where   epsilon v = MkFRR $ \_ -> epsilon v @@ -63,11 +67,16 @@ instance (TokenProductionRule p t) =>          TokenProductionRule (UnfoldDepthFirstRule p phi r t rr) t where   token tt = MkFRR $ \_ -> token tt+  anyToken = MkFRR $ \_ -> anyToken    instance (SimpleRecProductionRule p phi r rr) =>          RecProductionRule (UnfoldDepthFirstRule p phi r t rr) phi r where   ref idx = MkFRR $ \g -> ref' idx (g idx)  +instance (PenaltyProductionRule p) =>+         PenaltyProductionRule (UnfoldDepthFirstRule p phi r t rr) where+  penalty _ r = r+ instance (ProductionRule p,           LiftableProductionRule p,           SimpleRecProductionRule p phi r rr,@@ -90,10 +99,12 @@                    (ProductionRule p, EqFam phi,                     TokenProductionRule p t,                     EpsProductionRule p,+                    BiasedProductionRule p,+                    PenaltyProductionRule p,                     SimpleRecProductionRule p phi r rr,                     SimpleLoopProductionRule p phi r rr) =>                    UnfoldDepthFirstRule p phi r t rr v ->-                   GExtendedContextFreeGrammar phi t r rr ->+                   GAnyExtendedContextFreeGrammar phi t r rr ->                    (UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr) ->                    p v unfoldDepthFirst'' r grammar rg =@@ -102,10 +113,12 @@ unfoldDepthFirst' :: forall p phi r rr t ix.                    (ProductionRule p, EqFam phi,                     EpsProductionRule p,+                    PenaltyProductionRule p,+                    BiasedProductionRule p,                     TokenProductionRule p t,                     SimpleRecProductionRule p phi r rr,                     SimpleLoopProductionRule p phi r rr) =>-                   GExtendedContextFreeGrammar phi t r rr ->+                   GAnyExtendedContextFreeGrammar phi t r rr ->                    (UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr) ->                    phi ix -> p (rr ix) unfoldDepthFirst' grammar rg idx =@@ -117,20 +130,24 @@ unfoldDepthFirstProper :: forall p phi r rr t ix.                    (ProductionRule p, EqFam phi,                     EpsProductionRule p,+                    PenaltyProductionRule p,+                    BiasedProductionRule p,                     TokenProductionRule p t,                     SimpleRecProductionRule p phi r rr,                     SimpleLoopProductionRule p phi r rr) =>-                   GExtendedContextFreeGrammar phi t r rr ->+                   GAnyExtendedContextFreeGrammar phi t r rr ->                    phi ix -> p (rr ix) unfoldDepthFirstProper grammar = unfoldDepthFirst' grammar id   unfoldDepthFirst :: forall p phi r rr t ix.                    (ProductionRule p, EqFam phi,                     EpsProductionRule p,+                    PenaltyProductionRule p,+                    BiasedProductionRule p,                     TokenProductionRule p t,                     SimpleRecProductionRule p phi r rr,                     SimpleLoopProductionRule p phi r rr) =>-                   GExtendedContextFreeGrammar phi t r rr ->+                   GAnyExtendedContextFreeGrammar phi t r rr ->                    phi ix -> p (r ix) unfoldDepthFirst grammar idx = unfoldDepthFirst'' (ref idx) grammar id
grammar-combinators.cabal view
@@ -1,5 +1,5 @@ Name:                grammar-combinators-Version:             0.1+Version:             0.2 Description:     The grammar-combinators library is a novel parsing library using     an explicit representation of recursion to provide various novel@@ -48,10 +48,13 @@                      Text.GrammarCombinators.TH.FoldLoops                      Text.GrammarCombinators.TH.RealLL1                      Text.GrammarCombinators.Transform.CombineEpsilons+                     Text.GrammarCombinators.Transform.CombineGrammars                      Text.GrammarCombinators.Transform.FilterDies                      Text.GrammarCombinators.Transform.FoldLoops+                     Text.GrammarCombinators.Transform.IntroduceBias                      Text.GrammarCombinators.Transform.LeftCorner                      Text.GrammarCombinators.Transform.OptimizeGrammar+                     Text.GrammarCombinators.Transform.PenalizeErrors                      Text.GrammarCombinators.Transform.UnfoldChainNTs                      Text.GrammarCombinators.Transform.UnfoldDead                      Text.GrammarCombinators.Transform.UnfoldLoops@@ -59,6 +62,7 @@                      Text.GrammarCombinators.Transform.UniformPaull                      Text.GrammarCombinators.Utils.AssessSize                      Text.GrammarCombinators.Utils.CalcFirst+                     Text.GrammarCombinators.Utils.CombineProcessors                      Text.GrammarCombinators.Utils.EnumerateGrammar                      Text.GrammarCombinators.Utils.EnumTokens                      Text.GrammarCombinators.Utils.IsChainNT