{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module SuperUserSpark.Diagnose.Types where
import Import hiding ((<>))
import Data.Aeson
import Data.Hashable
import Text.Printf
import SuperUserSpark.Bake.Types
import SuperUserSpark.Compiler.Types
#if __GLASGOW_HASKELL__ < 840
import Data.Semigroup (Semigroup, (<>))
#endif
data DiagnoseAssignment = DiagnoseAssignment
{ diagnoseCardReference :: BakeCardReference
, diagnoseSettings :: DiagnoseSettings
} deriving (Show, Eq, Generic)
instance Validity DiagnoseAssignment
newtype DiagnoseSettings = DiagnoseSettings
{ diagnoseBakeSettings :: BakeSettings
} deriving (Show, Eq, Generic)
instance Validity DiagnoseSettings
defaultDiagnoseSettings :: DiagnoseSettings
defaultDiagnoseSettings =
DiagnoseSettings {diagnoseBakeSettings = defaultBakeSettings}
type SparkDiagnoser = ExceptT DiagnoseError (ReaderT DiagnoseSettings IO)
data DiagnoseError
= DiagnoseBakeError BakeError
| DiagnoseError String
deriving (Show, Eq, Generic)
instance Validity DiagnoseError
newtype HashDigest =
HashDigest Int
deriving (Show, Eq, Generic)
instance Validity HashDigest
instance Semigroup HashDigest where
HashDigest h1 <> HashDigest h2 = HashDigest $ h1 * 31 + h2
instance Monoid HashDigest where
mempty = HashDigest (hash ())
mappend = (<>)
instance Hashable HashDigest
instance ToJSON HashDigest where
toJSON (HashDigest i) = toJSON (printf "%016x" i :: String)
data Diagnostics
= Nonexistent
| IsFile
| IsDirectory
| IsLinkTo AbsP
| IsWeird
deriving (Show, Eq, Generic)
instance Validity Diagnostics
instance ToJSON Diagnostics where
toJSON Nonexistent = String "nonexistent"
toJSON IsFile = String "file"
toJSON IsDirectory = String "directory"
toJSON (IsLinkTo ap) =
object ["kind" .= String "link", "link destination" .= ap]
toJSON IsWeird = String "weird"
data DiagnosedFp = D
{ diagnosedFilePath :: AbsP
, diagnosedDiagnostics :: Diagnostics
, diagnosedHashDigest :: HashDigest
} deriving (Show, Eq, Generic)
instance Validity DiagnosedFp
instance ToJSON DiagnosedFp where
toJSON D {..} =
object $
["path" .= diagnosedFilePath, "diagnostics" .= diagnosedDiagnostics] ++
if diagnosedHashDigest == mempty
then []
else ["hash" .= diagnosedHashDigest]
type DiagnosedDeployment = Deployment DiagnosedFp