    {-# LANGUAGE CPP #-}

    -----------------------------------------------------------------------------

    -- |
    -- Module      :  Distribution.Fields.LexerMonad
    -- License     :  BSD3
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    module Distribution.Fields.LexerMonad
      ( InputStream
      , LexState (..)
      , LexResult (..)
      , Lex (..)
      , execLexer
      , getPos
      , setPos
      , adjustPos
      , getInput
      , setInput
      , getStartCode
      , setStartCode
      , LexWarning (..)
      , LexWarningType (..)
      , addWarning
      , addWarningAt
      , toPWarnings
      ) where

    import qualified Data.ByteString as B
    import qualified Data.List.NonEmpty as NE
    import Distribution.Compat.Prelude
    import Distribution.Parsec.Position (Position (..), positionRow, showPos)
    import Distribution.Parsec.Warning (PWarnType (..), PWarning (..))
    import Prelude ()

    import qualified Data.Map.Strict as Map

    #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 {forall a. Lex a -> LexState -> LexResult a
    unLex :: LexState -> LexResult a}

    instance Functor Lex where
      fmap :: forall a b. (a -> b) -> Lex a -> Lex b
    fmap = (a -> b) -> Lex a -> Lex b
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM

    instance Applicative Lex where
      pure :: forall a. a -> Lex a
    pure = a -> Lex a
    forall a. a -> Lex a
    returnLex
      <*> :: forall a b. Lex (a -> b) -> Lex a -> Lex b
    (<*>) = Lex (a -> b) -> Lex a -> Lex b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad Lex where
      return :: forall a. a -> Lex a
    return = a -> Lex a
    forall a. a -> Lex a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure
      >>= :: forall a b. Lex a -> (a -> Lex b) -> Lex b
    (>>=) = Lex a -> (a -> Lex b) -> Lex b
    forall a b. Lex a -> (a -> Lex b) -> Lex b
    thenLex

    data LexResult a = LexResult {-# UNPACK #-} !LexState a

    data LexWarningType
      = -- | Encountered non breaking space
        LexWarningNBSP
      | -- | BOM at the start of the cabal file
        LexWarningBOM
      | -- | Leading tags
        LexWarningTab
      | -- | indentation decreases
        LexInconsistentIndentation
      | -- | Brace syntax used
        LexBraces
      deriving (LexWarningType -> LexWarningType -> Bool
    (LexWarningType -> LexWarningType -> Bool)
    -> (LexWarningType -> LexWarningType -> Bool) -> Eq LexWarningType
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: LexWarningType -> LexWarningType -> Bool
    == :: LexWarningType -> LexWarningType -> Bool
    $c/= :: LexWarningType -> LexWarningType -> Bool
    /= :: LexWarningType -> LexWarningType -> Bool
    Eq, Eq LexWarningType
    Eq LexWarningType =>
    (LexWarningType -> LexWarningType -> Ordering)
    -> (LexWarningType -> LexWarningType -> Bool)
    -> (LexWarningType -> LexWarningType -> Bool)
    -> (LexWarningType -> LexWarningType -> Bool)
    -> (LexWarningType -> LexWarningType -> Bool)
    -> (LexWarningType -> LexWarningType -> LexWarningType)
    -> (LexWarningType -> LexWarningType -> LexWarningType)
    -> Ord LexWarningType
    LexWarningType -> LexWarningType -> Bool
    LexWarningType -> LexWarningType -> Ordering
    LexWarningType -> LexWarningType -> LexWarningType
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: LexWarningType -> LexWarningType -> Ordering
    compare :: LexWarningType -> LexWarningType -> Ordering
    $c< :: LexWarningType -> LexWarningType -> Bool
    < :: LexWarningType -> LexWarningType -> Bool
    $c<= :: LexWarningType -> LexWarningType -> Bool
    <= :: LexWarningType -> LexWarningType -> Bool
    $c> :: LexWarningType -> LexWarningType -> Bool
    > :: LexWarningType -> LexWarningType -> Bool
    $c>= :: LexWarningType -> LexWarningType -> Bool
    >= :: LexWarningType -> LexWarningType -> Bool
    $cmax :: LexWarningType -> LexWarningType -> LexWarningType
    max :: LexWarningType -> LexWarningType -> LexWarningType
    $cmin :: LexWarningType -> LexWarningType -> LexWarningType
    min :: LexWarningType -> LexWarningType -> LexWarningType
    Ord, Int -> LexWarningType -> ShowS
    [LexWarningType] -> ShowS
    LexWarningType -> String
    (Int -> LexWarningType -> ShowS)
    -> (LexWarningType -> String)
    -> ([LexWarningType] -> ShowS)
    -> Show LexWarningType
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> LexWarningType -> ShowS
    showsPrec :: Int -> LexWarningType -> ShowS
    $cshow :: LexWarningType -> String
    show :: LexWarningType -> String
    $cshowList :: [LexWarningType] -> ShowS
    showList :: [LexWarningType] -> ShowS
    Show)

    data LexWarning
      = LexWarning
          !LexWarningType
          {-# UNPACK #-} !Position
      deriving (Int -> LexWarning -> ShowS
    [LexWarning] -> ShowS
    LexWarning -> String
    (Int -> LexWarning -> ShowS)
    -> (LexWarning -> String)
    -> ([LexWarning] -> ShowS)
    -> Show LexWarning
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> LexWarning -> ShowS
    showsPrec :: Int -> LexWarning -> ShowS
    $cshow :: LexWarning -> String
    show :: LexWarning -> String
    $cshowList :: [LexWarning] -> ShowS
    showList :: [LexWarning] -> ShowS
    Show)

    toPWarnings :: [LexWarning] -> [PWarning]
    toPWarnings :: [LexWarning] -> [PWarning]
    toPWarnings =
      ((LexWarningType, NonEmpty Position) -> Maybe PWarning)
    -> [(LexWarningType, NonEmpty Position)] -> [PWarning]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe ((LexWarningType -> NonEmpty Position -> Maybe PWarning)
    -> (LexWarningType, NonEmpty Position) -> Maybe PWarning
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry LexWarningType -> NonEmpty Position -> Maybe PWarning
    toWarning)
        ([(LexWarningType, NonEmpty Position)] -> [PWarning])
    -> ([LexWarning] -> [(LexWarningType, NonEmpty Position)])
    -> [LexWarning]
    -> [PWarning]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Map LexWarningType (NonEmpty Position)
    -> [(LexWarningType, NonEmpty Position)]
    forall k a. Map k a -> [(k, a)]
    Map.toList
        (Map LexWarningType (NonEmpty Position)
     -> [(LexWarningType, NonEmpty Position)])
    -> ([LexWarning] -> Map LexWarningType (NonEmpty Position))
    -> [LexWarning]
    -> [(LexWarningType, NonEmpty Position)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (NonEmpty Position -> NonEmpty Position -> NonEmpty Position)
    -> [(LexWarningType, NonEmpty Position)]
    -> Map LexWarningType (NonEmpty Position)
    forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
    Map.fromListWith ((NonEmpty Position -> NonEmpty Position -> NonEmpty Position)
    -> NonEmpty Position -> NonEmpty Position -> NonEmpty Position
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip NonEmpty Position -> NonEmpty Position -> NonEmpty Position
    forall a. Semigroup a => a -> a -> a
    (<>)) -- fromListWith gives existing element first.
        ([(LexWarningType, NonEmpty Position)]
     -> Map LexWarningType (NonEmpty Position))
    -> ([LexWarning] -> [(LexWarningType, NonEmpty Position)])
    -> [LexWarning]
    -> Map LexWarningType (NonEmpty Position)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (LexWarning -> (LexWarningType, NonEmpty Position))
    -> [LexWarning] -> [(LexWarningType, NonEmpty Position)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(LexWarning LexWarningType
    t Position
    p) -> (LexWarningType
    t, Position -> NonEmpty Position
    forall a. a -> NonEmpty a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Position
    p))
      where
        toWarning :: LexWarningType -> NonEmpty Position -> Maybe PWarning
    toWarning LexWarningType
    LexWarningBOM NonEmpty Position
    poss =
          PWarning -> Maybe PWarning
    forall a. a -> Maybe a
    Just (PWarning -> Maybe PWarning) -> PWarning -> Maybe PWarning
    forall a b. (a -> b) -> a -> b
    $ PWarnType -> Position -> String -> PWarning
    PWarning PWarnType
    PWTLexBOM (NonEmpty Position -> Position
    forall a. NonEmpty a -> a
    NE.head NonEmpty Position
    poss) String
    "Byte-order mark found at the beginning of the file"
        toWarning LexWarningType
    LexWarningNBSP NonEmpty Position
    poss =
          PWarning -> Maybe PWarning
    forall a. a -> Maybe a
    Just (PWarning -> Maybe PWarning) -> PWarning -> Maybe PWarning
    forall a b. (a -> b) -> a -> b
    $ PWarnType -> Position -> String -> PWarning
    PWarning PWarnType
    PWTLexNBSP (NonEmpty Position -> Position
    forall a. NonEmpty a -> a
    NE.head NonEmpty Position
    poss) (String -> PWarning) -> String -> PWarning
    forall a b. (a -> b) -> a -> b
    $ String
    "Non breaking spaces at " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ", " (NonEmpty String -> [String]
    forall a. NonEmpty a -> [a]
    NE.toList (NonEmpty String -> [String]) -> NonEmpty String -> [String]
    forall a b. (a -> b) -> a -> b
    $ (Position -> String) -> NonEmpty Position -> NonEmpty String
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Position -> String
    showPos NonEmpty Position
    poss)
        toWarning LexWarningType
    LexWarningTab NonEmpty Position
    poss =
          PWarning -> Maybe PWarning
    forall a. a -> Maybe a
    Just (PWarning -> Maybe PWarning) -> PWarning -> Maybe PWarning
    forall a b. (a -> b) -> a -> b
    $ PWarnType -> Position -> String -> PWarning
    PWarning PWarnType
    PWTLexTab (NonEmpty Position -> Position
    forall a. NonEmpty a -> a
    NE.head NonEmpty Position
    poss) (String -> PWarning) -> String -> PWarning
    forall a b. (a -> b) -> a -> b
    $ String
    "Tabs used as indentation at " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ", " (NonEmpty String -> [String]
    forall a. NonEmpty a -> [a]
    NE.toList (NonEmpty String -> [String]) -> NonEmpty String -> [String]
    forall a b. (a -> b) -> a -> b
    $ (Position -> String) -> NonEmpty Position -> NonEmpty String
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Position -> String
    showPos NonEmpty Position
    poss)
        toWarning LexWarningType
    LexInconsistentIndentation NonEmpty Position
    poss =
          PWarning -> Maybe PWarning
    forall a. a -> Maybe a
    Just (PWarning -> Maybe PWarning) -> PWarning -> Maybe PWarning
    forall a b. (a -> b) -> a -> b
    $ PWarnType -> Position -> String -> PWarning
    PWarning PWarnType
    PWTInconsistentIndentation (NonEmpty Position -> Position
    forall a. NonEmpty a -> a
    NE.head NonEmpty Position
    poss) (String -> PWarning) -> String -> PWarning
    forall a b. (a -> b) -> a -> b
    $ String
    "Inconsistent indentation. Indentation jumps at lines " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ", " (NonEmpty String -> [String]
    forall a. NonEmpty a -> [a]
    NE.toList (NonEmpty String -> [String]) -> NonEmpty String -> [String]
    forall a b. (a -> b) -> a -> b
    $ (Position -> String) -> NonEmpty Position -> NonEmpty String
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Int -> String
    forall a. Show a => a -> String
    show (Int -> String) -> (Position -> Int) -> Position -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Position -> Int
    positionRow) NonEmpty Position
    poss)
        -- LexBraces warning about using { } delimeters is not reported as parser warning.
        toWarning LexWarningType
    LexBraces NonEmpty Position
    _ =
          Maybe PWarning
    forall a. Maybe a
    Nothing

    {- FOURMOLU_DISABLE -}
    data LexState = LexState
      { LexState -> Position
    curPos :: {-# UNPACK #-} !Position
      -- ^ position at current input location
      , LexState -> InputStream
    curInput :: {-# UNPACK #-} !InputStream
      -- ^ the current input
      , LexState -> Int
    curCode :: {-# UNPACK #-} !StartCode
      -- ^ lexer code
      , LexState -> [LexWarning]
    warnings :: [LexWarning]
    #ifdef CABAL_PARSEC_DEBUG
      ,  dbgText :: V.Vector T.Text
      -- ^ input lines, to print pretty debug info
    #endif
      }
    {- FOURMOLU_ENABLE -}

    -- 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.
    {- FOURMOLU_DISABLE -}
    execLexer :: Lex a -> InputStream -> ([LexWarning], a)
    execLexer :: forall a. Lex a -> InputStream -> ([LexWarning], a)
    execLexer (Lex LexState -> LexResult a
    lexer) InputStream
    input =
      case LexState -> LexResult a
    lexer LexState
    initialState of
        LexResult LexState{warnings :: LexState -> [LexWarning]
    warnings = [LexWarning]
    ws} a
    result -> ([LexWarning]
    ws, a
    result)
      where
        initialState :: LexState
    initialState =
          LexState
            { -- TODO: add 'startPosition'
              curPos :: Position
    curPos = Int -> Int -> Position
    Position Int
    1 Int
    1
            , curInput :: InputStream
    curInput = InputStream
    input
            , curCode :: Int
    curCode = Int
    0
            , warnings :: [LexWarning]
    warnings = []
    #ifdef CABAL_PARSEC_DEBUG
            ,  dbgText = V.fromList . T.lines . T.decodeUtf8 $ input
    #endif
            }
    {- FOURMOLU_ENABLE -}

    {-# INLINE returnLex #-}
    returnLex :: a -> Lex a
    returnLex :: forall a. a -> Lex a
    returnLex a
    a = (LexState -> LexResult a) -> Lex a
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult a) -> Lex a)
    -> (LexState -> LexResult a) -> Lex a
    forall a b. (a -> b) -> a -> b
    $ \LexState
    s -> LexState -> a -> LexResult a
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s a
    a

    {-# INLINE thenLex #-}
    thenLex :: Lex a -> (a -> Lex b) -> Lex b
    (Lex LexState -> LexResult a
    m) thenLex :: forall a b. Lex a -> (a -> Lex b) -> Lex b
    `thenLex` a -> Lex b
    k = (LexState -> LexResult b) -> Lex b
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult b) -> Lex b)
    -> (LexState -> LexResult b) -> Lex b
    forall a b. (a -> b) -> a -> b
    $ \LexState
    s -> case LexState -> LexResult a
    m LexState
    s of LexResult LexState
    s' a
    a -> (Lex b -> LexState -> LexResult b
    forall a. Lex a -> LexState -> LexResult a
    unLex (a -> Lex b
    k a
    a)) LexState
    s'

    setPos :: Position -> Lex ()
    setPos :: Position -> Lex ()
    setPos Position
    pos = (LexState -> LexResult ()) -> Lex ()
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult ()) -> Lex ())
    -> (LexState -> LexResult ()) -> Lex ()
    forall a b. (a -> b) -> a -> b
    $ \LexState
    s -> LexState -> () -> LexResult ()
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s{curPos = pos} ()

    getPos :: Lex Position
    getPos :: Lex Position
    getPos = (LexState -> LexResult Position) -> Lex Position
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult Position) -> Lex Position)
    -> (LexState -> LexResult Position) -> Lex Position
    forall a b. (a -> b) -> a -> b
    $ \s :: LexState
    s@LexState{curPos :: LexState -> Position
    curPos = Position
    pos} -> LexState -> Position -> LexResult Position
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s Position
    pos

    adjustPos :: (Position -> Position) -> Lex ()
    adjustPos :: (Position -> Position) -> Lex ()
    adjustPos Position -> Position
    f = (LexState -> LexResult ()) -> Lex ()
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult ()) -> Lex ())
    -> (LexState -> LexResult ()) -> Lex ()
    forall a b. (a -> b) -> a -> b
    $ \s :: LexState
    s@LexState{curPos :: LexState -> Position
    curPos = Position
    pos} -> LexState -> () -> LexResult ()
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s{curPos = f pos} ()

    getInput :: Lex InputStream
    getInput :: Lex InputStream
    getInput = (LexState -> LexResult InputStream) -> Lex InputStream
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult InputStream) -> Lex InputStream)
    -> (LexState -> LexResult InputStream) -> Lex InputStream
    forall a b. (a -> b) -> a -> b
    $ \s :: LexState
    s@LexState{curInput :: LexState -> InputStream
    curInput = InputStream
    i} -> LexState -> InputStream -> LexResult InputStream
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s InputStream
    i

    setInput :: InputStream -> Lex ()
    setInput :: InputStream -> Lex ()
    setInput InputStream
    i = (LexState -> LexResult ()) -> Lex ()
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult ()) -> Lex ())
    -> (LexState -> LexResult ()) -> Lex ()
    forall a b. (a -> b) -> a -> b
    $ \LexState
    s -> LexState -> () -> LexResult ()
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s{curInput = i} ()

    getStartCode :: Lex Int
    getStartCode :: Lex Int
    getStartCode = (LexState -> LexResult Int) -> Lex Int
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult Int) -> Lex Int)
    -> (LexState -> LexResult Int) -> Lex Int
    forall a b. (a -> b) -> a -> b
    $ \s :: LexState
    s@LexState{curCode :: LexState -> Int
    curCode = Int
    c} -> LexState -> Int -> LexResult Int
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s Int
    c

    setStartCode :: Int -> Lex ()
    setStartCode :: Int -> Lex ()
    setStartCode Int
    c = (LexState -> LexResult ()) -> Lex ()
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult ()) -> Lex ())
    -> (LexState -> LexResult ()) -> Lex ()
    forall a b. (a -> b) -> a -> b
    $ \LexState
    s -> LexState -> () -> LexResult ()
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s{curCode = c} ()

    -- | Add warning at the current position
    addWarning :: LexWarningType -> Lex ()
    addWarning :: LexWarningType -> Lex ()
    addWarning LexWarningType
    wt = (LexState -> LexResult ()) -> Lex ()
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult ()) -> Lex ())
    -> (LexState -> LexResult ()) -> Lex ()
    forall a b. (a -> b) -> a -> b
    $ \s :: LexState
    s@LexState{curPos :: LexState -> Position
    curPos = Position
    pos, warnings :: LexState -> [LexWarning]
    warnings = [LexWarning]
    ws} ->
      LexState -> () -> LexResult ()
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s{warnings = LexWarning wt pos : ws} ()

    -- | Add warning at specific position
    addWarningAt :: Position -> LexWarningType -> Lex ()
    addWarningAt :: Position -> LexWarningType -> Lex ()
    addWarningAt Position
    pos LexWarningType
    wt = (LexState -> LexResult ()) -> Lex ()
    forall a. (LexState -> LexResult a) -> Lex a
    Lex ((LexState -> LexResult ()) -> Lex ())
    -> (LexState -> LexResult ()) -> Lex ()
    forall a b. (a -> b) -> a -> b
    $ \s :: LexState
    s@LexState{warnings :: LexState -> [LexWarning]
    warnings = [LexWarning]
    ws} ->
      LexState -> () -> LexResult ()
    forall a. LexState -> a -> LexResult a
    LexResult LexState
    s{warnings = LexWarning wt pos : ws} ()