diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for discover-instances + +## Unreleased changes + +## 0.1.0.0 + +- Initial Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Matt Parsons (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Matt Parsons nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# discover-instances + +A Haskell package that defines a `TemplateHaskell` helper for discovering and working with instances of a type class. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/discover-instances.cabal b/discover-instances.cabal new file mode 100644 --- /dev/null +++ b/discover-instances.cabal @@ -0,0 +1,55 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: discover-instances +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/parsonsmatt/discover-instances#readme +bug-reports: https://github.com/parsonsmatt/discover-instances/issues +author: Matt Parsons +maintainer: parsonsmatt@gmail.com +copyright: Matt Parsons +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/parsonsmatt/discover-instances + +library + exposed-modules: + DiscoverInstances + other-modules: + Paths_discover_instances + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.12 && <5 + , some-dict-of + , template-haskell + , th-compat + default-language: Haskell2010 + +test-suite discover-instances-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_discover_instances + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.12 && <5 + , discover-instances + , some-dict-of + , template-haskell + , th-compat + default-language: Haskell2010 diff --git a/src/DiscoverInstances.hs b/src/DiscoverInstances.hs new file mode 100644 --- /dev/null +++ b/src/DiscoverInstances.hs @@ -0,0 +1,248 @@ +{-# 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 = liftSplice $ do + let + className = + show (typeRep (Proxy @c)) + instanceDecs <- reifyInstances (mkName className) [VarT (mkName "a")] + + dicts <- fmap listTE $ traverse decToDict instanceDecs + + 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 dicts f = + fmap (\(SomeDictOf p) -> f p) 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 dicts f = + traverse (\(SomeDictOf p) -> f p) dicts + +listTE :: [TExp a] -> TExp [a] +listTE = TExp . ListE . map unType + +decToDict :: forall k (c :: k -> Constraint). InstanceDec -> Q (TExp [SomeDict c]) +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 [| [ SomeDictOf $proxy ] |] + _ -> 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 + examineSplice [|| [] ||] + + _ -> do + reportWarning $ + "discoverInstances called on 'reifyInstances' somehow returned something that wasn't a type class instance." + examineSplice [|| [] ||] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -ddump-splices #-} + +import Data.Foldable +import Data.Proxy +import Data.Typeable +import DiscoverInstances + +show :: [SomeDict Show] +show = $$(discoverInstances @Show) + +eq :: [SomeDict Eq] +eq = $$(discoverInstances) + +functor :: [SomeDict Functor] +functor = $$discoverInstances + +main :: IO () +main = do + for_ functor $ \(SomeDictOf p@(Proxy :: Proxy t)) -> do + print 1234