WIP

Author: phadej

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

@@ -1,10 +1,10 @@
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE DeriveFoldable    #-}
-{-# LANGUAGE DeriveFunctor     #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE MultiWayIf        #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE DeriveFoldable      #-}
+{-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE DeriveTraversable   #-}
+{-# LANGUAGE MultiWayIf          #-}
+{-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 -- | License: GPL-3.0-or-later AND BSD-3-Clause
 --
@@ -58,9 +58,9 @@ import qualified Data.Map.Strict                 as M
 import qualified Distribution.CabalSpecVersion   as C
 import qualified Distribution.FieldGrammar       as C
 import qualified Distribution.Fields             as C
+import qualified Distribution.Fields.ConfVar     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
@@ -433,38 +433,48 @@ parseCondTree
 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
+        let (fs, ss) = C.partitionFields fields
+        (ss', branches) <- second concat . unzip <$> traverse (goIfs id id) ss
+        x <- subparse fs ss'
+        return $ C.CondNode x () branches
 
-    parseIfs
+    goIfs
         :: ([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
-      parseElseIfs (C.CondBranch test' fields') accS accB sections
-    parseIfs accS accB (section : sections) = do
-      parseIfs (accS . (section :)) accB sections
-
-    parseElseIfs 
+    goIfs accS accB [] =
+        return (accS [], accB [])
+    goIfs accS accB (C.MkSection (C.Name pos name) test fields : sections)
+        | name == "if" = do
+            test' <- C.parseConditionConfVar test
+            fields' <- go fields
+            goElse (C.CondBranch test' fields') accS accB sections
+        | name == "else" = do
+            C.parseFailure pos "standalone else"
+            return ([], [])
+        | name == "elif" = do
+            C.parseFailure pos "standalone elif"
+            goIfs accS accB sections
+    goIfs accS accB (section : sections) = do
+        goIfs (accS . (section :)) accB sections
+
+    goElse
         :: (Maybe (C.CondTree C.ConfVar () a) -> C.CondBranch C.ConfVar () a)
         -> ([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])
-    parseElseIfs make accS accB [] = do
+    goElse make accS accB [] = do
         let condTree = make Nothing
         return (accS [], accB [condTree])
-    parseElseIfs make accS accB (C.MkSection (C.Name pos name) _args _fields : _sections) | name == "else" = do
-        C.parseFailure pos "else is not supprted yet"
-        return ([], [])
-    parseElseIfs make accS accB (C.MkSection (C.Name pos name) _args _fields : _sections) | name == "elif" = do
-        C.parseFailure pos "elif is not supprted yet"
-        return ([], [])
-    parseElseIfs make accS accB (section : sections) = do
-        parseIfs (accS . (section :)) (accB . (make Nothing :)) sections
+    goElse _make _accS _accB (C.MkSection (C.Name pos name) _args _fields : _sections)
+        | name == "else" = do
+            C.parseFailure pos "else is not supprted yet"
+            return ([], [])
+        | name == "elif" = do
+            C.parseFailure pos "elif is not supprted yet"
+            return ([], [])
+    goElse make accS accB (section : sections) = do
+        let condTree = make Nothing
+        goIfs (accS . (section :)) (accB . (condTree :)) sections

src/HaskellCI.hs

@@ -35,8 +35,8 @@ import System.Process        (readProcessWithExitCode)
 
 import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription, testedWith)
 import Distribution.Text
+import Distribution.Types.CondTree     (CondBranch (..), CondTree (..))
 import Distribution.Version
-import Distribution.Types.CondTree (CondTree (..), CondBranch (..))
 
 import qualified Data.ByteString       as BS
 import qualified Data.List.NonEmpty    as NE
@@ -363,7 +363,7 @@ getCabalFiles InputTypeProject path = do
     contents <- liftIO $ BS.readFile path
     prj0 <- either (putStrLnErr . renderParseError) return $ parseProjectWithConditionals path contents
     let prj0' :: Project Void String String
-        prj0' = simplifyProject prj0   
+        prj0' = simplifyProject prj0
     prj1 <- either (putStrLnErr . renderResolveError) return =<< liftIO (resolveProject path prj0')
     either (putStrLnErr . renderParseError) return =<< liftIO (readPackagesOfProject prj1)
 getCabalFiles InputTypePackage path = do
@@ -378,18 +378,19 @@ simplifyProject' :: CondBranch v d (Project Void String String) -> Project Void
 simplifyProject' (CondBranch _ t Nothing)  = simplifyProject t
 simplifyProject' (CondBranch _ t (Just e)) = simplifyProject t <<>> simplifyProject e
 
+-- TODO: we preserve only top-level structure and packages specs.
 (<<>>) :: Project pkg opt uri -> Project pkg opt uri -> Project pkg opt uri
 x <<>> y = Project
-    { prjPackages     = prjPackages x <> prjPackages y 
+    { prjPackages     = prjPackages x <> prjPackages y
     , prjOptPackages  = prjOptPackages x <> prjOptPackages y
     , prjUriPackages  = prjUriPackages x <> prjUriPackages y
-    , prjConstraints  = prjConstraints x <> prjConstraints y
-    , prjAllowNewer   = prjAllowNewer x <> prjAllowNewer y
-    , prjReorderGoals = prjReorderGoals x || prjReorderGoals y
-    , prjMaxBackjumps = max (prjMaxBackjumps x) (prjMaxBackjumps y)
+    , prjConstraints  = prjConstraints x
+    , prjAllowNewer   = prjAllowNewer x
+    , prjReorderGoals = prjReorderGoals x
+    , prjMaxBackjumps = prjMaxBackjumps x
     , prjOptimization = prjOptimization x
-    , prjSourceRepos  = prjSourceRepos x <> prjSourceRepos y
-    , prjOtherFields  = prjOtherFields x<> prjOtherFields y
+    , prjSourceRepos  = prjSourceRepos x
+    , prjOtherFields  = prjOtherFields x
     }
 
 -------------------------------------------------------------------------------