Earley 0.8.1 → 0.8.2

raw patch · 4 files changed

+150/−60 lines, 4 filesdep −containersdep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: containers

Dependency ranges changed: unordered-containers

API changes (from Hackage documentation)

Files

• Earley.cabal +4/−4
• Text/Earley/Mixfix.hs +65/−0
• examples/Mixfix.hs +36/−56
• tests/Tests.hs +45/−0

@@ -1,5 +1,5 @@ name:                Earley-version:             0.8.1+version:             0.8.2 synopsis:            Parsing all context-free grammars using Earley's algorithm. description:         See <https://www.github.com/ollef/Earley> for more                      information and@@ -23,9 +23,9 @@   location: https://github.com/ollef/Earley.git  library-  exposed-modules:     Text.Earley.Derived, Text.Earley.Grammar, Text.Earley.Parser Text.Earley+  exposed-modules:     Text.Earley.Derived, Text.Earley.Grammar, Text.Earley.Mixfix, Text.Earley.Parser Text.Earley   -- other-modules:-  build-depends:       base >=4.7 && <4.9, containers >=0.5, ListLike >=4.1+  build-depends:       base >=4.7 && <4.9, ListLike >=4.1   -- hs-source-dirs:   default-language:    Haskell2010   ghc-options:         -Wall -funbox-strict-fields@@ -64,7 +64,7 @@   ghc-options:         -Wall   hs-source-dirs:      examples   default-language:    Haskell2010-  build-depends:       base, Earley, containers+  build-depends:       base, Earley, unordered-containers  executable earley-very-ambiguous   if !flag(examples)

@@ -0,0 +1,65 @@+{-# LANGUAGE CPP, RecursiveDo #-}+module Text.Earley.Mixfix where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Either+import Data.Foldable(asum, foldrM)+import Text.Earley++data Associativity+  = LeftAssoc+  | NonAssoc+  | RightAssoc+  deriving (Eq, Show)++-- | An identifier with identifier parts ('Just's), and holes ('Nothing's)+-- representing the positions of its arguments.+--+-- Example (commonly written "if_then_else_"):+-- @['Just' "if", Nothing, 'Just' "then", Nothing, 'Just' "else", Nothing] :: 'Holey' 'String'@+type Holey a = [Maybe a]++-- | Create a grammar for parsing mixfix expressions.+mixfixExpression+  :: [[(Holey (Prod r e t ident), Associativity)]]+  -- ^ A table of holey identifier parsers, with associativity information.+  -- The identifiers should be in groups of precedence levels listed from+  -- binding the least to the most tightly.+  --+  -- The associativity is taken into account when an identifier starts or+  -- ends with a hole, or both. Internal holes (e.g. after "if" in+  -- "if_then_else_") start from the beginning of the table.+  -> Prod r e t expr+  -- ^ An atom, i.e. what is parsed at the lowest level. This will+  -- commonly be a (non-mixfix) identifier or a parenthesised expression.+  -> (Holey ident -> [expr] -> expr)+  -- ^ How to combine the successful application of a holey identifier to its+  -- arguments into an expression.+  -> Grammar r e (Prod r e t expr)+mixfixExpression table atom app = mdo+  expr <- foldrM ($) atom $ map (level expr) table+  return expr+  where+    app' xs = app (either (const Nothing) Just <$> xs) $ lefts xs+    level expr idents next = mdo+      same <- rule $ asum $ next : map (mixfixIdent same) idents+      return same+      where+        cons p q = (:) <$> p <*> q+        mixfixIdent same (ps, a) = app' <$> go ps+          where+            go ps' = case ps' of+              [] -> pure []+              [Just p] -> pure . Right <$> p+              Nothing:rest -> cons (Left <$> if a == RightAssoc then next+                                                                else same)+                $ go rest+              [Just p, Nothing] -> cons (Right <$> p)+                $ pure . Left <$> if a == LeftAssoc then next else same+              Just p:Nothing:rest -> cons (Right <$> p)+                $ cons (Left <$> expr)+                $ go rest+              Just p:rest@(Just _:_) -> cons (Right <$> p) $ go rest+

@@ -1,54 +1,25 @@-{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE CPP, RecursiveDo #-} import Control.Applicative import Control.Arrow(first)-import Data.Foldable(asum, foldrM)+import Data.Maybe+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif import System.Environment import Text.Earley-import qualified Data.Set as S--type Ident = String--data IdentPart = Ident Ident | Hole-  deriving Show--type HoleyIdent = [IdentPart]+import Text.Earley.Mixfix+import qualified Data.HashSet as HS -holey :: Ident -> HoleyIdent+holey :: String -> Holey String holey ""       = []-holey ('_':xs) = Hole    : holey xs-holey xs       = Ident i : holey rest-  where (i, rest) = span (/= '_') xs --data Assoc = LeftAssoc | RightAssoc | NonAssoc-  deriving (Eq, Show)+holey ('_':xs) = Nothing : holey xs+holey xs       = Just i : holey rest+  where (i, rest) = span (/= '_') xs -data Expr = V HoleyIdent | App Expr [Expr]+data Expr = V (Holey String) | App Expr [Expr]   deriving Show -grammar :: [[(HoleyIdent, Assoc)]] -> Grammar r String (Prod r String String Expr)-grammar table = mdo-  let ident = (V . (:[]) . Ident) <$> satisfy (`S.notMember` mixfixParts)-  expr  <- foldrM ($) ident (normalApp expr : levels expr)-  return expr-  where-    mixfixParts = S.fromList [s | xs <- table, (ys, _) <- xs, Ident s <- ys]-    normalApp expr next = rule $ App <$> expr <*> some next-                              <|> next-    levels expr = map (level expr) table-    level expr idents next = mdo-      same <- rule $ asum $ next : map (mixfixIdent same) idents-      return same-      where-        mixfixIdent same (ps, a) = App (V ps) <$> go ps-          where-            go ps' = case ps' of-              [Ident s]         -> []    <$  namedSymbol s-              Hole:rest         -> (:)   <$> (if a == RightAssoc then next else same) <*> go rest-              [Ident s, Hole]   -> (:[]) <$  namedSymbol s <*> (if a == LeftAssoc then next else same)-              Ident s:Hole:rest -> (:)   <$  namedSymbol s <*> expr <*> go rest-              _                 -> error "invalid identifier"--identTable :: [[(HoleyIdent, Assoc)]]+identTable :: [[(Holey String, Associativity)]] identTable = (map . map) (first holey)   [ [("_->_",          RightAssoc)]   , [("_,_",           NonAssoc)]@@ -56,31 +27,40 @@   , [("_|-_:_",        NonAssoc)]   , [("_+_",           LeftAssoc)]   , [("_*_",           LeftAssoc)]-  , [("(_)",           NonAssoc)-    ,("[_]",           NonAssoc)-    ,("<_>",           NonAssoc)-    ]   ] -pretty :: Expr -> String-pretty (V ps) = concatMap go ps+grammar :: Grammar r String (Prod r String String Expr)+grammar = mdo+  ident     <- rule $ (V . pure . Just) <$> satisfy (not . (`HS.member` mixfixParts))+                   <?> "identifier"+  atom      <- rule $ ident+                   <|> namedSymbol "(" *> expr <* namedSymbol ")"+  normalApp <- rule $ atom+                   <|> App <$> atom <*> some atom+  expr      <- mixfixExpression table normalApp (App . V)+  return expr   where-    go Hole      = "_"-    go (Ident s) = s+    table = map (map $ first $ map $ fmap namedSymbol) identTable+    mixfixParts = HS.fromList [s | xs <- identTable , (ys, _) <- xs+                                 , Just s <- ys]+               `mappend` HS.fromList ["(", ")"]++pretty :: Expr -> String+pretty (V ps) = concatMap (fromMaybe "_") ps pretty (App e es) = "(" ++ pretty e ++ " " ++ unwords (map pretty es) ++ ")" -tokenize :: String -> [Ident]+tokenize :: String -> [String] tokenize ""        = [] tokenize (' ':xs)  = tokenize xs tokenize ('\n':xs) = tokenize xs tokenize (x:xs)-  | x `S.member` special = [x] : tokenize xs-  | otherwise            = (x:as) : tokenize bs+  | x `HS.member` special = [x] : tokenize xs+  | otherwise             = (x:as) : tokenize bs   where-    (as, bs) = span (`S.notMember` special) xs-    special = S.fromList "()[], \n"+    (as, bs) = break (`HS.member` special) xs+    special = HS.fromList "(), \n"  main :: IO () main = do   x:_ <- getArgs-  print $ first (map pretty) $ fullParses $ parser (grammar identTable) (tokenize x)+  print $ first (map pretty) $ fullParses $ parser grammar $ tokenize x

@@ -6,6 +6,7 @@ import Data.Char import Control.Applicative 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@@ -77,6 +78,23 @@   , 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 = []}   ]  optional_ :: Prod r Char Char (Maybe Char, Char)@@ -185,3 +203,30 @@   | 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 String (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 "]"]+