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

-- | This is an experiment, do not use.
module Text.GrammarCombinators.Parser.RealLL1 (
  FirstSet(FS,firstTokens,canBeEmpty,canBeEOI),
  BranchSelectorMemo(DefaultBranchSelectorMemo,SplitBranchSelectorMemoL, FlipBS),
  RealLL1Table (MkRealLL1Table),
  parseRealLL1, 
  prepareLL1Parser,
  ) where

import Text.GrammarCombinators.Base

import Control.Monad.Maybe
import Control.Monad.State

import Data.Set 
import Data.Enumerable (enumerate) 
import qualified Data.Set as Set

data (Token t) => FirstSet t = 
  FS {
    firstTokens :: Set t,
    canBeEmpty :: Bool, 
    canBeEOI :: Bool
    } deriving (Show)

data BranchSelector t = MkBS { 
  selectBranch :: forall a. [ConcreteToken t] -> a -> a -> (a, BranchSelector t)
  }

defaultBranchSelector :: BranchSelector t
defaultBranchSelector = 
  MkBS (error "defaultBranchSelector selecting branch???")

data BranchSelectorMemo t =
    DefaultBranchSelectorMemo
  | SplitBranchSelectorMemoL (FirstSet t) (BranchSelectorMemo t) (BranchSelectorMemo t)
  | FlipBS (BranchSelectorMemo t)

unBranchSelectorMemo :: forall t. (Token t) => BranchSelectorMemo t -> BranchSelector t
unBranchSelectorMemo DefaultBranchSelectorMemo = defaultBranchSelector
unBranchSelectorMemo (SplitBranchSelectorMemoL fs bsm1 bsm2) = 
  let bs1 = unBranchSelectorMemo bsm1
      bs2 = unBranchSelectorMemo bsm2
      selBranch :: Set t -> Bool -> [ConcreteToken t] -> a -> a -> (a, BranchSelector t)
      selBranch fts _ (t:_) b1 b2 = if classify t `member` fts then (b1,bs1) else (b2,bs2)
      selBranch _ f [] b1 b2 = if f then (b1,bs1) else (b2,bs2)
  in MkBS $ selBranch (firstTokens fs) (canBeEOI fs)
unBranchSelectorMemo (FlipBS bsm) =
  let bs = unBranchSelectorMemo bsm
  in MkBS $ \s b1 b2 -> selectBranch bs s b2 b1

data BranchData t = MkBD {
  branchSelector :: BranchSelectorMemo t,
  seqBS :: BranchSelectorMemo t -> BranchSelectorMemo t,
  firstSet :: FirstSet t
  }

type BranchSelectorGrammar phi t = forall ix. phi ix -> BranchData t

newtype (Domain phi, Token t) => BranchSelectorComputer phi (r :: * -> *) t v = MkBSC {
  branchData :: BranchSelectorGrammar phi t -> BranchData t
  }

type BSCGrammar phi r t rr = forall ix. phi ix -> BranchSelectorComputer phi r t (rr ix)

instance (Domain phi, Token t) => ProductionRule (BranchSelectorComputer phi r t) where
  a >>> b = MkBSC $ \g -> 
    let 
      bs = seqBS (branchData a g) (branchSelector (branchData b g))
      (FS fsa ea fa) = firstSet $ branchData a g
      (FS fsb eb fb) = firstSet $ branchData b g
      fs = FS (if ea then fsa `union` fsb else fsa) (ea && eb) (fa || (ea && fb))
      nseqbs = seqBS (branchData a g) . seqBS (branchData b g)
    in MkBD bs nseqbs fs
  a ||| b = MkBSC $ \g ->
    let
      fsa = firstSet $ branchData a g
      fsb = firstSet $ branchData b g
      (FS ftsa ea fa) = fsa
      (FS ftsb eb fb) = fsb
      fs = FS (ftsa `union` ftsb) (ea || eb) (fa || fb)
      bsa = branchSelector $ branchData a g
      bsb = branchSelector $ branchData b g
      sb bsa' bsb' = if not ea
           then SplitBranchSelectorMemoL fsa bsa' bsb'
           else FlipBS $ SplitBranchSelectorMemoL fsb bsb' bsa'
      seqbs rbs = sb (seqBS (branchData a g) rbs) (seqBS (branchData a g) rbs)
    in MkBD (sb bsa bsb) seqbs fs
  die = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty False False
  endOfInput = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty False True

instance (Domain phi, Token t) => LiftableProductionRule (BranchSelectorComputer phi r t) where
  epsilonL v _ = epsilon v

instance (Domain phi, Token t) => EpsProductionRule (BranchSelectorComputer phi r t) where
  epsilon _ = MkBSC $ \_ -> MkBD DefaultBranchSelectorMemo id $ FS Set.empty True False

instance (Token t, Domain phi) => TokenProductionRule (BranchSelectorComputer phi r t) t where
  token tt = MkBSC $ \_ -> 
    MkBD DefaultBranchSelectorMemo id $ FS (singleton tt) False False
  anyToken = MkBSC $ \_ -> 
    MkBD DefaultBranchSelectorMemo id $ FS (fromList enumerate) False False

instance (Token t, Domain phi) => RecProductionRule (BranchSelectorComputer phi r t) phi r where
  ref idx = MkBSC $ \g ->
    MkBD DefaultBranchSelectorMemo id $ firstSet $ g idx

instance (Token t, Domain phi) => LoopProductionRule (BranchSelectorComputer phi r t) phi r where
  manyRef idx = MkBSC $ \g ->
    let
      singleFS = firstSet $ g idx
      multFS = FS (firstTokens singleFS) True (canBeEOI singleFS)
    in MkBD DefaultBranchSelectorMemo id multFS 

fixBSC :: (Domain phi, Token t) => BSCGrammar phi r t rr -> BranchSelectorGrammar phi t
fixBSC gram idx = branchData (gram idx) (fixBSC gram)

data RealLL1Rule phi ixT r t v = MkRealLL1Rule {
  runLL1Rule :: BranchSelector t ->
                (forall ix. phi ix -> BranchSelector t) ->
                (forall ix. phi ix -> RealLL1Rule phi ixT r t (r ix)) ->
                MaybeT (State [ConcreteToken t]) v
  } 

type RealLL1Grammar phi ixT rr r t = (Domain phi, Token t) => phi ix -> RealLL1Rule phi ixT r t (rr ix)

instance ProductionRule (RealLL1Rule phi ixT r t) where
  a >>> b = MkRealLL1Rule $ \cs selg g -> do f <- runLL1Rule a cs selg g
                                             x <- runLL1Rule b cs selg g
                                             return $ f x
  a ||| b = MkRealLL1Rule $ \cs selg g ->
    do s <- get
       let (r,ns) = selectBranch cs s a b
       runLL1Rule r ns selg g
  die = MkRealLL1Rule $ \_ _ _ -> fail "die"
  endOfInput = MkRealLL1Rule $ \_ _ _ -> do [] <- get; return ()
  
instance LiftableProductionRule (RealLL1Rule phi ixT r t) where
  epsilonL v _ = epsilon v

instance EpsProductionRule (RealLL1Rule phi ixT r t) where
  epsilon v = MkRealLL1Rule $ \_ _ _ -> return v

instance (Token t) => TokenProductionRule (RealLL1Rule phi ixT r t) t where
  token tt = MkRealLL1Rule $ \_ _ _ ->
    let 
      errWrongToken c = show c ++ " read when " ++ show tt ++ " expected."
    in do (c:r) <- get
          if classify c == tt
            then put r >> return c
            else fail $ errWrongToken c
  anyToken = MkRealLL1Rule $ \_ _ _ ->
    do (c:r) <- get
       put r >> return c

instance RecProductionRule (RealLL1Rule phi ixT r t) phi r where
  ref idx = MkRealLL1Rule $ \_ selg g ->
    runLL1Rule (g idx) (selg idx) selg g

newtype RealLL1Table phi t = MkRealLL1Table { 
  unRealLL1Table :: Memo phi (K0 (BranchSelectorMemo t))
  }

prepareLL1Parser :: (Domain phi, Token t) => BSCGrammar phi r t rr -> RealLL1Table phi t
prepareLL1Parser gram = MkRealLL1Table $ toMemoK $ branchSelector . fixBSC gram

parseRealLL1 :: forall phi ixT t r ix. (Domain phi, Token t) => RealLL1Grammar phi ixT r r t -> RealLL1Table phi t ->
                phi ix -> [ConcreteToken t] -> Maybe (r ix)
parseRealLL1 gram selgmemo idx s =
  let
    selg :: phi ix' -> BranchSelector t
    selg = unBranchSelectorMemo . fromMemoK (unRealLL1Table selgmemo)
    m :: MaybeT (State [ConcreteToken t]) (r ix)
    m = runLL1Rule (gram idx) (selg idx) selg gram
  in evalState (runMaybeT m) s