summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Coolbal/CabalPlan.hs66
-rw-r--r--Coolbal/Target/Executable.hs3
-rw-r--r--Main.hs6
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