-- This file is part of Hoppy.
--
-- Copyright 2015-2021 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

-- | Support for specifying overrides of values based on parameters.
--
-- For example, an entity may have a name that you want to override on a
-- per-language basis.  A single value like this may be represented as a
-- @'WithOverrides' Language Name@ value.  Such a value will have a default
-- name, as well as zero or more overrides, keyed by @Language@.
--
-- A 'MapWithOverrides' type is also provided for ease of overriding values
-- inside of a map.
module Foreign.Hoppy.Generator.Override (
  WithOverrides,
  plain,
  overridden,
  unoverriddenValue,
  overriddenValues,
  MapWithOverrides,
  plainMap,
  mapWithOverrides,
  addOverrideMap,
  addOverrideMaps,
  applyOverrideMaps,
  insertMapOverride,
  overriddenMapLookup,
  ) where

import qualified Data.Map as M
import Data.Maybe (fromMaybe)

-- | Represents a default value of type @v@ with optional overrides keyed by
-- parameter type @p@.  The type @p@ must have an 'Ord' instance.
data WithOverrides p v = WithOverrides
  { WithOverrides p v -> v
unoverriddenValue :: v
    -- ^ The default, unoverriden value for the 'WithOverrides'.  Lookups on the
    -- override will return this value a given parameter doesn't have an
    -- override.

  , WithOverrides p v -> Map p v
overriddenValues :: M.Map p v
    -- ^ Any overridden values that have been added to the 'WithOverrides'.
  }

-- | Creates a 'WithOverrides' with the given default value @v@, and no
-- overridden values.
plain :: v -> WithOverrides p v
plain :: v -> WithOverrides p v
plain v
x = v -> Map p v -> WithOverrides p v
forall p v. v -> Map p v -> WithOverrides p v
WithOverrides v
x Map p v
forall k a. Map k a
M.empty

-- | Creates a 'WithOverrides' with the given default value @v@, and overridden
-- values in the map.
overridden :: v -> M.Map p v -> WithOverrides p v
overridden :: v -> Map p v -> WithOverrides p v
overridden = v -> Map p v -> WithOverrides p v
forall p v. v -> Map p v -> WithOverrides p v
WithOverrides

-- | Extracts a value, possibly overridden based on a parameter.
getOverride :: Ord p => p -> WithOverrides p v -> v
getOverride :: p -> WithOverrides p v -> v
getOverride p
p WithOverrides p v
o =
  v -> Maybe v -> v
forall a. a -> Maybe a -> a
fromMaybe (WithOverrides p v -> v
forall p v. WithOverrides p v -> v
unoverriddenValue WithOverrides p v
o) (Maybe v -> v) -> Maybe v -> v
forall a b. (a -> b) -> a -> b
$ p -> Map p v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup p
p (Map p v -> Maybe v) -> Map p v -> Maybe v
forall a b. (a -> b) -> a -> b
$ WithOverrides p v -> Map p v
forall p v. WithOverrides p v -> Map p v
overriddenValues WithOverrides p v
o

addOverride :: Ord p => p -> v -> WithOverrides p v -> WithOverrides p v
addOverride :: p -> v -> WithOverrides p v -> WithOverrides p v
addOverride p
p v
v WithOverrides p v
o = WithOverrides p v
o { overriddenValues :: Map p v
overriddenValues = p -> v -> Map p v -> Map p v
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert p
p v
v (Map p v -> Map p v) -> Map p v -> Map p v
forall a b. (a -> b) -> a -> b
$ WithOverrides p v -> Map p v
forall p v. WithOverrides p v -> Map p v
overriddenValues WithOverrides p v
o }

-- | Represents a map from @k@ values to @v@ values, where each entry can be
-- overridden based on parameter @p@.  A key is either present with a default
-- value and possibly some overridden values, or it is completely absent -- it
-- is not possible for a key to have overridden values but no default value.
newtype MapWithOverrides p k v =
  MapWithOverrides { MapWithOverrides p k v -> Map k (WithOverrides p v)
fromMapWithOverrides :: M.Map k (WithOverrides p v) }

-- | Converts a plain map to a 'MapWithOverrides' without any overrides.
plainMap :: M.Map k v -> MapWithOverrides p k v
plainMap :: Map k v -> MapWithOverrides p k v
plainMap = Map k (WithOverrides p v) -> MapWithOverrides p k v
forall p k v. Map k (WithOverrides p v) -> MapWithOverrides p k v
MapWithOverrides (Map k (WithOverrides p v) -> MapWithOverrides p k v)
-> (Map k v -> Map k (WithOverrides p v))
-> Map k v
-> MapWithOverrides p k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> WithOverrides p v) -> Map k v -> Map k (WithOverrides p v)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map v -> WithOverrides p v
forall v p. v -> WithOverrides p v
plain

-- | Direct constructor for 'MapWithOverrides'.
mapWithOverrides :: M.Map k (WithOverrides p v) -> MapWithOverrides p k v
mapWithOverrides :: Map k (WithOverrides p v) -> MapWithOverrides p k v
mapWithOverrides = Map k (WithOverrides p v) -> MapWithOverrides p k v
forall p k v. Map k (WithOverrides p v) -> MapWithOverrides p k v
MapWithOverrides

-- | Adds an override @v@ for key @k@ under parameter @p@ to a
-- 'MapWithOverrides'.
--
-- It is an error for a parameter to override a key that is not present in the
-- defaults map.
insertMapOverride ::
     (Ord p, Ord k, Show p, Show k)
  => p
  -> k
  -> v
  -> MapWithOverrides p k v
  -> MapWithOverrides p k v
insertMapOverride :: p -> k -> v -> MapWithOverrides p k v -> MapWithOverrides p k v
insertMapOverride p
p k
k v
v (MapWithOverrides Map k (WithOverrides p v)
m) =
  -- We could do this whole operation as an 'alter' rather than a
  -- 'lookup'/'adjust', but this way, if an insertion is invalid then we return
  -- an error directly rather than hiding it inside the resulting structure.
  case k -> Map k (WithOverrides p v) -> Maybe (WithOverrides p v)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k (WithOverrides p v)
m of
    Just WithOverrides p v
_ -> Map k (WithOverrides p v) -> MapWithOverrides p k v
forall p k v. Map k (WithOverrides p v) -> MapWithOverrides p k v
MapWithOverrides (Map k (WithOverrides p v) -> MapWithOverrides p k v)
-> Map k (WithOverrides p v) -> MapWithOverrides p k v
forall a b. (a -> b) -> a -> b
$ (WithOverrides p v -> WithOverrides p v)
-> k -> Map k (WithOverrides p v) -> Map k (WithOverrides p v)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (p -> v -> WithOverrides p v -> WithOverrides p v
forall p v.
Ord p =>
p -> v -> WithOverrides p v -> WithOverrides p v
addOverride p
p v
v) k
k Map k (WithOverrides p v)
m
    Maybe (WithOverrides p v)
Nothing ->
      [Char] -> MapWithOverrides p k v
forall a. HasCallStack => [Char] -> a
error ([Char] -> MapWithOverrides p k v)
-> [Char] -> MapWithOverrides p k v
forall a b. (a -> b) -> a -> b
$ [Char]
"insertMapOverride: Can't add override for parameter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ p -> [Char]
forall a. Show a => a -> [Char]
show p
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
      [Char]
" under key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ k -> [Char]
forall a. Show a => a -> [Char]
show k
k [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" that has no default value."

-- | Adds a collection of overrides @v@ for multiple keys @k@, all under a single
-- parameter @p@, to a 'MapWithOverrides'.
--
-- It is an error for a parameter to override a key that is not present in the
-- defaults map.
addOverrideMap ::
     (Ord p, Ord k, Show p, Show k)
  => p
  -> M.Map k v
  -> MapWithOverrides p k v
  -> MapWithOverrides p k v
addOverrideMap :: p -> Map k v -> MapWithOverrides p k v -> MapWithOverrides p k v
addOverrideMap p
p Map k v
pOverrides (MapWithOverrides Map k (WithOverrides p v)
m) =
  Map k (WithOverrides p v) -> MapWithOverrides p k v
forall p k v. Map k (WithOverrides p v) -> MapWithOverrides p k v
MapWithOverrides (Map k (WithOverrides p v) -> MapWithOverrides p k v)
-> Map k (WithOverrides p v) -> MapWithOverrides p k v
forall a b. (a -> b) -> a -> b
$
  (k -> v -> Map k (WithOverrides p v) -> Map k (WithOverrides p v))
-> Map k (WithOverrides p v)
-> Map k v
-> Map k (WithOverrides p v)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\k
k v
vOverride Map k (WithOverrides p v)
acc ->
                   (Maybe (WithOverrides p v) -> Maybe (WithOverrides p v))
-> k -> Map k (WithOverrides p v) -> Map k (WithOverrides p v)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (\Maybe (WithOverrides p v)
kOverrides -> case Maybe (WithOverrides p v)
kOverrides of
                             Just WithOverrides p v
overrides ->
                               WithOverrides p v -> Maybe (WithOverrides p v)
forall a. a -> Maybe a
Just (WithOverrides p v -> Maybe (WithOverrides p v))
-> WithOverrides p v -> Maybe (WithOverrides p v)
forall a b. (a -> b) -> a -> b
$ p -> v -> WithOverrides p v -> WithOverrides p v
forall p v.
Ord p =>
p -> v -> WithOverrides p v -> WithOverrides p v
addOverride p
p v
vOverride WithOverrides p v
overrides
                             Maybe (WithOverrides p v)
Nothing ->
                               [Char] -> Maybe (WithOverrides p v)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe (WithOverrides p v))
-> [Char] -> Maybe (WithOverrides p v)
forall a b. (a -> b) -> a -> b
$ [Char]
"addOverrideMap: Parameter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ p -> [Char]
forall a. Show a => a -> [Char]
show p
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                               [Char]
" supplies override for key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ k -> [Char]
forall a. Show a => a -> [Char]
show k
k [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                               [Char]
" that is not in the map of unoverridden values.")
                           k
k
                           Map k (WithOverrides p v)
acc)
                 Map k (WithOverrides p v)
m
                 Map k v
pOverrides

-- | Adds overrides @v@ for multiple keys @k@ under multiple parameters @p@ to a
-- 'MapWithOverrides'.
--
-- It is an error for a parameter to override a key that is not present in the
-- defaults map.
addOverrideMaps ::
     (Ord p, Ord k, Show p, Show k)
  => M.Map p (M.Map k v)
  -> MapWithOverrides p k v
  -> MapWithOverrides p k v
addOverrideMaps :: Map p (Map k v) -> MapWithOverrides p k v -> MapWithOverrides p k v
addOverrideMaps Map p (Map k v)
overrideMaps (MapWithOverrides Map k (WithOverrides p v)
m) =
  Map k (WithOverrides p v) -> MapWithOverrides p k v
forall p k v. Map k (WithOverrides p v) -> MapWithOverrides p k v
MapWithOverrides (Map k (WithOverrides p v) -> MapWithOverrides p k v)
-> Map k (WithOverrides p v) -> MapWithOverrides p k v
forall a b. (a -> b) -> a -> b
$
  (p
 -> Map k v
 -> Map k (WithOverrides p v)
 -> Map k (WithOverrides p v))
-> Map k (WithOverrides p v)
-> Map p (Map k v)
-> Map k (WithOverrides p v)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\p
p Map k v
pOverrides ->
                   MapWithOverrides p k v -> Map k (WithOverrides p v)
forall p k v. MapWithOverrides p k v -> Map k (WithOverrides p v)
fromMapWithOverrides (MapWithOverrides p k v -> Map k (WithOverrides p v))
-> (Map k (WithOverrides p v) -> MapWithOverrides p k v)
-> Map k (WithOverrides p v)
-> Map k (WithOverrides p v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Map k v -> MapWithOverrides p k v -> MapWithOverrides p k v
forall p k v.
(Ord p, Ord k, Show p, Show k) =>
p -> Map k v -> MapWithOverrides p k v -> MapWithOverrides p k v
addOverrideMap p
p Map k v
pOverrides (MapWithOverrides p k v -> MapWithOverrides p k v)
-> (Map k (WithOverrides p v) -> MapWithOverrides p k v)
-> Map k (WithOverrides p v)
-> MapWithOverrides p k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (WithOverrides p v) -> MapWithOverrides p k v
forall p k v. Map k (WithOverrides p v) -> MapWithOverrides p k v
MapWithOverrides)
                 Map k (WithOverrides p v)
m
                 Map p (Map k v)
overrideMaps

-- | Constructs a 'MapWithOverrides' from a map of default values and a bunch of
-- parameter-specific maps overlaid on top of it.
--
-- It is an error for a parameter to override a key that is not present in the
-- defaults map.
applyOverrideMaps ::
     (Ord p, Ord k, Show p, Show k)
  => M.Map p (M.Map k v)
  -> M.Map k v
  -> MapWithOverrides p k v
applyOverrideMaps :: Map p (Map k v) -> Map k v -> MapWithOverrides p k v
applyOverrideMaps Map p (Map k v)
overrideMaps Map k v
baseMap =
  Map k (WithOverrides p v) -> MapWithOverrides p k v
forall p k v. Map k (WithOverrides p v) -> MapWithOverrides p k v
MapWithOverrides (Map k (WithOverrides p v) -> MapWithOverrides p k v)
-> Map k (WithOverrides p v) -> MapWithOverrides p k v
forall a b. (a -> b) -> a -> b
$
  (p
 -> Map k v
 -> Map k (WithOverrides p v)
 -> Map k (WithOverrides p v))
-> Map k (WithOverrides p v)
-> Map p (Map k v)
-> Map k (WithOverrides p v)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\p
p Map k v
pOverrides Map k (WithOverrides p v)
acc ->
                   (k -> v -> Map k (WithOverrides p v) -> Map k (WithOverrides p v))
-> Map k (WithOverrides p v)
-> Map k v
-> Map k (WithOverrides p v)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\k
k v
vOverride Map k (WithOverrides p v)
acc' ->
                                    (Maybe (WithOverrides p v) -> Maybe (WithOverrides p v))
-> k -> Map k (WithOverrides p v) -> Map k (WithOverrides p v)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (\Maybe (WithOverrides p v)
kOverrides -> case Maybe (WithOverrides p v)
kOverrides of
                                              Just WithOverrides p v
overrides ->
                                                WithOverrides p v -> Maybe (WithOverrides p v)
forall a. a -> Maybe a
Just (WithOverrides p v -> Maybe (WithOverrides p v))
-> WithOverrides p v -> Maybe (WithOverrides p v)
forall a b. (a -> b) -> a -> b
$ p -> v -> WithOverrides p v -> WithOverrides p v
forall p v.
Ord p =>
p -> v -> WithOverrides p v -> WithOverrides p v
addOverride p
p v
vOverride WithOverrides p v
overrides
                                              Maybe (WithOverrides p v)
Nothing ->
                                                [Char] -> Maybe (WithOverrides p v)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe (WithOverrides p v))
-> [Char] -> Maybe (WithOverrides p v)
forall a b. (a -> b) -> a -> b
$ [Char]
"applyOverrideMaps: Parameter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ p -> [Char]
forall a. Show a => a -> [Char]
show p
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                                [Char]
" supplies override for key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ k -> [Char]
forall a. Show a => a -> [Char]
show k
k [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                                [Char]
" that is not in the map of unoverridden values.")
                                            k
k
                                            Map k (WithOverrides p v)
acc')
                                  Map k (WithOverrides p v)
acc
                                  Map k v
pOverrides)
                 ((v -> WithOverrides p v) -> Map k v -> Map k (WithOverrides p v)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map v -> WithOverrides p v
forall v p. v -> WithOverrides p v
plain Map k v
baseMap)
                 Map p (Map k v)
overrideMaps

-- | Looks up a value for @k@ in the given 'MapWithOverrides', with the
-- possibility that the value is overridden by the parameter @p@.
overriddenMapLookup :: (Ord p, Ord k) => p -> k -> MapWithOverrides p k v -> Maybe v
overriddenMapLookup :: p -> k -> MapWithOverrides p k v -> Maybe v
overriddenMapLookup p
p k
k (MapWithOverrides Map k (WithOverrides p v)
x) = p -> WithOverrides p v -> v
forall p v. Ord p => p -> WithOverrides p v -> v
getOverride p
p (WithOverrides p v -> v) -> Maybe (WithOverrides p v) -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> Map k (WithOverrides p v) -> Maybe (WithOverrides p v)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k (WithOverrides p v)
x