content: {-# LANGUAGE CPP                 #-}
  {-# LANGUAGE OverloadedStrings   #-}
  {-# LANGUAGE Rank2Types          #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TupleSections       #-}
  {-# LANGUAGE FlexibleContexts    #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Distribution.PackageDescription.Parsec
  -- Copyright   :  Isaac Jones 2003-2005
  -- License     :  BSD3
  --
  -- Maintainer  :  cabal-devel@haskell.org
  -- Portability :  portable
  --
  -- This defined parsers and partial pretty printers for the @.cabal@ format.
  
  module Distribution.PackageDescription.Parsec (
      -- * Package descriptions
      readGenericPackageDescription,
      parseGenericPackageDescription,
      parseGenericPackageDescriptionMaybe,
  
      -- ** Parsing
      ParseResult,
      runParseResult,
  
      -- ** Supplementary build information
      -- readHookedBuildInfo,
      -- parseHookedBuildInfo,
      ) where
  
  import           Prelude ()
  import           Distribution.Compat.Prelude
  import qualified Data.ByteString                                   as BS
  import           Data.List                                         (partition)
  import qualified Data.Map                                          as Map
  import qualified Distribution.Compat.SnocList                      as SnocList
  import           Distribution.PackageDescription
  import           Distribution.PackageDescription.Parsec.FieldDescr
  import           Distribution.Parsec.Class                         (parsec)
  import           Distribution.Parsec.ConfVar
                   (parseConditionConfVar)
  import           Distribution.Parsec.LexerMonad
                   (LexWarning, toPWarning)
  import           Distribution.Parsec.Parser
  import           Distribution.Parsec.Types.Common
  import           Distribution.Parsec.Types.Field                   (getName)
  import           Distribution.Parsec.Types.FieldDescr
  import           Distribution.Parsec.Types.ParseResult
  import           Distribution.Simple.Utils
                   (die', fromUTF8BS, warn)
  import           Distribution.Text                                 (display)
  import           Distribution.Types.ForeignLib
  import           Distribution.Types.CondTree
  import           Distribution.Types.UnqualComponentName
                   (UnqualComponentName, mkUnqualComponentName)
  import           Distribution.Verbosity                            (Verbosity)
  import           Distribution.Version
                   (LowerBound (..), Version, asVersionIntervals, mkVersion,
                   orLaterVersion)
  import           System.Directory
                   (doesFileExist)
  import qualified Text.Parsec                                       as P
  import qualified Text.Parsec.Error                                 as P
  
  -- ---------------------------------------------------------------
  -- Parsing
  
  -- | Helper combinator to do parsing plumbing for files.
  --
  -- Given a parser and a filename, return the parse of the file,
  -- after checking if the file exists.
  --
  -- Argument order is chosen to encourage partial application.
  readAndParseFile
      :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser
      -> Verbosity                         -- ^ Verbosity level
      -> FilePath                          -- ^ File to read
      -> IO a
  readAndParseFile parser verbosity fpath = do
      exists <- doesFileExist fpath
      unless exists $
        die' verbosity $
          "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
      bs <- BS.readFile fpath
      let (warnings, errors, result) = runParseResult (parser bs)
      traverse_ (warn verbosity . showPWarning fpath) warnings
      traverse_ (warn verbosity . showPError fpath) errors
      case result of
          Nothing -> die' verbosity $ "Failing parsing \"" ++ fpath ++ "\"."
          Just x  -> return x
  
  -- | Parse the given package file.
  readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
  readGenericPackageDescription = readAndParseFile parseGenericPackageDescription
  
  ------------------------------------------------------------------------------
  -- | Parses the given file into a 'GenericPackageDescription'.
  --
  -- In Cabal 1.2 the syntax for package descriptions was changed to a format
  -- with sections and possibly indented property descriptions.
  --
  -- TODO: add lex warnings
  parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription
  parseGenericPackageDescription bs = case readFields' bs of
      Right (fs, lexWarnings) -> parseGenericPackageDescription' lexWarnings fs
      -- TODO: better marshalling of errors
      Left perr -> parseFatalFailure (Position 0 0) (show perr)
  
  -- | 'Maybe' variant of 'parseGenericPackageDescription'
  parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription
  parseGenericPackageDescriptionMaybe =
      trdOf3 . runParseResult . parseGenericPackageDescription
    where
      trdOf3 (_, _, x) = x
  
  runFieldParser :: FieldParser a -> [FieldLine Position] -> ParseResult a
  runFieldParser p ls = runFieldParser' pos p =<< fieldlinesToString pos ls
    where
      -- TODO: make per line lookup
      pos = case ls of
          []                     -> Position 0 0
          (FieldLine pos' _ : _) -> pos'
  
  fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
  fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
  
  -- TODO: Take position  from FieldLine
  -- TODO: Take field name
  fieldlinesToString :: Position -> [FieldLine ann] -> ParseResult String
  fieldlinesToString pos fls =
      let str = intercalate "\n" . map (\(FieldLine _ bs') -> fromUTF8BS bs') $ fls
      in if '\xfffd' `elem` str
          then str <$ parseWarning pos PWTUTF "Invalid UTF8 encoding"
          else pure str
  
  runFieldParser' :: Position -> FieldParser a -> String -> ParseResult a
  runFieldParser' (Position row col) p str = case P.runParser p' [] "<field>" str of
      Right (pok, ws) -> do
          -- TODO: map pos
          traverse_ (\(PWarning t pos w) -> parseWarning pos t w) ws
          pure pok
      Left err        -> do
          let ppos = P.errorPos err
          -- Positions start from 1:1, not 0:0
          let epos = Position (row - 1 + P.sourceLine ppos) (col - 1 + P.sourceColumn ppos)
          let msg = P.showErrorMessages
                  "or" "unknown parse error" "expecting" "unexpected" "end of input"
                  (P.errorMessages err)
  
          parseFatalFailure epos $ msg ++ ": " ++ show str
    where
      p' = (,) <$ P.spaces <*> p <* P.spaces <* P.eof <*> P.getState
  
  -- Note [Accumulating parser]
  --
  -- This parser has two "states":
  -- * first we parse fields of PackageDescription
  -- * then we parse sections (libraries, executables, etc)
  parseGenericPackageDescription'
      :: [LexWarning]
      -> [Field Position]
      -> ParseResult GenericPackageDescription
  parseGenericPackageDescription' lexWarnings fs = do
      parseWarnings' (fmap toPWarning lexWarnings)
      let (syntax, fs') = sectionizeFields fs
      gpd <-  goFields emptyGpd fs'
      -- Various post checks
      maybeWarnCabalVersion syntax (packageDescription gpd)
      checkForUndefinedFlags gpd
      -- TODO: do other validations
      return gpd
    where
      -- First fields
      goFields
          :: GenericPackageDescription
          -> [Field Position]
          -> ParseResult GenericPackageDescription
      goFields gpd [] = pure gpd
      goFields gpd (Field (Name pos name) fieldLines : fields) =
          case Map.lookup name pdFieldParsers of
              -- TODO: can be more elegant
              Nothing -> fieldlinesToString pos fieldLines >>= \value -> case storeXFieldsPD name value (packageDescription gpd) of
                  Nothing -> do
                      parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
                      goFields gpd fields
                  Just pd ->
                      goFields (gpd { packageDescription = pd }) fields
              Just parser -> do
                  pd <- runFieldParser (parser $ packageDescription gpd) fieldLines
                  let gpd' = gpd { packageDescription = pd }
                  goFields gpd' fields
      goFields gpd fields@(Section _ _ _ : _) = goSections gpd fields
  
      -- Sections
      goSections
          :: GenericPackageDescription
          -> [Field Position]
          -> ParseResult GenericPackageDescription
      goSections gpd [] = pure gpd
      goSections gpd (Field (Name pos name) _ : fields) = do
          parseWarning pos PWTTrailingFields $ "Ignoring trailing fields after sections: " ++ show name
          goSections gpd fields
      goSections gpd (Section name args secFields : fields) = do
          gpd' <- parseSection gpd name args secFields
          goSections gpd' fields
  
      emptyGpd :: GenericPackageDescription
      emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
  
      pdFieldParsers :: Map FieldName (PackageDescription -> FieldParser PackageDescription)
      pdFieldParsers = Map.fromList $
          map (\x -> (fieldName x, fieldParser x)) pkgDescrFieldDescrs
  
      parseSection
          :: GenericPackageDescription
          -> Name Position
          -> [SectionArg Position]
          -> [Field Position]
          -> ParseResult GenericPackageDescription
      parseSection gpd (Name pos name) args fields
          | name == "library" && null args = do
              -- TODO: check that library is defined once
              l <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields
              let gpd' = gpd { condLibrary = Just l }
              pure gpd'
  
          -- Sublibraries
          | name == "library" = do
              name' <- parseUnqualComponentName pos args
              lib <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields
              -- TODO check duplicate name here?
              let gpd' = gpd { condSubLibraries = condSubLibraries gpd ++ [(name', lib)] }
              pure gpd'
  
          | name == "foreign-library" = do
              name' <- parseUnqualComponentName pos args
              flib <- parseCondTree foreignLibFieldDescrs storeXFieldsForeignLib (targetBuildDepends . foreignLibBuildInfo) emptyForeignLib fields
              -- TODO check duplicate name here?
              let gpd' = gpd { condForeignLibs = condForeignLibs gpd ++ [(name', flib)] }
              pure gpd'
  
          | name == "executable" = do
              name' <- parseUnqualComponentName pos args
              -- Note: we don't parse the "executable" field here, hence the tail hack. Duncan 2010
              exe <- parseCondTree (tail executableFieldDescrs) storeXFieldsExe (targetBuildDepends . buildInfo) emptyExecutable fields
              -- TODO check duplicate name here?
              let gpd' = gpd { condExecutables = condExecutables gpd ++ [(name', exe)] }
              pure gpd'
  
          | name == "test-suite" = do
              name' <- parseUnqualComponentName pos args
              testStanza <- parseCondTree testSuiteFieldDescrs storeXFieldsTest (targetBuildDepends . testStanzaBuildInfo) emptyTestStanza fields
              testSuite <- traverse (validateTestSuite pos) testStanza
              -- TODO check duplicate name here?
              let gpd' = gpd { condTestSuites = condTestSuites gpd ++ [(name', testSuite)] }
              pure gpd'
  
          | name == "benchmark" = do
              name' <- parseUnqualComponentName pos args
              benchStanza <- parseCondTree benchmarkFieldDescrs storeXFieldsBenchmark (targetBuildDepends . benchmarkStanzaBuildInfo) emptyBenchmarkStanza fields
              bench <- traverse (validateBenchmark pos) benchStanza
              -- TODO check duplicate name here?
              let gpd' = gpd { condBenchmarks = condBenchmarks gpd ++ [(name', bench)] }
              pure gpd'
  
          | name == "flag" = do
              name' <- parseName pos args
              name'' <- runFieldParser' pos parsec name' `recoverWith` mkFlagName ""
              flag <- parseFields flagFieldDescrs warnUnrec (emptyFlag name'') fields
              -- Check default flag
              let gpd' = gpd { genPackageFlags = genPackageFlags gpd ++ [flag] }
              pure gpd'
  
          | name == "custom-setup" && null args = do
              sbi <- parseFields setupBInfoFieldDescrs warnUnrec mempty fields
              let pd = packageDescription gpd
              -- TODO: what if already defined?
              let gpd' = gpd { packageDescription = pd { setupBuildInfo = Just sbi } }
              pure gpd'
  
          | name == "source-repository" = do
              kind <- case args of
                  [SecArgName spos secName] ->
                      runFieldParser' spos parsec (fromUTF8BS secName) `recoverWith` RepoHead
                  [] -> do
                      parseFailure pos $ "'source-repository' needs one argument"
                      pure RepoHead
                  _ -> do
                      parseFailure pos $ "Invalid source-repository kind " ++ show args
                      pure RepoHead
              sr <- parseFields sourceRepoFieldDescrs warnUnrec (emptySourceRepo kind) fields
              -- I want lens
              let pd =  packageDescription gpd
              let srs = sourceRepos pd
              let gpd' = gpd { packageDescription = pd { sourceRepos = srs ++ [sr] } }
              pure gpd'
  
          | otherwise = do
              parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
              pure gpd
  
      newSyntaxVersion :: Version
      newSyntaxVersion = mkVersion [1, 2]
  
      maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()
      maybeWarnCabalVersion syntax pkg
        | syntax == NewSyntax && specVersion pkg < newSyntaxVersion
        = parseWarning (Position 0 0) PWTNewSyntax $
               "A package using section syntax must specify at least\n"
            ++ "'cabal-version: >= 1.2'."
  
      maybeWarnCabalVersion syntax pkg
        | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion
        = parseWarning (Position 0 0) PWTOldSyntax $
               "A package using 'cabal-version: "
            ++ displaySpecVersion (specVersionRaw pkg)
            ++ "' must use section syntax. See the Cabal user guide for details."
        where
          displaySpecVersion (Left version)       = display version
          displaySpecVersion (Right versionRange) =
            case asVersionIntervals versionRange of
              [] {- impossible -}           -> display versionRange
              ((LowerBound version _, _):_) -> display (orLaterVersion version)
  
      maybeWarnCabalVersion _ _ = return ()
  
  {-
      handleFutureVersionParseFailure :: Version -> ParseResult a -> ParseResult GenericPackageDescription
      handleFutureVersionParseFailure _cabalVersionNeeded _parseBody =
          error "handleFutureVersionParseFailure"
  -}
  
   {-
        undefined (unless versionOk (warning message) >> parseBody)
          `catchParseError` \parseError -> case parseError of
          TabsError _   -> parseFail parseError
          _ | versionOk -> parseFail parseError
            | otherwise -> fail message
        where versionOk = cabalVersionNeeded <= cabalVersion
              message   = "This package requires at least Cabal version "
                       ++ display cabalVersionNeeded
      -}
  
      checkForUndefinedFlags
          :: GenericPackageDescription
          -> ParseResult ()
      checkForUndefinedFlags _gpd = pure ()
  {-
          let definedFlags = map flagName flags
          mapM_ (checkCondTreeFlags definedFlags) (maybeToList mlib)
          mapM_ (checkCondTreeFlags definedFlags . snd) sub_libs
          mapM_ (checkCondTreeFlags definedFlags . snd) exes
          mapM_ (checkCondTreeFlags definedFlags . snd) tests
  
      checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()
      checkCondTreeFlags definedFlags ct = do
          let fv = nub $ freeVars ct
          unless (all (`elem` definedFlags) fv) $
              fail $ "These flags are used without having been defined: "
                  ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]
  -}
  
  parseName :: Position -> [SectionArg Position] -> ParseResult String
  parseName pos args = case args of
      [SecArgName _pos secName] ->
           pure $ fromUTF8BS secName
      [SecArgStr _pos secName] ->
           pure secName
      [] -> do
           parseFailure pos $ "name required"
           pure ""
      _ -> do
           -- TODO: pretty print args
           parseFailure pos $ "Invalid name " ++ show args
           pure ""
  
  parseUnqualComponentName :: Position -> [SectionArg Position] -> ParseResult UnqualComponentName
  parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
  
  
  -- | Parse a non-recursive list of fields, given a list of field descriptions,
  --   a structure to accumulate the parsed fields, and a function
  --   that can decide what to do with fields which don't match any
  --   of the field descriptions.
  parseFields
      :: forall a.
         [FieldDescr a]        -- ^ descriptions of fields we know how to parse
      -> UnknownFieldParser a  -- ^ possibly do something with unrecognized fields
      -> a                     -- ^ accumulator
      -> [Field Position]      -- ^ fields to be parsed
      -> ParseResult a
  parseFields descrs _unknown = foldM go
    where
      go :: a -> Field Position -> ParseResult a
      go x (Section (Name pos name) _ _) = do
          -- Even we occur a subsection, we can continue parsing
          parseFailure pos $ "invalid subsection " ++ show name
          return x
      go x (Field (Name pos name) fieldLines) =
          case Map.lookup name fieldParsers of
              Nothing -> do
                  -- TODO: use 'unknown'
                  parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
                  return x
              Just parser ->
                  runFieldParser (parser x) fieldLines
  
      fieldParsers :: Map FieldName (a -> FieldParser a)
      fieldParsers = Map.fromList $
          map (\x -> (fieldName x, fieldParser x)) descrs
  
  type C c a = CondBranch ConfVar c a
  
  parseCondTree
      :: forall a c.
         [FieldDescr a]        -- ^ Field descriptions
      -> UnknownFieldParser a  -- ^ How to parse unknown fields
      -> (a -> c)              -- ^ Condition extractor
      -> a                     -- ^ Initial value
      -> [Field Position]      -- ^ Fields to parse
      -> ParseResult (CondTree ConfVar c a)
  parseCondTree descs unknown cond ini = impl
    where
      impl :: [Field Position] -> ParseResult (CondTree ConfVar c a)
      impl fields = do
          (x, xs) <- goFields (ini, mempty) fields
          return $ CondNode x (cond x) (SnocList.runSnocList xs)
  
      goFields
          :: (a, SnocList.SnocList (C c a))
          -> [Field Position]
          -> ParseResult (a, SnocList.SnocList (C c a))
      goFields xss [] = return xss
  
      goFields xxs (Section (Name _pos name) tes con : fields) | name == "if" = do
          tes'  <- parseConditionConfVar tes
          con' <- impl con
          -- Jump to 'else' state
          goElse tes' con' xxs fields
  
      goFields xxs (Section (Name pos name) _ _ : fields) = do
          -- Even we occur a subsection, we can continue parsing
          -- http://hackage.haskell.org/package/constraints-0.1/constraints.cabal
          parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name
          goFields xxs fields
  
      goFields (x, xs) (Field (Name pos name) fieldLines : fields) =
          case Map.lookup name fieldParsers of
              Nothing -> fieldlinesToString pos fieldLines >>= \value -> case unknown name value x of
                  Nothing -> do
                      parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
                      goFields (x, xs) fields
                  Just x' -> do
                      goFields (x', xs) fields
              Just parser -> do
                  x' <- runFieldParser (parser x) fieldLines
                  goFields (x', xs) fields
  
      -- Try to parse else branch
      goElse
          :: Condition ConfVar
          -> CondTree ConfVar c a
          -> (a, SnocList.SnocList (C c a))
          -> [Field Position]
          -> ParseResult (a, SnocList.SnocList (C c a))
      goElse tes con (x, xs) (Section (Name pos name) secArgs alt : fields) | name == "else" = do
          when (not . null $ secArgs) $ do
              parseFailure pos $ "`else` section has section arguments " ++ show secArgs
          alt' <- case alt of
              [] -> pure Nothing
              _  -> Just <$> impl alt
          let ieb = (CondBranch tes con alt')
          goFields (x, SnocList.snoc xs ieb) fields
      goElse tes con (x, xs) fields = do
          let ieb = (CondBranch tes con Nothing)
          goFields (x, SnocList.snoc xs ieb) fields
  
      fieldParsers :: Map FieldName (a -> FieldParser a)
      fieldParsers = Map.fromList $
          map (\x -> (fieldName x, fieldParser x)) descs
  
  {- Note [Accumulating parser]
  
  In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a ->
  FieldParser a)@.  The weird value is used because we accumulate structure of
  @a@ by folding over the fields.  There are various reasons for that:
  
  * Almost all fields are optional
  
  * This is simple approach so declarative bi-directional format (parsing and
  printing) of structure could be specified (list of @'FieldDescr' a@)
  
  * There are surface syntax fields corresponding to single field in the file:
    @license-file@ and @license-files@
  
  * This is quite safe approach.
  
  When/if we re-implement the parser to support formatting preservging roundtrip
  with new AST, this all need to be rewritten.
  -}
  
  -------------------------------------------------------------------------------
  -- Old syntax
  -------------------------------------------------------------------------------
  
  -- | "Sectionize" an old-style Cabal file.  A sectionized file has:
  --
  --  * all global fields at the beginning, followed by
  --
  --  * all flag declarations, followed by
  --
  --  * an optional library section, and an arbitrary number of executable
  --    sections (in any order).
  --
  -- The current implementation just gathers all library-specific fields
  -- in a library section and wraps all executable stanzas in an executable
  -- section.
  sectionizeFields :: [Field ann] -> (Syntax, [Field ann])
  sectionizeFields fs = case classifyFields fs of
      Just fields -> (OldSyntax, convert fields)
      Nothing     -> (NewSyntax, fs)
    where
      -- return 'Just' if all fields are simple fields
      classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])]
      classifyFields = traverse f
        where
          f (Field name fieldlines) = Just (name, fieldlines)
          f _                      = Nothing
  
      trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse
      isSpace' = (== 32)
  
      convert :: [(Name ann, [FieldLine ann])] -> [Field ann]
      convert fields =
        let
          toField (name, ls) = Field name ls
          -- "build-depends" is a local field now.  To be backwards
          -- compatible, we still allow it as a global field in old-style
          -- package description files and translate it to a local field by
          -- adding it to every non-empty section
          (hdr0, exes0) = break ((=="executable") . getName . fst) fields
          (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0
  
          (deps, libfs) = partition ((== "build-depends") . getName . fst)
                                     libfs0
  
          exes = unfoldr toExe exes0
          toExe [] = Nothing
          toExe ((Name pos n, ls) : r)
            | n == "executable" =
                let (efs, r') = break ((== "executable") . getName . fst) r
                in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r')
          toExe _ = error "unexpected input to 'toExe'"
  
          lib = case libfs of
              []                         -> []
              ((Name pos _,  _) : _) ->
                  [Section (Name pos "library") [] (map toField $ deps ++ libfs)]
  
        in map toField hdr ++ lib ++ exes
  
  -- | See 'sectionizeFields'.
  data Syntax = OldSyntax | NewSyntax
      deriving (Eq, Show)
  
  libFieldNames :: [FieldName]
  libFieldNames = map fieldName libFieldDescrs
  