102 lines
3.4 KiB
Haskell
102 lines
3.4 KiB
Haskell
{-# Language PatternSynonyms #-}
|
|
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module Data.Config.Suckless.KeyValue where
|
|
|
|
import Data.Config.Suckless.Syntax
|
|
import Data.Config.Suckless.Parse
|
|
|
|
import Data.String (IsString(..))
|
|
import Data.Set qualified as Set
|
|
import Data.Set (Set)
|
|
import Data.Maybe
|
|
import Data.Scientific
|
|
import Data.Aeson
|
|
import Prettyprinter
|
|
import Safe
|
|
|
|
type C = MegaParsec
|
|
|
|
class Monad m => HasCfgKey a b m where
|
|
-- type family CfgValue a :: Type
|
|
key :: Id
|
|
|
|
class (Monad m, HasCfgKey a b m) => HasCfgValue a b m where
|
|
cfgValue :: m b
|
|
|
|
class Monad m => HasConf m where
|
|
getConf :: m [Syntax C]
|
|
|
|
pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
|
|
pattern Key n ns <- SymbolVal n : ns
|
|
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Integer) m) => HasCfgValue a (Maybe Integer) m where
|
|
cfgValue = lastMay . val <$> getConf
|
|
where
|
|
val syn = [ e
|
|
| ListVal @C (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Integer) @m
|
|
]
|
|
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Scientific) m) => HasCfgValue a (Maybe Scientific) m where
|
|
cfgValue = lastMay . val <$> getConf
|
|
where
|
|
val syn = [ e
|
|
| ListVal @C (Key s [LitScientificVal e]) <- syn, s == key @a @(Maybe Scientific) @m
|
|
]
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Bool) m) => HasCfgValue a (Maybe Bool) m where
|
|
cfgValue = lastMay . val <$> getConf
|
|
where
|
|
val syn = [ e
|
|
| ListVal @C (Key s [LitBoolVal e]) <- syn, s == key @a @(Maybe Bool) @m
|
|
]
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Value) m) => HasCfgValue a (Maybe Value) m where
|
|
cfgValue = lastMay . val <$> getConf
|
|
where
|
|
val syn = [ toJSON v
|
|
| ListVal @C (Key s [v@ListVal{}]) <- syn, s == key @a @(Maybe Value) @m
|
|
]
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Maybe b) m) => HasCfgValue a (Maybe b) m where
|
|
cfgValue = lastMay . val <$> getConf
|
|
where
|
|
val syn = [ fromString (show $ pretty e)
|
|
| ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b) @m
|
|
]
|
|
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Integer) m) => HasCfgValue a (Set Integer) m where
|
|
cfgValue = Set.fromList . val <$> getConf
|
|
where
|
|
val syn = [ e
|
|
| ListVal @C (Key s [LitIntVal e]) <- syn, s == key @a @(Set Integer) @m
|
|
]
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Scientific) m) => HasCfgValue a (Set Scientific) m where
|
|
cfgValue = Set.fromList . val <$> getConf
|
|
where
|
|
val syn = [ e
|
|
| ListVal @C (Key s [LitScientificVal e]) <- syn, s == key @a @(Set Scientific) @m
|
|
]
|
|
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Value) m) => HasCfgValue a (Set Value) m where
|
|
cfgValue = Set.fromList . val <$> getConf
|
|
where
|
|
val syn = [ toJSON v
|
|
| ListVal @C (Key s [v@ListVal{}]) <- syn, s == key @a @(Set Value) @m
|
|
]
|
|
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Set b) m) => HasCfgValue a (Set b) m where
|
|
cfgValue = Set.fromList . val <$> getConf
|
|
where
|
|
val syn = [ fromString (show $ pretty e)
|
|
| ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Set b) @m
|
|
]
|
|
|
|
|