{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Module     : Baserock.Schema.V9
-- Copyright  : (c) Daniel Firth 2018
-- License    : BSD3
-- Maintainer : locallycompact@gmail.com
-- Stability  : experimental
--
-- This file defines the V9 Baserock Yaml Schema in Haskell
--
-----------------------------------------------------------------------------
module Baserock.Schema.V9 (

  -- * Schema
  ChunkInstructions (..),
  Chunk (..),
  Stratum (..),
  StratumBD (..),
  StratumInclude (..),
  System (..),

  -- * ASTs
  
  StratumAST,
  SystemAST,

  decodeStratumAST,
  encodeStratumAST,
  decodeSystemAST,
  encodeSystemAST,

  -- * toPrettyYaml
  ToPrettyYaml(..)

) where

import Algebra.Graph
import Control.Arrow
import Control.Applicative
import Control.Error.Safe
import Control.Error.Util
import Control.Monad
import Control.Monad.Except
import qualified Data.ByteString as BS
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Text (Text, unpack)
import Data.Yaml
import Data.Yaml.Pretty

listElemCmp as x y = fromJust $ liftA2 compare (elemIndex x as) (elemIndex y as)

possibly f v = if v == mempty then mempty else [f .= v]

class ToJSON a => ToPrettyYaml a where
  fieldOrder :: a -> [Text]

  fieldCmp :: a -> (Text -> Text -> Ordering)
  fieldCmp = listElemCmp . fieldOrder

  toPrettyYaml :: a -> BS.ByteString
  toPrettyYaml x = encodePretty (setConfCompare (fieldCmp x) defConfig) x

--- ChunkInstructions ("chunk.morph")
--
data ChunkInstructions = ChunkInstructions {
  chunkInstructionsName :: Text,
  buildSystem           :: Text,
  preConfigureCommands  :: [Text],
  configureCommands     :: [Text],
  postConfigureCommands :: [Text],
  preBuildCommands      :: [Text],
  buildCommands         :: [Text],
  postBuildCommands     :: [Text],
  preInstallCommands    :: [Text],
  installCommands       :: [Text],
  postInstallCommands   :: [Text]
} deriving (Eq, Show)

instance FromJSON ChunkInstructions where
  parseJSON = withObject "ChunkInstructions" $ \v -> ChunkInstructions
    <$> v .:  "name"
    <*> v .:? "build-system"            .!= "manual"
    <*> v .:? "pre-configure-commands"  .!= []
    <*> v .:? "configure-commands"      .!= []
    <*> v .:? "post-configure-commands" .!= []
    <*> v .:? "pre-build-commands"      .!= []
    <*> v .:? "build-commands"          .!= []
    <*> v .:? "post-build-commands"     .!= []
    <*> v .:? "pre-install-commands"    .!= []
    <*> v .:? "install-commands"        .!= []
    <*> v .:? "post-install-commands"   .!= []

instance ToJSON ChunkInstructions where
   toJSON x =
      object $ ["name" .= chunkInstructionsName x, "kind" .= ("chunk" :: Text), "build-system" .= buildSystem x]
            <> possibly "pre-configure-commands"  (preConfigureCommands x)
            <> possibly "configure-commands"      (configureCommands x)
            <> possibly "post-configure-commands" (postConfigureCommands x)
            <> possibly "pre-build-commands"      (preBuildCommands x)
            <> possibly "build-commands"          (buildCommands x)
            <> possibly "post-build-commands"     (postBuildCommands x)
            <> possibly "pre-install-commands"    (preInstallCommands x)
            <> possibly "install-commands"        (installCommands x)
            <> possibly "post-install-commands"   (postInstallCommands x)

instance ToPrettyYaml ChunkInstructions where
  fieldOrder = const $ ["name", "kind", "build-system"]
   <> fmap (<> "-commands") ["configure", "build", "install"] >>= \x -> ["pre-" <> x, x, "post-" <> x]
   <> ["rpm-metadata"]


-- Stratum ("stratum.morph")

data Chunk = Chunk {
  chunkName        :: Text,
  chunkMorph       :: Maybe Text,
  repo             :: Text,
  ref              :: Text,
  sha              :: Maybe Text,
  buildMode        :: Text,
  chunkBuildSystem :: Text,
  chunkBDs         :: [Text]
} deriving (Eq, Show)

instance FromJSON Chunk where
  parseJSON = withObject "Chunk" $ \v -> Chunk
    <$> v .:  "name"
    <*> v .:? "morph"
    <*> v .:  "repo"
    <*> v .:  "ref"
    <*> v .:? "sha"
    <*> v .:? "build-mode"    .!= "staging"
    <*> v .:? "build-system"  .!= "manual"
    <*> v .:? "build-depends" .!= []

instance ToJSON Chunk where
  toJSON x = object $ ["name" .= chunkName x, "repo" .= repo x, "ref" .= ref x, "sha" .= sha x]
                    <> possibly "morph" (chunkMorph x)
                    <> possibly "build-mode" (buildMode x)
                    <> possibly "build-system" (chunkBuildSystem x)
                    <> possibly "build-depends" (chunkBDs x)

instance ToPrettyYaml Chunk where
  fieldOrder = const ["name", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends"]

data StratumBD = StratumBD {
  stratumBDMorph :: Text
} deriving (Eq, Show)

instance FromJSON StratumBD where
  parseJSON = withObject "StratumBD" $ \v -> StratumBD
    <$> v .: "morph"

instance ToJSON StratumBD where
  toJSON x = object ["morph" .= stratumBDMorph x]

data Stratum = Stratum {
  stratumName        :: Text,
  stratumDescription :: Maybe Text,
  stratumBDs         :: [StratumBD],
  chunks             :: [Chunk]
} deriving (Eq, Show)

instance FromJSON Stratum where
  parseJSON = withObject "Stratum" $ \v -> Stratum
    <$> v .:  "name"
    <*> v .:? "description"
    <*> v .:? "build-depends" .!= []
    <*> v .:  "chunks"

instance ToJSON Stratum where
  toJSON x = object $ ["name" .= stratumName x, "kind" .= ("stratum" :: Text), "chunks" .= chunks x]
                   <> possibly "description" (stratumDescription x)
                   <> possibly "build-depends" (stratumBDs x)

instance ToPrettyYaml Stratum where
  fieldOrder = const ["name", "kind", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends", "chunks"]

-- System ("system.morph")

data StratumInclude = StratumInclude {
  stratumIncludeName  :: Text,
  stratumIncludeMorph :: Text
} deriving (Eq, Show)

instance FromJSON StratumInclude where
  parseJSON = withObject "StratumInclude" $ \v -> StratumInclude
    <$> v .: "name"
    <*> v .: "morph"

instance ToJSON StratumInclude where
  toJSON x = object ["name" .= stratumIncludeName x, "morph" .= stratumIncludeMorph x]

instance ToPrettyYaml StratumInclude where
  fieldOrder = const ["name", "morph"]

data System = System {
  systemName              :: Text,
  systemDescription       :: Maybe Text,
  arch                    :: Text,
  strata                  :: [StratumInclude],
  configurationExtensions :: [Text]
} deriving (Eq, Show)

instance FromJSON System where
  parseJSON = withObject "System" $ \v -> System
    <$> v .:  "name"
    <*> v .:? "description"
    <*> v .:  "arch"
    <*> v .:  "strata"
    <*> v .:  "configuration-extensions"

instance ToJSON System where
  toJSON x = object $ ["name" .= systemName x, "kind" .= ("system" :: Text), "arch" .= arch x, "strata" .= strata x, "configuration-extensions" .= configurationExtensions x]
                    <> possibly "description" (systemDescription x)

instance ToPrettyYaml System where
  fieldOrder = const $ ["name", "morph", "kind", "description", "arch", "strata", "configuration-extensions"]

--- Decoders

type StratumAST = (Stratum, [(FilePath, ChunkInstructions)])
type SystemAST  = (System, [(FilePath, StratumAST)])

splitK a b = runKleisli $ Kleisli a &&& Kleisli b

decodeASTWith selector decoder x = runExceptT $ withExceptT (\e -> AesonException ("Error in " ++ x ++ ": " ++ show e)) $ do
  (ExceptT . decodeFileEither $ x) >>= splitK return (mapM (splitK return decoder) . selector)

decodeStratumAST :: FilePath -> IO (Either ParseException StratumAST)
decodeStratumAST = decodeASTWith (fmap unpack . mapMaybe chunkMorph . chunks) (ExceptT . decodeFileEither)

decodeSystemAST :: FilePath -> IO (Either ParseException SystemAST)
decodeSystemAST  = decodeASTWith (fmap (unpack . stratumIncludeMorph) . strata) (ExceptT . decodeStratumAST)

-- Encoders

encodeStratumAST :: FilePath -> StratumAST -> IO ()
encodeStratumAST f (x, as) = do
  BS.writeFile f (toPrettyYaml x)
  forM_ as $ \(i, j) -> BS.writeFile i (toPrettyYaml j)

encodeSystemAST :: FilePath -> SystemAST -> IO ()
encodeSystemAST f (x, as) = do
  BS.writeFile f (toPrettyYaml x)
  forM_ as $ \(i, j) -> encodeStratumAST i j

-- Utility

data BaserockGraphException = NoExistChunkBD Chunk Text
                            | NoExistStratumBD Stratum Text deriving Show

stratumGraph :: Stratum -> Either BaserockGraphException (Graph Chunk)
stratumGraph s = right edges $ sequence $ runExceptT $ do
  x <- ExceptT (fmap Right $ chunks s)
  y <- ExceptT (fmap Right $ chunkBDs x)
  z <- failWith (NoExistChunkBD x y) $ find ((== y) . chunkName) (chunks s)
  return (z, x)

-- V9 is non-regular in that graphs of Strata can be derived purely from the Stratum itself
-- where as graphs of Systems require a SystemAST. We aim to correct this.