UnfoldLoops.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 GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Text.GrammarCombinators.Transform.UnfoldLoops (
  unfoldLoops,
  unfoldLoopsP,
  unfoldLoopsRule,
  replaceLoopsRule
  ) where

import Text.GrammarCombinators.Base

newtype UnfoldLoopsWrapper p (phi :: * -> *) ixT (r :: * -> *) t v = ULW {
  runULW :: (forall ix. phi ix -> p [r ix]) -> (forall ix. phi ix -> p [r ix]) -> p v
  }

instance (ProductionRule p) =>
         ProductionRule (UnfoldLoopsWrapper p phi ixT r t) where
  ra >>> rb = ULW $ \gm gm1 -> runULW ra gm gm1 >>> runULW rb gm gm1
  ra ||| rb = ULW $ \gm gm1 -> runULW ra gm gm1 ||| runULW rb gm gm1
  die = ULW $ \_ _ -> die
  endOfInput = ULW $ \_ _ -> endOfInput

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

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

-- no newtype deriving for multi param type classes?
instance (TokenProductionRule p t) =>
         TokenProductionRule (UnfoldLoopsWrapper p phi ixT r t) t where
  token t = ULW $ \_ _ -> token t
  anyToken = ULW $ \_ _ -> anyToken

instance (PenaltyProductionRule p) =>
         PenaltyProductionRule (UnfoldLoopsWrapper p phi ixT r t) where
  penalty p r = ULW $ \gm gm1 -> penalty p $ runULW r gm gm1

instance (RecProductionRule p phi r) =>
         RecProductionRule (UnfoldLoopsWrapper p phi ixT r t) phi r where
  ref idx = ULW $ \_ _ -> ref idx

instance (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r) =>
         LoopProductionRule (UnfoldLoopsWrapper p phi ixT r t) phi r where
  manyRef idx = ULW $ \gm _ -> gm idx
  many1Ref idx = ULW $ \_ gm1 -> gm1 idx

-- | Unfold loops in a given grammar, replacing calls to
-- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise
-- for 'many1Ref'
unfoldLoops :: 
  GExtendedContextFreeGrammar phi t r rr ->
  GContextFreeGrammar phi t r rr
unfoldLoops gram idx = 
  unfoldLoopsRule (gram idx) 

-- | Unfold loops in a given grammar, replacing calls to
-- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise
-- for 'many1Ref'
unfoldLoopsP :: 
  GPenaltyExtendedContextFreeGrammar phi t r rr ->
  GPenaltyContextFreeGrammar phi t r rr
unfoldLoopsP gram idx = 
  unfoldLoopsRuleP (gram idx) 

-- | Unfold loops in a given rule, replacing calls to
-- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise
-- for 'many1Ref'
unfoldLoopsRule :: 
  ExtendedContextFreeRule phi r t v ->
  ContextFreeRule phi r t v
unfoldLoopsRule r = 
  let
    manyGram idx = manyInf $ ref idx
    oneOrMoreGram idx = (:) $>> ref idx >>> manyGram idx
  in replaceLoopsRule r manyGram oneOrMoreGram

-- | Unfold loops in a given rule, replacing calls to
-- 'manyRef' idx by 'manyInf' ('ref' idx) and likewise
-- for 'many1Ref'
unfoldLoopsRuleP :: 
  PenaltyExtendedContextFreeRule phi r t v ->
  PenaltyContextFreeRule phi r t v
unfoldLoopsRuleP r = 
  let manyGram idx = manyInf $ ref idx
      oneOrMoreGram idx = (:) $>> ref idx >>> manyGram idx
  in replaceLoopsRuleP r manyGram oneOrMoreGram

-- | Replace loops in a given rule by rules provided
-- in two provided sets of rules, replacing calls to
-- 'manyRef' by the corresponding rule from the first
-- set, and calls to 'manyRef' by the corresponding rule
-- from the second set. You likely don't need this
-- and should be looking at 'unfoldLoops' or 
-- 'unfoldLoopsRule' instead.
replaceLoopsRule :: 
  (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t) =>
  ExtendedContextFreeRule phi r t v ->
  (forall ix. phi ix -> p [r ix]) ->
  (forall ix. phi ix -> p [r ix]) ->
  p v
replaceLoopsRule r = 
  runULW r 

replaceLoopsRuleP :: 
  (ProductionRule p, EpsProductionRule p, RecProductionRule p phi r, TokenProductionRule p t, PenaltyProductionRule p) =>
  PenaltyExtendedContextFreeRule phi r t v ->
  (forall ix. phi ix -> p [r ix]) ->
  (forall ix. phi ix -> p [r ix]) ->
  p v
replaceLoopsRuleP r = runULW r