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