{-# 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 (..), 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
  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) -> PWarning)
-> [(LexWarningType, NonEmpty Position)] -> [PWarning]
forall a b. (a -> b) -> [a] -> [b]
map ((LexWarningType -> NonEmpty Position -> PWarning)
-> (LexWarningType, NonEmpty Position) -> PWarning
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LexWarningType -> NonEmpty Position -> 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
forall a. Semigroup a => a -> a -> a
(<>)
    ([(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 -> PWarning
toWarning LexWarningType
LexWarningBOM NonEmpty Position
poss =
      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 =
      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 =
      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)

{- 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} ()