Make compilerVersion accessor project-scope for V1 projects

5 files changed, 83 insertions, 33 deletions

diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs
index 6d9c831..8989273 100644
--- a/lib/Distribution/Helper.hs
+++ b/lib/Distribution/Helper.hs
@@ -96,11 +96,13 @@ module Distribution.Helper (
   ) where
 
 import Cabal.Plan hiding (Unit, UnitId, uDistDir)
+import Control.Arrow (first)
 import Control.Applicative
 import Control.Monad
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
 import Control.Exception as E
+import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
 import Data.List hiding (filter)
 import Data.String
@@ -266,17 +268,21 @@ getUnitModTimes
 
 
 -- | The version of GHC the project is configured to use for compilation.
-compilerVersion       :: Query pt (String, Version)
+compilerVersion :: Query pt (String, Version)
 compilerVersion = Query $ \qe ->
   getProjInfo qe >>= \proj_info ->
     let someUnit = NonEmpty.head $ piUnits proj_info in
-    --  ^ TODO: ASSUMPTION: Here we assume the compiler version is uniform
-    --  across all units so we just pick any one. I'm not sure this is true for
-    --  Stack.
+    --  ^ ASSUMPTION: Here we assume the compiler version is uniform across all
+    --  units so we just pick any one.
     case piImpl proj_info of
-      ProjInfoV1 -> uiCompilerId <$> getUnitInfo qe someUnit
+      ProjInfoV1 { piV1SetupHeader=UnitHeader{..} } ->
+          return $ first BS8.unpack $ uhCompilerId
+      --  ^ The package name here is restricted to Latin-1 because of the way
+      --  Cabal writes the header. Shouldn't matter too much V1 is legacy
+      --  anyways and GHC and it's glorious ASCII name rule the Haskell world.
       ProjInfoV2 { piV2CompilerId } -> return piV2CompilerId
       ProjInfoStack {} -> uiCompilerId <$> getUnitInfo qe someUnit
+      --  ^ TODO: Any way to get this faster for stack?
 
 -- | All local units currently active in a project\'s build plan.
 projectUnits          :: Query pt (NonEmpty (Unit pt))
@@ -432,11 +438,9 @@ readProjInfo qe pc pcm = withVerbosity $ do
     (DistDirV1 distdir, ProjConfV1{pcV1CabalFile}) -> do
       let projdir = plV1Dir projloc
       setup_config_path <- canonicalizePath (distdir </> "setup-config")
-      mhdr <- getCabalConfigHeader setup_config_path
+      mhdr <- readSetupConfigHeader setup_config_path
       case mhdr of
-        Nothing ->
-          panicIO $ printf "Could not read '%s' header" setup_config_path
-        Just (hdrCabalVersion, _) ->
+        Just hdr@(UnitHeader _pkgId ("Cabal", hdrCabalVersion) _compId) ->
           return ProjInfo
             { piCabalVersion = hdrCabalVersion
             , piProjConfModTimes = pcm
@@ -448,7 +452,15 @@ readProjInfo qe pc pcm = withVerbosity $ do
               , uImpl = UnitImplV1
               }
             , piImpl = ProjInfoV1
+              { piV1SetupHeader = hdr
+              }
             }
+        Just UnitHeader {uhSetupId=(setup_name, _)} ->
+          panicIO $ printf "Unknown Setup package-id in setup-config header '%s': '%s'"
+                      (BS8.unpack setup_name) setup_config_path
+        Nothing ->
+          panicIO $ printf "Could not read '%s' header" setup_config_path
+
     (DistDirV2 distdirv2, _) -> do
       let plan_path = distdirv2 </> "cache" </> "plan.json"
       plan_mtime <- modificationTime <$> getFileStatus plan_path
diff --git a/src/CabalHelper/Compiletime/Cabal.hs b/src/CabalHelper/Compiletime/Cabal.hs
index 69817c7..17f4d7f 100644
--- a/src/CabalHelper/Compiletime/Cabal.hs
+++ b/src/CabalHelper/Compiletime/Cabal.hs
@@ -20,11 +20,12 @@ Description : Cabal library source unpacking
 License     : GPL-3
 -}
 
-{-# LANGUAGE DeriveFunctor, ViewPatterns, CPP #-}
+{-# LANGUAGE DeriveFunctor, ViewPatterns, OverloadedStrings, CPP #-}
 
 module CabalHelper.Compiletime.Cabal where
 
 import Data.Char
+import Control.Exception
 import Data.List
 import Data.Maybe
 import Data.Time.Calendar
@@ -34,13 +35,15 @@ import Data.Version
 import System.Directory
 import System.Exit
 import System.FilePath
+import System.IO
 import Text.Printf
 
-
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
 
 import CabalHelper.Compiletime.Types
 import CabalHelper.Compiletime.Process
-import CabalHelper.Shared.Common (replace, parseVer, parseVerMay)
+import CabalHelper.Shared.Common (replace, parseVer, parseVerMay, parsePkgIdBS)
 
 type UnpackedCabalVersion = CabalVersion' (CommitId, CabalSourceDir)
 type ResolvedCabalVersion = CabalVersion' CommitId
@@ -259,3 +262,18 @@ findCabalFile pkgdir = do
 
 bultinCabalVersion :: Version
 bultinCabalVersion = parseVer VERSION_Cabal
+
+readSetupConfigHeader :: FilePath -> IO (Maybe UnitHeader)
+readSetupConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do
+  parseSetupHeader <$> BS.hGetLine h
+
+parseSetupHeader :: BS.ByteString -> Maybe UnitHeader
+parseSetupHeader header = case BS8.words header of
+  ["Saved", "package", "config", "for", pkgId ,
+   "written", "by", setupId,
+   "using", compId]
+    -> UnitHeader
+       <$> parsePkgIdBS pkgId
+       <*> parsePkgIdBS setupId
+       <*> parsePkgIdBS compId
+  _ -> Nothing
diff --git a/src/CabalHelper/Compiletime/Program/GHC.hs b/src/CabalHelper/Compiletime/Program/GHC.hs
index 644c6ec..547911f 100644
--- a/src/CabalHelper/Compiletime/Program/GHC.hs
+++ b/src/CabalHelper/Compiletime/Program/GHC.hs
@@ -112,7 +112,7 @@ listCabalVersions mdb = do
     True -> MaybeT $ logIOError "listCabalVersions" $ Just <$> do
       let mdbopt = ("--package-conf="++) <$> mdb_path
           args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
-      catMaybes . map (fmap snd . parsePkgId . fromString) . words
+      catMaybes . map (fmap snd . parsePkgId) . words
                <$> readProcess' (ghcPkgProgram ?cprogs) args ""
     _ -> mzero
 
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index 9911aec..95eea9f 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -27,6 +27,7 @@ module CabalHelper.Compiletime.Types where
 
 import Cabal.Plan
   ( PlanJson )
+import Data.ByteString (ByteString)
 import Data.IORef
 import Data.Version
 import Data.Typeable
@@ -229,6 +230,25 @@ uComponentName Unit { uImpl=UnitImplV2 { uiV2ComponentNames=[comp] } } =
 uComponentName _ =
     Nothing
 
+-- | The @setup-config@ header. Note that Cabal writes all the package names in
+-- the header using 'Data.ByteString.Char8' and hence all characters are
+-- truncated from Unicode codepoints to 8-bit Latin-1.
+--
+-- We can be fairly confident that 'uhSetupId' and 'uhCompilerId' won\'t have
+-- names that cause trouble here so it's ok to look at them but user packages
+-- are free to have any unicode name.
+data UnitHeader = UnitHeader
+    { uhBrokenPackageId  :: !(ByteString, Version)
+      -- ^ Name and version of the source package. Don't use this, it's broken
+      -- when the package name contains Unicode characters. See 'uiPackageId'
+      -- instead.
+    , uhSetupId    :: !(ByteString, Version)
+      -- ^ Name and version of the @Setup.hs@ implementation. We expect
+      -- @"Cabal"@ here, naturally.
+    , uhCompilerId :: !(ByteString, Version)
+      -- ^ Name and version of the compiler this Unit is configured to use.
+    } deriving (Eq, Ord, Read, Show)
+
 newtype UnitId = UnitId String
     deriving (Eq, Ord, Read, Show)
 
@@ -300,7 +320,9 @@ data ProjInfo pt = ProjInfo
   } deriving (Show)
 
 data ProjInfoImpl pt where
-  ProjInfoV1 :: ProjInfoImpl 'V1
+  ProjInfoV1 ::
+    { piV1SetupHeader :: !UnitHeader
+    } -> ProjInfoImpl 'V1
 
   ProjInfoV2 ::
     { piV2Plan        :: !PlanJson
@@ -313,7 +335,11 @@ data ProjInfoImpl pt where
     } -> ProjInfoImpl 'Stack
 
 instance Show (ProjInfoImpl pt) where
-    show ProjInfoV1 = "ProjInfoV1"
+    show ProjInfoV1 {..} = concat
+      [ "ProjInfoV1 {"
+      , "piV1SetupHeader = ", show piV1SetupHeader, ", "
+      , "}"
+      ]
     show ProjInfoV2 {..} = concat
       [ "ProjInfoV2 {"
       , "piV2Plan = ", show piV2Plan, ", "
diff --git a/src/CabalHelper/Shared/Common.hs b/src/CabalHelper/Shared/Common.hs
index 2d4b037..d65722b 100644
--- a/src/CabalHelper/Shared/Common.hs
+++ b/src/CabalHelper/Shared/Common.hs
@@ -81,24 +81,18 @@ errMsg str = do
   prog <- getProgName
   hPutStrLn stderr $ prog ++ ": " ++ str
 
--- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and
--- compiler version
-getCabalConfigHeader :: FilePath -> IO (Maybe (Version, (ByteString, Version)))
-getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do
-  parseHeader <$> BS.hGetLine h
-
-parseHeader :: ByteString -> Maybe (Version, (ByteString, Version))
-parseHeader header = case BS8.words header of
-  ["Saved", "package", "config", "for", _pkgId ,
-   "written", "by", cabalId,
-   "using", compId]
-    -> liftM2 (,) (snd <$> parsePkgId cabalId) (parsePkgId compId)
-  _ -> Nothing
-
-parsePkgId :: ByteString -> Maybe (ByteString, Version)
-parsePkgId bs =
-    case BS8.split '-' bs of
-      [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers)
+parsePkgId :: String -> Maybe (String, Version)
+parsePkgId s =
+    case span (/='-') (reverse s) of
+      (vers, '-':pkg) -> Just (reverse pkg, parseVer (reverse vers))
+      _ -> Nothing
+
+parsePkgIdBS :: ByteString -> Maybe (ByteString, Version)
+parsePkgIdBS bs =
+    case BS8.span (/='-') (BS.reverse bs) of
+      (vers, pkg') ->
+          Just ( BS.reverse $ BS.tail pkg'
+               , parseVer (BS8.unpack (BS.reverse vers)))
       _ -> Nothing
 
 parseVer :: String -> Version