1{-# LANGUAGE CPP #-} 2----------------------------------------------------------------------------- 3-- | 4-- Module : Distribution.Fields.LexerMonad 5-- License : BSD3 6-- 7-- Maintainer : cabal-devel@haskell.org 8-- Portability : portable 9module Distribution.Fields.LexerMonad ( 10 InputStream, 11 LexState(..), 12 LexResult(..), 13 14 Lex(..), 15 execLexer, 16 17 getPos, 18 setPos, 19 adjustPos, 20 21 getInput, 22 setInput, 23 24 getStartCode, 25 setStartCode, 26 27 LexWarning(..), 28 LexWarningType(..), 29 addWarning, 30 toPWarnings, 31 32 ) where 33 34import qualified Data.ByteString as B 35import qualified Data.List.NonEmpty as NE 36import Distribution.Compat.Prelude 37import Distribution.Parsec.Position (Position (..), showPos) 38import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) 39import Prelude () 40 41import qualified Data.Map.Strict as Map 42 43#ifdef CABAL_PARSEC_DEBUG 44-- testing only: 45import qualified Data.Text as T 46import qualified Data.Text.Encoding as T 47import qualified Data.Vector as V 48#endif 49 50-- simple state monad 51newtype Lex a = Lex { unLex :: LexState -> LexResult a } 52 53instance Functor Lex where 54 fmap = liftM 55 56instance Applicative Lex where 57 pure = returnLex 58 (<*>) = ap 59 60instance Monad Lex where 61 return = pure 62 (>>=) = thenLex 63 64data LexResult a = LexResult {-# UNPACK #-} !LexState a 65 66data LexWarningType 67 = LexWarningNBSP -- ^ Encountered non breaking space 68 | LexWarningBOM -- ^ BOM at the start of the cabal file 69 | LexWarningTab -- ^ Leading tags 70 deriving (Eq, Ord, Show) 71 72data LexWarning = LexWarning !LexWarningType 73 {-# UNPACK #-} !Position 74 deriving (Show) 75 76toPWarnings :: [LexWarning] -> [PWarning] 77toPWarnings 78 = map (uncurry toWarning) 79 . Map.toList 80 . Map.fromListWith (<>) 81 . map (\(LexWarning t p) -> (t, pure p)) 82 where 83 toWarning LexWarningBOM poss = 84 PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" 85 toWarning LexWarningNBSP poss = 86 PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) 87 toWarning LexWarningTab poss = 88 PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) 89 90data LexState = LexState { 91 curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location 92 curInput :: {-# UNPACK #-} !InputStream, -- ^ the current input 93 curCode :: {-# UNPACK #-} !StartCode, -- ^ lexer code 94 warnings :: [LexWarning] 95#ifdef CABAL_PARSEC_DEBUG 96 , dbgText :: V.Vector T.Text -- ^ input lines, to print pretty debug info 97#endif 98 } --TODO: check if we should cache the first token 99 -- since it looks like parsec's uncons can be called many times on the same input 100 101type StartCode = Int -- ^ An @alex@ lexer start code 102type InputStream = B.ByteString 103 104 105 106-- | Execute the given lexer on the supplied input stream. 107execLexer :: Lex a -> InputStream -> ([LexWarning], a) 108execLexer (Lex lexer) input = 109 case lexer initialState of 110 LexResult LexState{ warnings = ws } result -> (ws, result) 111 where 112 initialState = LexState 113 -- TODO: add 'startPosition' 114 { curPos = Position 1 1 115 , curInput = input 116 , curCode = 0 117 , warnings = [] 118#ifdef CABAL_PARSEC_DEBUG 119 , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input 120#endif 121 } 122 123{-# INLINE returnLex #-} 124returnLex :: a -> Lex a 125returnLex a = Lex $ \s -> LexResult s a 126 127{-# INLINE thenLex #-} 128thenLex :: Lex a -> (a -> Lex b) -> Lex b 129(Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s' 130 131setPos :: Position -> Lex () 132setPos pos = Lex $ \s -> LexResult s{ curPos = pos } () 133 134getPos :: Lex Position 135getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos 136 137adjustPos :: (Position -> Position) -> Lex () 138adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } () 139 140getInput :: Lex InputStream 141getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i 142 143setInput :: InputStream -> Lex () 144setInput i = Lex $ \s -> LexResult s{ curInput = i } () 145 146getStartCode :: Lex Int 147getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c 148 149setStartCode :: Int -> Lex () 150setStartCode c = Lex $ \s -> LexResult s{ curCode = c } () 151 152-- | Add warning at the current position 153addWarning :: LexWarningType -> Lex () 154addWarning wt = Lex $ \s@LexState{ curPos = pos, warnings = ws } -> 155 LexResult s{ warnings = LexWarning wt pos : ws } () 156