{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}
module Spec.ClassDict01 where
import Data.Constraint
import Data.Constraint.Deriving
import qualified Data.Monoid as M
main :: IO ()
main = case testOrd of
Dict -> do
-- pattern-matching against Dict type makes `Ord Test` instance available
-- within the scope of the case expression.
print $ compare (Test 1 "hello") (Test 1 "world")
print $ Test 2 "hello" > Test 1 "world"
print $ max (Test 3 "A") (Test 3 "B")
-- Note, Test derives `Eq`, but not `Ord`
data Test = Test Int String
deriving (Eq, Show, Read)
{-
Here I just use the function `defineOrd`.
In the source code, `defineOrd` is a dummy <<loop>> function,
but the GHC Core plugin replaces it with a proper implementation.
-}
testOrd :: Dict (Ord Test)
testOrd = defineOrd
cmp
(\a b -> cmp a b == LT)
(\a b -> cmp a b /= GT)
(\a b -> cmp a b == GT)
(\a b -> cmp a b /= LT)
(\a b -> if cmp a b == LT then b else a)
(\a b -> if cmp a b == GT then b else a)
where
cmp (Test i s) (Test j t) = compare i j M.<> compare s t
{-
This is where all the magic happens:
1. The ClassDict plugin pass picks up the `defineOrd` declaration
2. Checks the result type: `Dict (Ord a)`; infers the class of interest: `Ord`
3. Finds out the data constructor of the class `Ord` and compares it against the
given function signature
4. If the types agree, the plugin replaces the generated GHC Core code with
actual constructor (wrapped by `Dict`).
Note, the arguments of this function should be carefully translated from the
class declaration:
all superclasses go first, followed by all class methods (order matters!).
-}
{-# ANN defineOrd ClassDict #-}
defineOrd :: Eq a -- Superclass
=> (a -> a -> Ordering) -- compare
-> (a -> a -> Bool) -- (<)
-> (a -> a -> Bool) -- (<=)
-> (a -> a -> Bool) -- (>)
-> (a -> a -> Bool) -- (>=)
-> (a -> a -> a) -- max
-> (a -> a -> a) -- min
-> Dict (Ord a)
defineOrd = defineOrd