WIP

Author: phadej

cabal-install-parsers/src/Cabal/Project.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- | License: GPL-3.0-or-later AND BSD-3-Clause
 --
 module Cabal.Project (
@@ -59,6 +60,7 @@ import qualified Distribution.FieldGrammar       as C
 import qualified Distribution.Fields             as C
 import qualified Distribution.PackageDescription as C
 import qualified Distribution.Parsec             as C
+import qualified Distribution.Fields.ConfVar     as C
 
 import Cabal.Internal.Glob
 import Cabal.Internal.Newtypes
@@ -154,7 +156,7 @@ instance (NFData c, NFData b, NFData a) => NFData (Project c b a) where
         rnf x7 `seq` rnf x8 `seq` rnf x9 `seq`
         rnfList rnfPrettyField x10
       where
-        rnfList :: (a -> ()) -> [a] -> ()
+        rnfList :: (x -> ()) -> [x] -> ()
         rnfList _ []     = ()
         rnfList f (x:xs) = f x `seq` rnfList f xs
 
@@ -227,13 +229,13 @@ parseProject = parseWith $ \fields0 -> do
 -- Right (CondNode {condTreeData = ["foo","bar/*.cabal"], condTreeConstraints = (), condTreeComponents = []})
 --
 parseProjectWithConditionals :: FilePath -> ByteString -> Either (ParseError NonEmpty) (C.CondTree C.ConfVar () (Project Void String String))
-parseProjectWithConditionals = parseWith $ \fields0 -> do
-    let (fields1, sections) = C.partitionFields fields0
+parseProjectWithConditionals = parseWith $ \fields0 -> flip parseCondTree fields0 $ \fields1 sections -> do
     let fields2  = M.filterWithKey (\k _ -> k `elem` knownFields) fields1
-    (\n -> C.CondNode n () []) <$> parse fields0 fields2 sections
+    parse fields0 fields2 sections
   where
     knownFields = C.fieldGrammarKnownFieldList $ grammar []
 
+    parse :: [C.Field a] -> C.Fields C.Position -> [[C.Section C.Position]] -> C.ParseResult (Project Void String String)
     parse otherFields fields sections = do
         let prettyOtherFields = map void $ C.fromParsecFields $ filter otherFieldName otherFields
         prj <- C.parseFieldGrammar C.cabalSpecLatest fields $ grammar prettyOtherFields
@@ -419,3 +421,62 @@ readPackagesOfProject :: Project uri opt FilePath -> IO (Either (ParseError NonE
 readPackagesOfProject prj = runExceptT $ for prj $ \fp -> do
     contents <- liftIO $ BS.readFile fp
     either throwE (\gpd -> return (fp, gpd)) (parsePackage fp contents)
+
+-------------------------------------------------------------------------------
+-- Read package files
+-------------------------------------------------------------------------------
+
+parseCondTree
+  :: forall a. (C.Fields C.Position -> [[C.Section C.Position]] -> C.ParseResult a)  -- ^ parse
+  -> [C.Field C.Position]
+  -> C.ParseResult (C.CondTree C.ConfVar () a)
+parseCondTree subparse = go
+  where
+    go fields = do
+      let (fs, ss) = C.partitionFields fields
+      (ss', branches) <- second concat . unzip <$> traverse (parseIfs id id) ss
+      x <- subparse fs ss'
+      return $ C.CondNode x () branches
+
+    parseIfs
+        :: ([C.Section C.Position] -> [C.Section C.Position])
+        -> ([C.CondBranch C.ConfVar () a] -> [C.CondBranch C.ConfVar () a])
+        -> [C.Section C.Position]
+        -> C.ParseResult ([C.Section C.Position], [C.CondBranch C.ConfVar () a])
+    parseIfs accS accB [] = return (accS [], accB [])
+    parseIfs accS accB (C.MkSection (C.Name _ name) test fields : sections) | name == "if" = do
+      test' <- C.parseConditionConfVar test
+      fields' <- go fields
+      -- TODO: (elseFields, sections') <- parseElseIfs sections
+      let condTree :: C.CondBranch C.ConfVar () a
+          condTree = C.CondBranch test' fields' Nothing
+      parseIfs accS (accB . (condTree :)) sections
+    parseIfs accS accB (section : sections) = do
+      parseIfs (accS . (section :)) accB sections
+
+{-
+    parseElseIfs
+      :: [Section Position]
+      -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a])
+    parseElseIfs [] = return (Nothing, [])
+    parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do
+      unless (null args) $
+        parseFailure pos $
+          "`else` section has section arguments " ++ show args
+      elseFields <- go fields
+      sections' <- parseIfs sections
+      return (Just elseFields, sections')
+    parseElseIfs (MkSection (Name _ name) test fields : sections)
+      | hasElif == HasElif
+      , name == "elif" = do
+          test' <- parseConditionConfVar test
+          fields' <- go fields
+          (elseFields, sections') <- parseElseIfs sections
+          -- we parse an empty 'Fields', to get empty value for a node
+          a <- parseFieldGrammar v mempty grammar
+          return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
+    parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do
+      parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals."
+      (,) Nothing <$> parseIfs sections
+    parseElseIfs sections = (,) Nothing <$> parseIfs sections
+-}