Earley (empty) → 0.6.0

raw patch · 7 files changed

+473/−0 lines, 7 filesdep +ListLikedep +basedep +containerssetup-changed

Dependencies added: ListLike, base, containers, kan-extensions

Files

Earley.cabal +28/−0
LICENSE +30/−0
Setup.hs +2/−0
Text/Earley.hs +13/−0
Text/Earley/Derived.hs +18/−0
Text/Earley/Grammar.hs +136/−0
Text/Earley/Parser.hs +246/−0

+ Earley.cabal view

@@ -0,0 +1,28 @@+name:                Earley+version:             0.6.0+synopsis:            Parsing all context-free grammars using Earley's algorithm.+description:         See <https://www.github.com/ollef/Earley> for more+                     information and+                     <https://github.com/ollef/Earley/tree/master/examples> for+                     examples.+license:             BSD3+license-file:        LICENSE+author:              Olle Fredriksson+maintainer:          fredriksson.olle@gmail.com+copyright:           (c) 2014-2015 Olle Fredriksson+category:            Parsing+build-type:          Simple+cabal-version:       >=1.10++source-repository    head+  type:     git+  location: https://github.com/ollef/Earley.git++library+  exposed-modules:     Text.Earley.Derived, Text.Earley.Grammar, Text.Earley.Parser Text.Earley+  -- other-modules:+  build-depends:       base ==4.8.*, containers >=0.5, kan-extensions >=4.2, ListLike >=4.1+  -- hs-source-dirs:+  default-language:    Haskell2010+  ghc-options:         -Wall -funbox-strict-fields+

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2014-2015, Olle Fredriksson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Olle Fredriksson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ Text/Earley.hs view

@@ -0,0 +1,13 @@+-- | Parsing all context-free grammars using Earley's algorithm.+module Text.Earley+  ( -- * Context-free grammars+    Prod, satisfy, (<?>), Grammar, rule+  , -- * Derived operators+    symbol, namedSymbol, word+  , -- * Parsing+    Report(..), Result(..), parser, allParses, fullParses+  )+  where+import Text.Earley.Grammar+import Text.Earley.Derived+import Text.Earley.Parser

+ Text/Earley/Derived.hs view

@@ -0,0 +1,18 @@+-- | Derived operators.+module Text.Earley.Derived where+import Control.Applicative hiding (many)++import Text.Earley.Grammar++-- | Match a single token.+symbol :: Eq t => t -> Prod r e t t+symbol 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++-- | Match a list of tokens in sequence.+{-# INLINE word #-}+word :: Eq t => [t] -> Prod r e t [t]+word = foldr (liftA2 (:) . satisfy . (==)) (pure [])

+ Text/Earley/Grammar.hs view

@@ -0,0 +1,136 @@+-- | Context-free grammars.+{-# LANGUAGE GADTs, RankNTypes #-}+module Text.Earley.Grammar+  ( Prod(..)+  , satisfy+  , (<?>)+  , Grammar(..)+  , rule+  ) where+import Control.Applicative+import Control.Monad+import Control.Monad.Fix++infixr 0 <?>++-- | A production.+--+-- The type parameters are:+--+-- @a@: The return type of the production.+--+-- @t@: The type of the terminals that the production operates on.+--+-- @e@: The type of names, used for example to report expected tokens.+--+-- @r@: The type of a non-terminal. This plays a role similar to the @s@ in the+--      type @ST s a@.  Since the 'parser' function expects the @r@ to be+--      universally quantified, there is not much to do with this parameter+--      other than leaving it universally quantified.+--+-- As an example, @'Prod' r 'String' 'Char' 'Int'@ is the type of a production that+-- returns an 'Int', operates on (lists of) characters and reports 'String'+-- names.+--+-- Most of the functionality of 'Prod's is obtained through its instances, e.g.+-- '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+  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+  -- with rules) to be able to satisfy the Alternative interface.+  Plus        :: !(Prod r e t a) -> !(Prod r e t a) -> Prod r e t a+  Many        :: !(Prod r e t a) -> !(Prod r e t ([a] -> b)) -> Prod r e t b+  Empty       :: Prod r e t a+  -- 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++-- | A named production (used for reporting expected things).+(<?>) :: Prod r e t a -> e -> Prod r e t a+(<?>) = Named++instance Monoid (Prod r e t a) where+  mempty  = empty+  mappend = (<|>)++instance Functor (Prod r e t) where+  {-# INLINE fmap #-}+  fmap f (Terminal b p)    = Terminal b $ fmap (f .) p+  fmap f (NonTerminal r p) = NonTerminal r $ fmap (f .) p+  fmap f (Pure x)          = Pure $ f x+  fmap f (Plus p q)        = Plus (fmap f p) (fmap f q)+  fmap f (Many p q)        = Many p $ fmap (f .) q+  fmap _ Empty             = Empty+  fmap f (Named p n)       = Named (fmap f p) n++instance Applicative (Prod r e t) where+  pure = Pure+  {-# INLINE (<*>) #-}+  Terminal b p    <*> q = Terminal b $ flip <$> p <*> q+  NonTerminal r p <*> q = NonTerminal r $ flip <$> p <*> q+  Pure f          <*> q = fmap f q+  Plus a b        <*> q = a <*> q <|> b <*> q+  Many a p        <*> q = Many a $ flip <$> p <*> q+  Empty           <*> _ = Empty+  Named p n       <*> q = Named (p <*> q) n++instance Alternative (Prod r e t) where+  empty = Empty+  Empty     <|> q         = q+  p         <|> Empty     = p+  Named p m <|> q         = Named (p <|> q) m+  p         <|> Named q n = Named (p <|> q) n+  p         <|> q         = Plus p q+  many p       = Many p $ Pure id+  some p       = (:) <$> p <*> many p++-- | A context-free grammar.+--+-- The type parameters are:+--+-- @a@: The return type of the grammar (often a 'Prod').+--+-- @e@: The type of names, used for example to report expected tokens.+--+-- @r@: The type of a non-terminal. This plays a role similar to the @s@ in the+--      type @ST s a@.  Since the 'parser' function expects the @r@ to be+--      universally quantified, there is not much to do with this parameter+--      other than leaving it universally quantified.+--+-- Most of the functionality of 'Grammar's is obtained through its instances,+-- e.g.  'Monad' and 'MonadFix'. Note that GHC has syntactic sugar for+-- 'MonadFix': use @{-\# LANGUAGE RecursiveDo \#-}@ and @mdo@ instead of+-- @do@.+data Grammar r e a where+  RuleBind :: Prod r e t a -> (Prod r e t a -> Grammar r e b) -> Grammar r e b+  FixBind  :: (a -> Grammar r e a) -> (a -> Grammar r e b) -> Grammar r e b+  Return   :: a -> Grammar r e a++instance Functor (Grammar r e) where+  fmap f (RuleBind ps h) = RuleBind ps (fmap f . h)+  fmap f (FixBind g h)   = FixBind g (fmap f . h)+  fmap f (Return x)      = Return $ f x++instance Applicative (Grammar r e) where+  pure  = return+  (<*>) = ap++instance Monad (Grammar r e) where+  return = Return+  RuleBind ps f >>= k = RuleBind ps (f >=> k)+  FixBind f g   >>= k = FixBind f (g >=> k)+  Return x      >>= k = k x++instance MonadFix (Grammar r e) where+  mfix f = FixBind f return++-- | Create a new non-terminal by listing its production rule.+rule :: Prod r e t a -> Grammar r e (Prod r e t a)+rule p = RuleBind p return

+ Text/Earley/Parser.hs view

@@ -0,0 +1,246 @@+-- | Parsing.+{-# LANGUAGE BangPatterns, DeriveFunctor, GADTs, Rank2Types #-}+module Text.Earley.Parser+  ( Report(..)+  , Result(..)+  , parser+  , allParses+  , fullParses+  ) where+import Control.Applicative+import Control.Arrow+import Control.Monad.Fix+import Control.Monad.ST.Lazy+import Data.Functor.Yoneda+import Data.ListLike(ListLike)+import qualified Data.ListLike as ListLike+import Data.STRef.Lazy+import Text.Earley.Grammar++-------------------------------------------------------------------------------+-- * Concrete rules and productions+-------------------------------------------------------------------------------+-- | The concrete rule type that the parser uses+data Rule s r e t a = Rule+  { ruleProd     :: ProdR s r e t a+  , ruleNullable :: {-# UNPACK #-} !(STRef s (Maybe [a]))+  , ruleConts    :: {-# UNPACK #-} !(STRef s (Conts s r e t a r))+  }++type ProdR s r e t a = Prod (Rule s r) e t a++nullable :: Rule s r e t a -> ST s [a]+nullable r = do+  mn <- readSTRef $ ruleNullable r+  case mn of+    Just xs -> return xs+    Nothing -> do+      writeSTRef (ruleNullable r) $ Just mempty+      res <- nullableProd $ ruleProd r+      writeSTRef (ruleNullable r) $ Just res+      return res++nullableProd :: ProdR s r e t a -> ST s [a]+nullableProd (Terminal _ _)    = return mempty+nullableProd (NonTerminal r p) = do+  as <- nullable r+  concat <$> mapM (\a -> nullableProd $ fmap ($ a) p) as+nullableProd (Pure a)          = return [a]+nullableProd (Plus a b)        = mappend <$> nullableProd a <*> nullableProd b+nullableProd (Many p q)        = do+  as <- nullableProd $ (:[]) <$> p <|> pure []+  concat <$> mapM (\a -> nullableProd $ fmap ($ a) q) as+nullableProd Empty             = return mempty+nullableProd (Named p _)       = nullableProd p++-------------------------------------------------------------------------------+-- * States and continuations+-------------------------------------------------------------------------------+type Pos = Int++-- | An Earley state with result type @a@.+data State s r e t a where+  State :: {-# UNPACK #-} !Pos+        -> !(ProdR s r e t b)+        -> {-# UNPACK #-} !(Conts s r e t b a)+        -> State s r e t a+  Final :: a -> State s r e t a++-- | A continuation accepting an @a@ and producing a @b@.+data Cont s r e t a b where+  Cont      :: {-# UNPACK #-} !Pos+            -> !(ProdR s r e t (a -> b))+            -> {-# UNPACK #-} !(Conts s r e t b c)+            -> Cont s r e t a c+  FinalCont :: (a -> c) -> Cont s r e t a c++type Conts s r e t a c = STRef s [Cont s r e t a c]++contraMapCont :: (b -> a) -> Cont s r e t a c -> Cont s r e t b c+contraMapCont f (Cont pos p cs) = (Cont pos $! ((. f) <$> p)) cs+contraMapCont f (FinalCont g)   = FinalCont (g . f)++contToState :: a -> Cont s r e t a c -> State s r e t c+contToState a (Cont pos p cs) = State pos (($ a) <$> p) cs+contToState a (FinalCont f)   = Final (f a)++-- | Strings of non-ambiguous continuations can be optimised by removing+--   indirections.+simplifyCont :: Conts s r e t b a -> ST s [Cont s r e t b a]+simplifyCont cont = readSTRef cont >>= go False+  where+    go !_ [Cont _ (Pure f) cont'] = do+      ks' <- simplifyCont cont'+      go True $ map (contraMapCont f) ks'+    go True ks = do+      writeSTRef cont ks+      return ks+    go False ks = return ks++-------------------------------------------------------------------------------+-- * Grammars+-------------------------------------------------------------------------------+-- | Interpret an abstract 'Grammar'.+grammar :: Grammar (Rule s r) e a -> ST s a+grammar g = case g of+  RuleBind p k -> do+    c  <- newSTRef =<< newSTRef mempty+    nr <- newSTRef Nothing+    grammar $ k $ NonTerminal (Rule p nr c) $ Pure id+  FixBind f k   -> do+    a <- mfix $ fmap grammar f+    grammar $ k a+  Return x      -> return x++-- | Given a grammar, construct an initial state.+initialState :: ProdR s a e t a -> ST s (State s a e t a)+initialState r = do+  rs <- newSTRef [FinalCont id]+  return $ State (-1) r rs++-------------------------------------------------------------------------------+-- * Parsing+-------------------------------------------------------------------------------+-- | A parsing report, which contains fields that are useful for presenting+-- errors to the user if a parse is deemed a failure.  Note however that we get+-- a report even when we successfully parse something.+data Report e i = Report+  { position   :: Int -- ^ The final position in the input (0-based) that the+                      -- parser reached.+  , expected   :: [e] -- ^ The named productions processed at the final+                      -- position.+  , unconsumed :: i   -- ^ The part of the input string that was not consumed,+                      -- which may be empty.+  } deriving Show++-- | The result of a parse.+data Result s e i a+  = Ended (Report e i)+    -- ^ The parser ended.+  | Parsed a Int i (i -> ST s (Result s e i a))+    -- ^ The parser parsed something, namely an 'a'. The 'Int' is the position+    -- in the input where it did so, the 'i' is the rest of the input, and the+    -- function is the parser continuation. This allows incrementally feeding+    -- the parser more input (e.g. when the 'i' is empty).+  deriving (Functor)++{-# INLINE uncons #-}+uncons :: ListLike i t => i -> Maybe (t, i)+uncons i+  | ListLike.null i = Nothing+  | otherwise       = Just (ListLike.head i, ListLike.tail i)++{-# INLINE safeTail #-}+safeTail :: ListLike i t => i -> i+safeTail ts'+  | ListLike.null ts' = ts'+  | otherwise         = ListLike.tail ts'++{-# SPECIALISE parse :: [State s a e t a] -> [State s a e t a] -> ST s () -> [e] -> Pos -> [t] -> ST s (Result s e [t] a) #-}+-- | The internal parsing routine+parse :: ListLike i t+      => [State s a e t a] -- ^ States to process at this position+      -> [State s a e t a] -- ^ States to process at the next position+      -> ST s ()           -- ^ Computation that resets the continuation refs of productions+      -> [e]               -- ^ Named productions encountered at this position+      -> Pos               -- ^ The current position in the input string+      -> i                 -- ^ The input string+      -> ST s (Result s e i a)+parse []      []    !reset names !pos   !ts = do+  reset+  return $ Ended Report {position = pos, expected = names, unconsumed = ts}+parse []      !next !reset _names !pos !ts = do+  reset+  parse next [] (return ()) [] (pos + 1) (safeTail ts)+parse (st:ss) !next !reset names !pos !ts = case st of+  Final a -> return $ Parsed a pos ts $ parse ss next reset names pos+  State spos pr scont -> case pr of+    Terminal f p -> case uncons ts of+      Just (t, _) | f t -> parse ss (State spos (($ t) <$> p) scont : next) reset names pos ts+      _                 -> parse ss next reset names pos ts+    NonTerminal r p -> do+      rkref <- readSTRef $ ruleConts r+      ks    <- readSTRef rkref+      writeSTRef rkref (Cont spos p scont : ks)+      nulls' <- nullable r+      let notExpanded = null ks+          p'          = liftYoneda p+          nulls       = fmap (\a -> State spos (lowerYoneda $ ($ a) <$> p') scont) nulls'+      if notExpanded then do+        let st' = State pos (ruleProd r) rkref+        parse (st' : nulls ++ ss)+              next+              ((writeSTRef (ruleConts r) =<< newSTRef mempty) >> reset)+              names+              pos+              ts+      else+        parse (nulls ++ ss) next reset names pos ts+    Pure a | spos /= pos -> do+      conts <- simplifyCont scont+      parse (map (contToState a) conts ++ ss) next reset names pos ts+           | otherwise -> parse ss next reset names pos ts++    Plus p q    -> parse (State spos p scont : State spos q scont : ss) next reset names pos ts+    Many p q    -> do+      rkref <- newSTRef [Cont spos (Many p ((\f as a -> f (a : as)) <$> q)) scont]+      let st' = State pos p rkref+          nst = State spos (($ []) <$> q) scont+      parse (st' : nst : ss) next reset names pos ts+    Empty       -> parse ss next reset names pos ts++    Named pr' n -> parse (State spos pr' scont : ss) next reset (n : names) pos ts++{-# INLINE parser #-}+-- | Create a parser from the given grammar.+parser :: ListLike i t+       => (forall r. Grammar r e (Prod r e t a))+       -> i+       -> ST s (Result s e i a)+parser g xs = do+  s <- initialState =<< grammar g+  parse [s] [] (return ()) [] 0 xs++-- | Return all parses from the result of a given parser. The result may+-- contain partial parses. The 'Int's are the position at which a result was+-- produced.+allParses :: (forall s. ST s (Result s e i a)) -> ([(a, Int)], Report e i)+allParses p = runST $ p >>= go+  where+    go :: Result s e i a -> ST s ([(a, Int)], Report e i)+    go r = case r of+      Ended report     -> return ([], report)+      Parsed a pos i k -> fmap (first ((a, pos) :)) $ go =<< k i++{-# INLINE fullParses #-}+-- | Return all parses that reached the end of the input from the result of a+--   given parser.+fullParses :: ListLike i t => (forall s. ST s (Result s e i a)) -> ([a], Report e i)+fullParses p = runST $ p >>= go+  where+    go :: ListLike i t => Result s e i a -> ST s ([a], Report e i)+    go r = case r of+      Ended report -> return ([], report)+      Parsed a _ i k+        | ListLike.null i -> fmap (first (a :)) $ go =<< k i+        | otherwise       -> go =<< k i