{-|
The default config primarily defines the styling and formatting
-}
module Config where
import Protolude as P (
Applicative (pure),
Char,
Eq ((==)),
FilePath,
Foldable (foldl),
Functor (fmap),
Generic,
Int,
Maybe (..),
Semigroup ((<>)),
Show,
Text,
decodeUtf8,
fromMaybe,
lines,
show,
unlines,
($),
(&),
(.),
)
import Data.Aeson (
FromJSON (parseJSON),
ToJSON (toJSON),
Value (String),
withObject,
withText,
(.!=),
(.:?),
)
import Data.Hourglass (TimeFormat (toFormat), TimeFormatString)
import Data.Text as T (
dropEnd,
isInfixOf,
pack,
replace,
split,
strip,
stripPrefix,
)
import Data.Yaml (encode)
import Prettyprinter.Internal (Pretty (pretty))
import Prettyprinter.Render.Terminal (
AnsiStyle,
Color (..),
color,
colorDull,
)
import Prettyprinter.Render.Terminal.Internal (ansiForeground)
import System.FilePath (takeBaseName)
data Hook = Hook
{ filePath :: Maybe FilePath
, interpreter :: Text
, body :: Text
}
deriving (Generic, Show)
instance ToJSON Hook
instance FromJSON Hook
emptyHook :: Hook
emptyHook =
Hook
{ filePath = Nothing
, interpreter = ""
, body = ""
}
data HookSet = HookSet
{ pre :: [Hook]
, post :: [Hook]
}
deriving (Generic, Show)
instance ToJSON HookSet
-- | Necessary to make fields optional without using a Maybe type
instance FromJSON HookSet where
parseJSON = withObject "hookSet" $ \o -> do
pre <- o .:? "pre" .!= pre emptyHookSet
post <- o .:? "post" .!= post emptyHookSet
pure $ HookSet{..}
emptyHookSet :: HookSet
emptyHookSet =
HookSet
{ pre = []
, post = []
}
data HooksConfig = HooksConfig
{ directory :: FilePath
, launch :: HookSet
, add :: HookSet
, modify :: HookSet
, exit :: HookSet
-- TODO: , delete :: HookSet
}
deriving (Generic, Show)
instance ToJSON HooksConfig
-- | Necessary to make fields optional without using a Maybe type
instance FromJSON HooksConfig where
parseJSON = withObject "hooksConfig" $ \o -> do
directory <- o .:? "directory" .!= directory defaultHooksConfig
launch <- o .:? "launch" .!= launch defaultHooksConfig
add <- o .:? "add" .!= add defaultHooksConfig
modify <- o .:? "modify" .!= modify defaultHooksConfig
exit <- o .:? "exit" .!= exit defaultHooksConfig
pure $ HooksConfig{..}
defaultHooksConfig :: HooksConfig
defaultHooksConfig =
HooksConfig
{ directory = ""
, launch = emptyHookSet
, add = emptyHookSet
, modify = emptyHookSet
, exit = emptyHookSet
}
addHookFilesToConfig :: Config -> [(FilePath, b, Text)] -> Config
addHookFilesToConfig =
let
buildHook :: FilePath -> Text -> Hook
buildHook filePath content =
case lines content of
firstLine : rest ->
Hook
{ filePath = Just filePath
, interpreter =
firstLine
& T.replace "#!" ""
& T.strip
, body =
rest
& unlines
& T.strip
}
_ -> emptyHook
addToHookSet :: Hook -> Text -> HookSet -> HookSet
addToHookSet hook stage hookSet =
case stage of
"pre" -> hookSet{pre = hookSet.pre <> [hook]}
"post" -> hookSet{post = hookSet.post <> [hook]}
_ -> hookSet
addToHooksConfig :: Text -> Text -> Hook -> HooksConfig -> HooksConfig
addToHooksConfig event stage hook hConfig =
case event of
"launch" ->
hConfig
{ launch = addToHookSet hook stage (hConfig & launch)
}
"add" ->
hConfig
{ add = addToHookSet hook stage (hConfig & add)
}
"modify" ->
hConfig
{ modify = addToHookSet hook stage (hConfig & modify)
}
"exit" ->
hConfig
{ exit = addToHookSet hook stage (hConfig & exit)
}
_ -> hConfig
in
P.foldl $ \conf (filePath, _, fileContent) ->
case split (== '-') $ pack $ takeBaseName filePath of
[stage, event] ->
conf
{ hooks =
addToHooksConfig
event
stage
(buildHook filePath fileContent)
conf.hooks
}
_ -> conf
data Config = Config
{ tableName :: Text
, idStyle :: AnsiStyle
, priorityStyle :: AnsiStyle
, dateStyle :: AnsiStyle
, bodyStyle :: AnsiStyle
, bodyClosedStyle :: AnsiStyle
, closedStyle :: AnsiStyle
, dueStyle :: AnsiStyle
, overdueStyle :: AnsiStyle
, tagStyle :: AnsiStyle
, utcFormat :: TimeFormatString
, utcFormatShort :: TimeFormatString
, dataDir :: FilePath
, dbName :: FilePath
, dateWidth :: Int
, bodyWidth :: Int
, prioWidth :: Int
, headCount :: Int
, maxWidth :: Int
, progressBarWidth :: Int
, hooks :: HooksConfig
}
deriving (Generic, Show)
-- | Necessary to make fields optional without using a Maybe type
{- FOURMOLU_DISABLE -}
instance FromJSON Config where
parseJSON = withObject "config" $ \o -> do
idStyle <- o .:? "idStyle" .!= defaultConfig.idStyle
priorityStyle <- o .:? "priorityStyle".!= defaultConfig.priorityStyle
tableName <- o .:? "tableName" .!= defaultConfig.tableName
dateStyle <- o .:? "dateStyle" .!= defaultConfig.dateStyle
bodyStyle <- o .:? "bodyStyle" .!= defaultConfig.bodyStyle
bodyClosedStyle <- o .:? "bodyClosedStyle".!= defaultConfig.bodyClosedStyle
closedStyle <- o .:? "closedStyle" .!= defaultConfig.closedStyle
dueStyle <- o .:? "dueStyle" .!= defaultConfig.dueStyle
overdueStyle <- o .:? "overdueStyle" .!= defaultConfig.overdueStyle
tagStyle <- o .:? "tagStyle" .!= defaultConfig.tagStyle
utcFormat <- o .:? "utcFormat" .!= defaultConfig.utcFormat
utcFormatShort <- o .:? "utcFormatShort" .!= defaultConfig.utcFormatShort
dataDir <- o .:? "dataDir" .!= defaultConfig.dataDir
dbName <- o .:? "dbName" .!= defaultConfig.dbName
dateWidth <- o .:? "dateWidth" .!= defaultConfig.dateWidth
bodyWidth <- o .:? "bodyWidth" .!= defaultConfig.bodyWidth
prioWidth <- o .:? "prioWidth" .!= defaultConfig.prioWidth
headCount <- o .:? "headCount" .!= defaultConfig.headCount
maxWidth <- o .:? "maxWidth" .!= defaultConfig.maxWidth
progressBarWidth <- o .:? "progressBarWidth"
.!= defaultConfig.progressBarWidth
hooks <- o .:? "hooks" .!= defaultConfig.hooks
pure $ Config{..}
{- FOURMOLU_ENABLE -}
instance ToJSON Config
instance Pretty Config where
pretty =
pretty
. dropEnd 1 -- Drop trailing newline to maybe add it later
. decodeUtf8
. Data.Yaml.encode
parseColor :: Text -> Maybe Color
parseColor colorTxt =
let
colorOnly = fromMaybe colorTxt $ stripPrefix "dull " colorTxt
colorToType = \case
"black" -> Just Black
"red" -> Just Red
"green" -> Just Green
"yellow" -> Just Yellow
"blue" -> Just Blue
"magenta" -> Just Magenta
"cyan" -> Just Cyan
"white" -> Just White
_ -> Nothing
in
colorToType colorOnly
parseAnsiStyle :: Text -> Maybe AnsiStyle
parseAnsiStyle colorTxt =
let
func =
if "dull" `T.isInfixOf` colorTxt
then colorDull
else color
colorMaybe = parseColor colorTxt
in
fmap func colorMaybe
instance FromJSON AnsiStyle where
parseJSON = withText "AnsiStyle" $ \value -> do
pure $ fromMaybe (color Black) $ parseAnsiStyle value
instance ToJSON AnsiStyle where
toJSON style = String $ show $ ansiForeground style
instance FromJSON TimeFormatString where
parseJSON = withText "TimeFormatString" $ \_ -> do
pure (toFormat ("YYYY-MM-DD H:MI:S" :: [Char]))
instance ToJSON TimeFormatString where
toJSON = pure "YYYY-MM-DD H:MI:S"
-- instance Pretty AnsiStyle where
-- pretty = pretty . (\_ -> ". " :: Text)
defaultConfig :: Config
defaultConfig =
Config
{ tableName = "tasks"
, idStyle = color Green
, priorityStyle = color Magenta
, dateStyle = color Black
, bodyStyle = color White
, bodyClosedStyle = color Black
, closedStyle = colorDull Black
, dueStyle = color Yellow
, overdueStyle = color Red
, tagStyle = color Blue
, utcFormat = toFormat ("YYYY-MM-DD H:MI:S" :: [Char])
, utcFormatShort = toFormat ("YYYY-MM-DD H:MI" :: [Char])
, dataDir = ""
, dbName = "main.db"
, dateWidth = 10
, bodyWidth = 10
, prioWidth = 4
, headCount = 20
, maxWidth = 120
, progressBarWidth = 24
, hooks =
HooksConfig
{ directory = ""
, launch = emptyHookSet
, add = emptyHookSet
, modify = emptyHookSet
, exit = emptyHookSet
}
}