Newer
Older
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
module Data.Valuation (
Valuation,
-- * Constructors
singleton,
fromMap,
fromPairs,
-- * Destructors
toMap,
toPairs,
-- * Access
-- * Helpers
viaMap,
viaMapF,
) where
import Data.Functor.Identity
import qualified Data.Map.Strict as Map
import Prelude hiding (not)
import qualified Prelude
-- | A Single truth assignment
data Truth l = Truth
{ label :: !l
, truth :: !Bool
}
is :: l -> Truth l
is l = Truth{label = l, truth = True}
{-# INLINE is #-}
isNot :: l -> Truth l
isNot l = Truth{label = l, truth = False}
{-# INLINE isNot #-}
not :: Truth l -> Truth l
not (Truth l t) = Truth l (Prelude.not t)
singleton :: (Ord l) => Truth l -> Valuation l
singleton (Truth l t) = fromMap $ Map.singleton l t
{-# INLINE singleton #-}
viaMap :: (Map.Map l Bool -> Map.Map l Bool) -> Valuation l -> Valuation l
viaMap fn = runIdentity . viaMapF (Identity . fn)
viaMapF :: (Functor f) => (Map.Map l Bool -> f (Map.Map l Bool)) -> Valuation l -> f (Valuation l)
viaMapF fn = fmap fromMap . fn . toMap
fromPairs :: (Ord l) => [(l, Bool)] -> Valuation l
fromPairs = Valuation . Map.fromList
toPairs :: Valuation l -> [(l, Bool)]
toPairs = Map.toList . toMap
truthValue :: (Ord l) => Valuation l -> l -> Maybe Bool
truthValue (Valuation m) = (`Map.lookup` m)
{- | Conditions a valuation with key value pair, if it conficts with the valuation,
it returns Nothing
-}
condition :: (Ord l) => Valuation l -> Truth l -> Maybe (Valuation l)
condition v (Truth l t) =
viaMapF
( Map.alterF
\case
Just t' | t' /= t -> Nothing
_ -> Just (Just t)
l
)
v
withTruth :: (Ord l) => Valuation l -> Truth l -> Valuation l
withTruth v (Truth l t) = viaMap (Map.insert l t) v
{-# INLINE withTruth #-}