src/Config.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE DuplicateRecordFields #-}
   4 {-# LANGUAGE DeriveGeneric #-}
   5
   6 module Config where
   7
   8 import GHC.Generics
   9 import Data.Aeson
  10 import Data.Aeson.Types
  11 import Data.Text hiding (map, init, length, splitAt, zip)
  12 import Data.Text.Lazy (toStrict)
  13 import Data.Aeson
  14 import Data.Aeson.TH
  15 import Data.Aeson.Text
  16
  17 data GlobalConfig = GlobalConfig {
  18   editor :: Text,
  19   commitCommand :: Maybe Text,
  20   gitRemote :: Maybe Text
  21   } deriving (Show, Generic)
  22
  23 data LocalConfig = LocalConfig {
  24   name :: Text,
  25   description :: Text,
  26   theme :: Text,
  27   editor :: Maybe Text,
  28   commitCommand :: Maybe Text,
  29   gitRemote :: Maybe Text
  30   } deriving (Show, Generic)
  31
  32 data ProjectConfig = ProjectConfig {
  33   name :: Text,
  34   description :: Text,
  35   theme :: Text,
  36   editor :: Text,
  37   commitCommand :: Maybe Text,
  38   gitRemote :: Maybe Text
  39   } deriving (Show, Generic)
  40
  41 instance ToJSON GlobalConfig where
  42   toJSON = genericToJSON defaultOptions
  43     { omitNothingFields = False }
  44
  45 instance FromJSON GlobalConfig where
  46   parseJSON = genericParseJSON defaultOptions
  47     { omitNothingFields = False }
  48
  49 instance ToJSON LocalConfig where
  50   toJSON = genericToJSON defaultOptions
  51     { omitNothingFields = True }
  52
  53 instance FromJSON LocalConfig where
  54   parseJSON = genericParseJSON defaultOptions
  55     { omitNothingFields = True }
  56
  57 maybeTrump :: LocalConfig -> GlobalConfig -> (LocalConfig -> Maybe a) -> (GlobalConfig -> Maybe a) -> Maybe a
  58 maybeTrump l g lf gf = case lf l of
  59   Just x -> Just x
  60   Nothing -> gf g
  61
  62 trump :: LocalConfig -> GlobalConfig -> (LocalConfig -> Maybe a) -> (GlobalConfig -> a) -> a
  63 trump l g lf gf = case lf l of
  64   Just x -> x
  65   Nothing -> gf g
  66
  67 getProjectConfig :: GlobalConfig -> LocalConfig -> ProjectConfig
  68 getProjectConfig g l = ProjectConfig
  69   (name (l :: LocalConfig))
  70   (description (l :: LocalConfig))
  71   (theme (l :: LocalConfig))
  72   (trumper editor editor)
  73   (maybeTrumper commitCommand commitCommand)
  74   (maybeTrumper gitRemote gitRemote)
  75   where
  76     trumper = trump l g
  77     maybeTrumper = maybeTrump l g