{-  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 EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Text.GrammarCombinators.Transform.FoldLoops (
  FLBaseIx, FLManyIx,
  Memo (FLM),
  FoldLoopsDomain (FLBase, FLMany),
  FoldLoopsValue (..),
  FoldLoopsResultValue (..),
  processFoldLoops,
  foldLoops,
  foldAndProcessLoops
  ) where

import Text.GrammarCombinators.Base

-- | A parametrised type such that 'FLBaseIx' ix represents
-- base non-terminal ix.
data FLBaseIx ix
-- | A parametrised type such that 'FLBaseIx' ix represents
-- the Kleene-'*' version of base non-terminal ix.
data FLManyIx ix 

-- | FoldLoopsDomain phi defines, for base domain phi, an
-- extended domain containing non-terminal types 
-- 'FLBaseIx' ix representing base non-terminal ix, and 
-- 'FLManyIx' ix representing a Kleene-* version of base
-- non-terminal ix.
data FoldLoopsDomain phi ix where
  
  FLBase :: phi ix -> FoldLoopsDomain phi (FLBaseIx ix)
  FLMany :: phi ix -> FoldLoopsDomain phi (FLManyIx ix)

instance (FoldFam phi) => FoldFam (FoldLoopsDomain phi) where
  foldFam f n =
    foldFam (f . FLMany) $
    foldFam (f . FLBase) n

instance (ShowFam phi) => ShowFam (FoldLoopsDomain phi) where
  showIdx (FLBase idx) = showIdx idx
  showIdx (FLMany idx) = showIdx idx ++ "*"

instance (EqFam phi) => EqFam (FoldLoopsDomain phi) where
  overrideIdx f (FLBase idx) v (FLBase idx') = unSubVal $ overrideIdx (MkSubVal . f . FLBase) idx (MkSubVal v) idx'
  overrideIdx f (FLMany idx) v (FLMany idx') = unSubVal $ overrideIdx (MkSubVal . f . FLMany) idx (MkSubVal v) idx'
  overrideIdx f _ _ idx = f idx

instance DomainMap (FoldLoopsDomain phi) phi FLBaseIx where
  supIx = FLBase
  subIx (FLBase idx) = idx
  
instance DomainMap (FoldLoopsDomain phi) phi FLManyIx where
  supIx = FLMany
  subIx (FLMany idx) = idx

instance (MemoFam phi) => MemoFam (FoldLoopsDomain phi) where
  data Memo (FoldLoopsDomain phi) v = FLM (Memo phi (SubVal FLBaseIx v)) (Memo phi (SubVal FLManyIx v))
  fromMemo (FLM mb _) (FLBase idx) = unSubVal $ fromMemo mb idx
  fromMemo (FLM _ mm) (FLMany idx) = unSubVal $ fromMemo mm idx 
  toMemo f = FLM (toMemo $ MkSubVal . f . FLBase) (toMemo $ MkSubVal . f . FLMany)

instance Domain phi => Domain (FoldLoopsDomain phi)

-- | FoldLoopsValue defines, for a semantic value family
-- r over base domain phi, a semantic value family 
-- 'FoldLoopsValue' r over domain 'FoldLoopsDomain' r, such
-- that the semantic value for base non-terminal 'FLBaseIx' 
-- is a wrapped version of type r ix, and for Kleene-* non-terminal
-- 'FLManyIx' a wrapped version of type [r ix]. 
data family FoldLoopsValue (r :: * -> *) ix
newtype instance FoldLoopsValue r (FLBaseIx ix) = FLBV { unFLBV :: r ix } deriving (Show)
newtype instance FoldLoopsValue r (FLManyIx ix) = FLMV { unFLMV :: [r ix] } deriving (Show)

-- | FoldLoopsResultValue defines, for semantic value families
-- r and rr over base domain phi, a semantic value family 
-- 'FoldLoopsResultValue' r rr over domain 'FoldLoopsDomain' r.
-- such that the semantic value for base non-terminal 'FLBaseIx' 
-- is a wrapped version of type rr ix, and for Kleene-* non-terminal
-- 'FLManyIx' a wrapped version of type [r ix]. 
data family FoldLoopsResultValue (r :: * -> *) (rr :: * -> *) ix
newtype instance FoldLoopsResultValue r rr (FLBaseIx ix) = FLRBV { unFLRBV :: rr ix }
newtype instance FoldLoopsResultValue r rr (FLManyIx ix) = FLRMV { unFLRMV :: [r ix] }

data FLWrap p unused1 unused2 phi r t v where
  FLW :: p v -> FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t v
unFLW :: FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t v -> p v
unFLW (FLW p) = p

instance (ProductionRule p) =>
         ProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where
  (FLW a) >>> (FLW b) = FLW $ a >>> b
  (FLW a) ||| (FLW b) = FLW $ a ||| b
  die = FLW die
  endOfInput = FLW endOfInput

instance (EpsProductionRule p) =>
         EpsProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where
  epsilon = FLW . epsilon

instance (LiftableProductionRule p) =>
         LiftableProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where
  epsilonL v q = FLW $ epsilonL v q

instance (TokenProductionRule p t) =>
         TokenProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) t where
  token = FLW . token
  anyToken = FLW anyToken

instance (RecProductionRule p (FoldLoopsDomain phi) (FoldLoopsValue r),
          ProductionRule p, EpsProductionRule p) => 
         RecProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) phi r where
  ref idx = FLW $ epsilon (\(FLBV v) -> v) >>> ref (FLBase idx)

instance (ProductionRule p, EpsProductionRule p, LiftableProductionRule p,
          TokenProductionRule p t, RecProductionRule p (FoldLoopsDomain phi) (FoldLoopsValue r)) =>
          LoopProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) phi r where
  manyRef idx = FLW $ epsilon (\(FLMV lv) -> lv) >>> ref (FLMany idx)

-- | Construct a processor for a grammar transformed using the 'foldLoops' algorithm, 
-- given a processor for the original grammar.
processFoldLoops :: forall phi r rr. GProcessor phi r rr -> GProcessor (FoldLoopsDomain phi) (FoldLoopsValue r) (FoldLoopsResultValue r rr)
processFoldLoops proc (FLBase (idx :: phi ix')) (FLRBV v) = FLBV $ proc idx v
processFoldLoops _ (FLMany _) (FLRMV vs) = FLMV vs

-- | Transform a given extended context-free grammar over a domain 'phi' into a standard
-- context-free grammar over the extended domain 'FoldLoopsDomain' 'phi'.
-- Calls to 'manyRef' idx are transformed into calls to 'ref' ('FLMany' idx),
-- where 'FLMany' idx is a new non-terminal representing the
-- Kleene-* version of underlying non-terminal 'idx'. Normal
-- calls to 'ref' idx are transformed into calls to 'ref' 
-- ('FLBase' idx) where 'FLBase' idx represents the unmodified
-- underlying non-terminal 'idx'. The 'foldLoops' algorithm 
-- constructs appropriate production rules for both types of
-- new non-terminals.
-- Values are wrapped in the 'FoldLoopsResultValue' 'r' 'rr'
-- semantic value family.
foldLoops :: 
  GExtendedContextFreeGrammar phi t r rr ->
  GContextFreeGrammar (FoldLoopsDomain phi) t (FoldLoopsValue r) (FoldLoopsResultValue r rr)
foldLoops bgram (FLBase (idx :: phi ix)) = 
  epsilon FLRBV >>> unFLW (bgram idx)
foldLoops _ (FLMany idx) = 
      epsilon (\(FLBV v) (FLMV vs) -> FLRMV (v:vs)) >>> 
      ref (FLBase idx) >>> ref (FLMany idx) 
  ||| epsilon (FLRMV [])
    
-- | Transform a given processing extended context-free 
-- grammar over a domain 'phi' into a standard context-free
-- grammar over the extended domain 'FoldLoopsDomain phi'.
-- Completely similar to 'foldLoops', but wraps values in the
-- 'FoldLoopsValue' 'r' semantic value family.
foldAndProcessLoops ::
  forall phi t r . Token t =>
  ProcessingExtendedContextFreeGrammar phi t r->
  ProcessingContextFreeGrammar (FoldLoopsDomain phi) t (FoldLoopsValue r)
foldAndProcessLoops gram = 
  let
    loopsproc = processFoldLoops identityProcessor
  in applyProcessor (foldLoops gram) loopsproc