{-# 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 ++ "'")