{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Constraint.Bare
-- Copyright   :  (c) 2019 Artem Chirkin
-- License     :  BSD3
-- Portability :  non-portable
--
-- Extract a Constraint from a Dict to manipulate it as a plain value.
-- It is supposed to be used in compiler plugins
--   -- to move around instances of type classes.
--
-----------------------------------------------------------------------------
module Data.Constraint.Bare
  ( BareConstraint, pattern DictValue
  , dictToBare, bareToDict
  , withBareConstraint
  ) where


import Data.Constraint (Dict (..))
import GHC.Base        (Constraint, Type)
import GHC.Exts        (unsafeCoerce#)

-- | An unsafeCoerced pointer to a Constraint, such as a class function dictionary.
data BareConstraint :: Constraint -> Type

-- | Extract the constraint inside the Dict GADT as if it was
--   an ordinary value of kind `Type`.
--
--   It exploits the feature of the GHC core language
--    -- representing constraints as ordinary type arguments of a function.
--   Thus, I unsafeCoerce between a function with one argument and a function
--    with no arguments and one constraint.
--
--   This pattern has never been tested with multiple constraints.
pattern DictValue :: BareConstraint c -> Dict c
pattern $bDictValue :: BareConstraint c -> Dict c
$mDictValue :: forall r (c :: Constraint).
Dict c -> (BareConstraint c -> r) -> (Void# -> r) -> r
DictValue c <- (dictToBare -> c)
  where
    DictValue BareConstraint c
c = BareConstraint c -> Dict c
forall (c :: Constraint). BareConstraint c -> Dict c
bareToDict BareConstraint c
c

#if __GLASGOW_HASKELL__ >= 802
{-# COMPLETE DictValue #-}
#endif

-- | Extract a `Constraint` from a `Dict`
dictToBare :: forall c . Dict c -> BareConstraint c
dictToBare :: Dict c -> BareConstraint c
dictToBare Dict c
Dict = case ((Any -> Any) -> Magic c (BareConstraint c)
unsafeCoerce# Any -> Any
forall a. a -> a
id :: Magic c (BareConstraint c)) of Magic c => BareConstraint c
c -> BareConstraint c
c => BareConstraint c
c
{-# INLINE dictToBare #-}

-- | Wrap a `Constraint` into a `Dict`
bareToDict :: forall c . BareConstraint c -> Dict c
bareToDict :: BareConstraint c -> Dict c
bareToDict = Magic c (Dict c) -> BareConstraint c -> Dict c
unsafeCoerce# ((c => Dict c) -> Magic c (Dict c)
forall (c :: Constraint) r. (c => r) -> Magic c r
Magic c => Dict c
forall (a :: Constraint). a => Dict a
Dict :: Magic c (Dict c))
{-# INLINE bareToDict #-}

-- | Provide a constraint to a function using `BareConstraint`.
--   This allows to provide constraints on-demand (lazily), rather than eagerly
--   pattern-matching against `Dict` before executing the function.
withBareConstraint :: forall c r . BareConstraint c -> (c => r) -> r
withBareConstraint :: BareConstraint c -> (c => r) -> r
withBareConstraint BareConstraint c
bc c => r
f = Magic c r -> BareConstraint c -> r
unsafeCoerce# ((c => r) -> Magic c r
forall (c :: Constraint) r. (c => r) -> Magic c r
Magic c => r
f :: Magic c r) BareConstraint c
bc

newtype Magic c r = Magic (c => r)