UUParse.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 FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | UUParse compatibility module.
module Text.GrammarCombinators.Parser.UUParse (
  parseUU,
  parseUUR,
  parseUURule,
  parseUUE
  ) where

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

import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances

import Data.Enumerable (enumerate)

newtype WrapP t loc ct v = WP { unWP :: P (Str (ConcreteToken t) [ConcreteToken t] loc) v }

instance (Token t) => ProductionRule (WrapP t loc ct) where
  a >>> b = WP $ unWP a <*> unWP b
  a ||| b = WP $ unWP a <|> unWP b
  endOfInput = WP $ const () <$> pEnd
  die = WP empty

instance (Token t) => EpsProductionRule (WrapP t loc ct) where
  epsilon v = WP $ pure v

instance (Token t) => LiftableProductionRule (WrapP t loc ct) where
  epsilonL v _ = epsilon v

instance (Token t, Show ct, ConcreteToken t ~ ct, IsLocationUpdatedBy loc ct) =>
         TokenProductionRule (WrapP t loc ct) t where
  token tt =
    let
      sat :: ConcreteToken t -> Bool
      sat t = classify t == tt
    in WP $ pSatisfy sat $ Insertion (show tt) (head $ enumConcreteTokens tt) 1
  anyToken = WP $ pSatisfy (const True :: ConcreteToken t -> Bool) $ Insertion "anyToken" (head $ enumConcreteTokens (head enumerate :: t)) 1

-- | Parse a given string according to a given regular grammar, starting from a given
-- start symbol using the UUParse error-correcting parsing library (always
-- produces a result)
parseUUR :: forall loc phi t r ix.
           (Token t, IsLocationUpdatedBy loc (ConcreteToken t)) =>
           ProcessingRegularGrammar phi t r ->
           phi ix -> loc -> [ConcreteToken t] -> r ix
parseUUR gram idx = parseUURule $ gram idx

-- | Parse a given string according to a given grammar, starting from a given
-- start symbol using the UUParse error-correcting parsing library (always
-- produces a result)
parseUU :: forall loc phi t r ix.
           (Token t, IsLocationUpdatedBy loc (ConcreteToken t)) =>
           ProcessingContextFreeGrammar phi t r ->
           phi ix -> loc -> [ConcreteToken t] -> r ix
parseUU gram = parseUUR (unfoldRecursion gram)

-- | Parse a given string according to a given regular production rule using the 
-- UUParse error-correcting parsing library (always produces a result).
parseUURule :: forall loc phi t r v.
           (Token t, IsLocationUpdatedBy loc (ConcreteToken t)) =>
           RegularRule phi r t v -> loc ->
           [ConcreteToken t] -> v
parseUURule rule loc s = 
  parse (unWP rule <* pEnd) $ createStr loc s 

-- | Parse a given string according to a given extended grammar, starting from a given
-- start symbol using the UUParse error-correcting parsing library (always
-- produces a result)
parseUUE :: forall loc phi t r ix.
           (Token t, IsLocationUpdatedBy loc (ConcreteToken t)) =>
           ProcessingExtendedContextFreeGrammar phi t r ->
           phi ix -> loc -> [ConcreteToken t] -> r ix
parseUUE gram = parseUU (unfoldLoops gram)