module Cabal.Plan
(
PlanJson(..)
, Unit(..)
, CompName(..)
, dispCompName
, CompInfo(..)
, UnitType(..)
, Ver(..)
, dispVer
, PkgName(..)
, PkgId(..)
, dispPkgId
, UnitId(..)
, Sha256(..)
, dispSha256
, planJsonIdGraph
, planJsonIdRoots
, findAndDecodePlanJson
, decodePlanJson
) where
import Control.Applicative as App
import Control.Monad
import Data.Aeson
import Data.Aeson.Types
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Version as DV
import System.Directory
import System.FilePath
import Text.ParserCombinators.ReadP
newtype Ver = Ver [Int]
deriving (Show,Eq,Ord)
newtype UnitId = UnitId Text
deriving (Show,Eq,Ord,FromJSON,ToJSON)
newtype PkgName = PkgName Text
deriving (Show,Eq,Ord,FromJSON,ToJSON)
data PkgId = PkgId !PkgName !Ver
deriving (Show,Eq,Ord)
newtype Sha256 = Sha256 B.ByteString
deriving (Eq,Ord)
data PlanJson = PlanJson
{ pjCabalVersion :: !Ver
, pjCabalLibVersion :: !Ver
, pjCompilerId :: !PkgId
, pjArch :: !Text
, pjOs :: !Text
, pjUnits :: !(M.Map UnitId Unit)
} deriving Show
data UnitType = UnitTypeBuiltin
| UnitTypeGlobal
| UnitTypeLocal
| UnitTypeInplace
deriving (Show,Eq)
data Unit = Unit
{ uId :: !UnitId
, uPId :: !PkgId
, uType :: !UnitType
, uSha256 :: !(Maybe Sha256)
, uComps :: !(Map CompName CompInfo)
, uFlags :: !(Map Text Bool)
} deriving Show
data CompName =
CompNameLib
| CompNameSubLib !Text
| CompNameExe !Text
| CompNameTest !Text
| CompNameBench !Text
| CompNameSetup
deriving (Show, Eq, Ord)
data CompInfo = CompInfo
{ ciLibDeps :: Set UnitId
, ciExeDeps :: Set UnitId
, ciBinFile :: Maybe FilePath
} deriving Show
instance FromJSON CompName where
parseJSON = withText "CompName" (maybe (fail "invalid CompName") pure . parseCompName)
instance ToJSON CompName where
toJSON = toJSON . dispCompName
instance FromJSONKey CompName where
fromJSONKey = FromJSONKeyTextParser (maybe (fail "CompName") pure . parseCompName)
instance ToJSONKey CompName where
toJSONKey = toJSONKeyText dispCompName
instance FromJSON CompInfo where
parseJSON = withObject "CompInfo" $ \o ->
CompInfo <$> o .:?! "depends"
<*> o .:?! "exe-depends"
<*> o .:? "bin-file"
instance FromJSON PkgId where
parseJSON = withText "PkgId" (maybe (fail "PkgId") pure . parsePkgId)
instance ToJSON PkgId where
toJSON = toJSON . dispPkgId
parseCompName :: Text -> Maybe CompName
parseCompName t0 = case T.splitOn ":" t0 of
["lib"] -> Just CompNameLib
["lib",n] -> Just $ CompNameSubLib n
["exe",n] -> Just $ CompNameExe n
["bench",n] -> Just $ CompNameBench n
["test",n] -> Just $ CompNameTest n
["setup"] -> Just CompNameSetup
_ -> Nothing
dispCompName :: CompName -> Text
dispCompName cn = case cn of
CompNameLib -> "lib"
CompNameSubLib n -> "lib:" <> n
CompNameExe n -> "exe:" <> n
CompNameBench n -> "bench:" <> n
CompNameTest n -> "test:" <> n
CompNameSetup -> "setup"
instance FromJSON PlanJson where
parseJSON = withObject "PlanJson" $ \o -> do
pjCabalVersion <- o .: "cabal-version"
unless (pjCabalVersion >= Ver [2]) $
fail ("plan.json version " ++ T.unpack (dispVer pjCabalVersion) ++ " not supported")
pjCabalLibVersion <- o .: "cabal-lib-version"
pjCompilerId <- o .: "compiler-id"
pjArch <- o .: "arch"
pjOs <- o .: "os"
pjUnits <- toMap =<< o .: "install-plan"
App.pure PlanJson{..}
where
toMap pil = do
let pim = M.fromList [ (uId pi',pi') | pi' <- pil ]
unless (M.size pim == length pil) $
fail "install-plan[] has duplicate ids"
pure pim
(.:?!) :: (FromJSON a, Monoid a) => Object -> Text -> Parser a
o .:?! fld = o .:? fld .!= mempty
planItemAllDeps :: Unit -> Set UnitId
planItemAllDeps Unit{..} = mconcat [ ciLibDeps <> ciExeDeps | CompInfo{..} <- M.elems uComps ]
instance FromJSON Unit where
parseJSON = withObject "Unit" $ \o -> do
mcomponents <- o .:? "components"
mcomponentname <- o .:? "component-name"
ty <- o .: "type"
mstyle <- o .:? "style"
uId <- o .: "id"
uPId <- PkgId <$> o .: "pkg-name" <*> o .: "pkg-version"
uType <- case (ty :: Text, mstyle :: Maybe Text) of
("pre-existing",Nothing) -> pure UnitTypeBuiltin
("configured",Just "global") -> pure UnitTypeGlobal
("configured",Just "local") -> pure UnitTypeLocal
("configured",Just "inplace") -> pure UnitTypeInplace
_ -> fail (show (ty,mstyle))
uFlags <- o .:?! "flags"
uSha256 <- o .:? "pkg-src-sha256"
uComps <- case (mcomponents, mcomponentname) of
(Just comps0, Nothing) ->
pure comps0
(Nothing, Just cname) ->
M.singleton cname <$> parseJSON (Object o)
(Nothing, Nothing) | uType == UnitTypeBuiltin ->
M.singleton CompNameLib <$> parseJSON (Object o)
_ -> fail (show o)
pure Unit{..}
findAndDecodePlanJson :: IO (PlanJson, FilePath)
findAndDecodePlanJson = do
projbase <- findProjRoot
let distFolder = projbase </> "dist-newstyle"
haveDistFolder <- doesDirectoryExist distFolder
unless haveDistFolder $
fail ("missing " ++ show distFolder ++ " folder; do you need to run 'cabal new-build'?")
let planJsonFn = distFolder </> "cache" </> "plan.json"
havePlanJson <- doesFileExist planJsonFn
unless havePlanJson $
fail "missing 'plan.json' file; do you need to run 'cabal new-build'?"
plan <- decodePlanJson planJsonFn
pure (plan, projbase)
decodePlanJson :: FilePath -> IO PlanJson
decodePlanJson planJsonFn = do
jsraw <- B.readFile planJsonFn
either fail pure $ eitherDecodeStrict' jsraw
findProjRoot :: IO FilePath
findProjRoot = do
cwd <- getCurrentDirectory
let tst d = do let fn = d </> "cabal.project"
ex <- doesFileExist fn
if ex then pure (Just fn) else pure Nothing
md <- walkUpFolders tst cwd
pure (maybe cwd fst md)
walkUpFolders :: (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe (FilePath,a))
walkUpFolders dtest d0 = do
home <- getHomeDirectory
let go d | d == home = pure Nothing
| isDrive d = pure Nothing
| otherwise = do
t <- dtest d
case t of
Just a -> pure $ Just (d, a)
Nothing -> go (takeDirectory d)
go d0
parseVer :: Text -> Maybe Ver
parseVer str = case reverse $ readP_to_S DV.parseVersion (T.unpack str) of
(ver, "") : _ | not (null (DV.versionBranch ver)), all (>= 0) (DV.versionBranch ver)
-> Just (Ver $ DV.versionBranch ver)
_ -> Nothing
dispVer :: Ver -> Text
dispVer (Ver ns) = T.pack $ intercalate "." (map show ns)
instance FromJSON Ver where
parseJSON = withText "Ver" (maybe (fail "Ver") pure . parseVer)
instance ToJSON Ver where
toJSON = toJSON . dispVer
parsePkgId :: Text -> Maybe PkgId
parsePkgId t = do
let (pns_, pvs) = T.breakOnEnd "-" t
pv <- parseVer pvs
pn <- T.stripSuffix "-" pns_
pure (PkgId (PkgName pn) pv)
dispPkgId :: PkgId -> Text
dispPkgId (PkgId (PkgName pn) pv) = pn <> "-" <> dispVer pv
parseSha256 :: Text -> Maybe Sha256
parseSha256 t
| B.length s == 32, B.null rest = Just (Sha256 s)
| otherwise = Nothing
where
(s, rest) = B16.decode $ T.encodeUtf8 t
dispSha256 :: Sha256 -> Text
dispSha256 (Sha256 s) = T.decodeLatin1 (B16.encode s)
instance FromJSON Sha256 where
parseJSON = withText "Sha256" (maybe (fail "Sha256") pure . parseSha256)
instance ToJSON Sha256 where
toJSON = toJSON . dispSha256
instance Show Sha256 where
show = show . dispSha256
planJsonIdGraph :: PlanJson -> Map UnitId (Set UnitId)
planJsonIdGraph PlanJson{..} = M.fromList [ (uId unit, planItemAllDeps unit)
| unit <- M.elems pjUnits
]
planJsonIdRoots :: PlanJson -> Set UnitId
planJsonIdRoots PlanJson{..} = M.keysSet pjUnits `S.difference` nonRoots
where
nonRoots :: Set UnitId
nonRoots = mconcat $ M.elems $ planJsonIdGraph PlanJson{..}