{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE QuasiQuotes #-}

-- | Global configuration
module Hinit.Config where

import Control.Algebra
import Control.Effect.Lift
import Control.Effect.Terminal
import Control.Effect.Throw
import Control.Effect.Time as T
import qualified Data.Map.Strict as M
import Data.String.Interpolate
import Data.Text (Text, pack, unpack)
import qualified Data.Text.IO as T
import Data.Time.Calendar
import Data.Time.Format.ISO8601
import Data.Time.LocalTime
import Distribution.Parsec
import Distribution.Pretty
import Distribution.SPDX
import GHC.Generics
import Hinit.Errors
import Hinit.Types
import Path
import Path.IO
import System.IO
import Toml hiding (Bool, Text, day)
import qualified Toml as T

data Config = Config
  { Config -> Text
name :: Text,
    Config -> Text
email :: Text,
    Config -> Text
ghUserName :: Text,
    Config -> Maybe LicenseId
license :: Maybe LicenseId,
    Config -> Maybe VCS
vcs :: Maybe VCS,
    Config -> Context
defAttrs :: Context
  }
  deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show, Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, (forall x. Config -> Rep Config x)
-> (forall x. Rep Config x -> Config) -> Generic Config
forall x. Rep Config x -> Config
forall x. Config -> Rep Config x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Config x -> Config
$cfrom :: forall x. Config -> Rep Config x
Generic)

configCodec :: TomlCodec Config
configCodec :: TomlCodec Config
configCodec =
  Text
-> Text
-> Text
-> Maybe LicenseId
-> Maybe VCS
-> Context
-> Config
Config
    (Text
 -> Text
 -> Text
 -> Maybe LicenseId
 -> Maybe VCS
 -> Context
 -> Config)
-> Codec Config Text
-> Codec
     Config
     (Text -> Text -> Maybe LicenseId -> Maybe VCS -> Context -> Config)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> TomlCodec Text
text Key
"name" TomlCodec Text -> (Config -> Text) -> Codec Config Text
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= Config -> Text
name
    Codec
  Config
  (Text -> Text -> Maybe LicenseId -> Maybe VCS -> Context -> Config)
-> Codec Config Text
-> Codec
     Config (Text -> Maybe LicenseId -> Maybe VCS -> Context -> Config)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Key -> TomlCodec Text
text Key
"email" TomlCodec Text -> (Config -> Text) -> Codec Config Text
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= Config -> Text
email
    Codec
  Config (Text -> Maybe LicenseId -> Maybe VCS -> Context -> Config)
-> Codec Config Text
-> Codec Config (Maybe LicenseId -> Maybe VCS -> Context -> Config)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Key -> TomlCodec Text
text Key
"github_username" TomlCodec Text -> (Config -> Text) -> Codec Config Text
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= Config -> Text
ghUserName
    Codec Config (Maybe LicenseId -> Maybe VCS -> Context -> Config)
-> Codec Config (Maybe LicenseId)
-> Codec Config (Maybe VCS -> Context -> Config)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> TomlCodec LicenseId -> TomlCodec (Maybe LicenseId)
forall a. TomlCodec a -> TomlCodec (Maybe a)
dioptional (Key -> TomlCodec LicenseId
licenseIdCodec Key
"license") TomlCodec (Maybe LicenseId)
-> (Config -> Maybe LicenseId) -> Codec Config (Maybe LicenseId)
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= Config -> Maybe LicenseId
license
    Codec Config (Maybe VCS -> Context -> Config)
-> Codec Config (Maybe VCS) -> Codec Config (Context -> Config)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Key -> TomlCodec (Maybe VCS)
vcsCodec Key
"vcs" TomlCodec (Maybe VCS)
-> (Config -> Maybe VCS) -> Codec Config (Maybe VCS)
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= Config -> Maybe VCS
vcs
    Codec Config (Context -> Config)
-> Codec Config Context -> TomlCodec Config
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> TomlCodec Context
contextCodec TomlCodec Context -> (Config -> Context) -> Codec Config Context
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= Config -> Context
defAttrs

licenseToToml :: LicenseId -> AnyValue
licenseToToml :: LicenseId -> AnyValue
licenseToToml LicenseId
license = Value 'TText -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue (Value 'TText -> AnyValue) -> Value 'TText -> AnyValue
forall a b. (a -> b) -> a -> b
$ Text -> Value 'TText
T.Text (Text -> Value 'TText) -> Text -> Value 'TText
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ LicenseId -> String
forall a. Pretty a => a -> String
prettyShow LicenseId
license

tomlToLicense :: AnyValue -> Either TomlBiMapError LicenseId
tomlToLicense :: AnyValue -> Either TomlBiMapError LicenseId
tomlToLicense (AnyValue Value t
v)
  | T.Text Text
t <- Value t
v =
    case String -> Either String LicenseId
forall a. Parsec a => String -> Either String a
eitherParsec (Text -> String
unpack Text
t) of
      Left String
err ->
        TomlBiMapError -> Either TomlBiMapError LicenseId
forall a b. a -> Either a b
Left (TomlBiMapError -> Either TomlBiMapError LicenseId)
-> TomlBiMapError -> Either TomlBiMapError LicenseId
forall a b. (a -> b) -> a -> b
$
          Text -> TomlBiMapError
ArbitraryError [i|Failed to parse license: #{err}|]
      Right LicenseId
l -> LicenseId -> Either TomlBiMapError LicenseId
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure LicenseId
l
  | Bool
otherwise = TomlBiMapError -> Either TomlBiMapError LicenseId
forall a b. a -> Either a b
Left (TomlBiMapError -> Either TomlBiMapError LicenseId)
-> TomlBiMapError -> Either TomlBiMapError LicenseId
forall a b. (a -> b) -> a -> b
$ MatchError -> TomlBiMapError
WrongValue (MatchError -> TomlBiMapError) -> MatchError -> TomlBiMapError
forall a b. (a -> b) -> a -> b
$ TValue -> AnyValue -> MatchError
MatchError TValue
TText (Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue Value t
v)

_LicenseId :: TomlBiMap LicenseId AnyValue
_LicenseId :: TomlBiMap LicenseId AnyValue
_LicenseId = BiMap TomlBiMapError AnyValue LicenseId
-> TomlBiMap LicenseId AnyValue
forall e a b. BiMap e a b -> BiMap e b a
invert (BiMap TomlBiMapError AnyValue LicenseId
 -> TomlBiMap LicenseId AnyValue)
-> BiMap TomlBiMapError AnyValue LicenseId
-> TomlBiMap LicenseId AnyValue
forall a b. (a -> b) -> a -> b
$ (LicenseId -> AnyValue)
-> (AnyValue -> Either TomlBiMapError LicenseId)
-> BiMap TomlBiMapError AnyValue LicenseId
forall field object error.
(field -> object)
-> (object -> Either error field) -> BiMap error object field
prism LicenseId -> AnyValue
licenseToToml AnyValue -> Either TomlBiMapError LicenseId
tomlToLicense

licenseIdCodec :: Key -> TomlCodec LicenseId
licenseIdCodec :: Key -> TomlCodec LicenseId
licenseIdCodec = TomlBiMap LicenseId AnyValue -> Key -> TomlCodec LicenseId
forall a. TomlBiMap a AnyValue -> Key -> TomlCodec a
match TomlBiMap LicenseId AnyValue
_LicenseId

askConfig :: forall sig m. Has Terminal sig m => m Config
askConfig :: m Config
askConfig = do
  Handle -> Doc AnsiStyle -> m ()
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
Has Terminal sig m =>
Handle -> Doc AnsiStyle -> m ()
prettyPrint Handle
stdout Doc AnsiStyle
"No config has been found, creating a new config (~/.config/hi/config.toml)"
  Handle -> Doc AnsiStyle -> m ()
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
Has Terminal sig m =>
Handle -> Doc AnsiStyle -> m ()
prettyPrint Handle
stdout Doc AnsiStyle
"Please enter your name:"
  Text
name <- m Text
askText
  Handle -> Doc AnsiStyle -> m ()
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
Has Terminal sig m =>
Handle -> Doc AnsiStyle -> m ()
prettyPrint Handle
stdout Doc AnsiStyle
"Your email:"
  Text
email <- m Text
askText
  Handle -> Doc AnsiStyle -> m ()
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
Has Terminal sig m =>
Handle -> Doc AnsiStyle -> m ()
prettyPrint Handle
stdout Doc AnsiStyle
"Your github username:"
  Text
ghUserName <- m Text
askText
  let vcs :: Maybe VCS
vcs = VCS -> Maybe VCS
forall a. a -> Maybe a
Just VCS
Git
  let defAttrs :: Context
defAttrs = Context
forall a. Monoid a => a
mempty
  let license :: Maybe a
license = Maybe a
forall a. Maybe a
Nothing
  Config -> m Config
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Config :: Text
-> Text
-> Text
-> Maybe LicenseId
-> Maybe VCS
-> Context
-> Config
Config {Maybe LicenseId
Maybe VCS
Context
Text
forall a. Maybe a
license :: forall a. Maybe a
defAttrs :: Context
vcs :: Maybe VCS
ghUserName :: Text
email :: Text
name :: Text
defAttrs :: Context
vcs :: Maybe VCS
license :: Maybe LicenseId
ghUserName :: Text
email :: Text
name :: Text
..}
  where
    askText :: m Text
    askText :: m Text
askText = do
      Maybe Text
resp <- String -> m (Maybe Text)
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
Has Terminal sig m =>
String -> m (Maybe Text)
prompt String
"> "
      m Text -> (Text -> m Text) -> Maybe Text -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Text
askText Text -> m Text
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Text
resp

getConfigFile :: (Has (Lift IO) sig m) => m (Path Abs File)
getConfigFile :: m (Path Abs File)
getConfigFile = do
  Path Abs Dir
configDir <- IO (Path Abs Dir) -> m (Path Abs Dir)
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type)
       a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (IO (Path Abs Dir) -> m (Path Abs Dir))
-> IO (Path Abs Dir) -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ XdgDirectory -> Maybe (Path Rel Dir) -> IO (Path Abs Dir)
forall (m :: Type -> Type).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgConfig (Maybe (Path Rel Dir) -> IO (Path Abs Dir))
-> Maybe (Path Rel Dir) -> IO (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> Maybe (Path Rel Dir)
forall a. a -> Maybe a
Just [reldir|hi|]
  IO () -> m ()
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type)
       a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> IO ()
forall (m :: Type -> Type) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
configDir
  let configFile :: Path Abs File
configFile = Path Abs Dir
configDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [relfile|config.toml|]
  Path Abs File -> m (Path Abs File)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Path Abs File
configFile

readConfig :: (Has (Lift IO) sig m, Has (Throw ConfigParseError) sig m) => Path Abs File -> m (Maybe Config)
readConfig :: Path Abs File -> m (Maybe Config)
readConfig Path Abs File
configFile = do
  Bool
exists <- IO Bool -> m Bool
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type)
       a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Path Abs File -> IO Bool
forall (m :: Type -> Type) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
configFile
  if Bool
exists
    then do
      Text
f <- IO Text -> m Text
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type)
       a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile (String -> IO Text) -> String -> IO Text
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
fromAbsFile Path Abs File
configFile
      case TomlCodec Config -> Text -> Either [TomlDecodeError] Config
forall a. TomlCodec a -> Text -> Either [TomlDecodeError] a
decode TomlCodec Config
configCodec Text
f of
        Left [TomlDecodeError]
e -> ConfigParseError -> m (Maybe Config)
forall e (sig :: (Type -> Type) -> Type -> Type)
       (m :: Type -> Type) a.
Has (Throw e) sig m =>
e -> m a
throwError (ConfigParseError -> m (Maybe Config))
-> ConfigParseError -> m (Maybe Config)
forall a b. (a -> b) -> a -> b
$ TomlFile -> [TomlDecodeError] -> ConfigParseError
ConfigParseError TomlFile
Global [TomlDecodeError]
e
        Right Config
config -> Maybe Config -> m (Maybe Config)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Config -> Maybe Config
forall a. a -> Maybe a
Just Config
config)
    else Maybe Config -> m (Maybe Config)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Config
forall a. Maybe a
Nothing

getConfig ::
  ( Has Terminal sig m,
    Has (Lift IO) sig m,
    Has (Throw ConfigParseError) sig m
  ) =>
  m Config
getConfig :: m Config
getConfig = do
  Path Abs File
configFile <- m (Path Abs File)
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
Has (Lift IO) sig m =>
m (Path Abs File)
getConfigFile
  Maybe Config
mConfig <- Path Abs File -> m (Maybe Config)
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
(Has (Lift IO) sig m, Has (Throw ConfigParseError) sig m) =>
Path Abs File -> m (Maybe Config)
readConfig Path Abs File
configFile
  case Maybe Config
mConfig of
    Just Config
c -> Config -> m Config
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Config
c
    Maybe Config
Nothing -> do
      Config
config <- m Config
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
Has Terminal sig m =>
m Config
askConfig
      IO () -> m ()
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type)
       a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile (Path Abs File -> String
fromAbsFile Path Abs File
configFile) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ TomlCodec Config -> Config -> Text
forall a. TomlCodec a -> a -> Text
encode TomlCodec Config
configCodec Config
config
      Config -> m Config
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Config
config

-- | Build two 'Context's from a program config
buildContextFromConfig :: Has Time sig m => Text -> Config -> m (Context, Context)
buildContextFromConfig :: Text -> Config -> m (Context, Context)
buildContextFromConfig Text
project Config {Maybe LicenseId
Maybe VCS
Context
Text
defAttrs :: Context
vcs :: Maybe VCS
license :: Maybe LicenseId
ghUserName :: Text
email :: Text
name :: Text
defAttrs :: Config -> Context
vcs :: Config -> Maybe VCS
license :: Config -> Maybe LicenseId
ghUserName :: Config -> Text
email :: Config -> Text
name :: Config -> Text
..} = do
  ZonedTime {LocalTime
TimeZone
zonedTimeToLocalTime :: ZonedTime -> LocalTime
zonedTimeZone :: ZonedTime -> TimeZone
zonedTimeZone :: TimeZone
zonedTimeToLocalTime :: LocalTime
..} <- m ZonedTime
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type).
Has Time sig m =>
m ZonedTime
T.getZonedTime
  let lday :: Day
lday = LocalTime -> Day
localDay LocalTime
zonedTimeToLocalTime
  let (Integer -> Text
forall a. Show a => a -> Text
show' -> Text
year, Int -> Text
forall a. Show a => a -> Text
show' -> Text
month, Int -> Text
forall a. Show a => a -> Text
show' -> Text
day) = Day -> (Integer, Int, Int)
toGregorian Day
lday
  let iso8601 :: Text
iso8601 = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Day -> String
forall t. ISO8601 t => t -> String
iso8601Show Day
lday
  let overrides :: [(Text, Val)]
overrides =
        [ (Text
"year", Text -> Val
Text Text
year),
          (Text
"month", Text -> Val
Text Text
month),
          (Text
"day", Text -> Val
Text Text
day),
          (Text
"iso8601", Text -> Val
Text Text
iso8601),
          (Text
"name", Text -> Val
Text Text
name),
          (Text
"email", Text -> Val
Text Text
email),
          (Text
"github_username", Text -> Val
Text Text
ghUserName),
          (Text
"project", Text -> Val
Text Text
project)
        ]
          [(Text, Val)] -> [(Text, Val)] -> [(Text, Val)]
forall a. [a] -> [a] -> [a]
++ [(Text, Val)]
-> (LicenseId -> [(Text, Val)]) -> Maybe LicenseId -> [(Text, Val)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\LicenseId
l -> (Text, Val) -> [(Text, Val)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text
"license", Text -> Val
Text (Text -> Val) -> Text -> Val
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ LicenseId -> String
forall a. Pretty a => a -> String
prettyShow LicenseId
l)) Maybe LicenseId
license
  (Context, Context) -> m (Context, Context)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(Text, Val)] -> Context
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Val)]
overrides, Context
defAttrs)
  where
    show' :: Show a => a -> Text
    show' :: a -> Text
show' = String -> Text
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show