{-# LANGUAGE CPP #-}
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
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
#endif
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
=
LexWarningNBSP
|
LexWarningBOM
|
LexWarningTab
|
LexInconsistentIndentation
|
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
(<>))
([(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)
toWarning LexWarningType
LexBraces NonEmpty Position
_ =
Maybe PWarning
forall a. Maybe a
Nothing
data LexState = LexState
{ LexState -> Position
curPos :: {-# UNPACK #-} !Position
, LexState -> InputStream
curInput :: {-# UNPACK #-} !InputStream
, LexState -> Int
curCode :: {-# UNPACK #-} !StartCode
, LexState -> [LexWarning]
warnings :: [LexWarning]
#ifdef CABAL_PARSEC_DEBUG
, dbgText :: V.Vector T.Text
#endif
}
type StartCode =
Int
type InputStream = B.ByteString
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
{
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 = (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} ()
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} ()
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} ()