{-# LANGUAGE  MagicHash,
              UnboxedTuples,
              ScopedTypeVariables #-}

module UU.Parsing.Offside( parseOffside
                         , pBlock
                         , pBlock1
                         , pOffside
                         , pOpen
                         , pClose
                         , pSeparator
                         , scanOffside
                         , scanOffsideWithTriggers
                         , scanLiftTokensToOffside
                         , OffsideTrigger(..)
                         , OffsideSymbol(..)
                         , OffsideInput
                         , Stream
                         , OffsideParser(..)
                         ) where

import GHC.Prim
import Data.Maybe
import Control.Applicative
import UU.Parsing.Interface
import UU.Parsing.Machine
import UU.Parsing.Derived(opt, pFoldr1Sep,pList,pList1, pList1Sep)
import UU.Scanner.Position

data OffsideTrigger
  = Trigger_IndentGT
  | Trigger_IndentGE
  deriving Eq

data OffsideSymbol s
  = Symbol s
  | SemiColon
  | CloseBrace
  | OpenBrace
  deriving (Ord,Eq,Show)

data Stream inp s p
  = Cons (OffsideSymbol s) (OffsideInput inp s p)
  | End inp

data IndentContext
  = Cxt     Bool                -- properties: allows nesting on equal indentation (triggered by Trigger_IndentGE)
            Int                 -- indentation

data OffsideInput inp s p
  = Off p                                   -- position
        (Stream inp s p)                    -- input stream
        (Maybe (OffsideInput inp s p))      -- next in stack of nested OffsideInput's

-- | plainly lift tokens to offside tokens
-- scanLiftTokensToOffside :: (InputState i s p) => [i] -> OffsideInput i s p -> OffsideInput i s p
scanLiftTokensToOffside ts rest
  = lift ts
  where cons p s r =  Off p (Cons (Symbol s) r) Nothing
        lift tss = case splitStateE tss of
                     Left' t ts -> cons (getPosition tss) t (lift ts)
                     _          -> rest

-- | convert tokens to offside tokens, dealing with Haskell's layout rule
scanOffside :: (InputState i s p, Position p, Eq s)
            =>  s ->  s -> s -> [s] -> i -> OffsideInput i s p
scanOffside mod open close triggers ts
  = scanOffsideWithTriggers mod open close (zip (repeat Trigger_IndentGT) triggers) ts

scanOffsideWithTriggers :: forall i s p. (InputState i s p, Position p, Eq s)
            =>  s ->  s -> s -> [(OffsideTrigger,s)] -> i -> OffsideInput i s p
scanOffsideWithTriggers mod open close triggers ts = start ts []
 where
 isModule    t = t == mod
 isOpen      t = t == open
 isClose     t = t == close
 isTrigger tr  = \t -> t `elem` triggers'
               where triggers' = [ s | (tr',s) <- triggers, tr == tr' ]
 isTriggerGT   = isTrigger Trigger_IndentGT
 isTriggerGE   = isTrigger Trigger_IndentGE
 end ts    = Off (getPosition ts) (End ts)
 cons :: p -> OffsideSymbol s -> OffsideInput i s p -> OffsideInput i s p
 cons p s r =  Off p (Cons s r) Nothing
 start = case splitStateE ts of
          Left' t _ | not (isModule t || isOpen t) -> implicitL 0 (Cxt False (column (getPosition ts)))
          _                                        -> layoutL   0

 -- L (<n>:ts) (m:ms)   = ; : (L ts (m:ms))     if m = n 
 --                     = } : (L (<n>:ts) ms)   if n < m 
 -- L (<n>:ts) ms       = L ts ms 
 startlnL  l n ts (m:ms) | m == n    = cons (getPosition ts) SemiColon  (layoutL (line (getPosition ts)) ts (m:ms))
                         | n <  m    = cons (getPosition ts) CloseBrace (startlnL l n ts ms)
 startlnL  l n ts ms                 = layoutL (line (getPosition ts))  ts ms

 -- L  ({n}:ts)  (m:ms) = { : (L  ts (n:m:ms))     if n >  m    (Note  1) 
 -- L  ({n}:ts)  (m:ms) = { : (L  ts (n:m:ms))     if n >= m    (as per Haskell2010, inside a do only) 
 -- L  ({n}:ts)  []     = { : (L  ts [n])          if n >  0    (Note  1) 
 -- L  ({n}:ts)  ms     = { : } : (L  (<n>:ts) ms) (Note  2) 
 implicitL l (Cxt ge n) ts (m:ms) |     n >  m
                                    || (n >= m && ge)
                                              = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts (n:m:ms))
 implicitL l (Cxt _  n) ts []     | n >  0    = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts [n])
 implicitL l (Cxt _  n) ts ms                 = cons (getPosition ts) OpenBrace (cons (getPosition ts) CloseBrace (startlnL l n ts ms))

 layoutL   ln  ts ms     | ln /= sln = startln (column pos) ts ms
                         | otherwise = sameln ts ms

  where sln       = line pos
        pos       = getPosition ts
        layout    = layoutL ln
        implicit  = implicitL ln
        startln   = startlnL ln
        -- If a let ,where ,do , or of keyword is not followed by the lexeme {,  
        -- the token {n} is inserted after the keyword, where nis the indentation of
        -- the  next lexeme if there is one, or 0 if the end of file has been reached. 
        aftertrigger isTriggerGE ts ms
          = case splitStateE ts of
              Left' t _  | isOpen t  -> layout ts ms
                         | otherwise -> implicit (Cxt isTriggerGE (column(getPosition ts))) ts ms
              Right' _               -> implicit (Cxt False       0                       ) ts ms


        -- L  ( }:ts)  (0:ms) = } : (L  ts ms)          (Note  3) 
        -- L  ( }:ts)  ms     = parse-error             (Note  3), matching of implicit/explicit braces is handled by parser
        -- L  ( {:ts)  ms     = {: (L  ts (0:ms))       (Note  4) 
        -- L  (t:ts)  (m:ms)  = }: (L  (t:ts)  ms)      if  m /= 0  and  parse-error(t) (Note  5) 
        -- L  (t:ts)  ms      = t : (L  ts ms) 
        sameln :: (InputState i s p, Position p, Eq s) => i -> [Int] -> OffsideInput i s p
        sameln tts ms
          = case splitStateE tts of
              Left'  t ts  ->
                        let tail
                              | isTriggerGE t = aftertrigger True  ts ms
                              | isTriggerGT t = aftertrigger False ts ms
                              | isClose     t = case ms of
                                                  0:rs -> layout ts rs
                                                  _    -> layout ts ms

                              | isOpen      t = layout ts (0:ms)
                              | otherwise     = layout ts ms
                            parseError = case ms of
                                           m:ms  | m /= 0 -> Just (layout tts ms)
                                           _              -> Nothing
                        in  Off pos (Cons (Symbol t) tail) parseError
              Right' rest -> endofinput pos rest ms
          where pos = getPosition tts

        -- L  []  []          = [] 
        -- L  []  (m:ms)      = } : L  []  ms           if m /=0   (Note  6) 
        --                    = L [] ms, if m == 0 (this is an error, the parser should yield a parse error, if this situation occurs)
        endofinput pos rest []                 = Off pos (End rest) Nothing
        endofinput pos rest (m:ms) | m /= 0    = cons pos CloseBrace (endofinput pos rest ms)
                                   | otherwise = endofinput pos rest ms


instance InputState inp s p => InputState (OffsideInput inp s p) (OffsideSymbol s) p where
  splitStateE inp@(Off p stream _)
    = case stream of
        Cons s rest -> Left' s rest
                    where take 0 _                    = []
                          take _ (Off _ (End _)    _) = []
                          take n (Off _ (Cons h t) _) = h : take (n-1) t
        _           -> Right' inp
  splitState (Off _ stream _)
    = case stream of
        Cons s rest -> (# s, rest #)

  getPosition (Off pos _ _ ) = pos

instance Symbol s => Symbol (OffsideSymbol s) where
  deleteCost s = case s of
                  Symbol s   -> deleteCost s
                  SemiColon  -> 5#
                  OpenBrace  -> 5#
                  CloseBrace -> 5#
  symBefore s = case s of
                 Symbol s   -> Symbol (symBefore s)
                 SemiColon  -> error "Symbol.symBefore SemiColon"
                 OpenBrace  -> error "Symbol.symBefore OpenBrace"
                 CloseBrace -> error "Symbol.symBefore CloseBrace"
  symAfter s = case s of
                 Symbol s   -> Symbol (symAfter s)
                 SemiColon  -> error "Symbol.symAfter SemiColon"
                 OpenBrace  -> error "Symbol.symAfter OpenBrace"
                 CloseBrace -> error "Symbol.symAfter CloseBrace"

newtype OffsideParser i o s p a  = OP (AnaParser (OffsideInput i s p) o (OffsideSymbol s) p a)

instance  (Symbol s, Ord s, InputState i s p, OutputState o) => IsParser (OffsideParser i o s p) s where
  {-
  (<*>:) = operator  (<*>:)
  (<*: ) = operator  (<*: )
  ( *>:) = operator  ( *>:)
  (<|>:) = operator  (<|>:)
  (<$>:) = operatorr (<$>:)
  (<$: ) = operatorr (<$ )
  pSucceed = OP . pSucceed
  pFail    = OP pFail
  -}
  pLow     = OP . pLow
  pCostRange c s (Range l r) = OP (getSymbol <$> pCostRange c (Symbol s) (Range (Symbol l)(Symbol r)))
  pCostSym   c s t           = OP (getSymbol <$> pCostSym c (Symbol s) (Symbol t))
  pSym   s                   = OP (getSymbol <$> pSym (Symbol s))
  pRange s (Range l r)       = OP (getSymbol <$> pRange (Symbol s) (Range (Symbol l)(Symbol r)))
  getfirsts  (OP p)          = removeSymbol (getfirsts p)
  setfirsts  exp (OP p)      = OP (setfirsts (addSymbol exp) p)
  getzerop  (OP p)           = fmap OP (getzerop p)
  getonep   (OP p)           = fmap OP (getonep p)

instance (Symbol s, Ord s, InputState i s p, OutputState o) => Applicative (OffsideParser i o s p) where
  (<*>) = operator  (<*>)
  {-# INLINE (<*>) #-}
  (<* ) = operator  (<* )
  {-# INLINE (<*) #-}
  ( *>) = operator  ( *>)
  {-# INLINE (*>) #-}
  pure      = OP . pure
  {-# INLINE pure #-}

instance (Symbol s, Ord s, InputState i s p, OutputState o) => Alternative (OffsideParser i o s p) where
  (<|>) = operator  (<|>)
  {-# INLINE (<|>) #-}
  empty = OP pFail
  {-# INLINE empty #-}

instance (Symbol s, Ord s, InputState i s p, OutputState o, Applicative (OffsideParser i o s p)) => Functor (OffsideParser i o s p) where
  fmap = operatorr fmap
  {-# INLINE fmap #-}
  (<$) = operatorr (<$)
  {-# INLINE (<$) #-}

removeSymbol exp = case exp of
        ESym (Range (Symbol l) (Symbol r)) -> ESym (Range l r)
        ESym _                             -> EOr []
        EStr txt                           -> EStr txt
        EOr  exps                          -> EOr  (map removeSymbol exps)
        ESeq exps                          -> ESeq (map removeSymbol exps)

addSymbol exp = case exp of
        ESym (Range l r) -> ESym (Range (Symbol l) (Symbol r))
        EStr txt         -> EStr txt
        EOr  exps        -> EOr  (map addSymbol exps)
        ESeq exps        -> ESeq (map addSymbol exps)

getSymbol (Symbol s) = s

operator  f (OP p) (OP q) = OP (f p q)
operatorr f g (OP p) = OP (f g p)

pSeparator :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s)
           => OffsideParser i o s p ()
pSeparator = OP (() <$ pCostSym 5# SemiColon SemiColon)

pClose, pOpen :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s)
           => OffsideParser i o s p ()


pClose = OP (pWrap f g ( () <$ pSym CloseBrace) )
  where g state steps1 k = (state,ar,k)
          where ar = case state of
                               Off _ _ (Just state')
                                 -> let steps2 = k state'
                                    in if not (hasSuccess steps1) && hasSuccess steps2
                                       then Cost 1# steps2
                                       else steps1
                               _ -> steps1

        f acc state steps k = let (stl,ar,str2rr) = g state (val snd steps)  k
                              in (stl ,val (acc ()) ar , str2rr )

pOpen  = OP (() <$ pSym OpenBrace)

pOffside :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s)
         => OffsideParser i o s p x
         -> OffsideParser i o s p y
         -> OffsideParser i o s p a
         -> OffsideParser i o s p a
         -> OffsideParser i o s p a
pOffside open close bodyE bodyI =
       open *> bodyE <* close
   <|> pOpen *> bodyI <* pClose

pBlock :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s)
       => OffsideParser i o s p x
       -> OffsideParser i o s p y
       -> OffsideParser i o s p z
       -> OffsideParser i o s p a
       -> OffsideParser i o s p [a]
pBlock open sep close p =  pOffside open close explicit implicit
 where elem = (Just <$> p) `opt` Nothing
       sep' = () <$ sep
       elems s = (\h t -> catMaybes (h:t)) <$> elem <*> pList (s *> elem)
       explicit = elems sep'
       implicit = elems (sep' <|> pSeparator)
{-
 where elem = (:) <$> p `opt` id
       sep' = () <$ sep        
       elems s = ($[]) <$> pFoldr1Sep ((.),id) s elem
       explicit = elems sep'
       implicit = elems (sep' <|> pSeparator)
-}

pBlock1 :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s)
       => OffsideParser i o s p x
       -> OffsideParser i o s p y
       -> OffsideParser i o s p z
       -> OffsideParser i o s p a
       -> OffsideParser i o s p [a]
pBlock1 open sep close p =  pOffside open close explicit implicit
 where elem = (Just <$> p) `opt` Nothing
       sep' = () <$ sep
       elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList (s *> elem)
       explicit = elems sep'
       implicit = elems (sep' <|> pSeparator)
{-
 where elem = (Just <$> p) `opt` Nothing
       sep' = () <$ sep
       elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList ( s *> elem)
       explicit = elems sep'
       implicit = elems (sep' <|> pSeparator)
-}
{-
pBlock1 open sep close p =  pOffside open close explicit implicit
 where elem = (Just <$> p) <|> pSucceed Nothing
       sep' = () <$ sep
       elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList ( s *> elem)
       explicit = elems sep'
       implicit = elems (sep' <|> pSeparator)
-}
{-
pBlock1 open sep close p =  pOffside open close explicit implicit
 where elem = (:) <$> p `opt` id
       sep' = () <$ sep
       elems s = (:) <$ pList s <*> p <*> (($[]) <$> pFoldr1Sep ((.),id) s elem)
       explicit = elems sep'
       implicit = elems (sep' <|> pSeparator)
-}
{-
pBlock1 open sep close p =  pOffside open close explicit implicit
 where sep'    = () <$ sep
       elems s = pList s *> pList1Sep (pList1 s) p <* pList s
       explicit = elems sep'
       implicit = elems (sep' <|> pSeparator)
-}

parseOffside :: (Symbol s, InputState i s p, Position p)
             => OffsideParser i Pair s p a
             -> OffsideInput i s p
             -> Steps (a, OffsideInput i s p) (OffsideSymbol s) p
parseOffside (OP p) inp = val fromPair (parse p inp)
  where fromPair (Pair x (Pair y _)) = (x,y)