From 70f8330a21c335f36980f4b491d5b4e65a035c1c Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Thu, 18 Feb 2021 14:18:32 +0100 Subject: Compatibility with more plan.json files --- Coolbal/CabalPlan.hs | 66 ++++++++++++++++++++++++++++++++++---------- Coolbal/Target/Executable.hs | 3 +- Main.hs | 6 ++-- 3 files changed, 57 insertions(+), 18 deletions(-) diff --git a/Coolbal/CabalPlan.hs b/Coolbal/CabalPlan.hs index 6d0bd04..ae6dbf6 100644 --- a/Coolbal/CabalPlan.hs +++ b/Coolbal/CabalPlan.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ViewPatterns #-} module Coolbal.CabalPlan ( CabalPlan(..), PlanPackage(..), + ParseResult(..), parseCabalPlan, ) where @@ -12,6 +14,7 @@ import Data.Foldable (toList) import Data.List (find) import qualified GHC.Exts as IsList (IsList(..)) import qualified Json +import System.IO.Error (catchIOError) data CabalPlan = CabalPlan @@ -23,44 +26,77 @@ data PlanPackage = PreExisting { ppName :: String , ppVersion :: String - , ppDepends :: [String] } + , ppDepends :: Maybe [String] } | Configured { ppName :: String , ppVersion :: String , ppLocal :: Bool - , ppComponent :: String - , ppDepends :: [String] } + , ppDepends :: Maybe [String] } deriving (Show) +data ParseResult e a = NotFound | ParseError e | Parsed a + deriving (Show) + +instance Functor (ParseResult e) where + fmap _ NotFound = NotFound + fmap _ (ParseError e) = ParseError e + fmap f (Parsed x) = Parsed (f x) + +instance Applicative (ParseResult e) where + pure = Parsed + NotFound <*> _ = NotFound + _ <*> NotFound = NotFound + ParseError e <*> _ = ParseError e + _ <*> ParseError e = ParseError e + Parsed f <*> Parsed x = Parsed (f x) + +instance Monad (ParseResult e) where + NotFound >>= _ = NotFound + ParseError e >>= _ = ParseError e + Parsed x >>= f = f x + +instance MonadFail (ParseResult String) where + fail = ParseError + -parseCabalPlan :: FilePath -> IO (Maybe CabalPlan) -parseCabalPlan fpath = parseFromValue <$> Bytes.readFile fpath +parseCabalPlan :: FilePath -> IO (ParseResult String CabalPlan) +parseCabalPlan fpath = do + res <- (Just <$> Bytes.readFile fpath) `catchIOError` (\_ -> return Nothing) + case res of + Nothing -> return NotFound + Just contents -> return (parseFromValue contents) where parseFromValue (Json.decode -> Right toplevel) = do Json.Object obj <- return toplevel Json.String compiler <- locate "compiler-id" obj Json.Array pkgs <- locate "install-plan" obj CabalPlan (IsList.toList compiler) <$> mapM parsePackage (toList pkgs) - parseFromValue _ = Nothing + parseFromValue _ = fail "JSON decode failed" parsePackage value = do Json.Object obj <- return value Json.String typ <- locate "type" obj Json.String name <- locate "pkg-name" obj Json.String version <- locate "pkg-version" obj - Json.Array dependsArr <- locate "depends" obj - depends <- mapM (\case Json.String s -> Just s ; _ -> Nothing) (toList dependsArr) + depends <- case locate "depends" obj of + Parsed (Json.Array dependsArr) -> + Just <$> mapM (\case Json.String s -> return (IsList.toList s) + _ -> fail "Dependency is not a string") + (toList dependsArr) + _ -> return Nothing if | typ == IsList.fromList "pre-existing" -> - return (PreExisting (IsList.toList name) (IsList.toList version) (map IsList.toList depends)) + return (PreExisting (IsList.toList name) (IsList.toList version) depends) | typ == IsList.fromList "configured" -> do Json.String style <- locate "style" obj - Json.String component <- locate "component-name" obj return (Configured (IsList.toList name) (IsList.toList version) (style == IsList.fromList "local") - (IsList.toList component) - (map IsList.toList depends)) + depends) | otherwise -> - Nothing + fail ("Unknown package type '" ++ IsList.toList typ ++ "'") -locate :: Foldable f => String -> f Json.Member -> Maybe Json.Value -locate key = fmap (\(Json.Member _ v) -> v) . find (\(Json.Member k _) -> k == IsList.fromList key) +locate :: Foldable f => String -> f Json.Member -> ParseResult String Json.Value +locate key l + | Just value <- fmap (\(Json.Member _ v) -> v) (find (\(Json.Member k _) -> k == IsList.fromList key) l) + = return value + | otherwise + = fail ("Key not found in object: '" ++ key ++ "'") diff --git a/Coolbal/Target/Executable.hs b/Coolbal/Target/Executable.hs index 6358ab7..725b057 100644 --- a/Coolbal/Target/Executable.hs +++ b/Coolbal/Target/Executable.hs @@ -28,10 +28,11 @@ makeExeTarget exe plan , Just language <- defaultLanguage bi , True <- language `elem` knownLanguages , Just flags <- lookup GHC (perCompilerFlavorToList (options bi)) + , Just deps <- ppDepends planpkg = Just (ExeTarget { exeTargetName = unUnqualComponentName (exeName exe) , exeTargetPkgDbDir = currentHomeDirectory ++ "/.cabal/store/" ++ planCompiler plan ++ "/package.db" - , exeTargetDeps = ppDepends planpkg + , exeTargetDeps = deps , exeTargetLanguage = show language , exeTargetMain = modulePath exe , exeTargetSrcDirs = hsSourceDirs bi diff --git a/Main.hs b/Main.hs index 5cbf592..c1f5f9b 100644 --- a/Main.hs +++ b/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Main where import Control.Monad (forM_, when) @@ -35,8 +36,9 @@ compatibleTargets pd plan = parseCabalPlan' :: FoundCabalSpec -> IO CabalPlan parseCabalPlan' foundSpec = parseCabalPlan (foundcsRootDir foundSpec "dist-newstyle/cache/plan.json") - >>= maybe (die "Cabal plan.json not found; make sure to run 'cabal build' beforehand") - return + >>= \case NotFound -> die "Cabal plan.json not found; make sure to run 'cabal build' beforehand" + ParseError e -> die ("Error when parsing Cabal plan.json: " ++ e) + Parsed plan -> return plan readCachedTargets :: (AnyTarget -> Bool) -> IO (FilePath, [AnyTarget], [(String, [AnyTarget])]) readCachedTargets predicate = do -- cgit v1.2.3-54-g00ecf