module GLL.Combinators.Combinators (
    parse,
    parseString,
    char,
    epsilon,
    (<$>),
    (<$),
    (<*>),
    (<*),
    (<::=>)
    ) where

import Prelude hiding ((<*>),(<*),(<$>),(<$))

import GLL.Common
import GLL.Types.Grammar hiding (epsilon)
import GLL.Types.Abstract
import GLL.Machines.RGLL (gllSPPF, pNodeLookup)

import Control.Monad
import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Set as S

type SymbVisit1 b = Symbol 
type SymbVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt]
type SymbVisit3 b = Int -> ParseContext -> SPPF -> Int -> Int -> [b]

type IMVisit1 b   = [Symbol] 
type IMVisit2 b   = M.Map Nt [Alt] -> M.Map Nt [Alt]
type IMVisit3 b   = Int -> ParseContext -> SPPF -> (Alt,Int) -> Int -> Int -> [b]

type ParseContext = IM.IntMap (IM.IntMap (S.Set Nt))

type SymbParser b = (SymbVisit1 b,SymbVisit2 b, SymbVisit3 b)
type IMParser b   = (IMVisit1 b, IMVisit2 b, IMVisit3 b)

parseString :: (Show a) => SymbParser a -> String -> [a]
parseString p = parse p . map Char

parse :: (Show a) => SymbParser a -> [Token] -> [a]
parse (vpa1,vpa2,vpa3) input =  
    let snode               = (start, 0, m)
        m                   = length input
        start               = vpa1
        rules               = vpa2 M.empty
        as                  = vpa3 (length input) IM.empty sppf 0 m
        grammar = case start of
                    Nt x        -> Grammar x [] [ Rule x alts [] | (x, alts) <- M.assocs rules ]
                    Term t      -> Grammar "S" [] [Rule "S" [Alt "S" [start]] []]
                    Error _ _   -> error "can not parse error"
        sppf    = gllSPPF grammar input
    in as 

inParseContext :: ParseContext -> (Symbol, Int, Int) -> Bool
inParseContext ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx
 where  inner = maybe False (S.member x) . IM.lookup r

toParseContext :: ParseContext -> (Nt, Int, Int) -> ParseContext
toParseContext ctx (x, l, r) = IM.alter inner l ctx
 where  inner mm = case mm of 
                    Nothing -> Just $ singleRX
                    Just m  -> Just $ IM.insertWith (S.union) r singleX m
        singleRX = IM.singleton r singleX
        singleX  = S.singleton x

-- TODO take ParseContext into account while memoising?
memoParser :: SymbParser a -> SymbParser a
memoParser (v1,v2,v3) = (v1,v2,v3')
 where v3' m pctx sppf l r = (table IM.! l) IM.! r
        where table = IM.fromAscList 
                    [ (l', rMap) | l' <- [0..m]
                    , let rMap = IM.fromAscList [ (r',v) | r' <- [0..m]
                                             , let v = v3 m pctx sppf l' r' ]]

mkParser :: String -> [IMParser a] -> SymbParser a 
mkParser x altPs =  
    let vas1 = [ va1              | va1 <- map (\(f,_,_) -> f) altPs ]
        alts  = map (Alt x) vas1 
    in (Nt x
       ,\rules ->
           if x `M.member` rules 
            then rules 
            else foldr ($) (M.insert x alts rules) $ (map (\(_,s,_) -> s) altPs)
       ,\m ctx sppf l r -> 
        let ctx' = ctx `toParseContext` (x,l,r)
            vas2 = [ va3 m ctx' sppf (alt,length rhs) l r 
                   | (alt@(Alt _ rhs), va3) <- zip alts (map (\(_,_,t) -> t) altPs) ]
        in if ctx `inParseContext` (Nt x, l, r) 
                then []
                else concat vas2
       )
infix 5 <::=>
(<::=>) = mkParser

infixl 4 <*>
(<*>) :: IMParser (a -> b) -> SymbParser a -> IMParser b
(vimp1,vimp2,vimp3) <*> (vpa1,vpa2,vpa3) =
  (vimp1++[vpa1]
  ,\rules ->
    let rules1  = vpa2 rules
        rules2  = vimp2 rules1
    in rules2
  ,\m ctx sppf (alt@(Alt x rhs),j) l r ->
    let ks      = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)
    in [ a2b a | k <- ks, a <- vpa3 m ctx sppf k r, a2b <- vimp3 m ctx sppf (alt,j-1) l k ]
  )

infixl 4 <*
(<*) :: IMParser b -> SymbParser a -> IMParser b
(vimp1,vimp2,vimp3) <* (vpa1,vpa2,vpa3) =
  (vimp1++[vpa1]
  ,\rules ->
    let rules1  = vpa2 rules
        rules2  = vimp2 rules1
    in rules2
  ,\m ctx sppf (alt@(Alt x rhs),j) l r ->
    let ks      = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)
    in [ b | k <- ks, a <- vpa3 m ctx sppf k r, b <- vimp3 m ctx sppf (alt,j-1) l k ]
  )

infixl 4 <$>
(<$>) :: (a -> b) -> SymbParser a -> IMParser b
f <$> (vpa1,vpa2,vpa3) =
  ([vpa1]
  ,\rules -> 
    vpa2 rules
  ,\m ctx sppf (alt,j) l r ->
    let a = vpa3 m ctx sppf l r
    in maybe [] (const (map f a)) $ sppf `pNodeLookup` ((alt,1),l,r)
  )
infixl 4 <$
(<$) :: b -> SymbParser a -> IMParser b
f <$ (vpa1,vpa2,vpa3) =
  ([vpa1]
  ,\rules -> 
    vpa2 rules
  ,\m ctx sppf (alt,j) l r ->
    let a = vpa3 m ctx sppf l r
    in maybe [] (const (map (const f) a)) $ sppf `pNodeLookup` ((alt,1),l,r)
  )

char :: Char -> SymbParser Char
char c =    (charT c, id,\_ _ _ _ _ -> [c]) 

epsilon :: SymbParser ()
epsilon = (Term Epsilon, id ,\_ _ _ _ _ -> [()])