{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -- | Generally speaking, this module is only useful to discover instances -- of unary type classes where the instance is unconstrained. -- -- That is to say - not all that useful in libraries. -- -- However, this has ended up being super useful to me in a bunch of -- application contexts. Consider @persistent-discover@, which grabs all -- the @PersistEntity@ instances in scope and makes the @[EntityDef]@ for -- them. Or consider a front-end types generating module, which needs to -- import a ton of modules, and then call @toSomeFrontEndClass :: SomeClass -- a => Proxy a -> SomeThing@ on each thing. -- -- This library can simplify that process. -- -- @since 0.1.0.0 module DiscoverInstances ( -- * The main interface discoverInstances -- * Using the results of 'discoverInstances' -- $using , withInstances , forInstances , module SomeDictOf -- * Re-exports , module Data.Proxy ) where import Data.Proxy import Data.Typeable import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax.Compat import SomeDictOf -- | This TemplateHaskell function accepts a type and splices in a list of -- 'SomeDict's that provide evidence that the type is an instance of -- the class that you asked for. -- -- There are some limitations. -- -- * The class can only accept a single parameter. -- * The instances returned do not have a context. -- -- Example Use: -- -- @ -- eq :: ['SomeDict' Eq] -- eq = $$(discoverInstances) -- @ -- -- This function uses typed @TemplateHaskell@, which means you don't need to -- provide a type annotation directly. However, you can pass a type directly. -- -- @ -- ord :: ['SomeDict' 'Ord'] -- ord = $$(discoverInstances @Ord) -- @ -- -- GHC supports using the @$$@ syntax without parentheses if the expression is -- a single term. So you can also write this: -- -- @ -- functor :: ['SomeDict' 'Functor'] -- functor = $$discoverInstances -- @ -- -- But you'll get an error if you type-apply like that. -- -- @since 0.1.0.0 discoverInstances :: forall (c :: _ -> Constraint) . (Typeable c) => SpliceQ [SomeDict c] discoverInstances :: SpliceQ [SomeDict c] discoverInstances = SpliceQ [SomeDict c] -> SpliceQ [SomeDict c] forall a (m :: * -> *). m (TExp a) -> m (TExp a) liftSplice (SpliceQ [SomeDict c] -> SpliceQ [SomeDict c]) -> SpliceQ [SomeDict c] -> SpliceQ [SomeDict c] forall a b. (a -> b) -> a -> b $ do let className :: String className = TypeRep -> String forall a. Show a => a -> String show (Proxy c -> TypeRep forall k (proxy :: k -> *) (a :: k). Typeable a => proxy a -> TypeRep typeRep (Proxy c forall k (t :: k). Proxy t Proxy @c)) [InstanceDec] instanceDecs <- Name -> [Type] -> Q [InstanceDec] reifyInstances (String -> Name mkName String className) [Name -> Type VarT (String -> Name mkName String "a")] TExp [[SomeDict c]] dicts <- ([TExp [SomeDict c]] -> TExp [[SomeDict c]]) -> Q [TExp [SomeDict c]] -> Q (TExp [[SomeDict c]]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [TExp [SomeDict c]] -> TExp [[SomeDict c]] forall a. [TExp a] -> TExp [a] listTE (Q [TExp [SomeDict c]] -> Q (TExp [[SomeDict c]])) -> Q [TExp [SomeDict c]] -> Q (TExp [[SomeDict c]]) forall a b. (a -> b) -> a -> b $ (InstanceDec -> SpliceQ [SomeDict c]) -> [InstanceDec] -> Q [TExp [SomeDict c]] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse InstanceDec -> SpliceQ [SomeDict c] forall k (c :: k -> Constraint). InstanceDec -> Q (TExp [SomeDict c]) decToDict [InstanceDec] instanceDecs SpliceQ [SomeDict c] -> SpliceQ [SomeDict c] forall (m :: * -> *) a. Splice m a -> Splice m a examineSplice [|| concat $$(liftSplice $ pure dicts) ||] -- $using -- -- Once you've acquired a @'SomeDict' c@ for some type class @c@ that you care -- about, it's not entirely clear how you might use it. -- -- The "SomeDictOf" module contains functions for working with these, but the -- simplest thing to do is probably pattern match on them directly. The use case -- that this library was designed to support is iterating over all the visible -- instances of a class and performing some operation on the class. -- -- Consider the @persistent@ database library. The @PersistEntity@ type class -- defines a method @entityDef :: PersistEntity a => proxy a -> EntityDef@, -- where the @EntityDef@ type contains information that relates the type to the -- database encoding for the type. Let's get all the @EntityDef@s for the types -- in scope: -- -- @ -- entityDefs :: [EntityDef] -- entityDefs = -- 'map' -- (\\('SomeDictOf' proxy) -> entityDef proxy) -- $$('discoverInstances' \@PersistEntity) -- @ -- -- The @EntityDef@ for an entity include the documentation comments written for -- the entity. So we can print out all the documentation for the database -- tables. -- -- Another intended use is to render generated code. We use the -- @aeson-typescript@ library to generate TypeScript code for our API. Without -- this library, we maintain a list of types to generate code for. This list is -- duplicated in the imports, as well as the data declarations. -- -- @ -- import Model.Foo -- import Model.Bar -- import Model.Baz -- import Model.Quux -- -- renderTypeScript :: IO () -- renderTypeScript = do -- writeToFile $ concat -- [ writeType \@Foo -- , writeType \@Bar -- , writeType \@Baz -- , writeType \@Quux -- ] -- @ -- -- With 'discoverInstances', we can skip a lot of this work. -- -- @ -- import Model.Foo -- import Model.Bar -- import Model.Baz -- import Model.Quux -- -- renderTypeScript :: IO () -- renderTypeScript = do -- writeToFile $ concat -- $ flip map $$('discoverInstances' \@TypeScript) -- $ \\('SomeDictOf' ('Proxy' :: 'Proxy' ty) -> -- writeType \@ty -- @ -- -- The above two patterns are encapsulated in 'withInstances'. We can rewrite -- them like this: -- -- @ -- entityDefs = -- 'withInstances' -- $$(discoverInstances \@PersistEntity) -- $ \\proxy -> entityDef proxy -- -- renderTypeScript :: IO () -- renderTypeScript = do -- writeToFile $ concat -- $ 'withInstances' $$('discoverInstances' \@TypeScript) -- $ \\('Proxy' :: 'Proxy' ty) -> -- writeType \@ty -- @ -- -- Another use case is to load all models out of the database, to ensure that -- serialization and deserialization logic works. 'forInstances' is useful for -- operating over instances effectfully. -- -- @ --loadAllModels :: SqlPersistM () --loadAllModels = do -- 'forInstances' $$('discoverInstances' \@PersistEntity) \\('Proxy' :: 'Proxy' a) -> do -- selectList [] [] :: SqlPersistM [Entity a] -- @ -- | An alias for the pattern: -- -- @ -- flip map $$discoverInstances $ \\('SomeDictOf' p) -> f p -- @ -- -- @since 0.1.0.0 withInstances :: Functor f => f (SomeDict c) -> (forall a. c a => Proxy a -> r) -> f r withInstances :: f (SomeDict c) -> (forall (a :: k). c a => Proxy a -> r) -> f r withInstances f (SomeDict c) dicts forall (a :: k). c a => Proxy a -> r f = (SomeDict c -> r) -> f (SomeDict c) -> f r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (\(SomeDictOf Proxy a p) -> Proxy a -> r forall (a :: k). c a => Proxy a -> r f Proxy a p) f (SomeDict c) dicts -- | An alias for the pattern: -- -- @ -- for $$discoverInstances $ \\('SomeDictOf' p) -> do -- f p -- @ -- -- @since 0.1.0.0 forInstances :: (Traversable t, Applicative f) => t (SomeDict c) -> (forall a. c a => Proxy a -> f r) -> f (t r) forInstances :: t (SomeDict c) -> (forall (a :: k). c a => Proxy a -> f r) -> f (t r) forInstances t (SomeDict c) dicts forall (a :: k). c a => Proxy a -> f r f = (SomeDict c -> f r) -> t (SomeDict c) -> f (t r) forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (\(SomeDictOf Proxy a p) -> Proxy a -> f r forall (a :: k). c a => Proxy a -> f r f Proxy a p) t (SomeDict c) dicts listTE :: [TExp a] -> TExp [a] listTE :: [TExp a] -> TExp [a] listTE = Exp -> TExp [a] forall a. Exp -> TExp a TExp (Exp -> TExp [a]) -> ([TExp a] -> Exp) -> [TExp a] -> TExp [a] forall b c a. (b -> c) -> (a -> b) -> a -> c . [Exp] -> Exp ListE ([Exp] -> Exp) -> ([TExp a] -> [Exp]) -> [TExp a] -> Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . (TExp a -> Exp) -> [TExp a] -> [Exp] forall a b. (a -> b) -> [a] -> [b] map TExp a -> Exp forall a. TExp a -> Exp unType decToDict :: forall k (c :: k -> Constraint). InstanceDec -> Q (TExp [SomeDict c]) decToDict :: InstanceDec -> Q (TExp [SomeDict c]) decToDict = \case InstanceD Maybe Overlap _moverlap [Type] cxt Type typ [InstanceDec] _decs -> case [Type] cxt of [] -> do let t :: Type t = case Type typ of AppT Type _ Type t' -> Type -> Type stripSig Type t' Type _ -> Type t stripSig :: Type -> Type stripSig (SigT Type a Type _) = Type a stripSig Type x = Type x proxy :: ExpQ proxy = [| Proxy :: Proxy $(pure t) |] ExpQ -> Q (TExp [SomeDict c]) forall a. ExpQ -> Q (TExp a) unsafeTExpCoerce [| [ SomeDictOf $proxy ] |] [Type] _ -> do -- reportWarning $ -- "I haven't figured out how to put constrained instances on here, so I'm skipping the type: " -- <> show typ -- <> ", context: " -- <> show cxt Q (TExp [SomeDict c]) -> Q (TExp [SomeDict c]) forall (m :: * -> *) a. Splice m a -> Splice m a examineSplice [|| [] ||] InstanceDec _ -> do String -> Q () reportWarning (String -> Q ()) -> String -> Q () forall a b. (a -> b) -> a -> b $ String "discoverInstances called on 'reifyInstances' somehow returned something that wasn't a type class instance." Q (TExp [SomeDict c]) -> Q (TExp [SomeDict c]) forall (m :: * -> *) a. Splice m a -> Splice m a examineSplice [|| [] ||]