Merge pull request commercialhaskell#2085 from phadej/issue-2084

Resolve commercialhaskell#2084: Rewrite solver output parseLine using regexp

src/Stack/Package.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -9,7 +10,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE CPP #-}
 
 -- | Dealing with Cabal.
 
@@ -37,21 +37,19 @@ module Stack.Package
   ,cabalFilePackageId)
   where
 
-#if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative (Applicative, (<$>), (<*>))
-#endif
+import Prelude ()
+import Prelude.Compat
 
 import           Control.Arrow ((&&&))
 import           Control.Exception hiding (try,catch)
-import           Control.Monad
+import           Control.Monad (liftM, liftM2, (<=<), when, forM)
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger (MonadLogger,logWarn)
-import           Control.Monad.Reader
+import           Control.Monad.Reader (MonadReader,runReaderT,ask,asks)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as C8
-import           Data.Function
-import           Data.List
+import           Data.List.Compat
 import           Data.List.Extra (nubOrd)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -85,7 +83,6 @@ import           Path as FL
 import           Path.Extra
 import           Path.Find
 import           Path.IO hiding (findFiles)
-import           Prelude
 import           Safe (headDef, tailSafe)
 import           Stack.Build.Installed
 import           Stack.Constants

src/Stack/Sig/GPG.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 
 {-|
@@ -15,9 +13,8 @@ Portability : POSIX
 
 module Stack.Sig.GPG (gpgSign, gpgVerify) where
 
-#if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative ((<$>), (<*>))
-#endif
+import Prelude ()
+import Prelude.Compat
 
 import           Control.Monad.Catch (MonadThrow, throwM)
 import           Control.Monad.IO.Class (MonadIO, liftIO)

src/Stack/Sig/Sign.hs

@@ -16,9 +16,8 @@ Portability : POSIX
 
 module Stack.Sig.Sign (sign, signPackage, signTarBytes) where
 
-#if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative (Applicative(..))
-#endif
+import Prelude ()
+import Prelude.Compat
 
 import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Compression.GZip as GZip

src/Stack/Solver.hs

@@ -12,19 +12,26 @@ module Stack.Solver
     , mergeConstraints
     , solveExtraDeps
     , solveResolverSpec
+    -- * Internal - for tests
+    , parseCabalOutputLine
     ) where
 
+import Prelude ()
+import Prelude.Compat
+
 import           Control.Applicative
 import           Control.Exception (assert)
 import           Control.Exception.Enclosed  (tryIO)
+import           Control.Monad               (when,void,join,liftM,unless,zipWithM_)
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
-import           Control.Monad.Reader
+import           Control.Monad.Reader        (MonadReader, asks)
 import           Control.Monad.Trans.Control
 import           Data.Aeson.Extended         ( WithJSONWarnings(..), object, (.=), toJSON
                                              , logJSONWarnings)
 import qualified Data.ByteString             as S
+import           Data.Char                   (isSpace)
 import           Data.Either
 import           Data.Function               (on)
 import qualified Data.HashMap.Strict         as HashMap
@@ -43,16 +50,16 @@ import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
 import           Data.Text.Encoding.Error    (lenientDecode)
 import qualified Data.Text.Lazy              as LT
 import           Data.Text.Lazy.Encoding     (decodeUtf8With)
+import           Data.Tuple                  (swap)
 import qualified Data.Yaml                   as Yaml
 import qualified Distribution.Package        as C
 import qualified Distribution.PackageDescription as C
 import qualified Distribution.Text           as C
 import           Network.HTTP.Client.Conduit (HasHttpManager)
+import           Text.Regex.Applicative.Text (match, sym, psym, anySym, few)
 import           Path
 import           Path.Find                   (findFiles)
 import           Path.IO                     hiding (findExecutable, findFiles)
-import           Prelude
-import           Safe                        (headMay)
 import           Stack.BuildPlan
 import           Stack.Constants             (stackDotYaml)
 import           Stack.Package               (printCabalFileWarning
@@ -68,6 +75,7 @@ import qualified System.Directory            as D
 import qualified System.FilePath             as FP
 import           System.Process.Read
 
+
 data ConstraintType = Constraint | Preference deriving (Eq)
 type ConstraintSpec = Map PackageName (Version, Map FlagName Bool)
 
@@ -164,49 +172,13 @@ cabalSolver menv cabalfps constraintType
                $ dropWhile (not . T.isPrefixOf "In order, ")
                $ T.lines
                $ decodeUtf8 bs
-            (errs, pairs) = partitionEithers $ map parseLine ls
+            (errs, pairs) = partitionEithers $ map parseCabalOutputLine ls
         if null errs
           then return $ Right (Map.fromList pairs)
           else error $ "The following lines from cabal-install output could \
                        \not be parsed: \n"
                        ++ (T.unpack (T.intercalate "\n" errs))
 
-    -- An ugly parser to extract module id and flags
-    parseLine :: Text -> Either Text (PackageName, (Version, Map FlagName Bool))
-    parseLine t0 = maybe (Left t0) Right $ do
-        -- Sample outputs to parse:
-        -- text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package))
-        -- hspec-snap-1.0.0.0 *test (via: servant-snap-0.5) (new package)
-        -- time-locale-compat-0.1.1.1 -old-locale (via: http-api-data-0.2.2) (new package))
-
-        if (not $ T.null t0) then do
-            ident':rest <- Just $ T.words t0
-            PackageIdentifier name version <-
-                parsePackageIdentifierFromString $ T.unpack ident'
-
-            nextWord <- headMay rest
-            rest' <- case T.head nextWord of
-                '(' -> Just $ dropWhile (")" `T.isSuffixOf`) rest
-                '*' -> Just $ dropWhile ("*" `T.isPrefixOf`) rest
-                '+' -> Just rest
-                '-' -> Just rest
-                _ -> Nothing
-
-            let fl = takeWhile (not . ("(" `T.isPrefixOf`)) rest'
-            flags <- mapM parseFlag fl
-            Just (name, (version, Map.fromList flags))
-        else Nothing
-
-    parseFlag :: Text -> Maybe (FlagName, Bool)
-    parseFlag t0 = do
-        (fl, st) <- case T.head t0 of
-                '-' -> Just $ (T.tail t0, False)
-                '+' -> Just $ (T.tail t0, True)
-                _   -> Nothing
-        if (not $ T.null fl) then do
-            flag <- parseFlagNameFromString $ T.unpack fl
-            return (flag, st)
-        else Nothing
 
     toConstraintArgs userFlagMap =
         [formatFlagConstraint package flag enabled
@@ -227,6 +199,33 @@ cabalSolver menv cabalfps constraintType
     -- TODO - this should be done only for manual flags.
     flagConstraints Preference = fmap snd srcConstraints
 
+
+    -- An ugly parser to extract module id and flags
+parseCabalOutputLine :: Text -> Either Text (PackageName, (Version, Map FlagName Bool))
+parseCabalOutputLine t0 = maybe (Left t0) Right . join .  match re $ t0
+    -- Sample outputs to parse:
+    -- text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package))
+    -- hspec-snap-1.0.0.0 *test (via: servant-snap-0.5) (new package)
+    -- time-locale-compat-0.1.1.1 -old-locale (via: http-api-data-0.2.2) (new package))
+    -- flowdock-rest-0.2.0.0 -aeson-compat *test (via: haxl-fxtra-0.0.0.0) (new package)
+  where
+    re = mk <$> some (psym $ not . isSpace) <*> many (lexeme reMaybeFlag)
+
+    reMaybeFlag = 
+        (\s -> Just (True, s))  <$ sym '+' <*> some (psym $ not . isSpace) <|>
+        (\s -> Just (False, s)) <$ sym '-' <*> some (psym $ not . isSpace) <|>
+        Nothing <$ sym '*' <* some (psym $ not . isSpace) <|>
+        Nothing <$ sym '(' <* few anySym <* sym ')'
+
+    mk :: String -> [Maybe (Bool, String)] -> Maybe (PackageName, (Version, Map FlagName Bool))
+    mk ident fl = do
+        PackageIdentifier name version <-
+            parsePackageIdentifierFromString ident
+        fl' <- (traverse . traverse) parseFlagNameFromString $ catMaybes fl
+        return (name, (version, Map.fromList $ map swap fl'))
+
+    lexeme r = some (psym isSpace) *> r
+
 getCabalConfig :: (MonadLogger m, MonadReader env m, HasConfig env, MonadIO m, MonadThrow m)
                => FilePath -- ^ temp dir
                -> ConstraintType

src/Stack/Types/Sig.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE OverloadedStrings  #-}
@@ -16,9 +15,8 @@ Portability : POSIX
 module Stack.Types.Sig
        (Signature(..), Fingerprint, mkFingerprint, SigException(..)) where
 
-#if __GLASGOW_HASKELL__ < 710
-import           Control.Applicative ((<$>))
-#endif
+import Prelude ()
+import Prelude.Compat
 
 import           Control.Exception (Exception)
 import           Data.Aeson (Value(..), ToJSON(..), FromJSON(..))

src/test/Stack/SolverSpec.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Test suite for "Stack.Solver"
+module Stack.SolverSpec where
+
+import           Data.Text (unpack)
+import           Stack.Types
+import           Test.Hspec
+import qualified Data.Map as Map
+
+import Stack.Solver
+
+spec :: Spec
+spec =
+  describe "Stack.Solver" $ do
+    successfulExample 
+      "text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package)"
+      $(mkPackageName "text")
+      $(mkVersion "1.2.1.1")
+      [ ($(mkFlagName "integer-simple"), False)
+      ]
+    successfulExample 
+      "hspec-snap-1.0.0.0 *test (via: servant-snap-0.5) (new package)"
+      $(mkPackageName "hspec-snap")
+      $(mkVersion "1.0.0.0")
+      []
+    successfulExample
+      "time-locale-compat-0.1.1.1 -old-locale (via: http-api-data-0.2.2) (new package)"
+      $(mkPackageName "time-locale-compat")
+      $(mkVersion "0.1.1.1")
+      [ ($(mkFlagName "old-locale"), False)
+      ]
+    successfulExample
+      "flowdock-rest-0.2.0.0 -aeson-compat *test (via: haxl-fxtra-0.0.0.0) (new package)"
+      $(mkPackageName "flowdock-rest")
+      $(mkVersion "0.2.0.0")
+      [ ($(mkFlagName "aeson-compat"), False)
+      ]
+  where
+    successfulExample input pkgName pkgVersion flags =
+      it ("parses " ++ unpack input) $ 
+        parseCabalOutputLine input `shouldBe` Right (pkgName, (pkgVersion, Map.fromList flags))

stack-7.8.yaml

@@ -45,3 +45,4 @@ extra-deps:
 - x509-system-1.6.3
 - http-client-tls-0.2.4
 - connection-0.2.5
+- regex-applicative-text-0.1.0.1

stack.cabal

@@ -143,6 +143,7 @@ library
                    , async >= 2.0.2 && < 2.2
                    , attoparsec >= 0.12.1.5 && < 0.14
                    , base >= 4.7 && <5
+                   , base-compat >=0.6 && <0.10
                    , base16-bytestring
                    , base64-bytestring
                    , binary >= 0.7
@@ -187,6 +188,7 @@ library
                    , pretty >= 1.1.1.1
                    , process >= 1.2.0.0
                    , resourcet >= 1.1.4.1
+                   , regex-applicative-text >=0.1.0.1 && <0.2
                    , retry >= 0.6 && < 0.8
                    , safe >= 0.3
                    , semigroups >= 0.5 && < 0.19