RecursiveDescent.hs

{-  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 GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Text.GrammarCombinators.Parser.RecursiveDescent (
  parseRecDec
  ) where

import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Transform.UnfoldRecursion

import Control.Monad.State
import Control.Monad.Maybe

import Data.Maybe

newtype RecDecRule t v = RecDecRule { runRD :: MaybeT (State [ConcreteToken t]) v } deriving (Monad)

instance MonadPlus (RecDecRule t) where
  mzero = RecDecRule $ fail "mzero"
  ma `mplus` mb =
    RecDecRule $ MaybeT $ do olds <- get
                             result <- runMaybeT $ runRD ma 
                             if isNothing result
                               then put olds >> runMaybeT (runRD mb)
                               else return result 

instance ProductionRule (RecDecRule t) where
  (>>>) = liftM2 ($) 
  (|||) = mplus
  die = mzero
  endOfInput = RecDecRule $ do [] <- get; return ()
  
instance EpsProductionRule (RecDecRule t) where
  epsilon = return

instance LiftableProductionRule (RecDecRule t) where
  epsilonL v _ = return v

instance (Token t) => TokenProductionRule (RecDecRule t) t where
  token c = 
    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 =
  case flip runState s $ runMaybeT $ runRD parser of
    (v,[]) -> v
    _ -> error "No full parse"

-- | Parse a given string according to a given grammar, starting from a given start non-terminal,
-- with a simple backtracking recursive descent parser algorithm.
parseRecDec :: forall phi t r ix. (Token t) =>
               ProcessingContextFreeGrammar phi t r -> phi ix -> [ConcreteToken t] -> Maybe (r ix)
parseRecDec gram = 
  let
    rpwgram :: phi ix -> RecDecRule t (r ix)
    rpwgram = unfoldRecursion gram
  in parseRecDecBase . rpwgram