diff options
| -rw-r--r-- | Coolbal/CabalPlan.hs | 66 | ||||
| -rw-r--r-- | Coolbal/Target/Executable.hs | 3 | ||||
| -rw-r--r-- | 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 @@ -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 |