{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving, StandaloneDeriving #-}

-- Implements "Indentation Senstivie Parsing" for Trifecta
module Text.Trifecta.Indentation (
  I.IndentationRel(..), I.Indentation, I.infIndentation, I.mkIndentationState,
  I.IndentationState,
  IndentationParsing(..),
  Token,
  IndentationParserT,
  runIndentationParserT,
  evalIndentationParserT,
  execIndentationParserT,
  ) where

import Control.Applicative
import Control.Monad.State.Lazy as LazyState
import Control.Monad.State.Strict as StrictState

import Text.Parser.Combinators (Parsing(..))
import Text.Parser.Token (TokenParsing(..))
import Text.Parser.Char (CharParsing(..))
import Text.Parser.LookAhead (LookAheadParsing(..))
import Text.Trifecta.Combinators (DeltaParsing(..), MarkParsing(..))
import Text.Trifecta.Delta (Delta, column)

import Text.Parser.Indentation.Implementation (IndentationState(..), IndentationRel(..), LocalState)
import qualified Text.Parser.Indentation.Implementation as I

--------------
-- User API --
--------------

class IndentationParsing m where
  localTokenMode :: (IndentationRel -> IndentationRel) -> m a -> m a
  localIndentation :: IndentationRel -> m a -> m a
  absoluteIndentation :: m a -> m a
  ignoreAbsoluteIndentation :: m a -> m a
  localAbsoluteIndentation :: m a -> m a
  localAbsoluteIndentation = ignoreAbsoluteIndentation . absoluteIndentation

----------------------
-- Lifted Instances --
----------------------

{- TODO:
Applicative
Functor
MonadWriter w m
MonadError e m
Monad m
MonadReader r m
MonadTrans (StateT s)	 
Monad m
Monad m
MonadFix m
MonadPlus m
MonadIO m
MonadCont m
#-}

{-# INLINE liftLazyStateT2 #-}
liftLazyStateT2 :: (m (a, s) -> m (a, s)) -> LazyState.StateT s m a -> LazyState.StateT s m a
liftLazyStateT2 f m = LazyState.StateT $ \s -> f (LazyState.runStateT m s)

instance (IndentationParsing i) => IndentationParsing (LazyState.StateT s i) where
  localTokenMode f = liftLazyStateT2 (localTokenMode f)
  localIndentation r = liftLazyStateT2 (localIndentation r)
  absoluteIndentation = liftLazyStateT2 absoluteIndentation
  ignoreAbsoluteIndentation = liftLazyStateT2 ignoreAbsoluteIndentation
  localAbsoluteIndentation = liftLazyStateT2 localAbsoluteIndentation

{-# INLINE liftStrictStateT2 #-}
liftStrictStateT2 :: (m (a, s) -> m (a, s)) -> StrictState.StateT s m a -> StrictState.StateT s m a
liftStrictStateT2 f m = StrictState.StateT $ \s -> f (StrictState.runStateT m s)

instance (IndentationParsing i) => IndentationParsing (StrictState.StateT s i) where
  localTokenMode f = liftStrictStateT2 (localTokenMode f)
  localIndentation r = liftStrictStateT2 (localIndentation r)
  absoluteIndentation = liftStrictStateT2 absoluteIndentation
  ignoreAbsoluteIndentation = liftStrictStateT2 ignoreAbsoluteIndentation
  localAbsoluteIndentation = liftStrictStateT2 localAbsoluteIndentation

---------------
-- Data Type --
---------------

-- TODO: do we need a strict version of this?
newtype IndentationParserT t m a = IndentationParserT { unIndentationParserT :: LazyState.StateT IndentationState m a }
  deriving (Functor, Applicative, Monad, MonadTrans, MonadPlus, Alternative)

deriving instance (Parsing m, MonadPlus m) => Parsing (IndentationParserT t m)
deriving instance (DeltaParsing m) => DeltaParsing (IndentationParserT Char m)
deriving instance (MarkParsing Delta m) => MarkParsing Delta (IndentationParserT Char m)
deriving instance (DeltaParsing m) => DeltaParsing (IndentationParserT Token m)
deriving instance (MarkParsing Delta m) => MarkParsing Delta (IndentationParserT Token m)

{-# INLINE runIndentationParserT #-}
runIndentationParserT :: IndentationParserT t m a -> IndentationState -> m (a, IndentationState)
runIndentationParserT (IndentationParserT m) = LazyState.runStateT m

{-# INLINE evalIndentationParserT #-}
evalIndentationParserT :: (Monad m) => IndentationParserT t m a -> IndentationState -> m a
evalIndentationParserT (IndentationParserT m) = LazyState.evalStateT m

{-# INLINE execIndentationParserT #-}
execIndentationParserT :: (Monad m) => IndentationParserT t m a -> IndentationState -> m IndentationState
execIndentationParserT (IndentationParserT m) = LazyState.execStateT m

---------------------
-- Class Instances --
---------------------

-- Putting the check in CharParsing --

instance (DeltaParsing m) => CharParsing (IndentationParserT Char m) where
  satisfy f = checkIndentation (satisfy f)

instance (DeltaParsing m) => TokenParsing (IndentationParserT Char m) where
  someSpace = IndentationParserT $ someSpace -- Ignore indentation of whitespace

-- Putting the check in TokenParsing --

data Token

instance (DeltaParsing m) => CharParsing (IndentationParserT Token m) where
  satisfy f = IndentationParserT $ satisfy f

instance (DeltaParsing m) => TokenParsing (IndentationParserT Token m) where
  token p = checkIndentation (token (unIndentationParserT p))

--------

instance (LookAheadParsing m, MonadPlus m) => LookAheadParsing (IndentationParserT t m) where
  lookAhead m = IndentationParserT $ do
    s <- get
    x <- lookAhead (unIndentationParserT m)
    put s
    return x

--------

instance (Monad m) => IndentationParsing (IndentationParserT t m) where
  {-# INLINE localTokenMode #-}
  localTokenMode = I.localTokenMode localState

  {-# INLINE localIndentation #-}
  localIndentation = I.localIndentation localStateUnlessAbsMode

  {-# INLINE absoluteIndentation #-}
  absoluteIndentation = I.absoluteIndentation localState

  {-# INLINE ignoreAbsoluteIndentation #-}
  ignoreAbsoluteIndentation = I.ignoreAbsoluteIndentation localState

  {-# INLINE localAbsoluteIndentation #-}
  localAbsoluteIndentation = I.localAbsoluteIndentation localState

---------------------
-- Private Helpers --
---------------------

{-# INLINE localState #-}
localState :: (Monad m) => LocalState (IndentationParserT t m a)
localState pre post m = IndentationParserT $ do
  is <- get
  put (pre is)
  x <- unIndentationParserT m
  is' <- get
  put (post is is')
  return x

{-# INLINE localStateUnlessAbsMode #-}
localStateUnlessAbsMode :: (Monad m) => LocalState (IndentationParserT t m a)
localStateUnlessAbsMode pre post m = IndentationParserT $ do
  a <- gets I.indentationStateAbsMode
  unIndentationParserT $ if a then m else localState pre post m

{-# INLINE checkIndentation #-}
checkIndentation :: (DeltaParsing m) => LazyState.StateT IndentationState m a -> IndentationParserT t m a
checkIndentation m = IndentationParserT $ do
    is <- get
    p <- position
    let ok is' = do x <- m; put is'; return x
        err msg = fail msg
    I.updateIndentation is (fromIntegral $ column p + 1) ok err