{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}

{-|
Module      : Data.JoinSemilattice.Defined
Description : Values with differing levels of "definedness".
Copyright   : (c) Tom Harding, 2020
License     : MIT

The 'Defined' type simplifies the join semilattice-shaped knowledge down to its
simplest form, by saying there are only three possible states of knowledge:

- I don't know anything about this value.
- I know exactly what this value is.
- I'm getting conflicting information.

The simplicity of the type makes it incredibly helpful when we're trying to
lift regular computations into the world of propagators.
-}
module Data.JoinSemilattice.Defined where

import Control.Applicative (liftA2)
import Data.Hashable (Hashable)
import Data.Input.Config (Config (..), Input (..))
import Data.Kind (Type)
import Data.List.NonEmpty (unzip)
import Data.Monoid (Ap (..))
import GHC.Generics (Generic)
import Prelude hiding (unzip)

-- | Defines simple "levels of knowledge" about a value.
data Defined (x :: Type)
  = Unknown   -- ^ Nothing has told me what this value is.
  | Exactly x -- ^ Everyone who has told me this value agrees.
  | Conflict  -- ^ Two sources disagree on what this value should be.
  deriving stock (Defined x -> Defined x -> Bool
(Defined x -> Defined x -> Bool)
-> (Defined x -> Defined x -> Bool) -> Eq (Defined x)
forall x. Eq x => Defined x -> Defined x -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Defined x -> Defined x -> Bool
$c/= :: forall x. Eq x => Defined x -> Defined x -> Bool
== :: Defined x -> Defined x -> Bool
$c== :: forall x. Eq x => Defined x -> Defined x -> Bool
Eq, Eq (Defined x)
Eq (Defined x)
-> (Defined x -> Defined x -> Ordering)
-> (Defined x -> Defined x -> Bool)
-> (Defined x -> Defined x -> Bool)
-> (Defined x -> Defined x -> Bool)
-> (Defined x -> Defined x -> Bool)
-> (Defined x -> Defined x -> Defined x)
-> (Defined x -> Defined x -> Defined x)
-> Ord (Defined x)
Defined x -> Defined x -> Bool
Defined x -> Defined x -> Ordering
Defined x -> Defined x -> Defined x
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall x. Ord x => Eq (Defined x)
forall x. Ord x => Defined x -> Defined x -> Bool
forall x. Ord x => Defined x -> Defined x -> Ordering
forall x. Ord x => Defined x -> Defined x -> Defined x
min :: Defined x -> Defined x -> Defined x
$cmin :: forall x. Ord x => Defined x -> Defined x -> Defined x
max :: Defined x -> Defined x -> Defined x
$cmax :: forall x. Ord x => Defined x -> Defined x -> Defined x
>= :: Defined x -> Defined x -> Bool
$c>= :: forall x. Ord x => Defined x -> Defined x -> Bool
> :: Defined x -> Defined x -> Bool
$c> :: forall x. Ord x => Defined x -> Defined x -> Bool
<= :: Defined x -> Defined x -> Bool
$c<= :: forall x. Ord x => Defined x -> Defined x -> Bool
< :: Defined x -> Defined x -> Bool
$c< :: forall x. Ord x => Defined x -> Defined x -> Bool
compare :: Defined x -> Defined x -> Ordering
$ccompare :: forall x. Ord x => Defined x -> Defined x -> Ordering
$cp1Ord :: forall x. Ord x => Eq (Defined x)
Ord, Int -> Defined x -> ShowS
[Defined x] -> ShowS
Defined x -> String
(Int -> Defined x -> ShowS)
-> (Defined x -> String)
-> ([Defined x] -> ShowS)
-> Show (Defined x)
forall x. Show x => Int -> Defined x -> ShowS
forall x. Show x => [Defined x] -> ShowS
forall x. Show x => Defined x -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Defined x] -> ShowS
$cshowList :: forall x. Show x => [Defined x] -> ShowS
show :: Defined x -> String
$cshow :: forall x. Show x => Defined x -> String
showsPrec :: Int -> Defined x -> ShowS
$cshowsPrec :: forall x. Show x => Int -> Defined x -> ShowS
Show, a -> Defined b -> Defined a
(a -> b) -> Defined a -> Defined b
(forall a b. (a -> b) -> Defined a -> Defined b)
-> (forall a b. a -> Defined b -> Defined a) -> Functor Defined
forall a b. a -> Defined b -> Defined a
forall a b. (a -> b) -> Defined a -> Defined b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Defined b -> Defined a
$c<$ :: forall a b. a -> Defined b -> Defined a
fmap :: (a -> b) -> Defined a -> Defined b
$cfmap :: forall a b. (a -> b) -> Defined a -> Defined b
Functor, (forall x. Defined x -> Rep (Defined x) x)
-> (forall x. Rep (Defined x) x -> Defined x)
-> Generic (Defined x)
forall x. Rep (Defined x) x -> Defined x
forall x. Defined x -> Rep (Defined x) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x x. Rep (Defined x) x -> Defined x
forall x x. Defined x -> Rep (Defined x) x
$cto :: forall x x. Rep (Defined x) x -> Defined x
$cfrom :: forall x x. Defined x -> Rep (Defined x) x
Generic)
  deriving anyclass (Int -> Defined x -> Int
Defined x -> Int
(Int -> Defined x -> Int)
-> (Defined x -> Int) -> Hashable (Defined x)
forall x. Hashable x => Int -> Defined x -> Int
forall x. Hashable x => Defined x -> Int
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Defined x -> Int
$chash :: forall x. Hashable x => Defined x -> Int
hashWithSalt :: Int -> Defined x -> Int
$chashWithSalt :: forall x. Hashable x => Int -> Defined x -> Int
Hashable)
  deriving (Defined x
Defined x -> Defined x -> Bounded (Defined x)
forall a. a -> a -> Bounded a
forall x. Bounded x => Defined x
maxBound :: Defined x
$cmaxBound :: forall x. Bounded x => Defined x
minBound :: Defined x
$cminBound :: forall x. Bounded x => Defined x
Bounded, Integer -> Defined x
Defined x -> Defined x
Defined x -> Defined x -> Defined x
(Defined x -> Defined x -> Defined x)
-> (Defined x -> Defined x -> Defined x)
-> (Defined x -> Defined x -> Defined x)
-> (Defined x -> Defined x)
-> (Defined x -> Defined x)
-> (Defined x -> Defined x)
-> (Integer -> Defined x)
-> Num (Defined x)
forall x. Num x => Integer -> Defined x
forall x. Num x => Defined x -> Defined x
forall x. Num x => Defined x -> Defined x -> Defined x
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Defined x
$cfromInteger :: forall x. Num x => Integer -> Defined x
signum :: Defined x -> Defined x
$csignum :: forall x. Num x => Defined x -> Defined x
abs :: Defined x -> Defined x
$cabs :: forall x. Num x => Defined x -> Defined x
negate :: Defined x -> Defined x
$cnegate :: forall x. Num x => Defined x -> Defined x
* :: Defined x -> Defined x -> Defined x
$c* :: forall x. Num x => Defined x -> Defined x -> Defined x
- :: Defined x -> Defined x -> Defined x
$c- :: forall x. Num x => Defined x -> Defined x -> Defined x
+ :: Defined x -> Defined x -> Defined x
$c+ :: forall x. Num x => Defined x -> Defined x -> Defined x
Num) via (Ap Defined x)

instance Enum content => Enum (Defined content) where
  fromEnum :: Defined content -> Int
fromEnum = \case
    Exactly content
this -> content -> Int
forall a. Enum a => a -> Int
fromEnum content
this
    Defined content
_            -> String -> Int
forall a. HasCallStack => String -> a
error String
"fromEnum is undefined for non-exact values."

  toEnum :: Int -> Defined content
toEnum = content -> Defined content
forall (f :: * -> *) a. Applicative f => a -> f a
pure (content -> Defined content)
-> (Int -> content) -> Int -> Defined content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> content
forall a. Enum a => Int -> a
toEnum

instance Applicative Defined where
  pure :: a -> Defined a
pure = a -> Defined a
forall a. a -> Defined a
Exactly

  Defined (a -> b)
Conflict <*> :: Defined (a -> b) -> Defined a -> Defined b
<*> Defined a
_ = Defined b
forall x. Defined x
Conflict
  Defined (a -> b)
_ <*> Defined a
Conflict = Defined b
forall x. Defined x
Conflict

  Defined (a -> b)
Unknown <*> Defined a
_ = Defined b
forall x. Defined x
Unknown
  Defined (a -> b)
_ <*> Defined a
Unknown = Defined b
forall x. Defined x
Unknown

  Exactly a -> b
f <*> Exactly a
x
    = b -> Defined b
forall a. a -> Defined a
Exactly (a -> b
f a
x)

instance Eq content => Semigroup (Defined content) where
  Defined content
Conflict <> :: Defined content -> Defined content -> Defined content
<> Defined content
_ = Defined content
forall x. Defined x
Conflict
  Defined content
_ <> Defined content
Conflict = Defined content
forall x. Defined x
Conflict

  Defined content
this <> Defined content
Unknown = Defined content
this
  Defined content
Unknown <> Defined content
that = Defined content
that

  Exactly content
this <> Exactly content
that
    | content
this content -> content -> Bool
forall a. Eq a => a -> a -> Bool
== content
that = content -> Defined content
forall a. a -> Defined a
Exactly content
this
    | Bool
otherwise    = Defined content
forall x. Defined x
Conflict

instance Eq content => Monoid (Defined content) where
  mempty :: Defined content
mempty = Defined content
forall x. Defined x
Unknown

instance Real content => Real (Defined content) where
  toRational :: Defined content -> Rational
toRational = \case
    Exactly content
this -> content -> Rational
forall a. Real a => a -> Rational
toRational content
this
    Defined content
_            -> String -> Rational
forall a. HasCallStack => String -> a
error String
"toRational is undefined for non-exact values."

instance Integral content => Integral (Defined content) where
  quotRem :: Defined content
-> Defined content -> (Defined content, Defined content)
quotRem Defined content
this Defined content
that = Defined (content, content) -> (Defined content, Defined content)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip ((content -> content -> (content, content))
-> Defined content -> Defined content -> Defined (content, content)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 content -> content -> (content, content)
forall a. Integral a => a -> a -> (a, a)
quotRem Defined content
this Defined content
that)

  toInteger :: Defined content -> Integer
toInteger = \case
    Exactly content
this -> content -> Integer
forall a. Integral a => a -> Integer
toInteger content
this
    Defined content
_            -> String -> Integer
forall a. HasCallStack => String -> a
error String
"toInteger is undefined for non-exact values."

instance Fractional x => Fractional (Defined x) where
  / :: Defined x -> Defined x -> Defined x
(/) = (x -> x -> x) -> Defined x -> Defined x -> Defined x
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 x -> x -> x
forall a. Fractional a => a -> a -> a
(/)

  fromRational :: Rational -> Defined x
fromRational = x -> Defined x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Defined x) -> (Rational -> x) -> Rational -> Defined x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> x
forall a. Fractional a => Rational -> a
fromRational
  recip :: Defined x -> Defined x
recip        = (x -> x) -> Defined x -> Defined x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> x
forall a. Fractional a => a -> a
recip

instance Input (Defined content) where
  type Raw (Defined content) = content

  from :: Int -> [Raw (Defined content)] -> Config m (Defined content)
from Int
count [Raw (Defined content)]
options = [Defined content]
-> (Defined content -> m [Defined content])
-> Config m (Defined content)
forall (m :: * -> *) x. [x] -> (x -> m [x]) -> Config m x
Config (Int -> Defined content -> [Defined content]
forall a. Int -> a -> [a]
replicate Int
count Defined content
forall x. Defined x
Unknown) do
    [Defined content] -> m [Defined content]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Defined content] -> m [Defined content])
-> (Defined content -> [Defined content])
-> Defined content
-> m [Defined content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Defined content
Unknown -> (content -> Defined content) -> [content] -> [Defined content]
forall a b. (a -> b) -> [a] -> [b]
map content -> Defined content
forall a. a -> Defined a
Exactly [content]
[Raw (Defined content)]
options
      Defined content
decided -> [ Defined content
decided ]