Replace cabal project parsing with Parsec

Cabal-syntax/src/Distribution/FieldGrammar.hs

@@ -65,6 +65,20 @@ x ^^^ f = f x
 data PS ann = PS (Fields ann) [Section ann] [[Section ann]]
 
 -- | Partition field list into field map and groups of sections.
+-- Groups sections between fields. This means that the following snippet contains
+-- two section groups:
+--
+-- @
+-- -- first group
+-- some-section
+--     field: value
+-- another-section
+--     field: value
+-- foo: bar
+-- -- second group
+-- yet-another-section
+--     field: value
+-- @
 partitionFields :: [Field ann] -> (Fields ann, [[Section ann]])
 partitionFields = finalize . foldl' f (PS mempty mempty mempty)
   where

Cabal-syntax/src/Distribution/Fields/ParseResult.hs

@@ -16,6 +16,7 @@ module Distribution.Fields.ParseResult
   , getCabalSpecVersion
   , setCabalSpecVersion
   , withoutWarnings
+  , liftParseResult
   ) where
 
 import Distribution.Compat.Prelude
@@ -62,6 +63,17 @@ runParseResult pr = unPR pr emptyPRState failure success
     -- If there are any errors, don't return the result
     success (PRState warns (err : errs) v) _ = (warns, Left (v, err :| errs))
 
+-- | Chain parsing operations that involve 'IO' actions.
+liftParseResult :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b)
+liftParseResult f pr = unPR pr emptyPRState failure success
+  where
+    failure s = return $ PR $ \s' failure' _ -> failure' (concatPRState s s')
+    success s a = do
+      pr' <- f a
+      return $ PR $ \s' failure' success' -> unPR pr' (concatPRState s s') failure' success'
+    concatPRState (PRState warnings errors version) (PRState warnings' errors' version') =
+      (PRState (warnings ++ warnings') (toList errors ++ errors') (version <|> version'))
+
 instance Functor ParseResult where
   fmap f (PR pr) = PR $ \ !s failure success ->
     pr s failure $ \ !s' a ->

Cabal/src/Distribution/Simple/Compiler.hs

@@ -50,6 +50,7 @@ module Distribution.Simple.Compiler
   , interpretPackageDBStack
   , coercePackageDB
   , coercePackageDBStack
+  , readPackageDb
 
     -- * Support for optimisation levels
   , OptimisationLevel (..)
@@ -92,7 +93,9 @@ module Distribution.Simple.Compiler
   , showProfDetailLevel
   ) where
 
+import Distribution.Compat.CharParsing
 import Distribution.Compat.Prelude
+import Distribution.Parsec
 import Distribution.Pretty
 import Prelude ()
 
@@ -103,6 +106,7 @@ import Distribution.Version
 
 import Language.Haskell.Extension
 
+import Data.Bool (bool)
 import qualified Data.Map as Map (lookup)
 import System.Directory (canonicalizePath)
 
@@ -202,6 +206,15 @@ data PackageDBX fp
 instance Binary fp => Binary (PackageDBX fp)
 instance Structured fp => Structured (PackageDBX fp)
 
+-- | Parse a PackageDB stack entry
+--
+-- @since 3.7.0.0
+readPackageDb :: String -> Maybe PackageDB
+readPackageDb "clear" = Nothing
+readPackageDb "global" = Just GlobalPackageDB
+readPackageDb "user" = Just UserPackageDB
+readPackageDb other = Just (SpecificPackageDB (makeSymbolicPath other))
+
 -- | We typically get packages from several databases, and stack them
 -- together. This type lets us be explicit about that stacking. For example
 -- typical stacks include:
@@ -293,20 +306,36 @@ data OptimisationLevel
 instance Binary OptimisationLevel
 instance Structured OptimisationLevel
 
+instance Parsec OptimisationLevel where
+  parsec = parsecOptimisationLevel
+
+parsecOptimisationLevel :: CabalParsing m => m OptimisationLevel
+parsecOptimisationLevel = boolParser <|> intParser
+  where
+    boolParser = (bool NoOptimisation NormalOptimisation) <$> parsec
+    intParser = intToOptimisationLevel <$> integral
+
 flagToOptimisationLevel :: Maybe String -> OptimisationLevel
 flagToOptimisationLevel Nothing = NormalOptimisation
 flagToOptimisationLevel (Just s) = case reads s of
-  [(i, "")]
-    | i >= fromEnum (minBound :: OptimisationLevel)
-        && i <= fromEnum (maxBound :: OptimisationLevel) ->
-        toEnum i
-    | otherwise ->
-        error $
-          "Bad optimisation level: "
-            ++ show i
-            ++ ". Valid values are 0..2"
+  [(i, "")] -> intToOptimisationLevel i
   _ -> error $ "Can't parse optimisation level " ++ s
 
+intToOptimisationLevel :: Int -> OptimisationLevel
+intToOptimisationLevel i
+  | i >= minLevel && i <= maxLevel = toEnum i
+  | otherwise =
+      error $
+        "Bad optimisation level: "
+          ++ show i
+          ++ ". Valid values are "
+          ++ show minLevel
+          ++ ".."
+          ++ show maxLevel
+  where
+    minLevel = fromEnum (minBound :: OptimisationLevel)
+    maxLevel = fromEnum (maxBound :: OptimisationLevel)
+
 -- ------------------------------------------------------------
 
 -- * Debug info levels
@@ -326,6 +355,12 @@ data DebugInfoLevel
 instance Binary DebugInfoLevel
 instance Structured DebugInfoLevel
 
+instance Parsec DebugInfoLevel where
+  parsec = parsecDebugInfoLevel
+
+parsecDebugInfoLevel :: CabalParsing m => m DebugInfoLevel
+parsecDebugInfoLevel = flagToDebugInfoLevel . pure <$> parsecToken
+
 flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel
 flagToDebugInfoLevel Nothing = NormalDebugInfo
 flagToDebugInfoLevel (Just s) = case reads s of
@@ -563,6 +598,12 @@ data ProfDetailLevel
 instance Binary ProfDetailLevel
 instance Structured ProfDetailLevel
 
+instance Parsec ProfDetailLevel where
+  parsec = parsecProfDetailLevel
+
+parsecProfDetailLevel :: CabalParsing m => m ProfDetailLevel
+parsecProfDetailLevel = flagToProfDetailLevel <$> parsecToken
+
 flagToProfDetailLevel :: String -> ProfDetailLevel
 flagToProfDetailLevel "" = ProfDetailDefault
 flagToProfDetailLevel s =

Cabal/src/Distribution/Simple/Flag.hs

@@ -34,6 +34,7 @@ module Distribution.Simple.Flag
 
 import Distribution.Compat.Prelude hiding (get)
 import Distribution.Compat.Stack
+import Distribution.Parsec
 import Prelude ()
 
 -- ------------------------------------------------------------
@@ -99,6 +100,12 @@ instance Enum a => Enum (Flag a) where
   enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c
   enumFromThenTo _ _ _ = []
 
+instance Parsec a => Parsec (Flag a) where
+  parsec = parsecFlag
+
+parsecFlag :: (Parsec a, CabalParsing m) => m (Flag a)
+parsecFlag = (Flag <$> parsec) <|> pure mempty
+
 -- | Wraps a value in 'Flag'.
 toFlag :: a -> Flag a
 toFlag = Flag

Cabal/src/Distribution/Simple/InstallDirs.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 
 -----------------------------------------------------------------------------
@@ -44,16 +45,21 @@ module Distribution.Simple.InstallDirs
   , compilerTemplateEnv
   , packageTemplateEnv
   , abiTemplateEnv
+  , installDirsGrammar
   , installDirsTemplateEnv
   ) where
 
 import Distribution.Compat.Prelude
 import Prelude ()
 
 import Distribution.Compat.Environment (lookupEnv)
+import Distribution.Compat.Lens (Lens')
 import Distribution.Compiler
+import Distribution.FieldGrammar
 import Distribution.Package
+import Distribution.Parsec
 import Distribution.Pretty
+import Distribution.Simple.Flag
 import Distribution.Simple.InstallDirs.Internal
 import Distribution.System
 
@@ -506,6 +512,12 @@ instance Read PathTemplate where
     , (template, "") <- reads path
     ]
 
+instance Parsec PathTemplate where
+  parsec = parsecPathTemplate
+
+parsecPathTemplate :: CabalParsing m => m PathTemplate
+parsecPathTemplate = parsecFilePath >>= return . toPathTemplate
+
 -- ---------------------------------------------------------------------------
 -- Internal utilities
 
@@ -552,3 +564,81 @@ foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"
                               -> Prelude.IO CInt
 #endif
 {- FOURMOLU_ENABLE -}
+
+-- ---------------------------------------------------------------------------
+-- FieldGrammar
+
+installDirsGrammar :: ParsecFieldGrammar' (InstallDirs (Flag PathTemplate))
+installDirsGrammar =
+  InstallDirs
+    <$> optionalFieldDef "prefix" installDirsPrefixLens mempty
+    <*> optionalFieldDef "bindir" installDirsBindirLens mempty
+    <*> optionalFieldDef "libdir" installDirsLibdirLens mempty
+    <*> optionalFieldDef "libsubdir" installDirsLibsubdirLens mempty
+    <*> optionalFieldDef "dynlibdir" installDirsDynlibdirLens mempty
+    <*> (pure NoFlag) -- flibdir
+    <*> optionalFieldDef "libexecdir" installDirsLibexecdirLens mempty
+    <*> optionalFieldDef "libexecsubdir" installDirsLibexecsubdirLens mempty
+    <*> (pure NoFlag) -- includedir
+    <*> optionalFieldDef "datadir" installDirsDatadirLens mempty
+    <*> optionalFieldDef "datasubdir" installDirsDatasubdirLens mempty
+    <*> optionalFieldDef "docdir" installDirsDocdirLens mempty
+    <*> (pure NoFlag) -- mandir
+    <*> optionalFieldDef "htmldir" installDirsHtmldirLens mempty
+    <*> optionalFieldDef "haddockdir" installDirsHaddockdirLens mempty
+    <*> optionalFieldDef "sysconfdir" installDirsSysconfdirLens mempty
+
+-- ---------------------------------------------------------------------------
+-- Lenses
+
+installDirsPrefixLens :: Lens' (InstallDirs a) a
+installDirsPrefixLens f c = fmap (\x -> c{prefix = x}) (f (prefix c))
+{-# INLINEABLE installDirsPrefixLens #-}
+
+installDirsBindirLens :: Lens' (InstallDirs a) a
+installDirsBindirLens f c = fmap (\x -> c{bindir = x}) (f (bindir c))
+{-# INLINEABLE installDirsBindirLens #-}
+
+installDirsLibdirLens :: Lens' (InstallDirs a) a
+installDirsLibdirLens f c = fmap (\x -> c{libdir = x}) (f (libdir c))
+{-# INLINEABLE installDirsLibdirLens #-}
+
+installDirsLibsubdirLens :: Lens' (InstallDirs a) a
+installDirsLibsubdirLens f c = fmap (\x -> c{libsubdir = x}) (f (libsubdir c))
+{-# INLINEABLE installDirsLibsubdirLens #-}
+
+installDirsDynlibdirLens :: Lens' (InstallDirs a) a
+installDirsDynlibdirLens f c = fmap (\x -> c{dynlibdir = x}) (f (dynlibdir c))
+{-# INLINEABLE installDirsDynlibdirLens #-}
+
+installDirsLibexecdirLens :: Lens' (InstallDirs a) a
+installDirsLibexecdirLens f c = fmap (\x -> c{libexecdir = x}) (f (libexecdir c))
+{-# INLINEABLE installDirsLibexecdirLens #-}
+
+installDirsLibexecsubdirLens :: Lens' (InstallDirs a) a
+installDirsLibexecsubdirLens f c = fmap (\x -> c{libexecsubdir = x}) (f (libexecsubdir c))
+{-# INLINEABLE installDirsLibexecsubdirLens #-}
+
+installDirsDatadirLens :: Lens' (InstallDirs a) a
+installDirsDatadirLens f c = fmap (\x -> c{datadir = x}) (f (datadir c))
+{-# INLINEABLE installDirsDatadirLens #-}
+
+installDirsDatasubdirLens :: Lens' (InstallDirs a) a
+installDirsDatasubdirLens f c = fmap (\x -> c{datasubdir = x}) (f (datasubdir c))
+{-# INLINEABLE installDirsDatasubdirLens #-}
+
+installDirsDocdirLens :: Lens' (InstallDirs a) a
+installDirsDocdirLens f c = fmap (\x -> c{docdir = x}) (f (docdir c))
+{-# INLINEABLE installDirsDocdirLens #-}
+
+installDirsHtmldirLens :: Lens' (InstallDirs a) a
+installDirsHtmldirLens f c = fmap (\x -> c{htmldir = x}) (f (htmldir c))
+{-# INLINEABLE installDirsHtmldirLens #-}
+
+installDirsHaddockdirLens :: Lens' (InstallDirs a) a
+installDirsHaddockdirLens f c = fmap (\x -> c{haddockdir = x}) (f (haddockdir c))
+{-# INLINEABLE installDirsHaddockdirLens #-}
+
+installDirsSysconfdirLens :: Lens' (InstallDirs a) a
+installDirsSysconfdirLens f c = fmap (\x -> c{sysconfdir = x}) (f (sysconfdir c))
+{-# INLINEABLE installDirsSysconfdirLens #-}

Cabal/src/Distribution/Simple/PackageDescription.hs

@@ -18,6 +18,8 @@ module Distribution.Simple.PackageDescription
 
     -- * Utility Parsing function
   , parseString
+  , readAndParseFile
+  , flattenDups
   ) where
 
 import Distribution.Compat.Prelude

Cabal/src/Distribution/Simple/Setup/Config.hs

@@ -897,15 +897,6 @@ configureOptions showOrParseArgs =
 readPackageDbList :: String -> [Maybe PackageDB]
 readPackageDbList str = [readPackageDb str]
 
--- | Parse a PackageDB stack entry
---
--- @since 3.7.0.0
-readPackageDb :: String -> Maybe PackageDB
-readPackageDb "clear" = Nothing
-readPackageDb "global" = Just GlobalPackageDB
-readPackageDb "user" = Just UserPackageDB
-readPackageDb other = Just (SpecificPackageDB (makeSymbolicPath other))
-
 showPackageDbList :: [Maybe PackageDB] -> [String]
 showPackageDbList = map showPackageDb
 

Cabal/src/Distribution/Types/DumpBuildInfo.hs

@@ -5,6 +5,7 @@ module Distribution.Types.DumpBuildInfo
   ) where
 
 import Distribution.Compat.Prelude
+import Distribution.Parsec
 
 data DumpBuildInfo
   = NoDumpBuildInfo
@@ -13,3 +14,14 @@ data DumpBuildInfo
 
 instance Binary DumpBuildInfo
 instance Structured DumpBuildInfo
+
+instance Parsec DumpBuildInfo where
+  parsec = parsecDumpBuildInfo
+
+parsecDumpBuildInfo :: CabalParsing m => m DumpBuildInfo
+parsecDumpBuildInfo = boolToDumpBuildInfo <$> parsec
+
+boolToDumpBuildInfo :: Bool -> DumpBuildInfo
+boolToDumpBuildInfo bool = case bool of
+  True -> DumpBuildInfo
+  _ -> NoDumpBuildInfo

cabal-install-solver/src/Distribution/Solver/Types/Settings.hs

@@ -105,3 +105,26 @@ instance Parsec OnlyConstrained where
     , P.string "none" >> return OnlyConstrainedNone
     ]
 
+instance Parsec ReorderGoals where
+  parsec = ReorderGoals <$> parsec
+
+instance Parsec CountConflicts where
+  parsec = CountConflicts <$> parsec
+
+instance Parsec FineGrainedConflicts where
+  parsec = FineGrainedConflicts <$> parsec
+
+instance Parsec MinimizeConflictSet where
+  parsec = MinimizeConflictSet <$> parsec
+
+instance Parsec StrongFlags where
+  parsec = StrongFlags <$> parsec
+
+instance Parsec AllowBootLibInstalls where
+  parsec = AllowBootLibInstalls <$> parsec
+
+instance Parsec PreferOldest where
+  parsec = PreferOldest <$> parsec
+
+instance Parsec IndependentGoals where
+  parsec = IndependentGoals <$> parsec