From 70f8330a21c335f36980f4b491d5b4e65a035c1c Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Thu, 18 Feb 2021 14:18:32 +0100
Subject: Compatibility with more plan.json files

---
 Coolbal/CabalPlan.hs | 66 ++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 51 insertions(+), 15 deletions(-)

(limited to 'Coolbal/CabalPlan.hs')

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 ++ "'")
-- 
cgit v1.2.3-70-g09d2