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

module Text.GrammarCombinators.Transform.LeftCorner (
  LCBaseIx, LCNTMinNTIx, LCNTMinTIx,
  LCDomain (LCBase, LCNTMinNT, LCNTMinT),
  LCValue( LCBV, LCNTMinNTV, LCNTMinTV ),
  transformLeftCorner,
  transformLeftCornerE
  ) where

import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Utils.CalcFirst

import Data.Map (Map, (!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Enumerable
import Control.Applicative ((<*>))

-- NOTES:
-- recursion only through list of left-corner terminals, so we can handle non-processing CFG's?

data LCBaseIx ix
data LCNTMinNTIx ix' ix
data LCNTMinTIx t ix

-- | 'LCDomain' defines, for a base domain phi an extended
-- domain containing the non-terminals used by the left-
-- corner transform.
data LCDomain phi t ix where
  LCBase :: phi ix -> LCDomain phi t (LCBaseIx ix)
  LCNTMinNT :: phi ix' -> phi ix -> LCDomain phi t (LCNTMinNTIx ix' ix)
  LCNTMinT :: t -> phi ix -> LCDomain phi t (LCNTMinTIx t ix)

instance (ShowFam phi, Show t) => ShowFam (LCDomain phi t) where
  showIdx (LCBase idx) = showIdx idx
  showIdx (LCNTMinNT idx' idx) = showIdx idx ++ "-" ++ showIdx idx'
  showIdx (LCNTMinT tt idx) = showIdx idx ++ "-" ++ show tt

instance (Token t, FoldFam phi) => FoldFam (LCDomain phi t) where
  foldFam (f :: forall ix. LCDomain phi t ix -> b -> b) n =
    let n' = foldFam (f . LCBase) n
        f' idx = foldFam (f . (LCNTMinNT `flip` idx))
        n'' = foldFam f' n'
        f'' tt = foldFam (f . LCNTMinT tt)
        n''' = foldr f'' n'' enumerate
    in n''' 

newtype WrapLCNTMinNTMemo phi r ix' =
  WLCNTMNTM { unWLCNTMNT :: Memo phi (SubVal (LCNTMinNTIx ix') r) }

instance (MemoFam phi, Token t) =>
         MemoFam (LCDomain phi t) where
  data Memo (LCDomain phi t) r =
    MemoLCD (Memo phi (SubVal LCBaseIx r))
            (Memo phi (WrapLCNTMinNTMemo phi r))
            (Map t (Memo phi (SubVal (LCNTMinTIx t) r)))
  toMemo f = MemoLCD (toMemo (MkSubVal . f . LCBase))
                     (toMemo (WLCNTMNTM . (\idx' -> toMemo (MkSubVal . f . LCNTMinNT idx'))))
                     (Map.fromList (map (\tt -> (tt, toMemo (MkSubVal . f . LCNTMinT tt))) enumerate))
  fromMemo (MemoLCD mb _ _) (LCBase idx) = unSubVal $ fromMemo mb idx
  fromMemo (MemoLCD _ mnmn _) (LCNTMinNT idx' idx) =
    unSubVal $ fromMemo (unWLCNTMNT $ fromMemo mnmn idx') idx
  fromMemo (MemoLCD _ _ mnmt) (LCNTMinT tt idx) =
    unSubVal $ fromMemo (mnmt ! tt) idx

instance (Domain phi, Token t) => Domain (LCDomain phi t)

newtype WrapFSect phi r ix = WFS {
  unWFS :: forall ix'. phi ix' -> r (LCNTMinNTIx ix ix')
  }

instance (EqFam phi, Token t) => EqFam (LCDomain phi t) where
  overrideIdx f (LCBase idx) v (LCBase idx') =
    unSubVal $ overrideIdx (MkSubVal . f . LCBase) idx (MkSubVal v) idx'
  overrideIdx (f :: forall ix. LCDomain phi t ix -> r ix) (LCNTMinNT idx idxm) v (LCNTMinNT idx' idxm') =
    let
      fc :: forall ix ixm. phi ix -> phi ixm -> r (LCNTMinNTIx ix ixm)
      fc idx'' idxm'' = f $ LCNTMinNT idx'' idxm''
      fsect' idxm'' = unSubVal $ overrideIdx (MkSubVal . fc idx) idxm (MkSubVal v) idxm''
      fc' :: forall ix ixm. phi ix -> phi ixm -> r (LCNTMinNTIx ix ixm)
      fc' idxm'' = unWFS $ overrideIdx (\idx'' -> WFS $ fc idx'') idx (WFS fsect') idxm''
    in fc' idx' idxm'
  overrideIdx f (LCNTMinT tt idx) v (LCNTMinT tt' idx') =
    if tt == tt'
    then unSubVal $ overrideIdx (MkSubVal . f . LCNTMinT tt) idx (MkSubVal v) idx'
    else f (LCNTMinT tt' idx')
  overrideIdx f _ _ idx' = f idx'

instance DomainMap (LCDomain phi t) phi LCBaseIx where
  supIx = LCBase
  subIx (LCBase idx) = idx
  
data family LCValue (r :: * -> *) t ix
data instance LCValue r t (LCBaseIx ix) = LCBV { unLCBV :: r ix } deriving (Show)
data instance LCValue r t (LCNTMinNTIx ix' ix) = LCNTMinNTV { unLCNTMinNTV :: r ix' -> r ix}
data instance LCValue r t (LCNTMinTIx t ix) = LCNTMinTV { unLCNTMinTV :: ConcreteToken t -> r ix }

data TransformLCRule p (unused1 :: * -> *) (unused2 :: * -> *) (phi :: * -> *) (r :: * -> *) t v = 
  MkTLCIR {
    tlcEmpty :: Maybe v,
    tlcFull :: p v,
    tlcNTMinNT :: forall ix'. phi ix' -> p (r ix' -> v),
    tlcNTMinT :: t -> p (ConcreteToken t -> v)
    }

instance (ProductionRule p,
          EpsProductionRule p,
          RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
         ProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where
  ra >>> rb = 
    let
      es = tlcEmpty ra <*> tlcEmpty rb
      emptyA = maybe die epsilon $ tlcEmpty ra
      f = tlcFull ra >>> tlcFull rb
      rNTMinNT idx' =   flip $>> tlcNTMinNT ra idx' >>> tlcFull rb
                    ||| (.) $>> emptyA >>> tlcNTMinNT rb idx'
      rNTMinT tt =   flip $>> tlcNTMinT ra tt >>> tlcFull rb
                 ||| (.) $>> emptyA >>> tlcNTMinT rb tt
    in MkTLCIR es f rNTMinNT rNTMinT 
  ra ||| rb =
    let
      es = case (tlcEmpty ra, tlcEmpty rb) of
        (Just _, Just _) -> error "Ambiguous: empty disjunction"
        (Just va, Nothing) -> Just va
        (Nothing, Just vb) -> Just vb
        (Nothing, Nothing) -> Nothing
      f = tlcFull ra ||| tlcFull rb
      rNTMinNT idx' = tlcNTMinNT ra idx' ||| tlcNTMinNT rb idx'
      rNTMinT tt = tlcNTMinT ra tt ||| tlcNTMinT rb tt
    in MkTLCIR es f rNTMinNT rNTMinT 
  endOfInput = MkTLCIR Nothing endOfInput (const die) (const die)
  die = MkTLCIR Nothing die (const die) (const die) 

instance (ProductionRule p,
          EpsProductionRule p,
          RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
         EpsProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where
  epsilon v = MkTLCIR (Just v) (epsilon v) (const die) (const die) 

instance (ProductionRule p,
          EpsProductionRule p,
          RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
         LiftableProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where
  epsilonL v _ = epsilon v

instance (Token t, TokenProductionRule p t, ProductionRule p,
          LiftableProductionRule p,
          RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
         TokenProductionRule (TransformLCRule p unused1 unused2 phi r t) t where
  token tt = 
    let rNTMinT tt' = if tt == tt' then epsilonL id [|id|] else die
    in MkTLCIR Nothing (token tt) (const die) rNTMinT 

newtype WrapNTMinNTP p r ix surrIx =
  WNTMinNTP { unWNTMinNTP :: p (r surrIx -> r ix) }

instance (ProductionRule p, EqFam phi,
          EpsProductionRule p,
          RecProductionRule p (LCDomain phi t) (LCValue r t)) => 
         RecProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) phi r where
  ref idx = 
    let f = unLCBV $>> ref (LCBase idx)
        rNTMinNT idxm = unWNTMinNTP $ overrideIdx (\_ -> WNTMinNTP die) idx (WNTMinNTP $ epsilon id) idxm
    in MkTLCIR Nothing f rNTMinNT (const die) 

newtype WrapNTMinNTPs p r ix surrIx =
  WNTMinNTPs { unWNTMinNTPs :: p (r surrIx -> [r ix]) }
instance (EqFam phi,
          EpsProductionRule p,
          LoopProductionRule p (LCDomain phi t) (LCValue r t)) => 
         LoopProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) phi r where
  manyRef (idx :: phi ix) =
    let f = map unLCBV $>> manyRef (LCBase idx)
        rNTMinNTIdx = flip (:) $>> (map unLCBV $>> manyRef (LCBase idx))
        rNTMinNT idxm = unWNTMinNTPs $ overrideIdx (\_ -> WNTMinNTPs die) idx (WNTMinNTPs rNTMinNTIdx) idxm
    in MkTLCIR Nothing f rNTMinNT (const die)
  many1Ref (idx :: phi ix) =
    let f = map unLCBV $>> many1Ref (LCBase idx)
        rNTMinNTIdx = flip (:) $>> (map unLCBV $>> manyRef (LCBase idx))
        rNTMinNT idxm = unWNTMinNTPs $ overrideIdx (\_ -> WNTMinNTPs die) idx (WNTMinNTPs rNTMinNTIdx) idxm
    in MkTLCIR Nothing f rNTMinNT (const die) 

transformLeftCorner' ::
  forall p phi r t ix.
  (Domain phi, Token t, TokenProductionRule p t,
   ProductionRule p,
   EpsProductionRule p,
   RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
  (forall ix'. phi ix' ->
   TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t (r ix')) ->
  (forall ix'. phi ix' -> FirstSet t) ->
  LCDomain phi t ix ->
  p (LCValue r t ix)
transformLeftCorner' _ cfs (LCBase idx) = 
  let FS fs _ _ = cfs idx -- TODO: what if it can be empty?
      ruleT tt = flip ($) $>> token tt >>> (unLCNTMinTV $>> ref (LCNTMinT tt idx))
      ruleTs = LCBV $>> Set.fold ((|||) . ruleT) die fs
  in ruleTs 
transformLeftCorner' bgram _ (LCNTMinT tt idx) = 
  let
    bMinT idxB = flip (.) $>> tlcNTMinT (bgram idxB) tt >>> (unLCNTMinNTV $>> ref (LCNTMinNT idxB idx))
    bMinTs = foldFam ((|||) . bMinT) die
  in     LCNTMinTV $>> bMinTs
     ||| LCNTMinTV $>> tlcNTMinT (bgram idx) tt
transformLeftCorner' bgram _ (LCNTMinNT idxm idx) = 
  let
    cMinB idxC = LCNTMinNTV $>> (flip (.) $>> tlcNTMinNT (bgram idxC) idxm >>> follow idxC)
    baseFollow idxC = unLCNTMinNTV $>> ref (LCNTMinNT idxC idx)
    follow idxC = unWNTMinNTP $ overrideIdx (WNTMinNTP . baseFollow) idx (WNTMinNTP $ baseFollow idx ||| epsilon id) idxC
  in -- flip (|||) produces alternatives in a better order, typically
   foldFam (flip (|||) . cMinB) die 

-- | Apply the left-corner transform to a given grammar, removing direct and indirect left recursion.
-- 
-- Note that the new domain will contain O(n*t + n^2)
-- non-terminals where n is the amount of non-terminals and t is the
-- number of tokens, so when using this transformation, it can be beneficial to
-- use a token type with a more limited amount of token values than 'Char', at
-- least if you will use algorithms that fold over the full new grammar's domain 
-- (e.g. 'printGrammar' does, 'printReachableGrammar' doesn't).
transformLeftCorner ::
  (Domain phi, Token t) =>
  ProcessingContextFreeGrammar phi t r ->
  ProcessingContextFreeGrammar (LCDomain phi t) t (LCValue r t)
transformLeftCorner gram idx = transformLeftCorner' gram (calcFirst gram) idx 

-- | Apply the left-corner transform to a given extended grammar, removing direct and indirect left recursion.
transformLeftCornerE ::
  forall phi t r. (Domain phi, Token t) =>
  ProcessingExtendedContextFreeGrammar phi t r ->
  ProcessingExtendedContextFreeGrammar (LCDomain phi t) t (LCValue r t)
transformLeftCornerE gram idx = transformLeftCorner' gram (calcFirst gram) idx