1 files changed, 66 insertions, 0 deletions
diff --git a/Coolbal/CabalPlan.hs b/Coolbal/CabalPlan.hs
new file mode 100644
index 0000000..6d0bd04
--- /dev/null
+++ b/Coolbal/CabalPlan.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE ViewPatterns #-}
+module Coolbal.CabalPlan (
+    CabalPlan(..),
+    PlanPackage(..),
+    parseCabalPlan,
+) where
+
+import qualified Data.Bytes as Bytes
+import Data.Foldable (toList)
+import Data.List (find)
+import qualified GHC.Exts as IsList (IsList(..))
+import qualified Json
+
+
+data CabalPlan = CabalPlan
+    { planCompiler :: String
+    , planPackages :: [PlanPackage] }
+  deriving (Show)
+
+data PlanPackage
+    = PreExisting 
+        { ppName :: String
+        , ppVersion :: String
+        , ppDepends :: [String] }
+    | Configured
+        { ppName :: String
+        , ppVersion :: String
+        , ppLocal :: Bool
+        , ppComponent :: String
+        , ppDepends :: [String] }
+  deriving (Show)
+
+
+parseCabalPlan :: FilePath -> IO (Maybe CabalPlan)
+parseCabalPlan fpath = parseFromValue <$> Bytes.readFile fpath
+  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
+
+    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)
+        if | typ == IsList.fromList "pre-existing" ->
+               return (PreExisting (IsList.toList name) (IsList.toList version) (map IsList.toList 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))
+           | otherwise ->
+               Nothing
+
+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)