Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE MultiParamTypeClasses #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5
   6 -- | This module provides a 'FieldGrammarParser', one way to parse
   7 -- @.cabal@ -like files.
   8 --
   9 -- Fields can be specified multiple times in the .cabal files.  The order of
  10 -- such entries is important, but the mutual ordering of different fields is
  11 -- not.Also conditional sections are considered after non-conditional data.
  12 -- The example of this silent-commutation quirk is the fact that
  13 --
  14 -- @
  15 -- buildable: True
  16 -- if os(linux)
  17 --   buildable: False
  18 -- @
  19 --
  20 -- and
  21 --
  22 -- @
  23 -- if os(linux)
  24 --   buildable: False
  25 -- buildable: True
  26 -- @
  27 --
  28 -- behave the same! This is the limitation of 'GeneralPackageDescription'
  29 -- structure.
  30 --
  31 -- So we transform the list of fields @['Field' ann]@ into
  32 -- a map of grouped ordinary fields and a list of lists of sections:
  33 -- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@.
  34 --
  35 -- We need list of list of sections, because we need to distinguish situations
  36 -- where there are fields in between. For example
  37 --
  38 -- @
  39 -- if flag(bytestring-lt-0_10_4)
  40 --   build-depends: bytestring < 0.10.4
  41 --
  42 -- default-language: Haskell2020
  43 --
  44 -- else
  45 --   build-depends: bytestring >= 0.10.4
  46 --
  47 -- @
  48 --
  49 -- is obviously invalid specification.
  50 --
  51 -- We can parse 'Fields' like we parse @aeson@ objects, yet we use
  52 -- slightly higher-level API, so we can process unspecified fields,
  53 -- to report unknown fields and save custom @x-fields@.
  54 module Distribution.FieldGrammar.Parsec
  55   ( ParsecFieldGrammar
  56   , parseFieldGrammar
  57   , fieldGrammarKnownFieldList
  58
  59     -- * Auxiliary
  60   , Fields
  61   , NamelessField (..)
  62   , namelessFieldAnn
  63   , Section (..)
  64   , runFieldParser
  65   , runFieldParser'
  66   , fieldLinesToStream
  67   ) where
  68
  69 import Distribution.Compat.Newtype
  70 import Distribution.Compat.Prelude
  71 import Distribution.Utils.Generic (fromUTF8BS)
  72 import Distribution.Utils.String (trim)
  73 import Prelude ()
  74
  75 import qualified Data.ByteString as BS
  76 import qualified Data.List.NonEmpty as NE
  77 import qualified Data.Map.Strict as Map
  78 import qualified Data.Set as Set
  79 import qualified Distribution.Utils.ShortText as ShortText
  80 import qualified Text.Parsec as P
  81 import qualified Text.Parsec.Error as P
  82
  83 import Distribution.CabalSpecVersion
  84 import Distribution.FieldGrammar.Class
  85 import Distribution.Fields.Field
  86 import Distribution.Fields.ParseResult
  87 import Distribution.Parsec
  88 import Distribution.Parsec.FieldLineStream
  89 import Distribution.Parsec.Position (positionCol, positionRow)
  90
  91 -------------------------------------------------------------------------------
  92 -- Auxiliary types
  93 -------------------------------------------------------------------------------
  94
  95 type Fields ann = Map FieldName [NamelessField ann]
  96
  97 -- | Single field, without name, but with its annotation.
  98 data NamelessField ann = MkNamelessField !ann [FieldLine ann]
  99   deriving (Eq, Show, Functor)
 100
 101 namelessFieldAnn :: NamelessField ann -> ann
 102 namelessFieldAnn (MkNamelessField ann _) = ann
 103
 104 -- | The 'Section' constructor of 'Field'.
 105 data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann]
 106   deriving (Eq, Show, Functor)
 107
 108 -------------------------------------------------------------------------------
 109 -- ParsecFieldGrammar
 110 -------------------------------------------------------------------------------
 111
 112 data ParsecFieldGrammar s a = ParsecFG
 113   { fieldGrammarKnownFields :: !(Set FieldName)
 114   , fieldGrammarKnownPrefixes :: !(Set FieldName)
 115   , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a)
 116   }
 117   deriving (Functor)
 118
 119 parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
 120 parseFieldGrammar v fields grammar = do
 121   for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) ->
 122     for_ nfields $ \(MkNamelessField pos _) ->
 123       parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
 124   -- TODO: fields allowed in this section
 125
 126   -- parse
 127   fieldGrammarParser grammar v fields
 128   where
 129     isUnknownField k _ =
 130       not $
 131         k `Set.member` fieldGrammarKnownFields grammar
 132           || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
 133
 134 fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]
 135 fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields
 136
 137 instance Applicative (ParsecFieldGrammar s) where
 138   pure x = ParsecFG mempty mempty (\_ _ -> pure x)
 139   {-# INLINE pure #-}
 140
 141   ParsecFG f f' f'' <*> ParsecFG x x' x'' =
 142     ParsecFG
 143       (mappend f x)
 144       (mappend f' x')
 145       (\v fields -> f'' v fields <*> x'' v fields)
 146   {-# INLINE (<*>) #-}
 147
 148 warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult ()
 149 warnMultipleSingularFields _ [] = pure ()
 150 warnMultipleSingularFields fn (x : xs) = do
 151   let pos = namelessFieldAnn x
 152       poss = map namelessFieldAnn xs
 153   parseWarning pos PWTMultipleSingularField $
 154     "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss))
 155
 156 instance FieldGrammar Parsec ParsecFieldGrammar where
 157   blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser
 158
 159   uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
 160     where
 161       parser v fields = case Map.lookup fn fields of
 162         Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing"
 163         Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing"
 164         Just [x] -> parseOne v x
 165         Just xs@(_ : y : ys) -> do
 166           warnMultipleSingularFields fn xs
 167           NE.last <$> traverse (parseOne v) (y :| ys)
 168
 169       parseOne v (MkNamelessField pos fls) =
 170         unpack' _pack <$> runFieldParser pos parsec v fls
 171
 172   booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser
 173     where
 174       parser v fields = case Map.lookup fn fields of
 175         Nothing -> pure def
 176         Just [] -> pure def
 177         Just [x] -> parseOne v x
 178         Just xs@(_ : y : ys) -> do
 179           warnMultipleSingularFields fn xs
 180           NE.last <$> traverse (parseOne v) (y :| ys)
 181
 182       parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls
 183
 184   optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
 185     where
 186       parser v fields = case Map.lookup fn fields of
 187         Nothing -> pure Nothing
 188         Just [] -> pure Nothing
 189         Just [x] -> parseOne v x
 190         Just xs@(_ : y : ys) -> do
 191           warnMultipleSingularFields fn xs
 192           NE.last <$> traverse (parseOne v) (y :| ys)
 193
 194       parseOne v (MkNamelessField pos fls)
 195         | null fls = pure Nothing
 196         | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls
 197
 198   optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser
 199     where
 200       parser v fields = case Map.lookup fn fields of
 201         Nothing -> pure def
 202         Just [] -> pure def
 203         Just [x] -> parseOne v x
 204         Just xs@(_ : y : ys) -> do
 205           warnMultipleSingularFields fn xs
 206           NE.last <$> traverse (parseOne v) (y :| ys)
 207
 208       parseOne v (MkNamelessField pos fls)
 209         | null fls = pure def
 210         | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls
 211
 212   freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser
 213     where
 214       parser v fields = case Map.lookup fn fields of
 215         Nothing -> pure Nothing
 216         Just [] -> pure Nothing
 217         Just [x] -> parseOne v x
 218         Just xs@(_ : y : ys) -> do
 219           warnMultipleSingularFields fn xs
 220           NE.last <$> traverse (parseOne v) (y :| ys)
 221
 222       parseOne v (MkNamelessField pos fls)
 223         | null fls = pure Nothing
 224         | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls))
 225         | otherwise = pure (Just (fieldlinesToFreeText fls))
 226
 227   freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser
 228     where
 229       parser v fields = case Map.lookup fn fields of
 230         Nothing -> pure ""
 231         Just [] -> pure ""
 232         Just [x] -> parseOne v x
 233         Just xs@(_ : y : ys) -> do
 234           warnMultipleSingularFields fn xs
 235           NE.last <$> traverse (parseOne v) (y :| ys)
 236
 237       parseOne v (MkNamelessField pos fls)
 238         | null fls = pure ""
 239         | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls)
 240         | otherwise = pure (fieldlinesToFreeText fls)
 241
 242   -- freeTextFieldDefST = defaultFreeTextFieldDefST
 243   freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser
 244     where
 245       parser v fields = case Map.lookup fn fields of
 246         Nothing -> pure mempty
 247         Just [] -> pure mempty
 248         Just [x] -> parseOne v x
 249         Just xs@(_ : y : ys) -> do
 250           warnMultipleSingularFields fn xs
 251           NE.last <$> traverse (parseOne v) (y :| ys)
 252
 253       parseOne v (MkNamelessField pos fls) = case fls of
 254         [] -> pure mempty
 255         [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs)
 256         _
 257           | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls)
 258           | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls)
 259
 260   monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
 261     where
 262       parser v fields = case Map.lookup fn fields of
 263         Nothing -> pure mempty
 264         Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs
 265
 266       parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls
 267
 268   prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs))
 269     where
 270       parser :: Fields Position -> [(String, String)]
 271       parser values = reorder $ concatMap convert $ filter match $ Map.toList values
 272
 273       match (fn, _) = fnPfx `BS.isPrefixOf` fn
 274       convert (fn, fields) =
 275         [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls))
 276         | MkNamelessField pos fls <- fields
 277         ]
 278       -- hack: recover the order of prefixed fields
 279       reorder = map snd . sortBy (comparing fst)
 280
 281   availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
 282     where
 283       parser' v values
 284         | v >= vs = parser v values
 285         | otherwise = do
 286             let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
 287             for_ (Map.toList unknownFields) $ \(name, fields) ->
 288               for_ fields $ \(MkNamelessField pos _) ->
 289                 parseWarning pos PWTUnknownField $
 290                   "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored."
 291
 292             pure def
 293
 294   availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
 295     where
 296       parser' v values
 297         | v >= vs = parser v values
 298         | otherwise = do
 299             let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
 300             for_ (Map.toList unknownFields) $ \(name, fields) ->
 301               for_ fields $ \(MkNamelessField pos _) ->
 302                 parseWarning pos PWTUnknownField $
 303                   "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "."
 304
 305             parser v values
 306
 307   -- todo we know about this field
 308   deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
 309     where
 310       parser' v values
 311         | v >= vs = do
 312             let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names
 313             for_ (Map.toList deprecatedFields) $ \(name, fields) ->
 314               for_ fields $ \(MkNamelessField pos _) ->
 315                 parseWarning pos PWTDeprecatedField $
 316                   "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg
 317
 318             parser v values
 319         | otherwise = parser v values
 320
 321   removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
 322     where
 323       parser' v values
 324         | v >= vs = do
 325             let msg' = if null msg then "" else ' ' : msg
 326             let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
 327             let namePos =
 328                   [ (name, pos)
 329                   | (name, fields) <- Map.toList unknownFields
 330                   , MkNamelessField pos _ <- fields
 331                   ]
 332
 333             let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg'
 334
 335             case namePos of
 336               -- no fields => proceed (with empty values, to be sure)
 337               [] -> parser v mempty
 338               -- if there's single field: fail fatally with it
 339               ((name, pos) : rest) -> do
 340                 for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name'
 341                 parseFatalFailure pos $ makeMsg name
 342         | otherwise = parser v values
 343
 344   knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ())
 345
 346   hiddenField = id
 347
 348 -------------------------------------------------------------------------------
 349 -- Parsec
 350 -------------------------------------------------------------------------------
 351
 352 runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a
 353 runFieldParser' inputPoss p v str = case P.runParser p' [] "<field>" str of
 354   Right (pok, ws) -> do
 355     traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws
 356     pure pok
 357   Left err -> do
 358     let ppos = P.errorPos err
 359     let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos)
 360
 361     let msg =
 362           P.showErrorMessages
 363             "or"
 364             "unknown parse error"
 365             "expecting"
 366             "unexpected"
 367             "end of input"
 368             (P.errorMessages err)
 369     parseFatalFailure epos $ msg ++ "\n"
 370   where
 371     p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState
 372
 373     -- Positions start from 1:1, not 0:0
 374     mapPosition (Position prow pcol) = go (prow - 1) inputPoss
 375       where
 376         go _ [] = zeroPos
 377         go _ [Position row col] = Position row (col + pcol - 1)
 378         go n (Position row col : _) | n <= 0 = Position row (col + pcol - 1)
 379         go n (_ : ps) = go (n - 1) ps
 380
 381 runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a
 382 runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls)
 383   where
 384     poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position
 385
 386 fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
 387 fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
 388
 389 -- Example package with dot lines
 390 -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal
 391 fieldlinesToFreeText :: [FieldLine ann] -> String
 392 fieldlinesToFreeText [FieldLine _ "."] = "."
 393 fieldlinesToFreeText fls = intercalate "\n" (map go fls)
 394   where
 395     go (FieldLine _ bs)
 396       | s == "." = ""
 397       | otherwise = s
 398       where
 399         s = trim (fromUTF8BS bs)
 400
 401 fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String
 402 fieldlinesToFreeText3 _ [] = ""
 403 fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs
 404 fieldlinesToFreeText3 pos (FieldLine pos1 bs1 : fls2@(FieldLine pos2 _ : _))
 405   -- if first line is on the same line with field name:
 406   -- the indentation level is either
 407   -- 1. the indentation of left most line in rest fields
 408   -- 2. the indentation of the first line
 409   -- whichever is leftmost
 410   | positionRow pos == positionRow pos1 =
 411       concat $
 412         fromUTF8BS bs1
 413           : mealy (mk mcol1) pos1 fls2
 414   -- otherwise, also indent the first line
 415   | otherwise =
 416       concat $
 417         replicate (positionCol pos1 - mcol2) ' '
 418           : fromUTF8BS bs1
 419           : mealy (mk mcol2) pos1 fls2
 420   where
 421     mcol1 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (min (positionCol pos1) (positionCol pos2)) fls2
 422     mcol2 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (positionCol pos1) fls2
 423
 424     mk :: Int -> Position -> FieldLine Position -> (Position, String)
 425     mk col p (FieldLine q bs) =
 426       ( q
 427       , replicate newlines '\n'
 428           ++ replicate indent ' '
 429           ++ fromUTF8BS bs
 430       )
 431       where
 432         newlines = positionRow q - positionRow p
 433         indent = positionCol q - col
 434
 435 mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b]
 436 mealy f = go
 437   where
 438     go _ [] = []
 439     go s (x : xs) = let ~(s', y) = f s x in y : go s' xs
 440
 441 fieldLinesToStream :: [FieldLine ann] -> FieldLineStream
 442 fieldLinesToStream [] = fieldLineStreamEnd
 443 fieldLinesToStream [FieldLine _ bs] = FLSLast bs
 444 fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs)