Earley 0.10.1.0 → 0.11.0.0

raw patch · 14 files changed

+120/−374 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• Earley.cabal +4/−10
• Text/Earley.hs +3/−1
• Text/Earley/Derived.hs +34/−6
• Text/Earley/Grammar.hs +22/−6
• Text/Earley/Internal.hs +4/−4
• bench/BenchAll.hs +6/−6
• examples/Expr.hs +3/−3
• examples/Expr2.hs +1/−1
• examples/Infinite.hs +1/−1
• examples/Mixfix.hs +2/−2
• examples/VeryAmbiguous.hs +1/−1
• tests/Main.hs +25/−0
• tests/Tests.hs +0/−333

@@ -1,3 +1,17 @@+# 0.11.0.0++- Add `IsString Prod` instance+- Change the signature of `Terminal` to take a function `a -> Maybe b`, and add a new operator `terminal`+- Move `satisfy` to the `Derived` module+- Add the `token`, `namedToken`, and `list` operators+- Deprecate the `symbol`, `namedSymbol`, and `word` operators (use the above instead)+- Add the `listLike` operator++# 0.10.1.0++- Fix bug concerning nullable rules (#14)+- Add `runGrammar`+ # 0.10.0.1  - Add changelog

@@ -1,5 +1,5 @@ name:                Earley-version:             0.10.1.0+version:             0.11.0.0 synopsis:            Parsing all context-free grammars using Earley's algorithm. description:         See <https://www.github.com/ollef/Earley> for more                      information and@@ -13,13 +13,7 @@ category:            Parsing build-type:          Simple cabal-version:       >=1.10-tested-with:-                     GHC == 7.8.1,-                     GHC == 7.8.2,-                     GHC == 7.8.3,-                     GHC == 7.8.4,-                     GHC == 7.10.1,-                     GHC == 7.10.2+tested-with:         GHC ==7.6.*, GHC==7.8.*, GHC==7.10.*, GHC==8.0.*, GHC==8.1.*  extra-source-files:                       README.md@@ -42,7 +36,7 @@                        Text.Earley.Internal,                        Text.Earley.Mixfix,                        Text.Earley.Parser-  build-depends:       base >=4.7 && <4.9, ListLike >=4.1+  build-depends:       base >=4.6 && <4.10, ListLike >=4.1   default-language:    Haskell2010   ghc-options:         -Wall                        -funbox-strict-fields@@ -120,7 +114,7 @@  test-suite tests   type:                exitcode-stdio-1.0-  main-is:             Tests.hs+  main-is:             Main.hs   ghc-options:         -Wall   hs-source-dirs:      tests   default-language:    Haskell2010

@@ -1,8 +1,10 @@ -- | Parsing all context-free grammars using Earley's algorithm. module Text.Earley   ( -- * Context-free grammars-    Prod, satisfy, (<?>), Grammar, rule+    Prod, terminal, (<?>), Grammar, rule   , -- * Derived operators+    satisfy, token, namedToken, list, listLike+  , -- * Deprecated operators     symbol, namedSymbol, word   , -- * Parsing     Report(..), Result(..), parser, allParses, fullParses

@@ -1,18 +1,46 @@ -- | Derived operators. module Text.Earley.Derived where import Control.Applicative hiding (many)+import Data.ListLike(ListLike)+import qualified Data.ListLike as ListLike  import Text.Earley.Grammar +-- | Match a token that satisfies the given predicate. Returns the matched+-- token.+{-# INLINE satisfy #-}+satisfy :: (t -> Bool) -> Prod r e t t+satisfy p = Terminal f $ Pure id+  where+    f t | p t = Just t+    f _       = Nothing+ -- | Match a single token.-symbol :: Eq t => t -> Prod r e t t-symbol x = satisfy (== x)+token :: Eq t => t -> Prod r e t t+token x = satisfy (== x)  -- | Match a single token and give it the name of the token.-namedSymbol :: Eq t => t -> Prod r t t t-namedSymbol x = symbol x <?> x+namedToken :: Eq t => t -> Prod r t t t+namedToken x = token x <?> x  -- | Match a list of tokens in sequence.-{-# INLINE word #-}+{-# INLINE list #-}+list :: Eq t => [t] -> Prod r e t [t]+list = foldr (liftA2 (:) . satisfy . (==)) (pure [])++-- | Match a 'ListLike' of tokens in sequence.+{-# INLINE listLike #-}+listLike :: (Eq t, ListLike i t) => i -> Prod r e t i+listLike = ListLike.foldr (liftA2 ListLike.cons . satisfy . (==)) (pure ListLike.empty)++{-# DEPRECATED symbol "Use `token` instead" #-}+symbol :: Eq t => t -> Prod r e t t+symbol = token++{-# DEPRECATED namedSymbol "Use `namedToken` instead" #-}+namedSymbol :: Eq t => t -> Prod r e t t+namedSymbol = token++{-# DEPRECATED word "Use `list` or `listLike` instead" #-} word :: Eq t => [t] -> Prod r e t [t]-word = foldr (liftA2 (:) . satisfy . (==)) (pure [])+word = list

@@ -2,7 +2,7 @@ {-# LANGUAGE CPP, GADTs, RankNTypes #-} module Text.Earley.Grammar   ( Prod(..)-  , satisfy+  , terminal   , (<?>)   , alts   , Grammar(..)@@ -12,6 +12,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Fix+import Data.String (IsString(..)) #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif@@ -43,7 +44,7 @@ -- 'Functor', 'Applicative', and 'Alternative'. data Prod r e t a where   -- Applicative.-  Terminal    :: !(t -> Bool) -> !(Prod r e t (t -> b)) -> Prod r e t b+  Terminal    :: !(t -> Maybe a) -> !(Prod r e t (a -> b)) -> Prod r e t b   NonTerminal :: !(r e t a) -> !(Prod r e t (a -> b)) -> Prod r e t b   Pure        :: a -> Prod r e t a   -- Monoid/Alternative. We have to special-case 'many' (though it can be done@@ -53,10 +54,10 @@   -- Error reporting.   Named       :: !(Prod r e t a) -> e -> Prod r e t a --- | Match a token that satisfies the given predicate. Returns the matched token.-{-# INLINE satisfy #-}-satisfy :: (t -> Bool) -> Prod r e t t-satisfy p = Terminal p $ Pure id+-- | Match a token for which the given predicate returns @Just a@,+-- and return the @a@.+terminal :: (t -> Maybe a) -> Prod r e t a+terminal p = Terminal p $ Pure id  -- | A named production (used for reporting expected things). (<?>) :: Prod r e t a -> e -> Prod r e t a@@ -105,6 +106,21 @@   many (Alts [] _) = pure []   many p           = Many p $ Pure id   some p           = (:) <$> p <*> many p++-- | String literals can be interpreted as 'Terminal's+-- that match that string.+--+-- >>> :set -XOverloadedStrings+-- >>> import Data.Text (Text)+-- >>> let determiner = "the" <|> "a" <|> "an" :: Prod r e Text Text+--+instance (IsString t, Eq t, a ~ t) => IsString (Prod r e t a) where+  fromString s = Terminal f $ Pure id+    where+      fs = fromString s+      f t | t == fs = Just fs+      f _ = Nothing+  {-# INLINE fromString #-}  -- | A context-free grammar. --

@@ -239,10 +239,10 @@ parse (st:ss) env = case st of   Final res -> parse ss env {results = unResults res : results env}   State pr args pos scont -> case pr of-    Terminal f p -> case safeHead $ input env of-      Just t | f t -> parse ss env {next = State p (args . ($ t)) Previous scont-                                         : next env}-      _            -> parse ss env+    Terminal f p -> case safeHead (input env) >>= f of+      Just a -> parse ss env {next = State p (args . ($ a)) Previous scont+                                   : next env}+      Nothing -> parse ss env     NonTerminal r p -> do       rkref <- readSTRef $ ruleConts r       ks    <- readSTRef rkref

@@ -47,14 +47,14 @@  expr :: Grammar r (Prod r String Token Expr) expr = mdo-  x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2+  x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x2             <|> x2             <?> "sum"-  x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x3+  x2 <- rule $ Mul <$> x2 <* namedToken "*" <*> x3             <|> x3             <?> "product"   x3 <- rule $ Var <$> (satisfy isIdent <?> "identifier")-            <|> namedSymbol "(" *> x1 <* namedSymbol ")"+            <|> namedToken "(" *> x1 <* namedToken ")"   return x1  isIdent :: String -> Bool@@ -68,9 +68,9 @@  expr' :: Grammar r (Prod r String Token Expr) expr' = mdo-  let var = Var <$> satisfy isIdent <|> symbol "(" *> mul <* symbol ")"-  mul <- fmap (foldl1 Mul) <$> add `sepBy1` symbol "*"-  add <- fmap (foldl1 Add) <$> var `sepBy1` symbol "+"+  let var = Var <$> satisfy isIdent <|> token "(" *> mul <* token ")"+  mul <- fmap (foldl1 Mul) <$> add `sepBy1` token "*"+  add <- fmap (foldl1 Add) <$> var `sepBy1` token "+"   return mul  parseEarley :: [Token] -> Maybe Expr

@@ -12,14 +12,14 @@  expr :: Grammar r (Prod r String String Expr) expr = mdo-  x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2+  x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x2             <|> x2             <?> "sum"-  x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x3+  x2 <- rule $ Mul <$> x2 <* namedToken "*" <*> x3             <|> x3             <?> "product"   x3 <- rule $ Var <$> (satisfy ident <?> "identifier")-            <|> namedSymbol "(" *> x1 <* namedSymbol ")"+            <|> namedToken "(" *> x1 <* namedToken ")"   return x1   where     ident (x:_) = isAlpha x

@@ -19,7 +19,7 @@   let token :: Prod r String Char a -> Prod r String Char a       token p = whitespace *> p -      sym x   = token $ symbol x <?> [x]+      sym x   = token $ token x <?> [x]        ident   = token $ (:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum) <?> "identifier"       num     = token $ some (satisfy isDigit) <?> "number"

@@ -6,7 +6,7 @@ grammar :: Grammar r (Prod r () Char [Maybe Char]) grammar = mdo   as <- rule $ pure []-            <|> (:) <$> optional (symbol 'a') <*> as+            <|> (:) <$> optional (token 'a') <*> as   return as  -- This grammar has an infinite number of results. We can still recognise the

@@ -34,13 +34,13 @@   ident     <- rule $ (V . pure . Just) <$> satisfy (not . (`HS.member` mixfixParts))                    <?> "identifier"   atom      <- rule $ ident-                   <|> namedSymbol "(" *> expr <* namedSymbol ")"+                   <|> namedToken "(" *> expr <* namedToken ")"   normalApp <- rule $ atom                    <|> App <$> atom <*> some atom   expr      <- mixfixExpression table normalApp (App . V)   return expr   where-    table = map (map $ first $ map $ fmap namedSymbol) identTable+    table = map (map $ first $ map $ fmap namedToken) identTable     mixfixParts = HS.fromList [s | xs <- identTable , (ys, _) <- xs                                  , Just s <- ys]                `mappend` HS.fromList ["(", ")"]

@@ -5,7 +5,7 @@  g :: Grammar r (Prod r Char Char ()) g = mdo-  s <- rule $ () <$ symbol 'b'+  s <- rule $ () <$ token 'b'            <|> () <$ s <* s            <|> () <$ s <* s <* s            <?> 's'

@@ -0,0 +1,25 @@+module Main where+import Test.Tasty++import qualified Empty+import qualified Expr+import qualified InlineAlts+import qualified Issue11+import qualified Issue14+import qualified Mixfix+import qualified Optional+import qualified ReversedWords+import qualified VeryAmbiguous++main :: IO ()+main = defaultMain $ testGroup "Tests"+  [ Empty.tests+  , Expr.tests+  , InlineAlts.tests+  , Issue11.tests+  , Issue14.tests+  , Mixfix.tests+  , Optional.tests+  , ReversedWords.tests+  , VeryAmbiguous.tests+  ]

@@ -1,333 +0,0 @@-{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}-import Control.Applicative-import Data.Char-import Test.Tasty-import Test.Tasty.HUnit      as HU-import Test.Tasty.QuickCheck as QC--import Text.Earley-import Text.Earley.Mixfix--main :: IO ()-main = defaultMain tests -- -putStrLn . prettyExpr 0 $ Add (Add (Var "a") (Var "b")) (Add (Var "c") (Var "d")) -- defaultMain tests--tests :: TestTree-tests = testGroup "Tests" [qcProps, unitTests]--qcProps :: TestTree-qcProps = testGroup "QuickCheck Properties"-  [ QC.testProperty "Expr: parse . pretty = id" $-    \e -> [e] === parseExpr (prettyExpr 0 e)-  , QC.testProperty "Ambiguous Expr: parse . pretty ≈ id" $-    \e -> e `elem` parseAmbiguousExpr (prettyExpr 0 e)-  , QC.testProperty "The empty parser doesn't parse anything" $-    \(input :: String) ->-      allParses (parser (return empty :: forall r. Grammar r (Prod r () Char ()))) input-      == (,) [] Report { position   = 0-                       , expected   = []-                       , unconsumed = input-                       }-  , QC.testProperty "Many empty parsers parse very little" $-    \(input :: String) ->-      allParses (parser (return $ many empty <* pure "blah" :: forall r. Grammar r (Prod r () Char [()]))) input-      == (,) [([], 0)] Report { position   = 0-                              , expected   = []-                              , unconsumed = input-                              }-  , QC.testProperty "The same rule in alternatives gives many results (issue #14)" $-    \x -> fullParses (parser (issue14 x)) ""-    == (,) (replicate (issue14Length x) ())-           Report { position = 0, expected = [], unconsumed = [] }-  ]--unitTests :: TestTree-unitTests = testGroup "Unit Tests"-  [ HU.testCase "VeryAmbiguous gives the right number of results" $-      length (fst $ fullParses (parser veryAmbiguous) $ replicate 8 'b') @?= 2871-  , HU.testCase "VeryAmbiguous gives the correct report" $-      report (parser veryAmbiguous) (replicate 3 'b') @?=-      Report {position = 3, expected = "s", unconsumed = ""}-  , HU.testCase "Inline alternatives work" $-      let input = "ababbbaaabaa" in-      allParses (parser inlineAlts) input @?= allParses (parser nonInlineAlts) input-  , HU.testCase "Some reversed words" $-      let input = "wordwordstop"-          l     = length input in-      allParses (parser someWords) input-      @?= (,) [(["stop", "drow", "drow"], l)] Report { position   = l-                                                     , expected   = []-                                                     , unconsumed = []-                                                     }-  , HU.testCase "Optional Nothing" $-      fullParses (parser $ return optional_) "b"-      @?= (,) [(Nothing, 'b')] Report {position = 1, expected = "", unconsumed = ""}-  , HU.testCase "Optional Just" $-      fullParses (parser $ return optional_) "ab"-      @?= (,) [(Just 'a', 'b')] Report {position = 2, expected = "", unconsumed = ""}-  , HU.testCase "Optional using rules Nothing" $-      fullParses (parser $ optionalRule) "b"-      @?= (,) [(Nothing, 'b')] Report {position = 1, expected = "", unconsumed = ""}-  , HU.testCase "Optional using rules Just" $-      fullParses (parser $ optionalRule) "ab"-      @?= (,) [(Just 'a', 'b')] Report {position = 2, expected = "", unconsumed = ""}-  , HU.testCase "Optional without continuation Nothing" $-      fullParses (parser $ return $ optional $ namedSymbol 'a') ""-      @?= (,) [Nothing] Report {position = 0, expected = "a", unconsumed = ""}-  , HU.testCase "Optional without continuation Just" $-      fullParses (parser $ return $ optional $ namedSymbol 'a') "a"-      @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}-  , HU.testCase "Optional using rules without continuation Nothing" $-      fullParses (parser $ rule $ optional $ namedSymbol 'a') ""-      @?= (,) [Nothing] Report {position = 0, expected = "a", unconsumed = ""}-  , HU.testCase "Optional using rules without continuation Just" $-      fullParses (parser $ rule $ optional $ namedSymbol 'a') "a"-      @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}--  , HU.testCase "Mixfix 1" $-      let x = Ident [Just "x"] in-      fullParses (parser mixfixGrammar) (words "if x then x else x")-      @?= (,) [App ifthenelse [x, x, x]] Report {position = 6, expected = [], unconsumed = []}-  , HU.testCase "Mixfix 2" $-      let x = Ident [Just "x"] in-      fullParses (parser mixfixGrammar) (words "prefix x postfix")-      @?= (,) [App prefix [App postfix [x]]] Report {position = 3, expected = [], unconsumed = []}-  , HU.testCase "Mixfix 3" $-      let x = Ident [Just "x"] in-      fullParses (parser mixfixGrammar) (words "x infix1 x infix2 x")-      @?= (,) [App infix1 [x, App infix2 [x, x]]] Report {position = 5, expected = [], unconsumed = []}-  , HU.testCase "Mixfix 4" $-      let x = Ident [Just "x"] in-      fullParses (parser mixfixGrammar) (words "[ x ]")-      @?= (,) [App closed [x]] Report {position = 3, expected = [], unconsumed = []}--  , let x = words "+ + 5 6 7" in-    HU.testCase "Mixfix issue #11 1" $-    fullParses (parser $ issue11 LeftAssoc) x-    @?= (,) [] Report {position = 1, expected = [], unconsumed = drop 1 x}-  , let x = words "+ 5 + 6 7" in-    HU.testCase "Mixfix issue #11 2" $-    fullParses (parser $ issue11 LeftAssoc) x-    @?= (,) [] Report {position = 2, expected = [], unconsumed = drop 2 x}-  , let x = words "+ 5 6" in-    HU.testCase "Mixfix issue #11 3" $-    fullParses (parser $ issue11 LeftAssoc) x-    @?= (,) [Plus11 (Var11 "5") (Var11 "6")]-            Report {position = 3, expected = [], unconsumed = []}-  , let x = words "+ + 5 6 7" in-    HU.testCase "Mixfix issue #11 4" $-    fullParses (parser $ issue11 RightAssoc) x-    @?= (,) [Plus11 (Plus11 (Var11 "5") (Var11 "6")) (Var11 "7")]-            Report {position = 5, expected = [], unconsumed = []}-  , let x = words "+ 5 + 6 7" in-    HU.testCase "Mixfix issue #11 5" $-    fullParses (parser $ issue11 RightAssoc) x-    @?= (,) [Plus11 (Var11 "5") (Plus11 (Var11 "6") (Var11 "7"))]-            Report {position = 5, expected = [], unconsumed = []}-  , let x = words "+ 5 6" in-    HU.testCase "Mixfix issue #11 6" $-    fullParses (parser $ issue11 RightAssoc) x-    @?= (,) [Plus11 (Var11 "5") (Var11 "6")]-            Report {position = 3, expected = [], unconsumed = []}-  , let x = words "+ + 5 6 7" in-    HU.testCase "Mixfix issue #11 7" $-    fullParses (parser $ issue11 NonAssoc) x-    @?= (,) [Plus11 (Plus11 (Var11 "5") (Var11 "6")) (Var11 "7")]-            Report {position = 5, expected = [], unconsumed = []}-  , let x = words "+ 5 + 6 7" in-    HU.testCase "Mixfix issue #11 8" $-    fullParses (parser $ issue11 NonAssoc) x-    @?= (,) [Plus11 (Var11 "5") (Plus11 (Var11 "6") (Var11 "7"))]-            Report {position = 5, expected = [], unconsumed = []}-  , let x = words "+ 5 6" in-    HU.testCase "Mixfix issue #11 9" $-    fullParses (parser $ issue11 NonAssoc) x-    @?= (,) [Plus11 (Var11 "5") (Var11 "6")]-            Report {position = 3, expected = [], unconsumed = []}-  ]--optional_ :: Prod r Char Char (Maybe Char, Char)-optional_ = (,) <$> optional (namedSymbol 'a') <*> namedSymbol 'b'--optionalRule :: Grammar r (Prod r Char Char (Maybe Char, Char))-optionalRule = mdo-  test <- rule $ (,) <$> optional (namedSymbol 'a') <*> namedSymbol 'b'-  return test--inlineAlts :: Grammar r (Prod r Char Char String)-inlineAlts = mdo-  p <- rule $ pure []-           <|> (:) <$> (namedSymbol 'a' <|> namedSymbol 'b') <*> p-  return p--nonInlineAlts :: Grammar r (Prod r Char Char String)-nonInlineAlts = mdo-  ab <- rule $ namedSymbol 'a' <|> namedSymbol 'b'-  p  <- rule $ pure [] <|> (:) <$> ab <*> p-  return p--someWords :: Grammar r (Prod r () Char [String])-someWords = return $ flip (:) <$> (map reverse <$> some (word "word")) <*> word "stop"--veryAmbiguous :: Grammar r (Prod r Char Char ())-veryAmbiguous = mdo-  s <- rule $ () <$ symbol 'b'-           <|> () <$ s <* s-           <|> () <$ s <* s <* s-           <?> 's'-  return s--parseExpr :: String -> [Expr]-parseExpr input = fst (fullParses (parser expr) (lexExpr input)) -- We need to annotate types for point-free version--parseAmbiguousExpr :: String -> [Expr]-parseAmbiguousExpr input = fst (fullParses (parser ambiguousExpr) (lexExpr input))--data Expr-  = Add Expr Expr-  | Mul Expr Expr-  | Var String-  deriving (Eq, Ord, Show)--instance Arbitrary Expr where-  arbitrary = sized arbExpr-    where arbIdent           = Var <$> elements ["a", "b", "c", "x", "y", "z"]-          arbExpr n | n > 0  = oneof [ arbIdent-                                     , Add <$> arbExpr1 <*> arbExpr1-                                     , Mul <$> arbExpr1 <*> arbExpr1-                                     ]-                                     where arbExpr1 = arbExpr (n `div` 2)-          arbExpr _          = arbIdent--  shrink (Var _)    = []-  shrink (Add a b)  = a : b : [ Add a' b | a' <- shrink a ] ++ [ Add a b' | b' <- shrink b ]-  shrink (Mul a b)  = a : b : [ Mul a' b | a' <- shrink a ] ++ [ Mul a b' | b' <- shrink b ]--expr :: Grammar r (Prod r String String Expr)-expr = mdo-  x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2-            <|> x2-            <?> "sum"-  x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x3-            <|> x3-            <?> "product"-  x3 <- rule $ Var <$> (satisfy ident <?> "identifier")-            <|> namedSymbol "(" *> x1 <* namedSymbol ")"-  return x1-  where-    ident (x:_) = isAlpha x-    ident _     = False--ambiguousExpr :: Grammar r (Prod r String String Expr)-ambiguousExpr = mdo-  x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x1-            <|> x2-            <?> "sum"-  x2 <- rule $ Mul <$> x2 <* namedSymbol "*" <*> x2-            <|> x3-            <?> "product"-  x3 <- rule $ Var <$> (satisfy ident <?> "identifier")-            <|> namedSymbol "(" *> x1 <* namedSymbol ")"-  return x1-  where-    ident (x:_) = isAlpha x-    ident _     = False--prettyParens :: Bool -> String -> String-prettyParens True s  = "(" ++ s ++ ")"-prettyParens False s = s--prettyExpr :: Int -> Expr -> String-prettyExpr _ (Var s) = s-prettyExpr d (Add a b) = prettyParens (d > 0) $ prettyExpr 0 a ++ " + " ++ prettyExpr 1 b-prettyExpr d (Mul a b) = prettyParens (d > 1) $ prettyExpr 1 a ++ " * " ++ prettyExpr 2 b---- @words@ like lexer, but consider parentheses as separate tokens-lexExpr :: String -> [String]-lexExpr ""        = []-lexExpr ('(' : s) = "(" : lexExpr s-lexExpr (')' : s) = ")" : lexExpr s-lexExpr (c : s)-  | isSpace c     = lexExpr s-  | otherwise     = let (tok, rest) = span p (c : s)-                    in tok : lexExpr rest-  where p x       = not (x == '(' || x == ')' || isSpace x)--data MixfixExpr = Ident (Holey String) | App (Holey String) [MixfixExpr]-  deriving (Eq, Show)--mixfixGrammar :: Grammar r (Prod r String String MixfixExpr)-mixfixGrammar = mixfixExpression table-                                 (Ident . pure . Just <$> namedSymbol "x")-                                 App-  where-    hident = map (fmap symbol)-    table =-      [ [(hident ifthenelse, RightAssoc)]-      , [(hident prefix, RightAssoc)]-      , [(hident postfix, LeftAssoc)]-      , [(hident infix1, LeftAssoc)]-      , [(hident infix2, RightAssoc)]-      , [(hident closed, NonAssoc)]-      ]--ifthenelse, prefix, postfix, infix1, infix2, closed :: Holey String-ifthenelse = [Just "if", Nothing, Just "then", Nothing, Just "else", Nothing]-prefix = [Just "prefix", Nothing]-postfix = [Nothing, Just "postfix"]-infix1 = [Nothing, Just "infix1", Nothing]-infix2 = [Nothing, Just "infix2", Nothing]-closed = [Just "[", Nothing, Just "]"]---- Adapted from issue #11-data Mixfix11-  = Var11 String-  | Plus11 Mixfix11 Mixfix11-  deriving (Eq, Ord, Show)--issue11 :: Associativity -> Grammar r (Prod r String String Mixfix11)-issue11 a = mdo-    atomicExpr <- rule $ Var11 <$> satisfy (/= "+")--    expr <- mixfixExpression-               [[([Just (symbol "+"), Nothing, Nothing], a)]]-               atomicExpr-               (\x y -> case (x,y) of-                  ([Just "+", Nothing, Nothing], [e1,e2]) -> Plus11 e1 e2-                  _ -> undefined)--    return expr--data Issue14 a-  = Pure a-  | Alt (Issue14 a) (Issue14 a)-  | Ap (Issue14 a) (Issue14 a)-  deriving (Eq, Ord, Show)--instance Arbitrary a => Arbitrary (Issue14 a) where-  arbitrary = sized arbTree-    where arbTree n | n > 0  = oneof [ Pure <$> arbitrary-                                     , Alt <$> arbTree1 <*> arbTree1-                                     , Ap <$> arbTree1 <*> arbTree1-                                     ]-                                     where arbTree1 = arbTree (n `div` 2)-          arbTree _          = Pure <$> arbitrary--  shrink (Pure a)  = Pure <$> shrink a-  shrink (Alt a b) = a : b : [Alt a' b | a' <- shrink a] ++ [Alt a b' | b' <- shrink b]-  shrink (Ap a b)  = a : b : [Ap a' b | a' <- shrink a] ++ [Ap a b' | b' <- shrink b]--issue14Length :: Issue14 () -> Int-issue14Length (Pure ()) = 1-issue14Length (Alt a b) = ((+) $! issue14Length a) $! issue14Length b-issue14Length (Ap a b)  = ((*) $! issue14Length a) $! issue14Length b--issue14 :: Issue14 () -> Grammar r (Prod r () Char ())-issue14 tree = do-  emptyRule <- rule $ pure ()-  let x = go emptyRule tree-  return x-  where-    go x (Pure ())   = x-    go x (Alt b1 b2) = go x b1 <|> go x b2-    go x (Ap b1 b2)  = go x b1 <* go x b2-