UnfoldRecursion.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 GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Text.GrammarCombinators.Transform.UnfoldRecursion (
  UnfoldDepth,
  unfoldRecursion,
  unfoldRecursionP,
  unfoldRecursionB,
  unfoldRecursionE,
  selectNothing,
  selectAllOnce,
  selectNT,
  unselectNT,
  sumUD,
  scaleUD,
  modifyUnfoldDepth,
  unfoldSelective,
  unfoldSelectiveE,
  unfoldRule,
  unfoldRuleE
  ) where

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

data RPWRule p phi ixT r t v =
  RPWRule { unRPWRule :: (forall ix. phi ix -> p (r ix)) -> p v }

instance (ProductionRule p) =>
         ProductionRule (RPWRule p phi ixT r t) where
  a >>> b = RPWRule $ \g -> unRPWRule a g >>> unRPWRule b g
  a ||| b = RPWRule $ \g -> unRPWRule a g ||| unRPWRule b g
  die = RPWRule $ const die
  endOfInput = RPWRule $ const endOfInput

instance (LiftableProductionRule p) =>
         LiftableProductionRule (RPWRule p phi ixT r t) where
  epsilonL v q = RPWRule $ \_ -> epsilonL v q

instance (PenaltyProductionRule p) =>
         PenaltyProductionRule (RPWRule p phi ixT r t) where
  penalty p r = RPWRule $ \g -> penalty p $ unRPWRule r g

instance (BiasedProductionRule p) =>
         BiasedProductionRule (RPWRule p phi ixT r t) where
  a >||| b = RPWRule $ \g -> unRPWRule a g >||| unRPWRule b g
  a <||| b = RPWRule $ \g -> unRPWRule a g <||| unRPWRule b g

instance (EpsProductionRule p) =>
         EpsProductionRule (RPWRule p phi ixT r t) where
  epsilon v = RPWRule $ \_ -> epsilon v

instance (TokenProductionRule p t) =>
         TokenProductionRule (RPWRule p phi ixT r t) t where
  token c = RPWRule $ \_ -> token c
  anyToken = RPWRule $ \_ -> anyToken

instance (ProductionRule p) =>
         RecProductionRule (RPWRule p phi ixT r t) phi r where
  ref idx = RPWRule $ \g -> g idx

instance (LoopProductionRule p phi r) =>
         LoopProductionRule (RPWRule p phi ixT r t) phi r where
  -- we don't unfold loops, use unfoldLoops for that...
  manyRef idx = RPWRule $ \_ -> manyRef idx 
  many1Ref idx = RPWRule $ \_ -> many1Ref idx 

-- | Unfold recursion in a given contextx-free grammar, replacing
-- calls to
-- 'ref' idx with the non-terminal's production rule. This produces
-- production rules similar to those in traditional parser combinator
-- libraries.
unfoldRecursion ::
  ProcessingContextFreeGrammar phi t r ->
  ProcessingRegularGrammar phi t r
unfoldRecursion gram idx =
  unRPWRule (gram idx) $ unfoldRecursion gram

unfoldRecursionP ::
  ProcessingPenaltyContextFreeGrammar phi t r ->
  ProcessingPenaltyRegularGrammar phi t r
unfoldRecursionP gram idx =
  unRPWRule (gram idx) $ unfoldRecursionP gram

unfoldRecursionB ::
  ProcessingBiasedContextFreeGrammar phi t r ->
  ProcessingBiasedRegularGrammar phi t r
unfoldRecursionB gram idx =
  unRPWRule (gram idx) $ unfoldRecursionB gram

-- | Unfold recursion in a given extended context-free grammar,
-- replacing calls to
-- 'ref' idx with the non-terminal's production rule. This produces
-- production rules similar to those in traditional parser combinator
-- libraries.
unfoldRecursionE :: 
  ProcessingExtendedContextFreeGrammar phi t r ->
  ProcessingRegularGrammar phi t r
unfoldRecursionE gram = unfoldRecursion (unfoldLoops gram) 

-- instance (ProductionRule p) => SuperProductionRule (RPWRule p) where
--   subref subgram idxb = rpwSubRef (subgram idxb) idxb 
  
-- rpwSubRef :: forall p phi phi' supIxT ixT r ix t .
--              (DomainEmbedding phi phi' supIxT, HFunctor phi (PF phi), ProductionRule p) =>
--              RPWRule p phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t (PF phi' (SubVal supIxT r) ix) ->
--              phi' ix -> phi (supIxT ix) ->
--              RPWRule p phi ixT r t (PF phi r (supIxT ix)) 
-- rpwSubRef (RPWRule subintrule) idxb idx = RPWRule $ \outgram ->
--   let
--     restrictedGrammar :: forall ix'. phi' ix' -> p ((SubVal supIxT r) ix')
--     restrictedGrammar idx' = epsilon MkSubVal >>> outgram (supIx idx')
--     presult' :: p (PF phi' (SubVal supIxT r) ix)
--     presult' = subintrule restrictedGrammar
--   in epsilon (supPF idxb idx) >>> presult'

-- | A value of type UnfoldDepth defines for each non-terminal in a
-- grammar how many times it should be unfolded by the 'unfoldSelective'
-- or 'unfoldSelectiveE' algorithms.
type UnfoldDepth phi = forall ix. phi ix -> Integer

-- | A value of type 'UnfoldDepth' phi indicating nothing should be
-- unfolded at all. This can be used as a start value and then further
-- modified with the 'selectNT' function.
selectNothing :: UnfoldDepth phi
selectNothing _ = 0

-- | A value of type 'UnfoldDepth' phi indicating every non-terminal
-- should be unfolded once.
selectAllOnce :: UnfoldDepth phi
selectAllOnce _ = 1

sumUD :: UnfoldDepth phi -> UnfoldDepth phi -> UnfoldDepth phi
(da `sumUD` db) idx = da idx + db idx

scaleUD :: Integer -> UnfoldDepth phi -> UnfoldDepth phi
(r `scaleUD` d) idx = r * d idx

-- | A function modifying a given 'UnfoldDepth' phi by applying a given
-- function to the depth for a given non-terminal.
modifyUnfoldDepth :: (EqFam phi) => UnfoldDepth phi -> (Integer -> Integer) -> phi ix -> UnfoldDepth phi
modifyUnfoldDepth base f idx = overrideIdxK base idx $ f $ base idx

-- | A function modifying a given 'UnfoldDepth' phi by increasing 
-- the depth for a given non-terminal by 1.
selectNT :: (EqFam phi) => UnfoldDepth phi -> phi ix -> UnfoldDepth phi
selectNT base = modifyUnfoldDepth base (+1) 

-- | A function modifying a given 'UnfoldDepth' phi by decreasing 
-- the depth for a given non-terminal by 1.
unselectNT :: (EqFam phi) => UnfoldDepth phi -> phi ix -> UnfoldDepth phi
unselectNT base = modifyUnfoldDepth base (flip (-) 1) 

type RPWGrammar p phi ixT r v t =
  forall ix. phi ix -> RPWRule p phi ixT r t (v ix)

unfoldSelective' :: (EqFam phi, RecProductionRule p phi r) =>
  UnfoldDepth phi ->
  RPWGrammar p phi ixT r r t ->
  (forall ix. phi ix -> p (r ix))
unfoldSelective' sel gram idx =
  let
    rg idx' = if sel idx' > 0
              then unfoldSelective' (modifyUnfoldDepth sel (flip (-) 1) idx') gram idx'
              else ref idx'
  in unRPWRule (gram idx) rg

-- | Selectively unfold a given context-free grammar according to a 
-- given 'UnfoldDepth'.
unfoldSelective :: (EqFam phi) =>
  UnfoldDepth phi ->
  ProcessingContextFreeGrammar phi t r ->
  ProcessingContextFreeGrammar phi t r
unfoldSelective sel gram idx = unfoldSelective' sel gram idx

-- | Selectively unfold a given extended context-free grammar
-- according to a given 'UnfoldDepth'.
unfoldSelectiveE :: (EqFam phi) =>
  UnfoldDepth phi ->
  ProcessingExtendedContextFreeGrammar phi t r ->
  ProcessingExtendedContextFreeGrammar phi t r
unfoldSelectiveE sel gram idx =
  unfoldSelective' sel gram idx

-- | Unfold a given context-free rule by replacing all references to
-- non-terminals with the production rule for that non-terminal in 
-- a given processing context-free grammar.
unfoldRule :: ContextFreeRule phi r t v -> 
              ProcessingContextFreeGrammar phi t r ->
              ContextFreeRule phi r t v
unfoldRule r g = unRPWRule r g

-- | Unfold a given extended context-free rule by replacing all
-- references to
-- non-terminals with the production rule for that non-terminal in 
-- a given processing extended context-free grammar.
unfoldRuleE :: ExtendedContextFreeRule phi r t v -> 
              ProcessingExtendedContextFreeGrammar phi t r ->
              ExtendedContextFreeRule phi r t v
unfoldRuleE r g = unRPWRule r g