aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/CabalHelper/Compiletime/Cabal.hs24
-rw-r--r--src/CabalHelper/Compiletime/Program/GHC.hs2
-rw-r--r--src/CabalHelper/Compiletime/Types.hs30
-rw-r--r--src/CabalHelper/Shared/Common.hs30
4 files changed, 62 insertions, 24 deletions
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