TH.hs

{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoOverloadedLists #-}
{-# OPTIONS_GHC -fno-print-explicit-runtime-reps #-}

-- | adapated from 'discoverInstances' from https://hackage.haskell.org/package/discover-instances-0.1.0.0
module Spec.HTree.TH (discoverInstances, discoverInstancesTypeable) where

import Data.HTree.Existential (Has (Proves), Some (MkSome))
import Data.HTree.Families (Both)
import Data.Kind (Constraint)
import Data.Proxy (Proxy (Proxy))
import Data.Typeable (Typeable, typeRep)
import Language.Haskell.TH (Type)
import Language.Haskell.TH.Syntax
  ( Dec (InstanceD)
  , Exp (ListE)
  , InstanceDec
  , Q
  , TExp (TExp, unType)
  , Type (..)
  , mkName
  , reifyInstances
  , reportWarning
  , unsafeTExpCoerce
  )
import Language.Haskell.TH.Syntax.Compat
  ( SpliceQ
  , examineSplice
  , liftSplice
  )

discoverInstances :: forall {k} (c :: k -> Constraint). Typeable c => SpliceQ [Some (Has c Proxy)]
discoverInstances = liftSplice $ do
  let className = show (typeRep (Proxy @c))
      listTE :: [TExp a] -> TExp [a]
      listTE = TExp . ListE . map unType
  instanceDecs <- reifyInstances (mkName className) [VarT (mkName "a")]

  dicts <- listTE <$> traverse decToDict instanceDecs

  examineSplice [||concat $$(liftSplice $ pure dicts)||]

decToDict :: forall {k} (c :: k -> Constraint). InstanceDec -> Q (TExp [Some (Has c Proxy)])
decToDict = \case
  InstanceD _moverlap cxt typ _decs ->
    case cxt of
      [] -> do
        let t = case typ of
              AppT _ t' -> stripSig t'
              _ -> t
            stripSig (SigT a _) = a
            stripSig x = x
            proxy = [|Proxy :: Proxy $(pure t)|]
        unsafeTExpCoerce [|[MkSome (Proves $proxy)]|]
      _ -> examineSplice [||[]||]
  _ -> do
    reportWarning "discoverInstances called on 'reifyInstances' somehow returned something that wasn't a type class instance."
    examineSplice [||[]||]

discoverInstancesTypeable :: forall {k} (c :: k -> Constraint). Typeable c => SpliceQ [Some (Has (Both Typeable c) Proxy)]
discoverInstancesTypeable = liftSplice $ do
  let className = show (typeRep (Proxy @c))
      listTE :: [TExp a] -> TExp [a]
      listTE = TExp . ListE . map unType
  instanceDecs <- reifyInstances (mkName className) [VarT (mkName "a")]

  dicts <- listTE <$> traverse decToDictTypeable instanceDecs

  examineSplice [||concat $$(liftSplice $ pure dicts)||]

decToDictTypeable :: forall {k} (c :: k -> Constraint). InstanceDec -> Q (TExp [Some (Has (Both Typeable c) Proxy)])
decToDictTypeable = \case
  InstanceD _moverlap cxt typ _decs ->
    case cxt of
      [] -> do
        let t :: Maybe Type = clean =<< removeClass typ
            removeClass :: Type -> Maybe Type
            removeClass (AppT _ x) = pure x
            removeClass (SigT x _) = removeClass x
            removeClass _ = Nothing

            clean :: Type -> Maybe Type
            clean (AppT f x) = AppT <$> clean f <*> clean x
            clean (SigT x _) = clean x
            clean (VarT _) = Nothing
            clean (ConT n) = pure $ ConT n
            clean (ParensT n) = pure $ ParensT n
            clean (TupleT n) = pure $ TupleT n
            clean ListT = pure ListT
            clean _ = Nothing

            proxy = case t of
              Just t' -> Just [|Proxy :: Proxy $(pure t')|]
              Nothing -> Nothing

        unsafeTExpCoerce $ case proxy of
          Just proxy' -> [|[MkSome (Proves @(Both Typeable _) $proxy')]|]
          Nothing -> [|[]|]
      _ -> examineSplice [||[]||]
  _ -> do
    reportWarning "discoverInstances called on 'reifyInstances' somehow returned something that wasn't a type class instance."
    examineSplice [||[]||]