{-# LANGUAGE Safe #-}
module Data.Type.Dec (
    -- * Types
    Neg,
    Dec (..),
    Decidable (..),
    -- * Neg combinators
    toNegNeg,
    tripleNeg,
    contradict,
    contraposition,
    -- * Dec combinators
    decNeg,
    decShow,
    decToMaybe,
    decToBool,
    ) where

import Data.Void (Void)

-- | Intuitionistic negation.
type Neg a = a -> Void

-- | Decidable (nullary) relations.
data Dec a
    = Yes a
    | No (Neg a)

-- | Class of decidable types.
--
-- == Law
--
-- @a@ should be a Proposition, i.e. the 'Yes' answers should be unique.
--
-- /Note:/ We'd want to have decidable equality @:~:@ here too,
-- but that seems to be a deep dive into singletons.
class Decidable a where
    decide :: Dec a

-------------------------------------------------------------------------------
-- Neg combinators
-------------------------------------------------------------------------------

-- | We can negate anything twice.
--
-- Double-negation elimination is inverse of 'toNegNeg' and generally
-- impossible.
toNegNeg :: a -> Neg (Neg a)
toNegNeg :: a -> Neg (Neg a)
toNegNeg a
x = (Neg a -> Neg a
forall a b. (a -> b) -> a -> b
$ a
x)

-- | Triple negation can be reduced to a single one.
tripleNeg :: Neg (Neg (Neg a)) -> Neg a
tripleNeg :: Neg (Neg (Neg a)) -> Neg a
tripleNeg Neg (Neg (Neg a))
f a
a = Neg (Neg (Neg a))
f (a -> Neg (Neg a)
forall a. a -> Neg (Neg a)
toNegNeg a
a)

-- | Weak contradiction.
contradict :: (a -> Neg b) -> b -> Neg a
contradict :: (a -> Neg b) -> b -> Neg a
contradict a -> Neg b
f b
b a
a = a -> Neg b
f a
a b
b

-- | A variant of contraposition.
contraposition :: (a -> b) -> Neg b -> Neg a
contraposition :: (a -> b) -> Neg b -> Neg a
contraposition a -> b
f Neg b
nb a
a = Neg b
nb (a -> b
f a
a)

-------------------------------------------------------------------------------
-- Dec combinators
-------------------------------------------------------------------------------

instance Eq a => Eq (Dec a) where
    Yes a
x == :: Dec a -> Dec a -> Bool
== Yes a
y = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
    Yes a
_ == No Neg a
_   = Bool
False
    No Neg a
_  == Yes a
_  = Bool
False
    No Neg a
_  == No Neg a
_   = Bool
True  -- @'Not a' is a /h-Prop/ so all values are equal.

-- | 'decToBool' respects this ordering.
--
-- /Note:/ yet if you have @p :: a@ and @p :: 'Neg' a@, something is wrong.
--
instance Ord a => Ord (Dec a) where
    compare :: Dec a -> Dec a -> Ordering
compare (Yes a
a) (Yes a
b) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
    compare (No Neg a
_)  (Yes a
_) = Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bool
False Bool
True
    compare (Yes a
_) (No Neg a
_)  = Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bool
True Bool
False
    compare (No Neg a
_)  (No Neg a
_)  = Ordering
EQ

-- | Flip 'Dec' branches.
decNeg :: Dec a -> Dec (Neg a)
decNeg :: Dec a -> Dec (Neg a)
decNeg (Yes a
p) = Neg (Neg a) -> Dec (Neg a)
forall a. Neg a -> Dec a
No (a -> Neg (Neg a)
forall a. a -> Neg (Neg a)
toNegNeg a
p)
decNeg (No Neg a
np) = Neg a -> Dec (Neg a)
forall a. a -> Dec a
Yes Neg a
np

-- | Show 'Dec'.
--
-- >>> decShow $ Yes ()
-- "Yes ()"
--
-- >>> decShow $ No id
-- "No <toVoid>"
--
decShow :: Show a => Dec a -> String
decShow :: Dec a -> String
decShow (Yes a
x) = String
"Yes " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 a
x String
""
decShow (No Neg a
_)  = String
"No <toVoid>"

-- | Convert @'Dec' a@ to @'Maybe' a@, forgetting the 'No' evidence.
decToMaybe :: Dec a -> Maybe a
decToMaybe :: Dec a -> Maybe a
decToMaybe (Yes a
p) = a -> Maybe a
forall a. a -> Maybe a
Just a
p
decToMaybe (No Neg a
_)  = Maybe a
forall a. Maybe a
Nothing

-- | Convert 'Dec' to 'Bool', forgetting the evidence.
decToBool :: Dec a -> Bool
decToBool :: Dec a -> Bool
decToBool (Yes a
_) = Bool
True
decToBool (No Neg a
_)  = Bool
False