blob: ae6dbf6353b3ac08f1d6256449865407c9e2e3ce (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
module Coolbal.CabalPlan (
CabalPlan(..),
PlanPackage(..),
ParseResult(..),
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
import System.IO.Error (catchIOError)
data CabalPlan = CabalPlan
{ planCompiler :: String
, planPackages :: [PlanPackage] }
deriving (Show)
data PlanPackage
= PreExisting
{ ppName :: String
, ppVersion :: String
, ppDepends :: Maybe [String] }
| Configured
{ ppName :: String
, ppVersion :: String
, ppLocal :: Bool
, 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 (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 _ = 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
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) depends)
| typ == IsList.fromList "configured" -> do
Json.String style <- locate "style" obj
return (Configured (IsList.toList name) (IsList.toList version)
(style == IsList.fromList "local")
depends)
| otherwise ->
fail ("Unknown package type '" ++ IsList.toList typ ++ "'")
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 ++ "'")
|
