diff --git a/Earley.cabal b/Earley.cabal --- a/Earley.cabal +++ b/Earley.cabal @@ -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 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) diff --git a/Text/Earley/Mixfix.hs b/Text/Earley/Mixfix.hs new file mode 100644 --- /dev/null +++ b/Text/Earley/Mixfix.hs @@ -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 + diff --git a/examples/Mixfix.hs b/examples/Mixfix.hs --- a/examples/Mixfix.hs +++ b/examples/Mixfix.hs @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -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 "]"] +