{-# LANGUAGE OverloadedStrings #-}
module Types
    (
      module Types
    , module Control.Monad.Except
    , module Control.Monad.IO.Class
    , module Control.Monad.Reader
    , module Control.Monad.State
    , module Control.Monad.Writer
    , module Control.Monad.Trans
    , module Text.Parsec
    ) where

import           Control.Applicative
import           Control.Monad          (mzero)
import           Control.Monad.Except   (ExceptT, runExceptT, throwError)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Reader   (ReaderT, ask, asks, runReaderT)
import           Control.Monad.State    (StateT, get, gets, modify, put,
                                         runStateT)
import           Control.Monad.Trans    (lift)
import           Control.Monad.Writer   (WriterT, runWriterT, tell)
import           System.FilePath.Posix  (takeExtension)

import           Data.Aeson             (FromJSON (..), ToJSON (..), Value (..),
                                         object, (.:), (.=))

import           Data.Binary            (Binary (..), Get)
import qualified Data.Binary            as B
import           Data.ByteString        (ByteString)
import           Data.ByteString.Char8  (pack, unpack)
import           System.Directory       (Permissions (..))
import           Text.Parsec            (ParseError)

import           Constants

---[ Cards ]---
type CardName = String
type Source = FilePath
type Destination = FilePath
type Directory = FilePath

data Card = Card {
        card_name    :: CardName
    ,   card_path    :: FilePath
    ,   card_content :: Declaration
    } deriving (Show, Eq)

---[ Declarations ]---
data DeploymentKind = LinkDeployment
                    | CopyDeployment
    deriving (Show, Eq)

instance Binary DeploymentKind where
    put LinkDeployment = B.put True
    put CopyDeployment = B.put False
    get = do
        b <- B.get :: Get Bool
        return $ if b
        then LinkDeployment
        else CopyDeployment

instance Read DeploymentKind where
    readsPrec _ "link" = [(LinkDeployment,"")]
    readsPrec _ "copy" = [(CopyDeployment,"")]
    readsPrec _ _ = []

instance FromJSON DeploymentKind where
    parseJSON (String "link") = return LinkDeployment
    parseJSON (String "copy") = return CopyDeployment
    parseJSON _ = mzero

instance ToJSON DeploymentKind where
    toJSON LinkDeployment = String "link"
    toJSON CopyDeployment = String "copy"



data Declaration = SparkOff CardReference
                 | Deploy Source Destination (Maybe DeploymentKind)
                 | IntoDir Directory
                 | OutofDir Directory
                 | DeployKindOverride DeploymentKind
                 | Alternatives [Directory]
                 | Block [Declaration]
    deriving (Show, Eq)

---[ Card References ]--

-- Reference a card by name.
data CardNameReference = CardNameReference CardName
    deriving (Show, Eq)

-- Reference a card by the file it's in and therein potentially by a name reference
data CardFileReference = CardFileReference FilePath (Maybe CardNameReference)
    deriving (Show, Eq)

type CompilerCardReference = CardFileReference

type CompiledCardReference = FilePath

data DeployerCardReference = DeployerCardCompiled CompiledCardReference
                           | DeployerCardUncompiled CardFileReference
    deriving (Show, Eq)

type CheckerCardReference = DeployerCardReference

instance Read CardFileReference where
    readsPrec _ fp = case length (words fp) of
                      1 -> [(CardFileReference fp Nothing ,"")]
                      2 -> let [f, c] = words fp
                            in [(CardFileReference f (Just $ CardNameReference c), "")]
                      _ -> []

-- TODO refactor these
instance Read DeployerCardReference where
    readsPrec _ fp = case length (words fp) of
                      0 -> []
                      1 -> if takeExtension fp == ".sus"
                            then [(DeployerCardUncompiled (CardFileReference fp Nothing) ,"")]
                            else [(DeployerCardCompiled fp, "")]
                      2 -> let [f, c] = words fp
                            in [(DeployerCardUncompiled (CardFileReference f (Just $ CardNameReference c)), "")]
                      _ -> []


data CardReference = CardFile CardFileReference
                   | CardName CardNameReference
    deriving (Show, Eq)

---[ Base monad ]---

type Sparker = ExceptT SparkError (ReaderT SparkConfig IO)

---[ Options ]---

type Options = (Dispatch, GlobalOptions)

data GlobalOptions = GlobalOptions {
    opt_lineUp              :: Bool
  , opt_indent              :: Int
  , opt_trailingNewline     :: Bool
  , opt_alwaysQuote         :: Bool
  , opt_compress            :: Bool
  , opt_output              :: Maybe FilePath
  , opt_format              :: CompileFormat
  , opt_kind                :: Maybe DeploymentKind
  , opt_overrride           :: Maybe DeploymentKind
  , opt_thoroughness        :: CheckThoroughness
  , opt_replace_links       :: Bool
  , opt_replace_files       :: Bool
  , opt_replace_directories :: Bool
  , opt_replace             :: Bool
  , opt_debug               :: Bool
  } deriving (Show, Eq)

---[ Instructions ]--
type Instructions = (Dispatch, SparkConfig)

---[ Config ]---

data SparkConfig = Config {
        conf_format_lineUp              :: Bool
    ,   conf_format_indent              :: Int
    ,   conf_format_trailingNewline     :: Bool
    ,   conf_format_alwaysQuote         :: Bool
    ,   conf_format_oneLine             :: Bool
    ,   conf_compile_output             :: Maybe FilePath
    ,   conf_compile_format             :: CompileFormat
    ,   conf_compile_kind               :: Maybe DeploymentKind
    ,   conf_compile_override           :: Maybe DeploymentKind
    ,   conf_check_thoroughness         :: CheckThoroughness
    ,   conf_deploy_replace_links       :: Bool
    ,   conf_deploy_replace_files       :: Bool
    ,   conf_deploy_replace_directories :: Bool
    ,   conf_debug                      :: Bool
    } deriving (Show, Eq)


data CompileFormat = FormatBinary
                   | FormatText
                   | FormatJson
                   | FormatStandalone
    deriving (Show, Eq)

instance Read CompileFormat where
    readsPrec _ "binary"     = [(FormatBinary,"")]
    readsPrec _ "text"       = [(FormatText,"")]
    readsPrec _ "json"       = [(FormatJson,"")]
    readsPrec _ "standalone" = [(FormatStandalone,"")]
    readsPrec _ _ = []

data CheckThoroughness = ThoroughnessName
                       | ThoroughnessChecksum
                       | ThoroughnessContent
    deriving (Show, Eq)

instance Read CheckThoroughness where
    readsPrec _ "name"       = [(ThoroughnessName,"")]
    readsPrec _ "checksum"   = [(ThoroughnessChecksum,"")]
    readsPrec _ "content"    = [(ThoroughnessContent,"")]
    readsPrec _ _ = []


data SparkError = ParseError ParseError
                | CompileError CompileError
                | DeployError DeployError
                | UnpredictedError String
    deriving Show

runSparker :: SparkConfig -> Sparker a -> IO (Either SparkError a)
runSparker conf func = runReaderT (runExceptT func) conf

---[ Dispatching ]---

data Dispatch = DispatchParse FilePath
              | DispatchFormat FilePath
              | DispatchCompile CompilerCardReference
              | DispatchCheck CheckerCardReference
              | DispatchDeploy DeployerCardReference
    deriving (Show, Eq)


---[ Compiling Types ]---
data Deployment = Put {
        deployment_srcs :: [FilePath]
    ,   deployment_dst  :: FilePath
    ,   deployment_kind :: DeploymentKind
    }
    deriving Eq

instance Binary Deployment where
    put depl = do
        B.put $ map pack $ deployment_srcs depl
        B.put $ deployment_kind depl
        B.put $ pack $ deployment_dst depl
    get = do
        bsrcs <- B.get :: Get [ByteString]
        kind <- B.get :: Get DeploymentKind
        dst <- B.get :: Get ByteString
        return $ Put {
                deployment_srcs = map unpack bsrcs
            ,   deployment_kind = kind
            ,   deployment_dst = unpack dst
            }

instance Read Deployment where
    readsPrec _ str = [(Put {
                deployment_srcs = srcs
            ,   deployment_dst = dst
            ,   deployment_kind = kind
            }, "")]
      where
          srcs = (map unquote . reverse . drop 2 . reverse) ws
          kind = case lookup (last $ init ws) [(linkKindSymbol, LinkDeployment), (copyKindSymbol, CopyDeployment)] of
                    Nothing -> error "unrecognised deployment kind symbol"
                    Just k  -> k
          dst = last ws
          ws = words str
          unquote = tail . init

instance Show Deployment where
    show dep = unwords $ srcs ++ [k,dst]
      where
        srcs = map quote $ deployment_srcs dep
        k = case deployment_kind dep of
                LinkDeployment -> linkKindSymbol
                CopyDeployment -> copyKindSymbol
        dst = quote $ deployment_dst dep
        quote = (\s -> "\"" ++ s ++ "\"")

instance FromJSON Deployment where
    parseJSON (Object o) = Put <$> o .: "sources"
                               <*> o .: "destination"
                               <*> o .: "deployment kind"
    parseJSON _ = mzero

instance ToJSON Deployment where
    toJSON depl = object [
                           "sources" .= deployment_srcs depl
                         , "destination" .= deployment_dst depl
                         , "deployment kind" .= deployment_kind depl
                         ]



type CompileError = String

type SparkCompiler = StateT CompilerState (WriterT [Deployment] Sparker)

type CompilerPrefix = [PrefixPart]

data PrefixPart = Literal String
                | Alts [String]
    deriving (Show, Eq)

runSparkCompiler :: CompilerState -> SparkCompiler a -> Sparker ((a,CompilerState), [Deployment])
runSparkCompiler s func = runWriterT (runStateT func s)


data CompilerState = CompilerState {
        state_current_card             :: Card
    ,   state_current_directory        :: FilePath
    ,   state_all_cards                :: [Card]
    ,   state_declarations_left        :: [Declaration]
    ,   state_deployment_kind_override :: Maybe DeploymentKind
    ,   state_into                     :: Directory
    ,   state_outof_prefix             :: CompilerPrefix
    } deriving (Show, Eq)



---[ Deploying Types ]---

type SparkDeployer = StateT DeployerState Sparker
data DeployerState = DeployerState
data DeployError = PreDeployError [String]
                 | DuringDeployError [String]
                 | PostDeployError [String]
    deriving (Show, Eq)

runSparkDeployer :: DeployerState -> SparkDeployer a -> Sparker (a, DeployerState)
runSparkDeployer state func = runStateT func state

data Diagnostics = NonExistent
                 | IsFile Permissions
                 | IsDirectory Permissions
                 | IsLink Permissions
                 | IsPipe
                 | IsSocket
                 | IsCharDevice
                 | IsBlockDevice
    deriving (Show, Eq)

data PreDeployment = Ready FilePath FilePath DeploymentKind
                   | AlreadyDone
                   | Error String
    deriving (Show, Eq)

data ID = Plain String
        | Var String
    deriving (Show, Eq)


---[ Pretty Types ]---

type SparkFormatter = StateT FormatterState (WriterT String Sparker)
data FormatterState = FormatterState {
        state_current_indent        :: Int
    ,   state_longest_src           :: Int
    ,   state_newline_before_deploy :: Bool
    }
    deriving (Show, Eq)

runSparkFormatter :: FormatterState -> SparkFormatter a -> Sparker ((a, FormatterState), String)
runSparkFormatter state func = runWriterT (runStateT func state)