{-# 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,
    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 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative Lex where
  pure :: forall a. a -> Lex a
pure = forall a. a -> Lex a
returnLex
  <*> :: forall a 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >>= :: forall a 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
    = LexWarningNBSP  -- ^ Encountered non breaking space
    | LexWarningBOM   -- ^ BOM at the start of the cabal file
    | LexWarningTab   -- ^ Leading tags
  deriving (LexWarningType -> LexWarningType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LexWarningType -> LexWarningType -> Bool
$c/= :: LexWarningType -> LexWarningType -> Bool
== :: LexWarningType -> LexWarningType -> Bool
$c== :: LexWarningType -> LexWarningType -> Bool
Eq, Eq 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
min :: LexWarningType -> LexWarningType -> LexWarningType
$cmin :: LexWarningType -> LexWarningType -> LexWarningType
max :: LexWarningType -> LexWarningType -> LexWarningType
$cmax :: LexWarningType -> LexWarningType -> LexWarningType
>= :: LexWarningType -> LexWarningType -> Bool
$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
compare :: LexWarningType -> LexWarningType -> Ordering
$ccompare :: LexWarningType -> LexWarningType -> Ordering
Ord, Int -> LexWarningType -> ShowS
[LexWarningType] -> ShowS
LexWarningType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LexWarningType] -> ShowS
$cshowList :: [LexWarningType] -> ShowS
show :: LexWarningType -> String
$cshow :: LexWarningType -> String
showsPrec :: Int -> LexWarningType -> ShowS
$cshowsPrec :: Int -> LexWarningType -> ShowS
Show)

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

toPWarnings :: [LexWarning] -> [PWarning]
toPWarnings :: [LexWarning] -> [PWarning]
toPWarnings
    = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LexWarningType -> NonEmpty Position -> PWarning
toWarning)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(LexWarning LexWarningType
t Position
p) -> (LexWarningType
t, 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 (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 (forall a. NonEmpty a -> a
NE.head NonEmpty Position
poss) forall a b. (a -> b) -> a -> b
$ String
"Non breaking spaces at " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> 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 (forall a. NonEmpty a -> a
NE.head NonEmpty Position
poss) forall a b. (a -> b) -> a -> b
$ String
"Tabs used as indentation at " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Position -> String
showPos NonEmpty Position
poss)

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
     } --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 :: 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
      }

{-# INLINE returnLex #-}
returnLex :: a -> Lex a
returnLex :: forall a. a -> Lex a
returnLex a
a = forall a. (LexState -> LexResult a) -> Lex a
Lex forall a b. (a -> b) -> a -> b
$ \LexState
s -> 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 = forall a. (LexState -> LexResult a) -> Lex a
Lex forall a b. (a -> b) -> a -> b
$ \LexState
s -> case LexState -> LexResult a
m LexState
s of LexResult LexState
s' a
a -> (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 = forall a. (LexState -> LexResult a) -> Lex a
Lex forall a b. (a -> b) -> a -> b
$ \LexState
s -> forall a. LexState -> a -> LexResult a
LexResult LexState
s{ curPos :: Position
curPos = Position
pos } ()

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

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

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

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

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

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

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