diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/CabalHelper/Compiletime/Cabal.hs | 24 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Program/GHC.hs | 2 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 30 | ||||
| -rw-r--r-- | src/CabalHelper/Shared/Common.hs | 30 |
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 |