content: {-# LANGUAGE CPP #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Distribution.Parsec.LexerMonad
  -- License     :  BSD3
  --
  -- Maintainer  :  cabal-devel@haskell.org
  -- Portability :  portable
  module Distribution.Parsec.LexerMonad (
      InputStream,
      LexState(..),
      LexResult(..),
  
      Lex(..),
      execLexer,
  
      getPos,
      setPos,
      adjustPos,
  
      getInput,
      setInput,
  
      getStartCode,
      setStartCode,
  
      LexWarning(..),
      LexWarningType(..),
      addWarning,
      toPWarning,
  
    ) where
  
  import           Prelude ()
  import           Distribution.Compat.Prelude
  import qualified Data.ByteString                  as B
  import           Distribution.Parsec.Types.Common
                   (PWarnType (..), PWarning (..), Position (..))
  
  #ifdef CABAL_PARSEC_DEBUG
  -- testing only:
  import qualified Data.Text                        as T
  import qualified Data.Text.Encoding               as T
  import qualified Data.Vector                      as V
  #endif
  
  -- simple state monad
  newtype Lex a = Lex { unLex :: LexState -> LexResult a }
  
  instance Functor Lex where
    fmap = liftM
  
  instance Applicative Lex where
    pure = returnLex
    (<*>) = ap
  
  instance Monad Lex where
    return = pure
    (>>=)  = thenLex
  
  data LexResult a = LexResult {-# UNPACK #-} !LexState a
  
  data LexWarningType
      = LexWarningNBSP  -- ^ Encountered non breaking space
      | LexWarningBOM   -- ^ BOM at the start of the cabal file
    deriving (Show)
  
  data LexWarning = LexWarning                !LexWarningType
                               {-# UNPACK #-} !Position
                                              !String
    deriving (Show)
  
  toPWarning :: LexWarning -> PWarning
  toPWarning (LexWarning t p s) = PWarning t' p s
    where
      t' = case t of
          LexWarningNBSP -> PWTLexNBSP
          LexWarningBOM  -> PWTLexBOM
  
  data LexState = LexState {
          curPos   :: {-# UNPACK #-} !Position,        -- ^ position at current input location
          curInput :: {-# UNPACK #-} !InputStream,     -- ^ the current input
          curCode  :: {-# UNPACK #-} !StartCode,       -- ^ lexer code
          warnings :: [LexWarning]
  #ifdef CABAL_PARSEC_DEBUG
          , dbgText  :: V.Vector T.Text                -- ^ input lines, to print pretty debug info
  #endif
       } --TODO: check if we should cache the first token
         -- since it looks like parsec's uncons can be called many times on the same input
  
  type StartCode   = Int    -- ^ An @alex@ lexer start code
  type InputStream = B.ByteString
  
  
  
  -- | Execute the given lexer on the supplied input stream.
  execLexer :: Lex a -> InputStream -> ([LexWarning], a)
  execLexer (Lex lexer) input =
      case lexer initialState of
        LexResult LexState{ warnings = ws } result -> (ws, result)
    where
      initialState = LexState
        -- TODO: add 'startPosition'
        { curPos   = Position 1 1
        , curInput = input
        , curCode  = 0
        , warnings = []
  #ifdef CABAL_PARSEC_DEBUG
        , dbgText  = V.fromList . T.lines . T.decodeUtf8 $ input
  #endif
        }
  
  {-# INLINE returnLex #-}
  returnLex :: a -> Lex a
  returnLex a = Lex $ \s -> LexResult s a
  
  {-# INLINE thenLex #-}
  thenLex :: Lex a -> (a -> Lex b) -> Lex b
  (Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s'
  
  setPos :: Position -> Lex ()
  setPos pos = Lex $ \s -> LexResult s{ curPos = pos } ()
  
  getPos :: Lex Position
  getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos
  
  adjustPos :: (Position -> Position) -> Lex ()
  adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } ()
  
  getInput :: Lex InputStream
  getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i
  
  setInput :: InputStream -> Lex ()
  setInput i = Lex $ \s -> LexResult s{ curInput = i } ()
  
  getStartCode :: Lex Int
  getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c
  
  setStartCode :: Int -> Lex ()
  setStartCode c = Lex $ \s -> LexResult s{ curCode = c } ()
  
  -- | Add warning at the current position
  addWarning :: LexWarningType -> String -> Lex ()
  addWarning wt msg = Lex $ \s@LexState{ curPos = pos, warnings = ws  } ->
      LexResult s{ warnings = LexWarning wt pos msg : ws } ()
  