constraints-deriving 1.0.2.0 → 1.0.3.0
raw patch · 39 files changed
+4225/−4213 lines, 39 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Constraint.Deriving: DeriveAll' :: OverlapMode -> [String] -> DeriveAll
+ Data.Constraint.Deriving: [_forcedMode] :: DeriveAll -> OverlapMode
+ Data.Constraint.Deriving: [_ignoreList] :: DeriveAll -> [String]
+ Data.Constraint.Deriving.DeriveAll: DeriveAll' :: OverlapMode -> [String] -> DeriveAll
+ Data.Constraint.Deriving.DeriveAll: [_forcedMode] :: DeriveAll -> OverlapMode
+ Data.Constraint.Deriving.DeriveAll: [_ignoreList] :: DeriveAll -> [String]
Files
- LICENSE +30/−30
- README.md +112/−106
- Setup.hs +81/−81
- constraints-deriving.cabal +4/−4
- example/Lib/BackendFamily.hs +224/−224
- example/Lib/VecBackend.hs +109/−109
- example/Lib/Vector.hs +117/−117
- example/Main.hs +35/−35
- src-constraints/Data/Constraint.hs +786/−786
- src-constraints/Data/Constraint/Unsafe.hs +72/−72
- src/Data/Constraint/Bare.hs +63/−63
- src/Data/Constraint/Deriving.hs +78/−78
- src/Data/Constraint/Deriving/CorePluginM.hs +729/−729
- src/Data/Constraint/Deriving/DeriveAll.hs +930/−924
- src/Data/Constraint/Deriving/ToInstance.hs +278/−278
- test/Spec.hs +232/−232
- test/Spec/DeriveAll01.hs +24/−24
- test/Spec/DeriveAll02.hs +37/−37
- test/Spec/DeriveAll03.hs +34/−34
- test/Spec/DeriveAll04.hs +20/−20
- test/Spec/DeriveAll05.hs +13/−13
- test/Spec/DeriveAll06.hs +11/−11
- test/Spec/ToInstance01.hs +52/−52
- test/Spec/ToInstance02.hs +43/−43
- test/out/DeriveAll01.stderr +31/−31
- test/out/DeriveAll01.stdout +1/−1
- test/out/DeriveAll02.stderr +14/−14
- test/out/DeriveAll02.stdout +1/−1
- test/out/DeriveAll03.stderr +25/−25
- test/out/DeriveAll03.stdout +1/−1
- test/out/DeriveAll04.stderr +6/−6
- test/out/DeriveAll04.stdout +1/−1
- test/out/DeriveAll05.stderr +2/−2
- test/out/DeriveAll05.stdout +1/−1
- test/out/DeriveAll06.stderr +9/−9
- test/out/DeriveAll06.stdout +1/−1
- test/out/ToInstance01.stderr +10/−10
- test/out/ToInstance02.stderr +7/−7
- test/out/ToInstance02.stdout +1/−1
LICENSE view
@@ -1,30 +1,30 @@-Copyright Artem Chirkin (c) 2019--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 Artem Chirkin 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.+Copyright Artem Chirkin (c) 2019 + +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 Artem Chirkin 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.
README.md view
@@ -1,106 +1,112 @@-[](https://hackage.haskell.org/package/constraints-deriving)-[](http://travis-ci.org/achirkin/constraints-deriving)-# constraints-deriving--This project is based on the [constraints](http://hackage.haskell.org/package/constraints) library.-Module `Data.Constraint.Deriving` provides a GHC Core compiler plugin that generates class instances.--The main goal of this project is to make possible a sort of ad-hoc polymorphism that I wanted to-implement in [easytensor](http://hackage.haskell.org/package/easytensor) for performance reasons:-an umbrella type unifies multiple specialized type family backend instances;-if the type instance is known, GHC picks a specialized (overlapping) class instance for a required function;-otherwise, GHC resorts to a unified (overlappable) instance that is defined for the whole type family.--To use the plugin, add-```Haskell-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-```-to the header of your module.-For debugging, add a plugin option `dump-instances`:-```Haskell-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-```-to the header of your file; it will print all instances declared in the module (hand-written and auto-generated).-To enable much more verbose debug output, use library flag `dev` (for debugging the plugin itself).--Check out `example` folder for a motivating use case (enabled with flag `examples`).--The plugin is controlled via GHC annotations; there are two types of annotations corresponding to two plugin passes.-Both passes are core-to-core, which means the plugin runs after typechecker,-which in turn means **the generated class instances are available only outside of the module**.-A sort of inconvenience you may have experienced with template haskell 😉.--### DeriveAll--`DeriveAll` plugin pass inspects a newtype declaration.-To enable `DeriveAll` for a newtype `Foo`, add an annotation as follows:-```Haskell-data Bar a = ...-{-# ANN type Foo DeriveAll #-}-newtype Foo a = Foo (Bar a)---- the result is that Foo has the same set of instances as Bar-```-check out [`test/Spec/`](https://github.com/achirkin/constraints-deriving/tree/master/test/Spec) for [more examples](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/DeriveAll04.hs#L19-L20).--`DeriveAll` plugin pass looks through all possible type instances (in the presence of type families) of the base type,-and copies all class instances for the newtype wrapper.--Sometimes, you may need to refine the relation between the base type and the newtype;-you can do this via a special `type family DeriveContext newtype :: Constraint`.-By adding equality constraints, you can specify custom dependencies between type variables present in the newtype declaration-(e.g. [`test/Spec/DeriveAll01.hs`](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/DeriveAll01.hs#L24)).-By adding class constraints, you force these class constraints for all generated class instances-(e.g. in [`test/Spec/DeriveAll02.hs`](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/DeriveAll02.hs#L37)- all class instances of `BazTy a b c d e f` have an additional constraint `Show e`).---Note, the internal machinery is different from `GeneralizedNewtypeDeriving` approach:-rather than coercing every function in the instance definition from the base type to the newtype,-it coerces the whole instance dictionary.--#### Blacklisting instances from being DeriveAll-ed--Sometimes you may want to avoid deriving a number of instances for your newtype.-Use `DeriveAllBut [String]` constructor in the annotation and specify names of type classes you don't want to derive.-```Haskell-{-# ANN type CHF (DeriveAllBut ["Show"]) #-}-newtype CHF = CHF Double deriving Show---- the result is a normal `Show CHF` instance and the rest of `Double`'s instances are DeriveAll-ed-```-For your safety,-the plugin is hardcoded to **not** generate instances for any classes and types in-`GHC.Generics`, `Data.Data`, `Data.Typeable`, `Language.Haskell.TH`.---### ToInstance--`ToInstance` plugin pass converts a top-level `Ctx => Dict (Class t1..tn)` value declaration into-an instance of the form `instance Ctx => Class t1..tn`.-Thus, one can write arbitrary Haskell code (returning a class dictionary) to be executed every time-an instance is looked up by the GHC machinery.-To derive an instance this way, use `ToInstance (x :: OverlapMode)` for a declaration, e.g. as follows:-```Haskell-newtype Foo t = Foo t--{-# ANN deriveEq (ToInstance NoOverlap) #-}-deriveEq :: Eq t => Dict (Eq (Foo t))-deriveEq = mapDict (unsafeDerive Foo) Dict---- the result of the above is equal to--- deriving instance Eq t => Eq (Foo t)-```-You can find a more meaningful example in [`test/Spec/ToInstance01.hs`](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/ToInstance01.hs#L45-L47) or-[`example/Lib/VecBackend.hs`](https://github.com/achirkin/constraints-deriving/blob/master/example/Lib/VecBackend.hs).--**Danger**: `ToInstance` removes duplicate instances;-if you have defined an instance with the same head using vanilla Haskell and the plugin,-the latter will try to replace the former in place.-Behavior of the instance in the same module is undefined in this case-(the other modules should be fine seeing the plugin version).-*I used this trick to convince `.hs-boot` to see the instances generated by the plugin.*--## Further work--`DeriveAll` derivation mechanics currently may break functional dependencies (untested).+[](https://hackage.haskell.org/package/constraints-deriving) +[](http://travis-ci.org/achirkin/constraints-deriving) +# constraints-deriving + +This project is based on the [constraints](http://hackage.haskell.org/package/constraints) library. +Module `Data.Constraint.Deriving` provides a GHC Core compiler plugin that generates class instances. + +The main goal of this project is to make possible a sort of ad-hoc polymorphism that I wanted to +implement in [easytensor](http://hackage.haskell.org/package/easytensor) for performance reasons: +an umbrella type unifies multiple specialized type family backend instances; +if the type instance is known, GHC picks a specialized (overlapping) class instance for a required function; +otherwise, GHC resorts to a unified (overlappable) instance that is defined for the whole type family. + +To use the plugin, add +```Haskell +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +``` +to the header of your module. +For debugging, add a plugin option `dump-instances`: +```Haskell +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +``` +to the header of your file; it will print all instances declared in the module (hand-written and auto-generated). +To enable much more verbose debug output, use library flag `dev` (for debugging the plugin itself). + +Check out `example` folder for a motivating use case (enabled with flag `examples`). + +The plugin is controlled via GHC annotations; there are two types of annotations corresponding to two plugin passes. +Both passes are core-to-core, which means the plugin runs after typechecker, +which in turn means **the generated class instances are available only outside of the module**. +A sort of inconvenience you may have experienced with template haskell 😉. + +### DeriveAll + +`DeriveAll` plugin pass inspects a newtype declaration. +To enable `DeriveAll` for a newtype `Foo`, add an annotation as follows: +```Haskell +data Bar a = ... +{-# ANN type Foo DeriveAll #-} +newtype Foo a = Foo (Bar a) + +-- the result is that Foo has the same set of instances as Bar +``` +check out [`test/Spec/`](https://github.com/achirkin/constraints-deriving/tree/master/test/Spec) for [more examples](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/DeriveAll04.hs#L19-L20). + +`DeriveAll` plugin pass looks through all possible type instances (in the presence of type families) of the base type, +and copies all class instances for the newtype wrapper. + +Sometimes, you may need to refine the relation between the base type and the newtype; +you can do this via a special `type family DeriveContext newtype :: Constraint`. +By adding equality constraints, you can specify custom dependencies between type variables present in the newtype declaration +(e.g. [`test/Spec/DeriveAll01.hs`](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/DeriveAll01.hs#L24)). +By adding class constraints, you force these class constraints for all generated class instances +(e.g. in [`test/Spec/DeriveAll02.hs`](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/DeriveAll02.hs#L37) + all class instances of `BazTy a b c d e f` have an additional constraint `Show e`). + + +Note, the internal machinery is different from `GeneralizedNewtypeDeriving` approach: +rather than coercing every function in the instance definition from the base type to the newtype, +it coerces the whole instance dictionary. + +#### Blacklisting instances from being DeriveAll-ed + +Sometimes you may want to avoid deriving a number of instances for your newtype. +Use `DeriveAllBut [String]` constructor in the annotation and specify names of type classes you don't want to derive. +```Haskell +{-# ANN type CHF (DeriveAllBut ["Show"]) #-} +newtype CHF = CHF Double deriving Show + +-- the result is a normal `Show CHF` instance and the rest of `Double`'s instances are DeriveAll-ed +``` +For your safety, +the plugin is hardcoded to **not** generate instances for any classes and types in +`GHC.Generics`, `Data.Data`, `Data.Typeable`, `Language.Haskell.TH`. + +#### Overlapping instances + +By default `DeriveAll` marks all instances as `NoOverlap` if there are no overlapping +closed type families involved. +Otherwise, it marks overlapped type instances as `Incoherent`. +If this logic does not suit you, you can enforce `OverlapMode` using `DeriveAll'` data constructor. + +### ToInstance + +`ToInstance` plugin pass converts a top-level `Ctx => Dict (Class t1..tn)` value declaration into +an instance of the form `instance Ctx => Class t1..tn`. +Thus, one can write arbitrary Haskell code (returning a class dictionary) to be executed every time +an instance is looked up by the GHC machinery. +To derive an instance this way, use `ToInstance (x :: OverlapMode)` for a declaration, e.g. as follows: +```Haskell +newtype Foo t = Foo t + +{-# ANN deriveEq (ToInstance NoOverlap) #-} +deriveEq :: Eq t => Dict (Eq (Foo t)) +deriveEq = mapDict (unsafeDerive Foo) Dict + +-- the result of the above is equal to +-- deriving instance Eq t => Eq (Foo t) +``` +You can find a more meaningful example in [`test/Spec/ToInstance01.hs`](https://github.com/achirkin/constraints-deriving/blob/master/test/Spec/ToInstance01.hs#L45-L47) or +[`example/Lib/VecBackend.hs`](https://github.com/achirkin/constraints-deriving/blob/master/example/Lib/VecBackend.hs). + +**Danger**: `ToInstance` removes duplicate instances; +if you have defined an instance with the same head using vanilla Haskell and the plugin, +the latter will try to replace the former in place. +Behavior of the instance in the same module is undefined in this case +(the other modules should be fine seeing the plugin version). +*I used this trick to convince `.hs-boot` to see the instances generated by the plugin.* + +## Further work + +`DeriveAll` derivation mechanics currently may break functional dependencies (untested).
Setup.hs view
@@ -1,81 +1,81 @@-{--Here is a very unfortunate hack that allows me to re-export modules of-the "constraints" library if flag "constraints" is enabled.--I have to do this because:-- * if flag "constraints" is disabled, the library exports its own modules- (copied from the "constraints" library, thus the same API);-- * if I add reexported-modules in the package description, cabal check- complains for duplicate modules- (even though they are under mutually exclusive conditions);-- * I still want library users import the modules without PackageImports or alike- independently of their choice of flags.- -}-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE CPP #-}--#ifndef MIN_VERSION_Cabal-#define MIN_VERSION_Cabal(x,y,z) 0-#endif--module Main (main) where--import Distribution.PackageDescription-import Distribution.Simple-import qualified Distribution.ModuleName as ModuleName-#if MIN_VERSION_Cabal(2,0,0)-import Distribution.Types.CondTree (CondBranch(CondBranch))-#endif--main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { confHook = \(gpd, hbi) -> confHook simpleUserHooks (addReexportsGPD gpd, hbi) }--addReexportsGPD :: GenericPackageDescription -> GenericPackageDescription-addReexportsGPD gpd = gpd { condLibrary = addReexportsCT <$> condLibrary gpd }---addReexportsCT :: CondTree ConfVar [Dependency] Library- -> CondTree ConfVar [Dependency] Library-addReexportsCT ct = ct- { condTreeComponents = reexportBranch : condTreeComponents ct }- where- constraintsCondition = Var (Flag (mkFlagName "constraints"))- reexportContent = mempty- { reexportedModules =- [ ModuleReexport- { moduleReexportOriginalPackage = Just (mkPackageName "constraints")- , moduleReexportOriginalName = ModuleName.fromString "Data.Constraint"- , moduleReexportName = ModuleName.fromString "Data.Constraint"- }- , ModuleReexport- { moduleReexportOriginalPackage = Just (mkPackageName "constraints")- , moduleReexportOriginalName = ModuleName.fromString "Data.Constraint.Unsafe"- , moduleReexportName = ModuleName.fromString "Data.Constraint.Unsafe"- }- ]- }- constraintsTrueTree = CondNode- { condTreeData = reexportContent- , condTreeConstraints = []- , condTreeComponents = []- }- constraintsFalseTree = Nothing- reexportBranch =-#if MIN_VERSION_Cabal(2,0,0)- CondBranch-#else- (,,)-#endif- constraintsCondition constraintsTrueTree constraintsFalseTree--#if !MIN_VERSION_Cabal(2,0,0)-mkFlagName :: String -> FlagName-mkFlagName = FlagName--mkPackageName :: String -> PackageName-mkPackageName = PackageName-#endif+{- +Here is a very unfortunate hack that allows me to re-export modules of +the "constraints" library if flag "constraints" is enabled. + +I have to do this because: + + * if flag "constraints" is disabled, the library exports its own modules + (copied from the "constraints" library, thus the same API); + + * if I add reexported-modules in the package description, cabal check + complains for duplicate modules + (even though they are under mutually exclusive conditions); + + * I still want library users import the modules without PackageImports or alike + independently of their choice of flags. + -} +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} + +#ifndef MIN_VERSION_Cabal +#define MIN_VERSION_Cabal(x,y,z) 0 +#endif + +module Main (main) where + +import Distribution.PackageDescription +import Distribution.Simple +import qualified Distribution.ModuleName as ModuleName +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Types.CondTree (CondBranch(CondBranch)) +#endif + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { confHook = \(gpd, hbi) -> confHook simpleUserHooks (addReexportsGPD gpd, hbi) } + +addReexportsGPD :: GenericPackageDescription -> GenericPackageDescription +addReexportsGPD gpd = gpd { condLibrary = addReexportsCT <$> condLibrary gpd } + + +addReexportsCT :: CondTree ConfVar [Dependency] Library + -> CondTree ConfVar [Dependency] Library +addReexportsCT ct = ct + { condTreeComponents = reexportBranch : condTreeComponents ct } + where + constraintsCondition = Var (Flag (mkFlagName "constraints")) + reexportContent = mempty + { reexportedModules = + [ ModuleReexport + { moduleReexportOriginalPackage = Just (mkPackageName "constraints") + , moduleReexportOriginalName = ModuleName.fromString "Data.Constraint" + , moduleReexportName = ModuleName.fromString "Data.Constraint" + } + , ModuleReexport + { moduleReexportOriginalPackage = Just (mkPackageName "constraints") + , moduleReexportOriginalName = ModuleName.fromString "Data.Constraint.Unsafe" + , moduleReexportName = ModuleName.fromString "Data.Constraint.Unsafe" + } + ] + } + constraintsTrueTree = CondNode + { condTreeData = reexportContent + , condTreeConstraints = [] + , condTreeComponents = [] + } + constraintsFalseTree = Nothing + reexportBranch = +#if MIN_VERSION_Cabal(2,0,0) + CondBranch +#else + (,,) +#endif + constraintsCondition constraintsTrueTree constraintsFalseTree + +#if !MIN_VERSION_Cabal(2,0,0) +mkFlagName :: String -> FlagName +mkFlagName = FlagName + +mkPackageName :: String -> PackageName +mkPackageName = PackageName +#endif
constraints-deriving.cabal view
@@ -1,13 +1,13 @@-cabal-version: 1.24+cabal-version: 1.24 --- This file has been generated from package.yaml by hpack version 0.31.0.+-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack ----- hash: 48cc1543c057350d23f16b7333dcd83d11d54ae3dfb991b5f6809165c5f33613+-- hash: 8d0710b285a0acc454fbe87602556399bcc46f63b0fe48e5e2b02b3fde8f8be2 name: constraints-deriving-version: 1.0.2.0+version: 1.0.3.0 synopsis: Manipulating constraints and deriving class instances programmatically. description: The library provides a plugin to derive class instances programmatically. Please see the README on GitHub at <https://github.com/achirkin/constraints-deriving#readme> category: Constraints
example/Lib/BackendFamily.hs view
@@ -1,224 +1,224 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{- |- This module contains actual implementation of the `Backend` type family.-- The idea is that this module does not expose any implementation details;- one can even implement multiple copies of this file depending on the compiler or package flags,- (such as the presence of SIMD extensions).- - In this example, I provide four implementations, depending on the dimensionality of the vector.- Note, that no evidence of the implementation details is exported.- -}-module Lib.BackendFamily- ( Backend, DataElemType, DataDims- , KnownBackend ()- , inferBackendInstance- -- constructing data- , bCons, bUncons, bNil- ) where---import Data.Constraint-import Debug.Trace-import GHC.Base-import GHC.TypeLits (type (+), type (-), CmpNat, KnownNat, Nat, natVal)-#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif----- backend type level definitions-data UnitBase (t :: Type) = UnitBase- deriving (Eq, Ord, Show)--newtype ScalarBase (t :: Type) = ScalarBase { _unScalarBase :: t }- deriving (Eq, Ord, Show)--data Vec2Base (t :: Type) = Vec2Base t t- deriving (Eq, Ord, Show)--newtype ListBase (t :: Type) (n :: Nat) = ListBase { _unListBase :: [t] }- deriving (Eq, Ord, Show)---- backend mappings-type family Backend (t :: Type) (n :: Nat) = (v :: Type) | v -> t n where- Backend t 0 = UnitBase t- Backend t 1 = ScalarBase t- Backend t 2 = Vec2Base t- Backend t n = ListBase t n---- ideally, bijection in the backend mapping allows to identify t and n,--- but compiler does not like it.--type family DataElemType (backend :: Type) :: Type-type instance DataElemType (UnitBase t) = t-type instance DataElemType (ScalarBase t) = t-type instance DataElemType (Vec2Base t) = t-type instance DataElemType (ListBase t _) = t--type family DataDims (backend :: Type) :: Nat-type instance DataDims (UnitBase _) = 0-type instance DataDims (ScalarBase _) = 1-type instance DataDims (Vec2Base _) = 2-type instance DataDims (ListBase _ n) = n---- backend term level definition (GADT)-data BackendSing (backend :: Type) where- BS0 :: (Backend t 0 ~ UnitBase t , n ~ 0) => BackendSing (UnitBase t)- BS1 :: (Backend t 1 ~ ScalarBase t, n ~ 1) => BackendSing (ScalarBase t)- BS2 :: (Backend t 2 ~ Vec2Base t , n ~ 2) => BackendSing (Vec2Base t)- BSn :: (Backend t n ~ ListBase t n, CmpNat n 2 ~ 'GT) => BackendSing (ListBase t n)---deriving instance Eq (BackendSing backend)-deriving instance Ord (BackendSing backend)-deriving instance Show (BackendSing backend)----- | A framework for using Array type family instances.-class KnownBackend (t :: Type) where- -- | Get Array type family instance- bSing :: BackendSing t- default bSing :: ( Coercible (Backend (DataElemType t) (DataDims t)) t- , KnownBackend (Backend (DataElemType t) (DataDims t))- )- => BackendSing t- bSing = unsafeCoerce# (bSing @(Backend (DataElemType t) (DataDims t)))----instance Semigroup (UnitBase t) where- UnitBase <> UnitBase = UnitBase--instance Monoid (UnitBase t) where- mempty = UnitBase- mappend = (<>)---instance Num t => Semigroup (ScalarBase t) where- ScalarBase a <> ScalarBase b = ScalarBase (a + b)--instance Num t => Monoid (ScalarBase t) where- mempty = ScalarBase 0- mappend = (<>)--instance Num t => Semigroup (Vec2Base t) where- Vec2Base a1 a2 <> Vec2Base b1 b2 = Vec2Base (a1 + b1) (a2 + b2)--instance Num t => Monoid (Vec2Base t) where- mempty = Vec2Base 0 0- mappend = (<>)--instance Num t => Semigroup (ListBase t n) where- ListBase as <> ListBase bs = ListBase $ zipWith (+) as bs--instance (Num t, KnownNat n) => Monoid (ListBase t n) where- mempty = r- where- r = ListBase $ replicate (fromInteger $ natVal r) 0- mappend = (<>)--instance KnownBackend (UnitBase t) where- bSing = BS0-instance KnownBackend (ScalarBase t) where- bSing = BS1-instance KnownBackend (Vec2Base t) where- bSing = BS2-instance CmpNat n 2 ~ 'GT => KnownBackend (ListBase t n) where- bSing = case ( unsafeCoerce#- (Dict :: Dict (ListBase t n ~ ListBase t n) )- :: Dict (ListBase t n ~ Backend t n)- ) of- Dict -> BSn----- This function determines the logic of instance selection--- for the type b-inferBackendInstance- :: forall b c- . ( KnownBackend b- , c (UnitBase (DataElemType b))- , c (ScalarBase (DataElemType b))- , c (Vec2Base (DataElemType b))- , c (ListBase (DataElemType b) (DataDims b))- )- => Dict (c b)-inferBackendInstance = case (bSing :: BackendSing b) of- BS0 -> trace "---------- Selecting UnitBase" Dict- BS1 -> trace "---------- Selecting ScalarBase" Dict- BS2 -> trace "---------- Selecting Vec2Base" Dict- BSn -> trace "---------- Selecting ListBase" Dict-{-# INLINE inferBackendInstance #-}---bUncons :: forall t n m- . KnownBackend (Backend t n)- => Backend t n- -> Either ( Dict ( n ~ 0- , n ~ DataDims (Backend t n)- , t ~ DataElemType (Backend t n)- ))- ( Dict ( KnownBackend (Backend t m)- , n ~ (m + 1)- , m ~ (n - 1)- , n ~ DataDims (Backend t n)- , m ~ DataDims (Backend t m)- , t ~ DataElemType (Backend t n)- , t ~ DataElemType (Backend t m)- )- , t, Backend t m )-bUncons x = case dataTypeDims x of- Dict -> case bSing @(Backend t n) of- BS0 -> Left Dict- BS1 -> case unsafeDict @(n ~ n, m ~ m) @(n ~ 1, m ~ 0) Dict of- Dict -> case x of ScalarBase a -> Right (Dict, a, UnitBase)- BS2 -> case unsafeDict @(n ~ n, m ~ m) @(n ~ 2, m ~ 1) Dict of- Dict -> case x of Vec2Base a b -> Right (Dict, a, ScalarBase b)- BSn -> case x of- ListBase [a,b,c] -> case unsafeDict @(n ~ n, m ~ m) @(n ~ 3, m ~ 2) Dict of- Dict -> Right (Dict, a, Vec2Base b c)- ListBase (a:as) -> case unsafeDict- @(n ~ n, m ~ m, CmpNat 3 2 ~ 'GT, Backend t m ~ Backend t m)- @(n ~ (m + 1), m ~ (n - 1), CmpNat m 2 ~ 'GT, Backend t m ~ ListBase t m)- Dict of- Dict -> Right (Dict, a, ListBase @t @m as)- ListBase _ -> error "Unexpected-length vector"--unsafeDict :: forall a b . a => Dict a -> Dict b-unsafeDict _ = unsafeCoerce# (Dict @a)--dataTypeDims :: forall t n . Backend t n -> Dict (t ~ DataElemType (Backend t n), n ~ DataDims (Backend t n))-dataTypeDims _ = unsafeCoerce# (Dict @(t ~ t, n ~ n))---- Hmm, would be interesting to "provide" KnownBackend (Backend t (n+1))-bCons :: forall t n- . KnownBackend (Backend t n)- => t -> Backend t n -> Backend t (n + 1)-bCons a as = case dataTypeDims @t @n as of- Dict -> case bSing @(Backend t n) of- BS0 -> ScalarBase a- BS1 -> case as of ScalarBase b -> Vec2Base a b- BS2 -> case as of Vec2Base b c -> ListBase [a,b,c]- BSn -> case as of ListBase as' -> unsafeCoerce# (ListBase (a : as'))--bNil :: Backend t 0-bNil = UnitBase+{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | + This module contains actual implementation of the `Backend` type family. + + The idea is that this module does not expose any implementation details; + one can even implement multiple copies of this file depending on the compiler or package flags, + (such as the presence of SIMD extensions). + + In this example, I provide four implementations, depending on the dimensionality of the vector. + Note, that no evidence of the implementation details is exported. + -} +module Lib.BackendFamily + ( Backend, DataElemType, DataDims + , KnownBackend () + , inferBackendInstance + -- constructing data + , bCons, bUncons, bNil + ) where + + +import Data.Constraint +import Debug.Trace +import GHC.Base +import GHC.TypeLits (type (+), type (-), CmpNat, KnownNat, Nat, natVal) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#endif + + +-- backend type level definitions +data UnitBase (t :: Type) = UnitBase + deriving (Eq, Ord, Show) + +newtype ScalarBase (t :: Type) = ScalarBase { _unScalarBase :: t } + deriving (Eq, Ord, Show) + +data Vec2Base (t :: Type) = Vec2Base t t + deriving (Eq, Ord, Show) + +newtype ListBase (t :: Type) (n :: Nat) = ListBase { _unListBase :: [t] } + deriving (Eq, Ord, Show) + +-- backend mappings +type family Backend (t :: Type) (n :: Nat) = (v :: Type) | v -> t n where + Backend t 0 = UnitBase t + Backend t 1 = ScalarBase t + Backend t 2 = Vec2Base t + Backend t n = ListBase t n + +-- ideally, bijection in the backend mapping allows to identify t and n, +-- but compiler does not like it. + +type family DataElemType (backend :: Type) :: Type +type instance DataElemType (UnitBase t) = t +type instance DataElemType (ScalarBase t) = t +type instance DataElemType (Vec2Base t) = t +type instance DataElemType (ListBase t _) = t + +type family DataDims (backend :: Type) :: Nat +type instance DataDims (UnitBase _) = 0 +type instance DataDims (ScalarBase _) = 1 +type instance DataDims (Vec2Base _) = 2 +type instance DataDims (ListBase _ n) = n + +-- backend term level definition (GADT) +data BackendSing (backend :: Type) where + BS0 :: (Backend t 0 ~ UnitBase t , n ~ 0) => BackendSing (UnitBase t) + BS1 :: (Backend t 1 ~ ScalarBase t, n ~ 1) => BackendSing (ScalarBase t) + BS2 :: (Backend t 2 ~ Vec2Base t , n ~ 2) => BackendSing (Vec2Base t) + BSn :: (Backend t n ~ ListBase t n, CmpNat n 2 ~ 'GT) => BackendSing (ListBase t n) + + +deriving instance Eq (BackendSing backend) +deriving instance Ord (BackendSing backend) +deriving instance Show (BackendSing backend) + + +-- | A framework for using Array type family instances. +class KnownBackend (t :: Type) where + -- | Get Array type family instance + bSing :: BackendSing t + default bSing :: ( Coercible (Backend (DataElemType t) (DataDims t)) t + , KnownBackend (Backend (DataElemType t) (DataDims t)) + ) + => BackendSing t + bSing = unsafeCoerce# (bSing @(Backend (DataElemType t) (DataDims t))) + + + +instance Semigroup (UnitBase t) where + UnitBase <> UnitBase = UnitBase + +instance Monoid (UnitBase t) where + mempty = UnitBase + mappend = (<>) + + +instance Num t => Semigroup (ScalarBase t) where + ScalarBase a <> ScalarBase b = ScalarBase (a + b) + +instance Num t => Monoid (ScalarBase t) where + mempty = ScalarBase 0 + mappend = (<>) + +instance Num t => Semigroup (Vec2Base t) where + Vec2Base a1 a2 <> Vec2Base b1 b2 = Vec2Base (a1 + b1) (a2 + b2) + +instance Num t => Monoid (Vec2Base t) where + mempty = Vec2Base 0 0 + mappend = (<>) + +instance Num t => Semigroup (ListBase t n) where + ListBase as <> ListBase bs = ListBase $ zipWith (+) as bs + +instance (Num t, KnownNat n) => Monoid (ListBase t n) where + mempty = r + where + r = ListBase $ replicate (fromInteger $ natVal r) 0 + mappend = (<>) + +instance KnownBackend (UnitBase t) where + bSing = BS0 +instance KnownBackend (ScalarBase t) where + bSing = BS1 +instance KnownBackend (Vec2Base t) where + bSing = BS2 +instance CmpNat n 2 ~ 'GT => KnownBackend (ListBase t n) where + bSing = case ( unsafeCoerce# + (Dict :: Dict (ListBase t n ~ ListBase t n) ) + :: Dict (ListBase t n ~ Backend t n) + ) of + Dict -> BSn + + +-- This function determines the logic of instance selection +-- for the type b +inferBackendInstance + :: forall b c + . ( KnownBackend b + , c (UnitBase (DataElemType b)) + , c (ScalarBase (DataElemType b)) + , c (Vec2Base (DataElemType b)) + , c (ListBase (DataElemType b) (DataDims b)) + ) + => Dict (c b) +inferBackendInstance = case (bSing :: BackendSing b) of + BS0 -> trace "---------- Selecting UnitBase" Dict + BS1 -> trace "---------- Selecting ScalarBase" Dict + BS2 -> trace "---------- Selecting Vec2Base" Dict + BSn -> trace "---------- Selecting ListBase" Dict +{-# INLINE inferBackendInstance #-} + + +bUncons :: forall t n m + . KnownBackend (Backend t n) + => Backend t n + -> Either ( Dict ( n ~ 0 + , n ~ DataDims (Backend t n) + , t ~ DataElemType (Backend t n) + )) + ( Dict ( KnownBackend (Backend t m) + , n ~ (m + 1) + , m ~ (n - 1) + , n ~ DataDims (Backend t n) + , m ~ DataDims (Backend t m) + , t ~ DataElemType (Backend t n) + , t ~ DataElemType (Backend t m) + ) + , t, Backend t m ) +bUncons x = case dataTypeDims x of + Dict -> case bSing @(Backend t n) of + BS0 -> Left Dict + BS1 -> case unsafeDict @(n ~ n, m ~ m) @(n ~ 1, m ~ 0) Dict of + Dict -> case x of ScalarBase a -> Right (Dict, a, UnitBase) + BS2 -> case unsafeDict @(n ~ n, m ~ m) @(n ~ 2, m ~ 1) Dict of + Dict -> case x of Vec2Base a b -> Right (Dict, a, ScalarBase b) + BSn -> case x of + ListBase [a,b,c] -> case unsafeDict @(n ~ n, m ~ m) @(n ~ 3, m ~ 2) Dict of + Dict -> Right (Dict, a, Vec2Base b c) + ListBase (a:as) -> case unsafeDict + @(n ~ n, m ~ m, CmpNat 3 2 ~ 'GT, Backend t m ~ Backend t m) + @(n ~ (m + 1), m ~ (n - 1), CmpNat m 2 ~ 'GT, Backend t m ~ ListBase t m) + Dict of + Dict -> Right (Dict, a, ListBase @t @m as) + ListBase _ -> error "Unexpected-length vector" + +unsafeDict :: forall a b . a => Dict a -> Dict b +unsafeDict _ = unsafeCoerce# (Dict @a) + +dataTypeDims :: forall t n . Backend t n -> Dict (t ~ DataElemType (Backend t n), n ~ DataDims (Backend t n)) +dataTypeDims _ = unsafeCoerce# (Dict @(t ~ t, n ~ n)) + +-- Hmm, would be interesting to "provide" KnownBackend (Backend t (n+1)) +bCons :: forall t n + . KnownBackend (Backend t n) + => t -> Backend t n -> Backend t (n + 1) +bCons a as = case dataTypeDims @t @n as of + Dict -> case bSing @(Backend t n) of + BS0 -> ScalarBase a + BS1 -> case as of ScalarBase b -> Vec2Base a b + BS2 -> case as of Vec2Base b c -> ListBase [a,b,c] + BSn -> case as of ListBase as' -> unsafeCoerce# (ListBase (a : as')) + +bNil :: Backend t 0 +bNil = UnitBase
example/Lib/VecBackend.hs view
@@ -1,109 +1,109 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-{- |- This is where the magic happens.-- Via combination of DeriveAll and ToInstance plugin passes- I create a system of overlapping type class instances for `VecBackend` type.- This way, if GHC knows which backend (type instance of `Backend`) is behind `VecBackend`,- it can select overlapping class instance for it;- overwise, it selects overlappable instance based on `KnownBackend` constraint.- -}-module Lib.VecBackend where---import Data.Constraint-import Data.Constraint.Deriving-import Data.Constraint.Unsafe-import GHC.Base-import GHC.TypeLits (KnownNat, Nat)-import Unsafe.Coerce-#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif--import Lib.BackendFamily---- Try to comment out the annotation;--- You will see that the compiler has to select type class instances at runtime more often.-{-# ANN type VecBackend DeriveAll #-}-type role VecBackend phantom phantom representational--- I need two layers of wrappers to provide default overlappable instances to--- all type classes using KnownBackend mechanics.--- Type arguments are redundant here;--- nevertheless, they improve readability of error messages.-newtype VecBackend (t :: Type) (n :: Nat) (backend :: Type)- = VecBackend { _getBackend :: backend }-type instance DataElemType (VecBackend t _ _) = t-type instance DataDims (VecBackend _ n _) = n--- I use this type instance to inform `DeriveAll` core plugin that backend is an instance--- of type family `Backend t n`.--- This allows the plugin to find all possible instances of the type family and--- then lookup corresponding class instances.--- Otherwise, the plugin would have to derive all instances for all types in scope,--- because the newtype declaration is too general without these additional constraints.-type instance DeriveContext (VecBackend t n b) = b ~ Backend t n----{-# ANN inferEq (ToInstance Overlappable) #-}-inferEq :: forall t n b . ( KnownBackend b, Eq t) => Dict (Eq (VecBackend t n b))-inferEq = mapDict toVecBackend- . mapDict (Sub inferBackendInstance)- $ inferBase @t @n @b undefined--{-# ANN inferShow (ToInstance Overlappable) #-}-inferShow :: forall t n b . ( KnownBackend b, Show t)- => Dict (Show (VecBackend t n b))-inferShow = mapDict toVecBackend- . mapDict (Sub inferBackendInstance)- $ inferBase @t @n @b undefined--{-# ANN inferOrd (ToInstance Overlappable) #-}-inferOrd :: forall t n b . ( KnownBackend b, Ord t)- => Dict (Ord (VecBackend t n b))-inferOrd = mapDict toVecBackend- . mapDict (Sub inferBackendInstance)- $ inferBase @t @n @b undefined--{-# ANN inferSemigroup (ToInstance Overlappable) #-}-inferSemigroup :: forall t n b . ( KnownBackend b, Num t)- => Dict (Semigroup (VecBackend t n b))-inferSemigroup = mapDict toVecBackend- . mapDict (Sub inferBackendInstance)- $ inferBase @t @n @b undefined--{-# ANN inferMonoid (ToInstance Overlappable) #-}-inferMonoid :: forall t n b . ( KnownBackend b, Num t, KnownNat n)- => Dict (Monoid (VecBackend t n b))-inferMonoid = mapDict toVecBackend- . mapDict (Sub inferBackendInstance)- $ inferBase @t @n @b undefined---- This is the rule that cannot be encoded in the type system, but enforced--- as an invariant: VecBackend t n b implies DeriveContext t n b-inferBase :: VecBackend t n b- -> Dict (b ~ Backend t n, t ~ DataElemType b, n ~ DataDims b)-inferBase _ = unsafeCoerce- (Dict :: Dict (b ~ b, t ~ t, n ~ n) )-{-# INLINE inferBase #-}---- VecBackend is the newtype wrapper over b.--- It has the same represenation and I expect it to have the same instance behavior.-toVecBackend :: forall c t n b . c b :- c (VecBackend t n b)-toVecBackend = unsafeDerive VecBackend-{-# INLINE toVecBackend #-}+{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +{- | + This is where the magic happens. + + Via combination of DeriveAll and ToInstance plugin passes + I create a system of overlapping type class instances for `VecBackend` type. + This way, if GHC knows which backend (type instance of `Backend`) is behind `VecBackend`, + it can select overlapping class instance for it; + overwise, it selects overlappable instance based on `KnownBackend` constraint. + -} +module Lib.VecBackend where + + +import Data.Constraint +import Data.Constraint.Deriving +import Data.Constraint.Unsafe +import GHC.Base +import GHC.TypeLits (KnownNat, Nat) +import Unsafe.Coerce +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#endif + +import Lib.BackendFamily + +-- Try to comment out the annotation; +-- You will see that the compiler has to select type class instances at runtime more often. +{-# ANN type VecBackend DeriveAll #-} +type role VecBackend phantom phantom representational +-- I need two layers of wrappers to provide default overlappable instances to +-- all type classes using KnownBackend mechanics. +-- Type arguments are redundant here; +-- nevertheless, they improve readability of error messages. +newtype VecBackend (t :: Type) (n :: Nat) (backend :: Type) + = VecBackend { _getBackend :: backend } +type instance DataElemType (VecBackend t _ _) = t +type instance DataDims (VecBackend _ n _) = n +-- I use this type instance to inform `DeriveAll` core plugin that backend is an instance +-- of type family `Backend t n`. +-- This allows the plugin to find all possible instances of the type family and +-- then lookup corresponding class instances. +-- Otherwise, the plugin would have to derive all instances for all types in scope, +-- because the newtype declaration is too general without these additional constraints. +type instance DeriveContext (VecBackend t n b) = b ~ Backend t n + + + +{-# ANN inferEq (ToInstance Overlappable) #-} +inferEq :: forall t n b . ( KnownBackend b, Eq t) => Dict (Eq (VecBackend t n b)) +inferEq = mapDict toVecBackend + . mapDict (Sub inferBackendInstance) + $ inferBase @t @n @b undefined + +{-# ANN inferShow (ToInstance Overlappable) #-} +inferShow :: forall t n b . ( KnownBackend b, Show t) + => Dict (Show (VecBackend t n b)) +inferShow = mapDict toVecBackend + . mapDict (Sub inferBackendInstance) + $ inferBase @t @n @b undefined + +{-# ANN inferOrd (ToInstance Overlappable) #-} +inferOrd :: forall t n b . ( KnownBackend b, Ord t) + => Dict (Ord (VecBackend t n b)) +inferOrd = mapDict toVecBackend + . mapDict (Sub inferBackendInstance) + $ inferBase @t @n @b undefined + +{-# ANN inferSemigroup (ToInstance Overlappable) #-} +inferSemigroup :: forall t n b . ( KnownBackend b, Num t) + => Dict (Semigroup (VecBackend t n b)) +inferSemigroup = mapDict toVecBackend + . mapDict (Sub inferBackendInstance) + $ inferBase @t @n @b undefined + +{-# ANN inferMonoid (ToInstance Overlappable) #-} +inferMonoid :: forall t n b . ( KnownBackend b, Num t, KnownNat n) + => Dict (Monoid (VecBackend t n b)) +inferMonoid = mapDict toVecBackend + . mapDict (Sub inferBackendInstance) + $ inferBase @t @n @b undefined + +-- This is the rule that cannot be encoded in the type system, but enforced +-- as an invariant: VecBackend t n b implies DeriveContext t n b +inferBase :: VecBackend t n b + -> Dict (b ~ Backend t n, t ~ DataElemType b, n ~ DataDims b) +inferBase _ = unsafeCoerce + (Dict :: Dict (b ~ b, t ~ t, n ~ n) ) +{-# INLINE inferBase #-} + +-- VecBackend is the newtype wrapper over b. +-- It has the same represenation and I expect it to have the same instance behavior. +toVecBackend :: forall c t n b . c b :- c (VecBackend t n b) +toVecBackend = unsafeDerive VecBackend +{-# INLINE toVecBackend #-}
example/Lib/Vector.hs view
@@ -1,117 +1,117 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}-{- |- This is an example of using constraints-deriving plugin for optimization.-- This module presents a "front-end" Vector data type visible to a user.- It is a simple newtype wrapper over a "backend" data type family.- Behind the scenes, the compiler chooses the most efficient representations- for the backend based on a type family `Backend t n`.- For example, if the compiler knows that the size of a vector is 1,- than the `Vector t 1` type is a newtype wrapper over `t`,- and GHC statically uses all type class instances for `t`, sidestepping dynamic instance elaboration.- But, if GHC does not know the dimensionality of the vector statically,- it selects class instances dynamically at runtime. - -}-module Lib.Vector- ( -- * Data types- Vector (Z, (:*))- , SomeVector (..), KnownBackend (), Backend- , Nat- ) where---#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif-import Data.Constraint-import GHC.Base (Type, unsafeCoerce#)-import GHC.TypeLits (type (+), type (-), KnownNat, Nat)--import Lib.BackendFamily-import Lib.VecBackend---newtype Vector (t :: Type) (n ::Nat) = Vector (VecBackend t n (Backend t n))--pattern Z :: forall t n- . KnownBackend (Vector t n)- => n ~ 0- => Vector t n-pattern Z <- (vUncons -> Left Dict)- where- Z = Vector (VecBackend bNil)--pattern (:*) :: forall t n- . KnownBackend (Vector t n)- => forall m- . (KnownBackend (Vector t m), n ~ (m + 1), m ~ (n - 1))- => t -> Vector t m -> Vector t n-pattern (:*) x xs <- (vUncons -> Right (Dict, x, xs))- where- (:*) = vCons-infixr 7 :*-#if __GLASGOW_HASKELL__ >= 802-{-# Complete Z, (:*) #-}-#endif--vUncons :: forall t n m- . KnownBackend (Vector t n)- => Vector t n- -> Either ( Dict ( n ~ 0- , n ~ DataDims (Vector t n)- , t ~ DataElemType (Vector t n)- ))- ( Dict ( KnownBackend (Vector t m)- , n ~ (m + 1)- , m ~ (n - 1)- , n ~ DataDims (Vector t n)- , m ~ DataDims (Vector t m)- , t ~ DataElemType (Vector t n)- , t ~ DataElemType (Vector t m)- )- , t, Vector t m )-vUncons = case underiveKB @t @n of Dict -> unsafeCoerce# (bUncons @t @n @m)--vCons :: forall t n- . KnownBackend (Vector t n)- => t -> Vector t n -> Vector t (n + 1)-vCons = case underiveKB @t @n of Dict -> unsafeCoerce# (bCons @t @n)---data SomeVector (t :: Type) where- SomeVector :: (KnownNat (n :: Nat), KnownBackend (Backend t n))- => Vector t n -> SomeVector t---type instance DataElemType (Vector t n) = t-type instance DataDims (Vector t n) = n--instance (KnownBackend (Vector t n), Show t) => Show (Vector t n) where- show Z = "Z"- show (x :* xs) = show x ++ " :* " ++ show xs--instance KnownBackend (Backend t n) => KnownBackend (Vector t n)-deriving instance Eq (VecBackend t n (Backend t n)) => Eq (Vector t n)-deriving instance Ord (VecBackend t n (Backend t n)) => Ord (Vector t n)-deriving instance Semigroup (VecBackend t n (Backend t n)) => Semigroup (Vector t n)-deriving instance Monoid (VecBackend t n (Backend t n)) => Monoid (Vector t n)--underiveKB :: forall t n . KnownBackend (Vector t n) => Dict (KnownBackend (Backend t n))-underiveKB = unsafeCoerce# (Dict @(KnownBackend (Vector t n)))+{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{- | + This is an example of using constraints-deriving plugin for optimization. + + This module presents a "front-end" Vector data type visible to a user. + It is a simple newtype wrapper over a "backend" data type family. + Behind the scenes, the compiler chooses the most efficient representations + for the backend based on a type family `Backend t n`. + For example, if the compiler knows that the size of a vector is 1, + than the `Vector t 1` type is a newtype wrapper over `t`, + and GHC statically uses all type class instances for `t`, sidestepping dynamic instance elaboration. + But, if GHC does not know the dimensionality of the vector statically, + it selects class instances dynamically at runtime. + -} +module Lib.Vector + ( -- * Data types + Vector (Z, (:*)) + , SomeVector (..), KnownBackend (), Backend + , Nat + ) where + + +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#endif +import Data.Constraint +import GHC.Base (Type, unsafeCoerce#) +import GHC.TypeLits (type (+), type (-), KnownNat, Nat) + +import Lib.BackendFamily +import Lib.VecBackend + + +newtype Vector (t :: Type) (n ::Nat) = Vector (VecBackend t n (Backend t n)) + +pattern Z :: forall t n + . KnownBackend (Vector t n) + => n ~ 0 + => Vector t n +pattern Z <- (vUncons -> Left Dict) + where + Z = Vector (VecBackend bNil) + +pattern (:*) :: forall t n + . KnownBackend (Vector t n) + => forall m + . (KnownBackend (Vector t m), n ~ (m + 1), m ~ (n - 1)) + => t -> Vector t m -> Vector t n +pattern (:*) x xs <- (vUncons -> Right (Dict, x, xs)) + where + (:*) = vCons +infixr 7 :* +#if __GLASGOW_HASKELL__ >= 802 +{-# Complete Z, (:*) #-} +#endif + +vUncons :: forall t n m + . KnownBackend (Vector t n) + => Vector t n + -> Either ( Dict ( n ~ 0 + , n ~ DataDims (Vector t n) + , t ~ DataElemType (Vector t n) + )) + ( Dict ( KnownBackend (Vector t m) + , n ~ (m + 1) + , m ~ (n - 1) + , n ~ DataDims (Vector t n) + , m ~ DataDims (Vector t m) + , t ~ DataElemType (Vector t n) + , t ~ DataElemType (Vector t m) + ) + , t, Vector t m ) +vUncons = case underiveKB @t @n of Dict -> unsafeCoerce# (bUncons @t @n @m) + +vCons :: forall t n + . KnownBackend (Vector t n) + => t -> Vector t n -> Vector t (n + 1) +vCons = case underiveKB @t @n of Dict -> unsafeCoerce# (bCons @t @n) + + +data SomeVector (t :: Type) where + SomeVector :: (KnownNat (n :: Nat), KnownBackend (Backend t n)) + => Vector t n -> SomeVector t + + +type instance DataElemType (Vector t n) = t +type instance DataDims (Vector t n) = n + +instance (KnownBackend (Vector t n), Show t) => Show (Vector t n) where + show Z = "Z" + show (x :* xs) = show x ++ " :* " ++ show xs + +instance KnownBackend (Backend t n) => KnownBackend (Vector t n) +deriving instance Eq (VecBackend t n (Backend t n)) => Eq (Vector t n) +deriving instance Ord (VecBackend t n (Backend t n)) => Ord (Vector t n) +deriving instance Semigroup (VecBackend t n (Backend t n)) => Semigroup (Vector t n) +deriving instance Monoid (VecBackend t n (Backend t n)) => Monoid (Vector t n) + +underiveKB :: forall t n . KnownBackend (Vector t n) => Dict (KnownBackend (Backend t n)) +underiveKB = unsafeCoerce# (Dict @(KnownBackend (Vector t n)))
example/Main.hs view
@@ -1,35 +1,35 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-module Main (main) where--#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif-import Lib.Vector---main :: IO ()-main = do- print $ Z <> (mempty :: Vector Double 0)- print $ (7 :: Double) :* Z <> 15 :* Z- print $ (7 :: Double) :* Z <> mempty - print $ mempty <> 2 :* 6 :* Z <> v2- () <- case v2 of- a :* as -> print $ a :* Z <> as- print $ mempty <> 9 :* 8 :* 7 :* 6 :* 5 :* Z- <> 1 :* 2 :* 3 :* 4 :* 5 :* (Z :: Vector Double 0)- case sdf2 of- SomeVector x -> print $ mappend x x <> mempty- case sdf7 of- SomeVector x -> print $ x <> x <> x <> mempty <> x- where- -- The backend for v2 is known statically;- -- GHC will pick up all instances for Vec2Base- v2 = 3 :* 12 :* Z :: Vector Double 2- -- The two vectors below hide their dimensionality until runtime.- -- The only thing GHC knows is that they have instances of KnownBackend;- -- thus, it will lookup the rest of required type class instances via KnownBackend route.- sdf2 = SomeVector $ (2::Int) :* 6 :* Z- sdf7 = SomeVector $ (1::Float)- :* 2 :* 3 :* 4 :* 5 :* 16 :* 92 :* Z-+{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +module Main (main) where + +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#endif +import Lib.Vector + + +main :: IO () +main = do + print $ Z <> (mempty :: Vector Double 0) + print $ (7 :: Double) :* Z <> 15 :* Z + print $ (7 :: Double) :* Z <> mempty + print $ mempty <> 2 :* 6 :* Z <> v2 + () <- case v2 of + a :* as -> print $ a :* Z <> as + print $ mempty <> 9 :* 8 :* 7 :* 6 :* 5 :* Z + <> 1 :* 2 :* 3 :* 4 :* 5 :* (Z :: Vector Double 0) + case sdf2 of + SomeVector x -> print $ mappend x x <> mempty + case sdf7 of + SomeVector x -> print $ x <> x <> x <> mempty <> x + where + -- The backend for v2 is known statically; + -- GHC will pick up all instances for Vec2Base + v2 = 3 :* 12 :* Z :: Vector Double 2 + -- The two vectors below hide their dimensionality until runtime. + -- The only thing GHC knows is that they have instances of KnownBackend; + -- thus, it will lookup the rest of required type class instances via KnownBackend route. + sdf2 = SomeVector $ (2::Int) :* 6 :* Z + sdf7 = SomeVector $ (1::Float) + :* 2 :* 3 :* 4 :* 5 :* 16 :* 92 :* Z +
src-constraints/Data/Constraint.hs view
@@ -1,786 +1,786 @@-{--Copyright 2011-2015 Edward Kmett--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.--2. 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.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.- -}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE UndecidableSuperClasses #-}--------------------------------------------------------------------------------- |--- Module : Data.Constraint--- Copyright : (C) 2011-2015 Edward Kmett,--- License : BSD-style (see the file LICENSE)------ Stability : experimental--- Portability : non-portable------ This module is taken from--- <https://github.com/ekmett/constraints/blob/963c0e904ad48a5cec29a0cb649622d8c1872af4/src/Data/Constraint.hs constraints:Data.Constraint>--- A few things have been cut from the module to remove dependencies.--- ---------------------------------------------------------------------------------module Data.Constraint- (- -- * The Kind of Constraints- Constraint- -- * Dictionary- , Dict(Dict)- , HasDict(..)- , withDict- , (\\)- -- * Entailment- , (:-)(Sub)- , type (⊢)- , weaken1, weaken2, contract- , strengthen1, strengthen2- , (&&&), (***)- , trans, refl- , Bottom(no)- , top, bottom- -- * Dict is fully faithful- , mapDict- , unmapDict- -- * Reflection- , Class(..)- , (:=>)(..)- ) where-import Control.Applicative-import Control.Category-import Control.Monad-import Data.Complex-#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806-import Data.Kind-#endif-import Data.Ratio-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#endif-import Data.Data hiding (TypeRep)-import qualified GHC.Exts as Exts (Any)-import GHC.Exts (Constraint)-import Data.Bits (Bits)-import Data.Functor.Identity (Identity)-import Numeric.Natural (Natural)-import Data.Word (Word)-import Data.Coerce (Coercible)-import Data.Type.Coercion(Coercion(..))-#if MIN_VERSION_base(4,10,0)-import Data.Type.Equality ((:~~:)(..), type (~~))-import Type.Reflection (TypeRep, typeRepKind, withTypeable)-#endif---- | Values of type @'Dict' p@ capture a dictionary for a constraint of type @p@.------ e.g.------ @--- 'Dict' :: 'Dict' ('Eq' 'Int')--- @------ captures a dictionary that proves we have an:------ @--- instance 'Eq' 'Int--- @------ Pattern matching on the 'Dict' constructor will bring this instance into scope.----data Dict :: Constraint -> * where- Dict :: a => Dict a- deriving Typeable---instance (Typeable p, p) => Data (Dict p) where- gfoldl _ z Dict = z Dict- toConstr _ = dictConstr- gunfold _ z c = case constrIndex c of- 1 -> z Dict- _ -> error "gunfold"- dataTypeOf _ = dictDataType--dictConstr :: Constr-dictConstr = mkConstr dictDataType "Dict" [] Prefix--dictDataType :: DataType-dictDataType = mkDataType "Data.Constraint.Dict" [dictConstr]--deriving instance Eq (Dict a)-deriving instance Ord (Dict a)-deriving instance Show (Dict a)---- | Witnesses that a value of type @e@ contains evidence of the constraint @c@.------ Mainly intended to allow ('\\') to be overloaded, since it's a useful operator.-class HasDict c e | e -> c where- evidence :: e -> Dict c--instance HasDict a (Dict a) where- evidence = Prelude.id--instance a => HasDict b (a :- b) where- evidence (Sub x) = x--instance HasDict (Coercible a b) (Coercion a b) where- evidence Coercion = Dict--instance HasDict (a ~ b) (a :~: b) where- evidence Refl = Dict--#if MIN_VERSION_base(4,10,0)-instance HasDict (a ~~ b) (a :~~: b) where- evidence HRefl = Dict--instance HasDict (Typeable k, Typeable a) (TypeRep (a :: k)) where- evidence tr = withTypeable tr $ withTypeable (typeRepKind tr) Dict-#endif---- | From a 'Dict', takes a value in an environment where the instance--- witnessed by the 'Dict' is in scope, and evaluates it.------ Essentially a deconstruction of a 'Dict' into its continuation-style--- form.------ Can also be used to deconstruct an entailment, @a ':-' b@, using a context @a@.------ @--- withDict :: 'Dict' c -> (c => r) -> r--- withDict :: a => (a ':-' c) -> (c => r) -> r--- @-withDict :: HasDict c e => e -> (c => r) -> r-withDict d r = case evidence d of- Dict -> r--infixl 1 \\ -- required comment---- | Operator version of 'withDict', with the arguments flipped-(\\) :: HasDict c e => (c => r) -> e -> r-r \\ d = withDict d r--infixr 9 :--infixr 9 ⊢--type (⊢) = (:-)---- | This is the type of entailment.------ @a ':-' b@ is read as @a@ \"entails\" @b@.------ With this we can actually build a category for 'Constraint' resolution.------ e.g.------ Because @'Eq' a@ is a superclass of @'Ord' a@, we can show that @'Ord' a@--- entails @'Eq' a@.------ Because @instance 'Ord' a => 'Ord' [a]@ exists, we can show that @'Ord' a@--- entails @'Ord' [a]@ as well.------ This relationship is captured in the ':-' entailment type here.------ Since @p ':-' p@ and entailment composes, ':-' forms the arrows of a--- 'Category' of constraints. However, 'Category' only became sufficiently--- general to support this instance in GHC 7.8, so prior to 7.8 this instance--- is unavailable.------ But due to the coherence of instance resolution in Haskell, this 'Category'--- has some very interesting properties. Notably, in the absence of--- @IncoherentInstances@, this category is \"thin\", which is to say that--- between any two objects (constraints) there is at most one distinguishable--- arrow.------ This means that for instance, even though there are two ways to derive--- @'Ord' a ':-' 'Eq' [a]@, the answers from these two paths _must_ by--- construction be equal. This is a property that Haskell offers that is--- pretty much unique in the space of languages with things they call \"type--- classes\".------ What are the two ways?------ Well, we can go from @'Ord' a ':-' 'Eq' a@ via the--- superclass relationship, and then from @'Eq' a ':-' 'Eq' [a]@ via the--- instance, or we can go from @'Ord' a ':-' 'Ord' [a]@ via the instance--- then from @'Ord' [a] ':-' 'Eq' [a]@ through the superclass relationship--- and this diagram by definition must \"commute\".------ Diagrammatically,------ > Ord a--- > ins / \ cls--- > v v--- > Ord [a] Eq a--- > cls \ / ins--- > v v--- > Eq [a]------ This safety net ensures that pretty much anything you can write with this--- library is sensible and can't break any assumptions on the behalf of--- library authors.-newtype a :- b = Sub (a => Dict b)- deriving Typeable--type role (:-) nominal nominal---- TODO: _proper_ Data for @(p ':-' q)@ requires @(:-)@ to be cartesian _closed_.------ This is admissable, but not present by default---- constraint should be instance (Typeable p, Typeable q, p |- q) => Data (p :- q)-instance (Typeable p, Typeable q, p, q) => Data (p :- q) where- gfoldl _ z (Sub Dict) = z (Sub Dict)- toConstr _ = subConstr- gunfold _ z c = case constrIndex c of- 1 -> z (Sub Dict)- _ -> error "gunfold"- dataTypeOf _ = subDataType--subConstr :: Constr-subConstr = mkConstr dictDataType "Sub" [] Prefix--subDataType :: DataType-subDataType = mkDataType "Data.Constraint.:-" [subConstr]---- | Possible since GHC 7.8, when 'Category' was made polykinded.-instance Category (:-) where- id = refl- (.) = trans---- | Assumes 'IncoherentInstances' doesn't exist.-instance Eq (a :- b) where- _ == _ = True---- | Assumes 'IncoherentInstances' doesn't exist.-instance Ord (a :- b) where- compare _ _ = EQ--instance Show (a :- b) where- showsPrec d _ = showParen (d > 10) $ showString "Sub Dict"-------------------------------------------------------------------------------------- Constraints form a Category------------------------------------------------------------------------------------- | Transitivity of entailment------ If we view @(':-')@ as a Constraint-indexed category, then this is @('.')@-trans :: (b :- c) -> (a :- b) -> a :- c-trans f g = Sub $ Dict \\ f \\ g---- | Reflexivity of entailment------ If we view @(':-')@ as a Constraint-indexed category, then this is 'id'-refl :: a :- a-refl = Sub Dict------------------------------------------------------------------------------------- (,) is a Bifunctor------------------------------------------------------------------------------------- | due to the hack for the kind of @(,)@ in the current version of GHC we can't actually--- make instances for @(,) :: Constraint -> Constraint -> Constraint@, but @(,)@ is a--- bifunctor on the category of constraints. This lets us map over both sides.-(***) :: (a :- b) -> (c :- d) -> (a, c) :- (b, d)-f *** g = Sub $ Dict \\ f \\ g------------------------------------------------------------------------------------- Constraints are Cartesian------------------------------------------------------------------------------------- | Weakening a constraint product------ The category of constraints is Cartesian. We can forget information.-weaken1 :: (a, b) :- a-weaken1 = Sub Dict---- | Weakening a constraint product------ The category of constraints is Cartesian. We can forget information.-weaken2 :: (a, b) :- b-weaken2 = Sub Dict--strengthen1 :: Dict b -> a :- c -> a :- (b,c)-strengthen1 d e = unmapDict (const d) &&& e--strengthen2 :: Dict b -> a :- c -> a :- (c,b)-strengthen2 d e = e &&& unmapDict (const d)---- | Contracting a constraint / diagonal morphism------ The category of constraints is Cartesian. We can reuse information.-contract :: a :- (a, a)-contract = Sub Dict---- | Constraint product------ > trans weaken1 (f &&& g) = f--- > trans weaken2 (f &&& g) = g-(&&&) :: (a :- b) -> (a :- c) -> a :- (b, c)-f &&& g = Sub $ Dict \\ f \\ g------------------------------------------------------------------------------------- Initial and terminal morphisms------------------------------------------------------------------------------------- | Every constraint implies truth------ These are the terminal arrows of the category, and @()@ is the terminal object.------ Given any constraint there is a unique entailment of the @()@ constraint from that constraint.-top :: a :- ()-top = Sub Dict---- | 'Any' inhabits every kind, including 'Constraint' but is uninhabited, making it impossible to define an instance.-class Exts.Any => Bottom where- no :: a---- |--- This demonstrates the law of classical logic <http://en.wikipedia.org/wiki/Principle_of_explosion "ex falso quodlibet">-bottom :: Bottom :- a-bottom = Sub no------------------------------------------------------------------------------------- Dict is fully faithful------------------------------------------------------------------------------------- | Apply an entailment to a dictionary.------ From a category theoretic perspective 'Dict' is a functor that maps from the category--- of constraints (with arrows in ':-') to the category Hask of Haskell data types.-mapDict :: (a :- b) -> Dict a -> Dict b-mapDict p Dict = case p of Sub q -> q---- |--- This functor is fully faithful, which is to say that given any function you can write--- @Dict a -> Dict b@ there also exists an entailment @a :- b@ in the category of constraints--- that you can build.-unmapDict :: (Dict a -> Dict b) -> a :- b-unmapDict f = Sub (f Dict)--type role Dict nominal------------------------------------------------------------------------------------- Reflection------------------------------------------------------------------------------------- | Reify the relationship between a class and its superclass constraints as a class------ Given a definition such as------ @--- class Foo a => Bar a--- @------ you can capture the relationship between 'Bar a' and its superclass 'Foo a' with------ @--- instance 'Class' (Foo a) (Bar a) where 'cls' = 'Sub' 'Dict'--- @------ Now the user can use 'cls :: Bar a :- Foo a'-class Class b h | h -> b where- cls :: h :- b--infixr 9 :=>--- | Reify the relationship between an instance head and its body as a class------ Given a definition such as------ @--- instance Foo a => Foo [a]--- @------ you can capture the relationship between the instance head and its body with------ @--- instance Foo a ':=>' Foo [a] where 'ins' = 'Sub' 'Dict'--- @-class b :=> h | h -> b where- ins :: b :- h---- Bootstrapping--instance Class () (Class b a) where cls = Sub Dict-instance Class () (b :=> a) where cls = Sub Dict--instance Class b a => () :=> Class b a where ins = Sub Dict-instance (b :=> a) => () :=> (b :=> a) where ins = Sub Dict--instance Class () () where cls = Sub Dict-instance () :=> () where ins = Sub Dict---- Local, Prelude, Applicative, C.M.I and Data.Monoid instances---- Eq-instance Class () (Eq a) where cls = Sub Dict-instance () :=> Eq () where ins = Sub Dict-instance () :=> Eq Int where ins = Sub Dict-instance () :=> Eq Bool where ins = Sub Dict-instance () :=> Eq Integer where ins = Sub Dict-instance () :=> Eq Float where ins = Sub Dict-instance () :=> Eq Double where ins = Sub Dict-instance Eq a :=> Eq [a] where ins = Sub Dict-instance Eq a :=> Eq (Maybe a) where ins = Sub Dict-instance Eq a :=> Eq (Complex a) where ins = Sub Dict-instance Eq a :=> Eq (Ratio a) where ins = Sub Dict-instance (Eq a, Eq b) :=> Eq (a, b) where ins = Sub Dict-instance (Eq a, Eq b) :=> Eq (Either a b) where ins = Sub Dict-instance () :=> Eq (Dict a) where ins = Sub Dict-instance () :=> Eq (a :- b) where ins = Sub Dict-instance () :=> Eq Word where ins = Sub Dict-instance Eq a :=> Eq (Identity a) where ins = Sub Dict-#if MIN_VERSION_base(4,8,0)-instance Eq a :=> Eq (Const a b) where ins = Sub Dict-instance () :=> Eq Natural where ins = Sub Dict-#endif---- Ord-instance Class (Eq a) (Ord a) where cls = Sub Dict-instance () :=> Ord () where ins = Sub Dict-instance () :=> Ord Bool where ins = Sub Dict-instance () :=> Ord Int where ins = Sub Dict-instance ():=> Ord Integer where ins = Sub Dict-instance () :=> Ord Float where ins = Sub Dict-instance ():=> Ord Double where ins = Sub Dict-instance () :=> Ord Char where ins = Sub Dict-instance Ord a :=> Ord (Maybe a) where ins = Sub Dict-instance Ord a :=> Ord [a] where ins = Sub Dict-instance (Ord a, Ord b) :=> Ord (a, b) where ins = Sub Dict-instance (Ord a, Ord b) :=> Ord (Either a b) where ins = Sub Dict-instance Integral a :=> Ord (Ratio a) where ins = Sub Dict-instance () :=> Ord (Dict a) where ins = Sub Dict-instance () :=> Ord (a :- b) where ins = Sub Dict-instance () :=> Ord Word where ins = Sub Dict-instance Ord a :=> Ord (Identity a) where ins = Sub Dict-#if MIN_VERSION_base(4,8,0)-instance Ord a :=> Ord (Const a b) where ins = Sub Dict-instance () :=> Ord Natural where ins = Sub Dict-#endif---- Show-instance Class () (Show a) where cls = Sub Dict-instance () :=> Show () where ins = Sub Dict-instance () :=> Show Bool where ins = Sub Dict-instance () :=> Show Ordering where ins = Sub Dict-instance () :=> Show Char where ins = Sub Dict-instance () :=> Show Int where ins = Sub Dict-instance Show a :=> Show (Complex a) where ins = Sub Dict-instance Show a :=> Show [a] where ins = Sub Dict-instance Show a :=> Show (Maybe a) where ins = Sub Dict-instance (Show a, Show b) :=> Show (a, b) where ins = Sub Dict-instance (Show a, Show b) :=> Show (Either a b) where ins = Sub Dict-instance (Integral a, Show a) :=> Show (Ratio a) where ins = Sub Dict-instance () :=> Show (Dict a) where ins = Sub Dict-instance () :=> Show (a :- b) where ins = Sub Dict-instance () :=> Show Word where ins = Sub Dict-instance Show a :=> Show (Identity a) where ins = Sub Dict-#if MIN_VERSION_base(4,8,0)-instance Show a :=> Show (Const a b) where ins = Sub Dict-instance () :=> Show Natural where ins = Sub Dict-#endif---- Read-instance Class () (Read a) where cls = Sub Dict-instance () :=> Read () where ins = Sub Dict-instance () :=> Read Bool where ins = Sub Dict-instance () :=> Read Ordering where ins = Sub Dict-instance () :=> Read Char where ins = Sub Dict-instance () :=> Read Int where ins = Sub Dict-instance Read a :=> Read (Complex a) where ins = Sub Dict-instance Read a :=> Read [a] where ins = Sub Dict-instance Read a :=> Read (Maybe a) where ins = Sub Dict-instance (Read a, Read b) :=> Read (a, b) where ins = Sub Dict-instance (Read a, Read b) :=> Read (Either a b) where ins = Sub Dict-instance (Integral a, Read a) :=> Read (Ratio a) where ins = Sub Dict-instance () :=> Read Word where ins = Sub Dict-instance Read a :=> Read (Identity a) where ins = Sub Dict-#if MIN_VERSION_base(4,8,0)-instance Read a :=> Read (Const a b) where ins = Sub Dict-instance () :=> Read Natural where ins = Sub Dict-#endif---- Enum-instance Class () (Enum a) where cls = Sub Dict-instance () :=> Enum () where ins = Sub Dict-instance () :=> Enum Bool where ins = Sub Dict-instance () :=> Enum Ordering where ins = Sub Dict-instance () :=> Enum Char where ins = Sub Dict-instance () :=> Enum Int where ins = Sub Dict-instance () :=> Enum Integer where ins = Sub Dict-instance () :=> Enum Float where ins = Sub Dict-instance () :=> Enum Double where ins = Sub Dict-instance Integral a :=> Enum (Ratio a) where ins = Sub Dict-instance () :=> Enum Word where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Enum a :=> Enum (Identity a) where ins = Sub Dict-instance Enum a :=> Enum (Const a b) where ins = Sub Dict-#endif-#if MIN_VERSION_base(4,8,0)-instance () :=> Enum Natural where ins = Sub Dict-#endif---- Bounded-instance Class () (Bounded a) where cls = Sub Dict-instance () :=> Bounded () where ins = Sub Dict-instance () :=> Bounded Ordering where ins = Sub Dict-instance () :=> Bounded Bool where ins = Sub Dict-instance () :=> Bounded Int where ins = Sub Dict-instance () :=> Bounded Char where ins = Sub Dict-instance (Bounded a, Bounded b) :=> Bounded (a,b) where ins = Sub Dict-instance () :=> Bounded Word where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Bounded a :=> Bounded (Identity a) where ins = Sub Dict-instance Bounded a :=> Bounded (Const a b) where ins = Sub Dict-#endif---- Num-instance Class () (Num a) where cls = Sub Dict-instance () :=> Num Int where ins = Sub Dict-instance () :=> Num Integer where ins = Sub Dict-instance () :=> Num Float where ins = Sub Dict-instance () :=> Num Double where ins = Sub Dict-instance RealFloat a :=> Num (Complex a) where ins = Sub Dict-instance Integral a :=> Num (Ratio a) where ins = Sub Dict-instance () :=> Num Word where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Num a :=> Num (Identity a) where ins = Sub Dict-instance Num a :=> Num (Const a b) where ins = Sub Dict-#endif-#if MIN_VERSION_base(4,8,0)-instance () :=> Num Natural where ins = Sub Dict-#endif---- Real-instance Class (Num a, Ord a) (Real a) where cls = Sub Dict-instance () :=> Real Int where ins = Sub Dict-instance () :=> Real Integer where ins = Sub Dict-instance () :=> Real Float where ins = Sub Dict-instance () :=> Real Double where ins = Sub Dict-instance Integral a :=> Real (Ratio a) where ins = Sub Dict-instance () :=> Real Word where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Real a :=> Real (Identity a) where ins = Sub Dict-instance Real a :=> Real (Const a b) where ins = Sub Dict-#endif-#if MIN_VERSION_base(4,8,0)-instance () :=> Real Natural where ins = Sub Dict-#endif---- Integral-instance Class (Real a, Enum a) (Integral a) where cls = Sub Dict-instance () :=> Integral Int where ins = Sub Dict-instance () :=> Integral Integer where ins = Sub Dict-instance () :=> Integral Word where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Integral a :=> Integral (Identity a) where ins = Sub Dict-instance Integral a :=> Integral (Const a b) where ins = Sub Dict-#endif-#if MIN_VERSION_base(4,8,0)-instance () :=> Integral Natural where ins = Sub Dict-#endif---- Bits-instance Class (Eq a) (Bits a) where cls = Sub Dict-instance () :=> Bits Bool where ins = Sub Dict-instance () :=> Bits Int where ins = Sub Dict-instance () :=> Bits Integer where ins = Sub Dict-instance () :=> Bits Word where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Bits a :=> Bits (Identity a) where ins = Sub Dict-instance Bits a :=> Bits (Const a b) where ins = Sub Dict-#endif-#if MIN_VERSION_base(4,8,0)-instance () :=> Bits Natural where ins = Sub Dict-#endif---- Fractional-instance Class (Num a) (Fractional a) where cls = Sub Dict-instance () :=> Fractional Float where ins = Sub Dict-instance () :=> Fractional Double where ins = Sub Dict-instance RealFloat a :=> Fractional (Complex a) where ins = Sub Dict-instance Integral a :=> Fractional (Ratio a) where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Fractional a :=> Fractional (Identity a) where ins = Sub Dict-instance Fractional a :=> Fractional (Const a b) where ins = Sub Dict-#endif---- Floating-instance Class (Fractional a) (Floating a) where cls = Sub Dict-instance () :=> Floating Float where ins = Sub Dict-instance () :=> Floating Double where ins = Sub Dict-instance RealFloat a :=> Floating (Complex a) where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Floating a :=> Floating (Identity a) where ins = Sub Dict-instance Floating a :=> Floating (Const a b) where ins = Sub Dict-#endif---- RealFrac-instance Class (Real a, Fractional a) (RealFrac a) where cls = Sub Dict-instance () :=> RealFrac Float where ins = Sub Dict-instance () :=> RealFrac Double where ins = Sub Dict-instance Integral a :=> RealFrac (Ratio a) where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance RealFrac a :=> RealFrac (Identity a) where ins = Sub Dict-instance RealFrac a :=> RealFrac (Const a b) where ins = Sub Dict-#endif---- RealFloat-instance Class (RealFrac a, Floating a) (RealFloat a) where cls = Sub Dict-instance () :=> RealFloat Float where ins = Sub Dict-instance () :=> RealFloat Double where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance RealFloat a :=> RealFloat (Identity a) where ins = Sub Dict-instance RealFloat a :=> RealFloat (Const a b) where ins = Sub Dict-#endif---- Semigroup-instance Class () (Semigroup a) where cls = Sub Dict-instance () :=> Semigroup () where ins = Sub Dict-instance () :=> Semigroup Ordering where ins = Sub Dict-instance () :=> Semigroup [a] where ins = Sub Dict-instance Semigroup a :=> Semigroup (Maybe a) where ins = Sub Dict-instance (Semigroup a, Semigroup b) :=> Semigroup (a, b) where ins = Sub Dict-instance Semigroup a :=> Semigroup (Const a b) where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Semigroup a :=> Semigroup (Identity a) where ins = Sub Dict-#endif-#if MIN_VERSION_base(4,10,0)-instance Semigroup a :=> Semigroup (IO a) where ins = Sub Dict-#endif---- Monoid-#if MIN_VERSION_base(4,11,0)-instance Class (Semigroup a) (Monoid a) where cls = Sub Dict-#else-instance Class () (Monoid a) where cls = Sub Dict-#endif-instance () :=> Monoid () where ins = Sub Dict-instance () :=> Monoid Ordering where ins = Sub Dict-instance () :=> Monoid [a] where ins = Sub Dict-instance Monoid a :=> Monoid (Maybe a) where ins = Sub Dict-instance (Monoid a, Monoid b) :=> Monoid (a, b) where ins = Sub Dict-instance Monoid a :=> Monoid (Const a b) where ins = Sub Dict-#if MIN_VERSION_base(4,9,0)-instance Monoid a :=> Monoid (Identity a) where ins = Sub Dict-instance Monoid a :=> Monoid (IO a) where ins = Sub Dict-#endif---- Functor-instance Class () (Functor f) where cls = Sub Dict-instance () :=> Functor [] where ins = Sub Dict-instance () :=> Functor Maybe where ins = Sub Dict-instance () :=> Functor (Either a) where ins = Sub Dict-instance () :=> Functor ((->) a) where ins = Sub Dict-instance () :=> Functor ((,) a) where ins = Sub Dict-instance () :=> Functor IO where ins = Sub Dict-instance Monad m :=> Functor (WrappedMonad m) where ins = Sub Dict-instance () :=> Functor Identity where ins = Sub Dict-instance () :=> Functor (Const a) where ins = Sub Dict---- Applicative-instance Class (Functor f) (Applicative f) where cls = Sub Dict-instance () :=> Applicative [] where ins = Sub Dict-instance () :=> Applicative Maybe where ins = Sub Dict-instance () :=> Applicative (Either a) where ins = Sub Dict-instance () :=> Applicative ((->)a) where ins = Sub Dict-instance () :=> Applicative IO where ins = Sub Dict-instance Monoid a :=> Applicative ((,)a) where ins = Sub Dict-instance Monoid a :=> Applicative (Const a) where ins = Sub Dict-instance Monad m :=> Applicative (WrappedMonad m) where ins = Sub Dict---- Alternative-instance Class (Applicative f) (Alternative f) where cls = Sub Dict-instance () :=> Alternative [] where ins = Sub Dict-instance () :=> Alternative Maybe where ins = Sub Dict-instance MonadPlus m :=> Alternative (WrappedMonad m) where ins = Sub Dict---- Monad-#if MIN_VERSION_base(4,8,0)-instance Class (Applicative f) (Monad f) where cls = Sub Dict-#else-instance Class () (Monad f) where cls = Sub Dict-#endif-instance () :=> Monad [] where ins = Sub Dict-instance () :=> Monad ((->) a) where ins = Sub Dict-instance () :=> Monad (Either a) where ins = Sub Dict-instance () :=> Monad IO where ins = Sub Dict-instance () :=> Monad Identity where ins = Sub Dict---- MonadPlus-#if MIN_VERSION_base(4,8,0)-instance Class (Monad f, Alternative f) (MonadPlus f) where cls = Sub Dict-#else-instance Class (Monad f) (MonadPlus f) where cls = Sub Dict-#endif-instance () :=> MonadPlus [] where ins = Sub Dict-instance () :=> MonadPlus Maybe where ins = Sub Dict------------------------------------------------------------------------------------- UndecidableInstances-----------------------------------------------------------------------------------instance a :=> Enum (Dict a) where ins = Sub Dict-instance a => Enum (Dict a) where- toEnum _ = Dict- fromEnum Dict = 0--instance a :=> Bounded (Dict a) where ins = Sub Dict-instance a => Bounded (Dict a) where- minBound = Dict- maxBound = Dict--instance a :=> Read (Dict a) where ins = Sub Dict-deriving instance a => Read (Dict a)--instance () :=> Semigroup (Dict a) where ins = Sub Dict-instance Semigroup (Dict a) where- Dict <> Dict = Dict--instance a :=> Monoid (Dict a) where ins = Sub Dict-instance a => Monoid (Dict a) where-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif- mempty = Dict+{- +Copyright 2011-2015 Edward Kmett + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + -} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UndecidableSuperClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Constraint +-- Copyright : (C) 2011-2015 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Stability : experimental +-- Portability : non-portable +-- +-- This module is taken from +-- <https://github.com/ekmett/constraints/blob/963c0e904ad48a5cec29a0cb649622d8c1872af4/src/Data/Constraint.hs constraints:Data.Constraint> +-- A few things have been cut from the module to remove dependencies. +-- +-- +---------------------------------------------------------------------------- +module Data.Constraint + ( + -- * The Kind of Constraints + Constraint + -- * Dictionary + , Dict(Dict) + , HasDict(..) + , withDict + , (\\) + -- * Entailment + , (:-)(Sub) + , type (⊢) + , weaken1, weaken2, contract + , strengthen1, strengthen2 + , (&&&), (***) + , trans, refl + , Bottom(no) + , top, bottom + -- * Dict is fully faithful + , mapDict + , unmapDict + -- * Reflection + , Class(..) + , (:=>)(..) + ) where +import Control.Applicative +import Control.Category +import Control.Monad +import Data.Complex +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806 +import Data.Kind +#endif +import Data.Ratio +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif +import Data.Data hiding (TypeRep) +import qualified GHC.Exts as Exts (Any) +import GHC.Exts (Constraint) +import Data.Bits (Bits) +import Data.Functor.Identity (Identity) +import Numeric.Natural (Natural) +import Data.Word (Word) +import Data.Coerce (Coercible) +import Data.Type.Coercion(Coercion(..)) +#if MIN_VERSION_base(4,10,0) +import Data.Type.Equality ((:~~:)(..), type (~~)) +import Type.Reflection (TypeRep, typeRepKind, withTypeable) +#endif + +-- | Values of type @'Dict' p@ capture a dictionary for a constraint of type @p@. +-- +-- e.g. +-- +-- @ +-- 'Dict' :: 'Dict' ('Eq' 'Int') +-- @ +-- +-- captures a dictionary that proves we have an: +-- +-- @ +-- instance 'Eq' 'Int +-- @ +-- +-- Pattern matching on the 'Dict' constructor will bring this instance into scope. +-- +data Dict :: Constraint -> * where + Dict :: a => Dict a + deriving Typeable + + +instance (Typeable p, p) => Data (Dict p) where + gfoldl _ z Dict = z Dict + toConstr _ = dictConstr + gunfold _ z c = case constrIndex c of + 1 -> z Dict + _ -> error "gunfold" + dataTypeOf _ = dictDataType + +dictConstr :: Constr +dictConstr = mkConstr dictDataType "Dict" [] Prefix + +dictDataType :: DataType +dictDataType = mkDataType "Data.Constraint.Dict" [dictConstr] + +deriving instance Eq (Dict a) +deriving instance Ord (Dict a) +deriving instance Show (Dict a) + +-- | Witnesses that a value of type @e@ contains evidence of the constraint @c@. +-- +-- Mainly intended to allow ('\\') to be overloaded, since it's a useful operator. +class HasDict c e | e -> c where + evidence :: e -> Dict c + +instance HasDict a (Dict a) where + evidence = Prelude.id + +instance a => HasDict b (a :- b) where + evidence (Sub x) = x + +instance HasDict (Coercible a b) (Coercion a b) where + evidence Coercion = Dict + +instance HasDict (a ~ b) (a :~: b) where + evidence Refl = Dict + +#if MIN_VERSION_base(4,10,0) +instance HasDict (a ~~ b) (a :~~: b) where + evidence HRefl = Dict + +instance HasDict (Typeable k, Typeable a) (TypeRep (a :: k)) where + evidence tr = withTypeable tr $ withTypeable (typeRepKind tr) Dict +#endif + +-- | From a 'Dict', takes a value in an environment where the instance +-- witnessed by the 'Dict' is in scope, and evaluates it. +-- +-- Essentially a deconstruction of a 'Dict' into its continuation-style +-- form. +-- +-- Can also be used to deconstruct an entailment, @a ':-' b@, using a context @a@. +-- +-- @ +-- withDict :: 'Dict' c -> (c => r) -> r +-- withDict :: a => (a ':-' c) -> (c => r) -> r +-- @ +withDict :: HasDict c e => e -> (c => r) -> r +withDict d r = case evidence d of + Dict -> r + +infixl 1 \\ -- required comment + +-- | Operator version of 'withDict', with the arguments flipped +(\\) :: HasDict c e => (c => r) -> e -> r +r \\ d = withDict d r + +infixr 9 :- +infixr 9 ⊢ + +type (⊢) = (:-) + +-- | This is the type of entailment. +-- +-- @a ':-' b@ is read as @a@ \"entails\" @b@. +-- +-- With this we can actually build a category for 'Constraint' resolution. +-- +-- e.g. +-- +-- Because @'Eq' a@ is a superclass of @'Ord' a@, we can show that @'Ord' a@ +-- entails @'Eq' a@. +-- +-- Because @instance 'Ord' a => 'Ord' [a]@ exists, we can show that @'Ord' a@ +-- entails @'Ord' [a]@ as well. +-- +-- This relationship is captured in the ':-' entailment type here. +-- +-- Since @p ':-' p@ and entailment composes, ':-' forms the arrows of a +-- 'Category' of constraints. However, 'Category' only became sufficiently +-- general to support this instance in GHC 7.8, so prior to 7.8 this instance +-- is unavailable. +-- +-- But due to the coherence of instance resolution in Haskell, this 'Category' +-- has some very interesting properties. Notably, in the absence of +-- @IncoherentInstances@, this category is \"thin\", which is to say that +-- between any two objects (constraints) there is at most one distinguishable +-- arrow. +-- +-- This means that for instance, even though there are two ways to derive +-- @'Ord' a ':-' 'Eq' [a]@, the answers from these two paths _must_ by +-- construction be equal. This is a property that Haskell offers that is +-- pretty much unique in the space of languages with things they call \"type +-- classes\". +-- +-- What are the two ways? +-- +-- Well, we can go from @'Ord' a ':-' 'Eq' a@ via the +-- superclass relationship, and then from @'Eq' a ':-' 'Eq' [a]@ via the +-- instance, or we can go from @'Ord' a ':-' 'Ord' [a]@ via the instance +-- then from @'Ord' [a] ':-' 'Eq' [a]@ through the superclass relationship +-- and this diagram by definition must \"commute\". +-- +-- Diagrammatically, +-- +-- > Ord a +-- > ins / \ cls +-- > v v +-- > Ord [a] Eq a +-- > cls \ / ins +-- > v v +-- > Eq [a] +-- +-- This safety net ensures that pretty much anything you can write with this +-- library is sensible and can't break any assumptions on the behalf of +-- library authors. +newtype a :- b = Sub (a => Dict b) + deriving Typeable + +type role (:-) nominal nominal + +-- TODO: _proper_ Data for @(p ':-' q)@ requires @(:-)@ to be cartesian _closed_. +-- +-- This is admissable, but not present by default + +-- constraint should be instance (Typeable p, Typeable q, p |- q) => Data (p :- q) +instance (Typeable p, Typeable q, p, q) => Data (p :- q) where + gfoldl _ z (Sub Dict) = z (Sub Dict) + toConstr _ = subConstr + gunfold _ z c = case constrIndex c of + 1 -> z (Sub Dict) + _ -> error "gunfold" + dataTypeOf _ = subDataType + +subConstr :: Constr +subConstr = mkConstr dictDataType "Sub" [] Prefix + +subDataType :: DataType +subDataType = mkDataType "Data.Constraint.:-" [subConstr] + +-- | Possible since GHC 7.8, when 'Category' was made polykinded. +instance Category (:-) where + id = refl + (.) = trans + +-- | Assumes 'IncoherentInstances' doesn't exist. +instance Eq (a :- b) where + _ == _ = True + +-- | Assumes 'IncoherentInstances' doesn't exist. +instance Ord (a :- b) where + compare _ _ = EQ + +instance Show (a :- b) where + showsPrec d _ = showParen (d > 10) $ showString "Sub Dict" + + +-------------------------------------------------------------------------------- +-- Constraints form a Category +-------------------------------------------------------------------------------- + +-- | Transitivity of entailment +-- +-- If we view @(':-')@ as a Constraint-indexed category, then this is @('.')@ +trans :: (b :- c) -> (a :- b) -> a :- c +trans f g = Sub $ Dict \\ f \\ g + +-- | Reflexivity of entailment +-- +-- If we view @(':-')@ as a Constraint-indexed category, then this is 'id' +refl :: a :- a +refl = Sub Dict + +-------------------------------------------------------------------------------- +-- (,) is a Bifunctor +-------------------------------------------------------------------------------- + +-- | due to the hack for the kind of @(,)@ in the current version of GHC we can't actually +-- make instances for @(,) :: Constraint -> Constraint -> Constraint@, but @(,)@ is a +-- bifunctor on the category of constraints. This lets us map over both sides. +(***) :: (a :- b) -> (c :- d) -> (a, c) :- (b, d) +f *** g = Sub $ Dict \\ f \\ g + +-------------------------------------------------------------------------------- +-- Constraints are Cartesian +-------------------------------------------------------------------------------- + +-- | Weakening a constraint product +-- +-- The category of constraints is Cartesian. We can forget information. +weaken1 :: (a, b) :- a +weaken1 = Sub Dict + +-- | Weakening a constraint product +-- +-- The category of constraints is Cartesian. We can forget information. +weaken2 :: (a, b) :- b +weaken2 = Sub Dict + +strengthen1 :: Dict b -> a :- c -> a :- (b,c) +strengthen1 d e = unmapDict (const d) &&& e + +strengthen2 :: Dict b -> a :- c -> a :- (c,b) +strengthen2 d e = e &&& unmapDict (const d) + +-- | Contracting a constraint / diagonal morphism +-- +-- The category of constraints is Cartesian. We can reuse information. +contract :: a :- (a, a) +contract = Sub Dict + +-- | Constraint product +-- +-- > trans weaken1 (f &&& g) = f +-- > trans weaken2 (f &&& g) = g +(&&&) :: (a :- b) -> (a :- c) -> a :- (b, c) +f &&& g = Sub $ Dict \\ f \\ g + +-------------------------------------------------------------------------------- +-- Initial and terminal morphisms +-------------------------------------------------------------------------------- + +-- | Every constraint implies truth +-- +-- These are the terminal arrows of the category, and @()@ is the terminal object. +-- +-- Given any constraint there is a unique entailment of the @()@ constraint from that constraint. +top :: a :- () +top = Sub Dict + +-- | 'Any' inhabits every kind, including 'Constraint' but is uninhabited, making it impossible to define an instance. +class Exts.Any => Bottom where + no :: a + +-- | +-- This demonstrates the law of classical logic <http://en.wikipedia.org/wiki/Principle_of_explosion "ex falso quodlibet"> +bottom :: Bottom :- a +bottom = Sub no + +-------------------------------------------------------------------------------- +-- Dict is fully faithful +-------------------------------------------------------------------------------- + +-- | Apply an entailment to a dictionary. +-- +-- From a category theoretic perspective 'Dict' is a functor that maps from the category +-- of constraints (with arrows in ':-') to the category Hask of Haskell data types. +mapDict :: (a :- b) -> Dict a -> Dict b +mapDict p Dict = case p of Sub q -> q + +-- | +-- This functor is fully faithful, which is to say that given any function you can write +-- @Dict a -> Dict b@ there also exists an entailment @a :- b@ in the category of constraints +-- that you can build. +unmapDict :: (Dict a -> Dict b) -> a :- b +unmapDict f = Sub (f Dict) + +type role Dict nominal + +-------------------------------------------------------------------------------- +-- Reflection +-------------------------------------------------------------------------------- + +-- | Reify the relationship between a class and its superclass constraints as a class +-- +-- Given a definition such as +-- +-- @ +-- class Foo a => Bar a +-- @ +-- +-- you can capture the relationship between 'Bar a' and its superclass 'Foo a' with +-- +-- @ +-- instance 'Class' (Foo a) (Bar a) where 'cls' = 'Sub' 'Dict' +-- @ +-- +-- Now the user can use 'cls :: Bar a :- Foo a' +class Class b h | h -> b where + cls :: h :- b + +infixr 9 :=> +-- | Reify the relationship between an instance head and its body as a class +-- +-- Given a definition such as +-- +-- @ +-- instance Foo a => Foo [a] +-- @ +-- +-- you can capture the relationship between the instance head and its body with +-- +-- @ +-- instance Foo a ':=>' Foo [a] where 'ins' = 'Sub' 'Dict' +-- @ +class b :=> h | h -> b where + ins :: b :- h + +-- Bootstrapping + +instance Class () (Class b a) where cls = Sub Dict +instance Class () (b :=> a) where cls = Sub Dict + +instance Class b a => () :=> Class b a where ins = Sub Dict +instance (b :=> a) => () :=> (b :=> a) where ins = Sub Dict + +instance Class () () where cls = Sub Dict +instance () :=> () where ins = Sub Dict + +-- Local, Prelude, Applicative, C.M.I and Data.Monoid instances + +-- Eq +instance Class () (Eq a) where cls = Sub Dict +instance () :=> Eq () where ins = Sub Dict +instance () :=> Eq Int where ins = Sub Dict +instance () :=> Eq Bool where ins = Sub Dict +instance () :=> Eq Integer where ins = Sub Dict +instance () :=> Eq Float where ins = Sub Dict +instance () :=> Eq Double where ins = Sub Dict +instance Eq a :=> Eq [a] where ins = Sub Dict +instance Eq a :=> Eq (Maybe a) where ins = Sub Dict +instance Eq a :=> Eq (Complex a) where ins = Sub Dict +instance Eq a :=> Eq (Ratio a) where ins = Sub Dict +instance (Eq a, Eq b) :=> Eq (a, b) where ins = Sub Dict +instance (Eq a, Eq b) :=> Eq (Either a b) where ins = Sub Dict +instance () :=> Eq (Dict a) where ins = Sub Dict +instance () :=> Eq (a :- b) where ins = Sub Dict +instance () :=> Eq Word where ins = Sub Dict +instance Eq a :=> Eq (Identity a) where ins = Sub Dict +#if MIN_VERSION_base(4,8,0) +instance Eq a :=> Eq (Const a b) where ins = Sub Dict +instance () :=> Eq Natural where ins = Sub Dict +#endif + +-- Ord +instance Class (Eq a) (Ord a) where cls = Sub Dict +instance () :=> Ord () where ins = Sub Dict +instance () :=> Ord Bool where ins = Sub Dict +instance () :=> Ord Int where ins = Sub Dict +instance ():=> Ord Integer where ins = Sub Dict +instance () :=> Ord Float where ins = Sub Dict +instance ():=> Ord Double where ins = Sub Dict +instance () :=> Ord Char where ins = Sub Dict +instance Ord a :=> Ord (Maybe a) where ins = Sub Dict +instance Ord a :=> Ord [a] where ins = Sub Dict +instance (Ord a, Ord b) :=> Ord (a, b) where ins = Sub Dict +instance (Ord a, Ord b) :=> Ord (Either a b) where ins = Sub Dict +instance Integral a :=> Ord (Ratio a) where ins = Sub Dict +instance () :=> Ord (Dict a) where ins = Sub Dict +instance () :=> Ord (a :- b) where ins = Sub Dict +instance () :=> Ord Word where ins = Sub Dict +instance Ord a :=> Ord (Identity a) where ins = Sub Dict +#if MIN_VERSION_base(4,8,0) +instance Ord a :=> Ord (Const a b) where ins = Sub Dict +instance () :=> Ord Natural where ins = Sub Dict +#endif + +-- Show +instance Class () (Show a) where cls = Sub Dict +instance () :=> Show () where ins = Sub Dict +instance () :=> Show Bool where ins = Sub Dict +instance () :=> Show Ordering where ins = Sub Dict +instance () :=> Show Char where ins = Sub Dict +instance () :=> Show Int where ins = Sub Dict +instance Show a :=> Show (Complex a) where ins = Sub Dict +instance Show a :=> Show [a] where ins = Sub Dict +instance Show a :=> Show (Maybe a) where ins = Sub Dict +instance (Show a, Show b) :=> Show (a, b) where ins = Sub Dict +instance (Show a, Show b) :=> Show (Either a b) where ins = Sub Dict +instance (Integral a, Show a) :=> Show (Ratio a) where ins = Sub Dict +instance () :=> Show (Dict a) where ins = Sub Dict +instance () :=> Show (a :- b) where ins = Sub Dict +instance () :=> Show Word where ins = Sub Dict +instance Show a :=> Show (Identity a) where ins = Sub Dict +#if MIN_VERSION_base(4,8,0) +instance Show a :=> Show (Const a b) where ins = Sub Dict +instance () :=> Show Natural where ins = Sub Dict +#endif + +-- Read +instance Class () (Read a) where cls = Sub Dict +instance () :=> Read () where ins = Sub Dict +instance () :=> Read Bool where ins = Sub Dict +instance () :=> Read Ordering where ins = Sub Dict +instance () :=> Read Char where ins = Sub Dict +instance () :=> Read Int where ins = Sub Dict +instance Read a :=> Read (Complex a) where ins = Sub Dict +instance Read a :=> Read [a] where ins = Sub Dict +instance Read a :=> Read (Maybe a) where ins = Sub Dict +instance (Read a, Read b) :=> Read (a, b) where ins = Sub Dict +instance (Read a, Read b) :=> Read (Either a b) where ins = Sub Dict +instance (Integral a, Read a) :=> Read (Ratio a) where ins = Sub Dict +instance () :=> Read Word where ins = Sub Dict +instance Read a :=> Read (Identity a) where ins = Sub Dict +#if MIN_VERSION_base(4,8,0) +instance Read a :=> Read (Const a b) where ins = Sub Dict +instance () :=> Read Natural where ins = Sub Dict +#endif + +-- Enum +instance Class () (Enum a) where cls = Sub Dict +instance () :=> Enum () where ins = Sub Dict +instance () :=> Enum Bool where ins = Sub Dict +instance () :=> Enum Ordering where ins = Sub Dict +instance () :=> Enum Char where ins = Sub Dict +instance () :=> Enum Int where ins = Sub Dict +instance () :=> Enum Integer where ins = Sub Dict +instance () :=> Enum Float where ins = Sub Dict +instance () :=> Enum Double where ins = Sub Dict +instance Integral a :=> Enum (Ratio a) where ins = Sub Dict +instance () :=> Enum Word where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Enum a :=> Enum (Identity a) where ins = Sub Dict +instance Enum a :=> Enum (Const a b) where ins = Sub Dict +#endif +#if MIN_VERSION_base(4,8,0) +instance () :=> Enum Natural where ins = Sub Dict +#endif + +-- Bounded +instance Class () (Bounded a) where cls = Sub Dict +instance () :=> Bounded () where ins = Sub Dict +instance () :=> Bounded Ordering where ins = Sub Dict +instance () :=> Bounded Bool where ins = Sub Dict +instance () :=> Bounded Int where ins = Sub Dict +instance () :=> Bounded Char where ins = Sub Dict +instance (Bounded a, Bounded b) :=> Bounded (a,b) where ins = Sub Dict +instance () :=> Bounded Word where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Bounded a :=> Bounded (Identity a) where ins = Sub Dict +instance Bounded a :=> Bounded (Const a b) where ins = Sub Dict +#endif + +-- Num +instance Class () (Num a) where cls = Sub Dict +instance () :=> Num Int where ins = Sub Dict +instance () :=> Num Integer where ins = Sub Dict +instance () :=> Num Float where ins = Sub Dict +instance () :=> Num Double where ins = Sub Dict +instance RealFloat a :=> Num (Complex a) where ins = Sub Dict +instance Integral a :=> Num (Ratio a) where ins = Sub Dict +instance () :=> Num Word where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Num a :=> Num (Identity a) where ins = Sub Dict +instance Num a :=> Num (Const a b) where ins = Sub Dict +#endif +#if MIN_VERSION_base(4,8,0) +instance () :=> Num Natural where ins = Sub Dict +#endif + +-- Real +instance Class (Num a, Ord a) (Real a) where cls = Sub Dict +instance () :=> Real Int where ins = Sub Dict +instance () :=> Real Integer where ins = Sub Dict +instance () :=> Real Float where ins = Sub Dict +instance () :=> Real Double where ins = Sub Dict +instance Integral a :=> Real (Ratio a) where ins = Sub Dict +instance () :=> Real Word where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Real a :=> Real (Identity a) where ins = Sub Dict +instance Real a :=> Real (Const a b) where ins = Sub Dict +#endif +#if MIN_VERSION_base(4,8,0) +instance () :=> Real Natural where ins = Sub Dict +#endif + +-- Integral +instance Class (Real a, Enum a) (Integral a) where cls = Sub Dict +instance () :=> Integral Int where ins = Sub Dict +instance () :=> Integral Integer where ins = Sub Dict +instance () :=> Integral Word where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Integral a :=> Integral (Identity a) where ins = Sub Dict +instance Integral a :=> Integral (Const a b) where ins = Sub Dict +#endif +#if MIN_VERSION_base(4,8,0) +instance () :=> Integral Natural where ins = Sub Dict +#endif + +-- Bits +instance Class (Eq a) (Bits a) where cls = Sub Dict +instance () :=> Bits Bool where ins = Sub Dict +instance () :=> Bits Int where ins = Sub Dict +instance () :=> Bits Integer where ins = Sub Dict +instance () :=> Bits Word where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Bits a :=> Bits (Identity a) where ins = Sub Dict +instance Bits a :=> Bits (Const a b) where ins = Sub Dict +#endif +#if MIN_VERSION_base(4,8,0) +instance () :=> Bits Natural where ins = Sub Dict +#endif + +-- Fractional +instance Class (Num a) (Fractional a) where cls = Sub Dict +instance () :=> Fractional Float where ins = Sub Dict +instance () :=> Fractional Double where ins = Sub Dict +instance RealFloat a :=> Fractional (Complex a) where ins = Sub Dict +instance Integral a :=> Fractional (Ratio a) where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Fractional a :=> Fractional (Identity a) where ins = Sub Dict +instance Fractional a :=> Fractional (Const a b) where ins = Sub Dict +#endif + +-- Floating +instance Class (Fractional a) (Floating a) where cls = Sub Dict +instance () :=> Floating Float where ins = Sub Dict +instance () :=> Floating Double where ins = Sub Dict +instance RealFloat a :=> Floating (Complex a) where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Floating a :=> Floating (Identity a) where ins = Sub Dict +instance Floating a :=> Floating (Const a b) where ins = Sub Dict +#endif + +-- RealFrac +instance Class (Real a, Fractional a) (RealFrac a) where cls = Sub Dict +instance () :=> RealFrac Float where ins = Sub Dict +instance () :=> RealFrac Double where ins = Sub Dict +instance Integral a :=> RealFrac (Ratio a) where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance RealFrac a :=> RealFrac (Identity a) where ins = Sub Dict +instance RealFrac a :=> RealFrac (Const a b) where ins = Sub Dict +#endif + +-- RealFloat +instance Class (RealFrac a, Floating a) (RealFloat a) where cls = Sub Dict +instance () :=> RealFloat Float where ins = Sub Dict +instance () :=> RealFloat Double where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance RealFloat a :=> RealFloat (Identity a) where ins = Sub Dict +instance RealFloat a :=> RealFloat (Const a b) where ins = Sub Dict +#endif + +-- Semigroup +instance Class () (Semigroup a) where cls = Sub Dict +instance () :=> Semigroup () where ins = Sub Dict +instance () :=> Semigroup Ordering where ins = Sub Dict +instance () :=> Semigroup [a] where ins = Sub Dict +instance Semigroup a :=> Semigroup (Maybe a) where ins = Sub Dict +instance (Semigroup a, Semigroup b) :=> Semigroup (a, b) where ins = Sub Dict +instance Semigroup a :=> Semigroup (Const a b) where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Semigroup a :=> Semigroup (Identity a) where ins = Sub Dict +#endif +#if MIN_VERSION_base(4,10,0) +instance Semigroup a :=> Semigroup (IO a) where ins = Sub Dict +#endif + +-- Monoid +#if MIN_VERSION_base(4,11,0) +instance Class (Semigroup a) (Monoid a) where cls = Sub Dict +#else +instance Class () (Monoid a) where cls = Sub Dict +#endif +instance () :=> Monoid () where ins = Sub Dict +instance () :=> Monoid Ordering where ins = Sub Dict +instance () :=> Monoid [a] where ins = Sub Dict +instance Monoid a :=> Monoid (Maybe a) where ins = Sub Dict +instance (Monoid a, Monoid b) :=> Monoid (a, b) where ins = Sub Dict +instance Monoid a :=> Monoid (Const a b) where ins = Sub Dict +#if MIN_VERSION_base(4,9,0) +instance Monoid a :=> Monoid (Identity a) where ins = Sub Dict +instance Monoid a :=> Monoid (IO a) where ins = Sub Dict +#endif + +-- Functor +instance Class () (Functor f) where cls = Sub Dict +instance () :=> Functor [] where ins = Sub Dict +instance () :=> Functor Maybe where ins = Sub Dict +instance () :=> Functor (Either a) where ins = Sub Dict +instance () :=> Functor ((->) a) where ins = Sub Dict +instance () :=> Functor ((,) a) where ins = Sub Dict +instance () :=> Functor IO where ins = Sub Dict +instance Monad m :=> Functor (WrappedMonad m) where ins = Sub Dict +instance () :=> Functor Identity where ins = Sub Dict +instance () :=> Functor (Const a) where ins = Sub Dict + +-- Applicative +instance Class (Functor f) (Applicative f) where cls = Sub Dict +instance () :=> Applicative [] where ins = Sub Dict +instance () :=> Applicative Maybe where ins = Sub Dict +instance () :=> Applicative (Either a) where ins = Sub Dict +instance () :=> Applicative ((->)a) where ins = Sub Dict +instance () :=> Applicative IO where ins = Sub Dict +instance Monoid a :=> Applicative ((,)a) where ins = Sub Dict +instance Monoid a :=> Applicative (Const a) where ins = Sub Dict +instance Monad m :=> Applicative (WrappedMonad m) where ins = Sub Dict + +-- Alternative +instance Class (Applicative f) (Alternative f) where cls = Sub Dict +instance () :=> Alternative [] where ins = Sub Dict +instance () :=> Alternative Maybe where ins = Sub Dict +instance MonadPlus m :=> Alternative (WrappedMonad m) where ins = Sub Dict + +-- Monad +#if MIN_VERSION_base(4,8,0) +instance Class (Applicative f) (Monad f) where cls = Sub Dict +#else +instance Class () (Monad f) where cls = Sub Dict +#endif +instance () :=> Monad [] where ins = Sub Dict +instance () :=> Monad ((->) a) where ins = Sub Dict +instance () :=> Monad (Either a) where ins = Sub Dict +instance () :=> Monad IO where ins = Sub Dict +instance () :=> Monad Identity where ins = Sub Dict + +-- MonadPlus +#if MIN_VERSION_base(4,8,0) +instance Class (Monad f, Alternative f) (MonadPlus f) where cls = Sub Dict +#else +instance Class (Monad f) (MonadPlus f) where cls = Sub Dict +#endif +instance () :=> MonadPlus [] where ins = Sub Dict +instance () :=> MonadPlus Maybe where ins = Sub Dict + +-------------------------------------------------------------------------------- +-- UndecidableInstances +-------------------------------------------------------------------------------- + +instance a :=> Enum (Dict a) where ins = Sub Dict +instance a => Enum (Dict a) where + toEnum _ = Dict + fromEnum Dict = 0 + +instance a :=> Bounded (Dict a) where ins = Sub Dict +instance a => Bounded (Dict a) where + minBound = Dict + maxBound = Dict + +instance a :=> Read (Dict a) where ins = Sub Dict +deriving instance a => Read (Dict a) + +instance () :=> Semigroup (Dict a) where ins = Sub Dict +instance Semigroup (Dict a) where + Dict <> Dict = Dict + +instance a :=> Monoid (Dict a) where ins = Sub Dict +instance a => Monoid (Dict a) where +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + mempty = Dict
src-constraints/Data/Constraint/Unsafe.hs view
@@ -1,72 +1,72 @@-{--Copyright 2011-2015 Edward Kmett--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.--2. 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.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.- -}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Unsafe #-}-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}--------------------------------------------------------------------------------- |--- Module : Data.Constraint.Unsafe--- Copyright : (C) 2011-2015 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Stability : experimental--- Portability : non-portable------ This module is taken from--- <https://github.com/ekmett/constraints/blob/963c0e904ad48a5cec29a0cb649622d8c1872af4/src/Data/Constraint/Unsafe.hs constraints:Data.Constraint.Unsafe>--- A few things have been cut from the module.---------------------------------------------------------------------------------module Data.Constraint.Unsafe- ( Coercible- , unsafeCoerceConstraint- , unsafeDerive- , unsafeUnderive- ) where--import Data.Coerce-import Data.Constraint-import Unsafe.Coerce---- | Coerce a dictionary unsafely from one type to another-unsafeCoerceConstraint :: a :- b-unsafeCoerceConstraint = unsafeCoerce refl---- | Coerce a dictionary unsafely from one type to a newtype of that type-unsafeDerive :: Coercible n o => (o -> n) -> t o :- t n-unsafeDerive _ = unsafeCoerceConstraint---- | Coerce a dictionary unsafely from a newtype of a type to the base type-unsafeUnderive :: Coercible n o => (o -> n) -> t n :- t o-unsafeUnderive _ = unsafeCoerceConstraint+{- +Copyright 2011-2015 Edward Kmett + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + -} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Constraint.Unsafe +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Stability : experimental +-- Portability : non-portable +-- +-- This module is taken from +-- <https://github.com/ekmett/constraints/blob/963c0e904ad48a5cec29a0cb649622d8c1872af4/src/Data/Constraint/Unsafe.hs constraints:Data.Constraint.Unsafe> +-- A few things have been cut from the module. +-- +---------------------------------------------------------------------------- +module Data.Constraint.Unsafe + ( Coercible + , unsafeCoerceConstraint + , unsafeDerive + , unsafeUnderive + ) where + +import Data.Coerce +import Data.Constraint +import Unsafe.Coerce + +-- | Coerce a dictionary unsafely from one type to another +unsafeCoerceConstraint :: a :- b +unsafeCoerceConstraint = unsafeCoerce refl + +-- | Coerce a dictionary unsafely from one type to a newtype of that type +unsafeDerive :: Coercible n o => (o -> n) -> t o :- t n +unsafeDerive _ = unsafeCoerceConstraint + +-- | Coerce a dictionary unsafely from a newtype of a type to the base type +unsafeUnderive :: Coercible n o => (o -> n) -> t n :- t o +unsafeUnderive _ = unsafeCoerceConstraint
src/Data/Constraint/Bare.hs view
@@ -1,63 +1,63 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# 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- ) where---import Data.Constraint (Dict (..))-import GHC.Base (Constraint, Type, 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 DictValue c <- (dictToBare -> c)- where- DictValue c = bareToDict c--#if __GLASGOW_HASKELL__ >= 802-{-# COMPLETE DictValue #-}-#endif---- | Extract a `Constraint` from a `Dict`-dictToBare :: Dict c -> BareConstraint c-dictToBare Dict = case unsafeCoerce# id of MagicBC c -> c-{-# INLINE dictToBare #-}---- | Wrap a `Constraint` into a `Dict`-bareToDict :: BareConstraint c -> Dict c-bareToDict = unsafeCoerce# (MagicDi Dict)-{-# INLINE bareToDict #-}--newtype MagicDi c = MagicDi (c => Dict c)-newtype MagicBC c = MagicBC (c => BareConstraint c)+{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# 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 + ) where + + +import Data.Constraint (Dict (..)) +import GHC.Base (Constraint, Type, 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 DictValue c <- (dictToBare -> c) + where + DictValue c = bareToDict c + +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE DictValue #-} +#endif + +-- | Extract a `Constraint` from a `Dict` +dictToBare :: Dict c -> BareConstraint c +dictToBare Dict = case unsafeCoerce# id of MagicBC c -> c +{-# INLINE dictToBare #-} + +-- | Wrap a `Constraint` into a `Dict` +bareToDict :: BareConstraint c -> Dict c +bareToDict = unsafeCoerce# (MagicDi Dict) +{-# INLINE bareToDict #-} + +newtype MagicDi c = MagicDi (c => Dict c) +newtype MagicBC c = MagicBC (c => BareConstraint c)
src/Data/Constraint/Deriving.hs view
@@ -1,78 +1,78 @@-{-# LANGUAGE CPP #-}-module Data.Constraint.Deriving- ( plugin- -- * DeriveAll pass- , DeriveAll (..)- , DeriveContext- -- * ToInstance pass- , ToInstance (..)- , OverlapMode (..)- ) where----import Data.List (sortOn)-import GhcPlugins hiding (OverlapMode (..), overlapMode)-import InstEnv (is_cls, is_tys)-import Type (tyConAppTyCon_maybe)--import Data.Constraint.Deriving.DeriveAll-import Data.Constraint.Deriving.ToInstance------ | To use the plugin, add------ @--- {\-\# OPTIONS_GHC -fplugin Data.Constraint.Deriving \#-\}--- @------ to the header of your file.------ For debugging, add a plugin option @dump-instances@------ @--- {\-\# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances \#-\}--- @------ to the header of your file; it will print all instances declared in the module--- (hand-written and auto-generated).----plugin :: Plugin-plugin = defaultPlugin- { installCoreToDos = install-#if MIN_VERSION_ghc(8,6,0)- , pluginRecompile = purePlugin-#endif- }--install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]-install cmdopts todo = do- eref <- initCorePluginEnv- return ( deriveAllPass eref- : toInstancePass eref- : if elem "dump-instances" cmdopts- then dumpInstances:todo- else todo- )----- | Just print all instance signatures in this module-dumpInstances :: CoreToDo-dumpInstances = CoreDoPluginPass "Data.Constraint.Deriving.DumpInstances"- $ \guts -> guts <$ go (mg_insts guts)- where- locdoc i = ( ( getOccString $ is_cls i- , map (fmap getOccString . tyConAppTyCon_maybe)- $ is_tys i- ), ppr i)- go is = do- let is' = sortOn fst $ map locdoc is- putMsg $- blankLine- $+$- hang- (text "============ Class instances declared in this module ============")- 2 (vcat $ map snd is')- $+$- blankLine+{-# LANGUAGE CPP #-} +module Data.Constraint.Deriving + ( plugin + -- * DeriveAll pass + , DeriveAll (..) + , DeriveContext + -- * ToInstance pass + , ToInstance (..) + , OverlapMode (..) + ) where + + + +import Data.List (sortOn) +import GhcPlugins hiding (OverlapMode (..), overlapMode) +import InstEnv (is_cls, is_tys) +import Type (tyConAppTyCon_maybe) + +import Data.Constraint.Deriving.DeriveAll +import Data.Constraint.Deriving.ToInstance + + + +-- | To use the plugin, add +-- +-- @ +-- {\-\# OPTIONS_GHC -fplugin Data.Constraint.Deriving \#-\} +-- @ +-- +-- to the header of your file. +-- +-- For debugging, add a plugin option @dump-instances@ +-- +-- @ +-- {\-\# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances \#-\} +-- @ +-- +-- to the header of your file; it will print all instances declared in the module +-- (hand-written and auto-generated). +-- +plugin :: Plugin +plugin = defaultPlugin + { installCoreToDos = install +#if MIN_VERSION_ghc(8,6,0) + , pluginRecompile = purePlugin +#endif + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install cmdopts todo = do + eref <- initCorePluginEnv + return ( deriveAllPass eref + : toInstancePass eref + : if elem "dump-instances" cmdopts + then dumpInstances:todo + else todo + ) + + +-- | Just print all instance signatures in this module +dumpInstances :: CoreToDo +dumpInstances = CoreDoPluginPass "Data.Constraint.Deriving.DumpInstances" + $ \guts -> guts <$ go (mg_insts guts) + where + locdoc i = ( ( getOccString $ is_cls i + , map (fmap getOccString . tyConAppTyCon_maybe) + $ is_tys i + ), ppr i) + go is = do + let is' = sortOn fst $ map locdoc is + putMsg $ + blankLine + $+$ + hang + (text "============ Class instances declared in this module ============") + 2 (vcat $ map snd is') + $+$ + blankLine
src/Data/Constraint/Deriving/CorePluginM.hs view
@@ -1,729 +1,729 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-#if __GLASGOW_HASKELL__ < 802-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-#endif-module Data.Constraint.Deriving.CorePluginM- ( CorePluginM (), runCorePluginM- , CorePluginEnv (), CorePluginEnvRef, initCorePluginEnv- , liftCoreM, runTcM, liftIO, lookupName- -- * Error handling- , try, exception- -- * Accessing read-only on-demand variables- , ask- , tyConDict, tyConBareConstraint, tyConDeriveContext- , funDictToBare, tyEmptyConstraint, classTypeEq- -- * Reporting- , pluginWarning, pluginLocatedWarning- , pluginError, pluginLocatedError- -- * Tools- , newName, newTyVar, freshenTyVar, newLocalVar- , bullet, isConstraintKind, getModuleAnns- , filterAvails- , recMatchTyKi, replaceTypeOccurrences- , OverlapMode (..), toOverlapFlag, instanceOverlapMode- , lookupClsInsts, getInstEnvs, replaceInstance- -- * Debugging- , pluginDebug, pluginTrace- , HasCallStack- ) where--import qualified Avail-import Class (Class)-import Control.Applicative (Alternative (..))-import Control.Monad (join, (>=>))-import Data.Data (Data, typeRep)-import Data.IORef (IORef, modifyIORef', newIORef, readIORef)-import Data.Maybe (catMaybes)-import Data.Monoid as Mon (First (..), Monoid (..))-import Data.Proxy (Proxy (..))-import Data.Semigroup as Sem (Semigroup (..))-import qualified ErrUtils-import qualified Finder-import GhcPlugins hiding (OverlapMode (..), empty,- overlapMode, (<>))-import qualified GhcPlugins-import qualified IfaceEnv-import InstEnv (InstEnv, InstEnvs)-import qualified InstEnv-import qualified LoadIface-import MonadUtils (MonadIO (..))-import qualified OccName (varName)-import TcRnMonad (getEps, initTc)-import TcRnTypes (TcM)-import qualified Unify-#if __GLASGOW_HASKELL__ < 806-import qualified Kind (isConstraintKind)-import qualified TcRnMonad (initTcForLookup)-#endif-#if __GLASGOW_HASKELL__ < 802-import GHC.Stack (HasCallStack)-#endif-#if PLUGIN_DEBUG-import GHC.Stack (withFrozenCallStack)-#endif---- | Since I do not have access to the guts of CoreM monad,--- I implement a wrapper on top of it here.------ It provides two pieces of functionality:------ * Possibility to fail a computation with IO error action--- (to show a nice error to a user and continue the work if possible);------ * An environment with things that computed on demand, once at most.----newtype CorePluginM a = CorePluginM- { _runCorePluginM :: IORef CorePluginEnv -> CoreM (Either (IO ()) a) }--runCorePluginM :: CorePluginM a -> IORef CorePluginEnv -> CoreM (Maybe a)-runCorePluginM m e = _runCorePluginM m e >>= \case- Left er -> Nothing <$ liftIO er- Right a -> pure $ Just a--instance Functor CorePluginM where- fmap f m = CorePluginM $ fmap (fmap f) . _runCorePluginM m--instance Applicative CorePluginM where- pure = CorePluginM . const . pure . Right- mf <*> ma = CorePluginM $ \e -> (<*>) <$> _runCorePluginM mf e <*> _runCorePluginM ma e--instance Alternative CorePluginM where- empty = CorePluginM . const $ pure $ Left $ pure ()- ma <|> mb = CorePluginM $ \e -> f <$> _runCorePluginM ma e <*> _runCorePluginM mb e- where- f (Left _) = id- f rx = const rx--instance Monad CorePluginM where- return = pure- ma >>= k = CorePluginM $ \e -> _runCorePluginM ma e >>= \case- Left a -> pure (Left a)- Right a -> _runCorePluginM (k a) e--instance MonadIO CorePluginM where- liftIO = liftCoreM . liftIO--instance MonadThings CorePluginM where- lookupThing = liftCoreM . lookupThing--instance MonadUnique CorePluginM where- getUniqueSupplyM = CorePluginM $ const $ Right <$> getUniqueSupplyM----- | Wrap CoreM action-liftCoreM :: CoreM a -> CorePluginM a-liftCoreM = CorePluginM . const . fmap Right---- | Synonym for `fail`-exception :: CorePluginM a-exception = empty---- | Return `Nothing` if the computation fails-try :: CorePluginM a -> CorePluginM (Maybe a)-try m = CorePluginM $ _runCorePluginM m >=> f- where- f (Left e) = Right Nothing <$ liftIO e- f (Right a) = pure . Right $ Just a---- | Try and ignore the result-try' :: CorePluginM a -> CorePluginM ()-try' m = () <$ try m---- | Reference to the plugin environment variables.-type CorePluginEnvRef = IORef CorePluginEnv---- | Plugin environment------ Its components are supposed to be computed at most once, when they are needed.-data CorePluginEnv = CorePluginEnv- { modConstraint :: CorePluginM Module- , modConstraintBare :: CorePluginM Module- , modDeriveAll :: CorePluginM Module- , modToInstance :: CorePluginM Module- , modDataTypeEquality :: CorePluginM Module- , tyConDict :: CorePluginM TyCon- , tyConBareConstraint :: CorePluginM TyCon- , tyConDeriveContext :: CorePluginM TyCon- , funDictToBare :: CorePluginM Id- , tyEmptyConstraint :: CorePluginM Type- , classTypeEq :: CorePluginM Class- , globalInstEnv :: CorePluginM InstEnv- }---- | Ask a field of the CorePluginEnv environment.-ask :: (CorePluginEnv -> CorePluginM a) -> CorePluginM a-ask f = join $ CorePluginM $ liftIO . fmap (Right . f) . readIORef---- | Init the `CorePluginM` environment and save it to IORef.-initCorePluginEnv :: CoreM (IORef CorePluginEnv)-initCorePluginEnv = do- env <- liftIO $ newIORef defCorePluginEnv- -- need to force globalInstEnv as early as possible to make sure- -- that ExternalPackageState var is not yet contaminated with- -- many unrelated modules.- gie <- _runCorePluginM (ask globalInstEnv) env- seq gie $ return env----- | Lookup necessary environment components on demand.-defCorePluginEnv :: CorePluginEnv-defCorePluginEnv = CorePluginEnv- { modConstraint = do- mm <- try $ lookupModule mnConstraint [pnConstraintsDeriving, pnConstraints]- saveAndReturn mm $ \a e -> e { modConstraint = a }-- , modConstraintBare = do- mm <- try $ lookupModule mnConstraintBare [pnConstraintsDeriving]- saveAndReturn mm $ \a e -> e { modConstraintBare = a }-- , modDeriveAll = do- mm <- try $ lookupModule mnDeriveAll [pnConstraintsDeriving]- saveAndReturn mm $ \a e -> e { modDeriveAll = a }-- , modToInstance = do- mm <- try $ lookupModule mnToInstance [pnConstraintsDeriving]- saveAndReturn mm $ \a e -> e { modToInstance = a }-- , modDataTypeEquality = do- mm <- try $ lookupModule mnDataTypeEquality [pnBase]- saveAndReturn mm $ \a e -> e { modDataTypeEquality = a }-- , tyConDict = do- m <- ask modConstraint- mtc <- try $ lookupName m tnDict >>= lookupTyCon- saveAndReturn mtc $ \a e -> e { tyConDict = a }-- , tyConBareConstraint = do- m <- ask modConstraintBare- mtc <- try $ lookupName m tnBareConstraint >>= lookupTyCon- saveAndReturn mtc $ \a e -> e { tyConBareConstraint = a }-- , tyConDeriveContext = do- m <- ask modDeriveAll- mtc <- try $ lookupName m tnDeriveContext >>= lookupTyCon- saveAndReturn mtc $ \a e -> e { tyConDeriveContext = a }-- , funDictToBare = do- m <- ask modConstraintBare- mf <- try $ lookupName m vnDictToBare >>= lookupId- saveAndReturn mf $ \a e -> e { funDictToBare = a }-- , tyEmptyConstraint = do- ec <- flip mkTyConApp [] <$> lookupTyCon (cTupleTyConName 0)- saveAndReturn (Just ec) $ \a e -> e { tyEmptyConstraint = a }-- , classTypeEq = do- m <- ask modDataTypeEquality- mc <- try $ lookupName m cnTypeEq >>= lookupThing >>= \case- ATyCon tc | Just cls <- tyConClass_maybe tc- -> return cls- _ -> exception- saveAndReturn mc $ \a e -> e { classTypeEq = a }-- , globalInstEnv = do- hscEnv <- liftCoreM getHscEnv- mn <- moduleName <$> liftCoreM getModule-- mdesc- <- case [ m | m <- mgModSummaries $ hsc_mod_graph hscEnv- , ms_mod_name m == mn- , not (isBootSummary m) ] of- [] -> pluginError $ hsep- [ text "Could not find"- , ppr mn- , text "in the module graph."- ]- [md] -> return md- _ -> pluginError $ hsep- [ text "Found multiple modules"- , ppr mn- , text "in the module graph."- ]- -- direct module dependencies- modsDirect <- fmap catMaybes- . traverse (lookupDep hscEnv)- $ ms_srcimps mdesc ++ ms_textual_imps mdesc- let -- direct dependencies; must be in the explicit depenencies anyway- mSetDirect = mkUniqSet $ filter notMyOwn modsDirect- -- Modules that we definitely need to look through,- -- even if they are from other, hidden packages- reexportedDeps i = mkUniqSet $ do- a@Avail.AvailTC{} <- mi_exports i- let m = nameModule $ Avail.availName a- [ m | m /= mi_module i, notMyOwn m]- -- Load reexportedDeps recursively.- -- This enumerate all modules that export some type constructors- -- visible from the current module;- -- this includes our base types and also all classes in scope.- loadRec ms = do- ifs <- traverse (LoadIface.loadModuleInterface reason)- $ backToList ms- let ms' = foldr (unionUniqSets . reexportedDeps) ms ifs- if isEmptyUniqSet $ ms' `minusUniqSet` ms- then return ms- else loadRec ms'- gie <- runTcM $ do- mods <- backToList <$> loadRec mSetDirect- LoadIface.loadModuleInterfaces reason mods- eps_inst_env <$> getEps- saveAndReturn (Just gie) $ \a e -> e { globalInstEnv = a }-- }- where- saveAndReturn Nothing f = CorePluginM $ \eref ->- Left (pure ()) <$ liftIO (modifyIORef' eref $ f exception)- saveAndReturn (Just x) f = CorePluginM $ \eref ->- Right x <$ liftIO (modifyIORef' eref $ f (pure x))- maybeFound (Found _ m) = Just m- maybeFound _ = Nothing- lookupDep hsce (mpn, mn)- = maybeFound <$>- liftIO (Finder.findImportedModule hsce (unLoc mn) mpn)- reason = text $ "Constraints.Deriving.CorePluginM "- ++ "itinialization of global InstEnv"- -- Ignore my own modules: they do not contain any classes.- notMyOwn m = moduleNameString (moduleName m) `notElem`- [ "Data.Constraint.Deriving"- , "Data.Constraint.Deriving.DeriveAll"- , "Data.Constraint.Deriving.ToInstance"- , "Data.Constraint.Deriving.ToInstance"- , "Data.Constraint.Deriving.CorePluginM"- ]-#if __GLASGOW_HASKELL__ < 804- mgModSummaries = id-#endif-#if __GLASGOW_HASKELL__ >= 802- backToList = nonDetEltsUniqSet-#else- backToList = uniqSetToList-#endif---lookupName :: Module -> OccName -> CorePluginM Name-lookupName m occn = do- hscEnv <- liftCoreM getHscEnv- liftIO-#if __GLASGOW_HASKELL__ < 806- $ TcRnMonad.initTcForLookup hscEnv- $ IfaceEnv.lookupOrig m occn-#else- $ IfaceEnv.lookupOrigIO hscEnv m occn-#endif--runTcM :: TcM a -> CorePluginM a-runTcM mx = do- hsce <- liftCoreM getHscEnv- modu <- liftCoreM getModule- let sp = realSrcLocSpan $ mkRealSrcLoc (fsLit "<CorePluginM.runTcM>") 1 1- ((warns, errs), my) <- liftIO $ initTc hsce HsSrcFile False modu sp mx- mapM_ pluginWarning $ ErrUtils.pprErrMsgBagWithLoc warns- case my of- Nothing ->- let f [] = pluginError $ text "runTcM failed"- f [x] = pluginError x- f (x:xs) = pluginWarning x >> f xs- in f $ ErrUtils.pprErrMsgBagWithLoc errs- Just y -> do- mapM_ pluginWarning $ ErrUtils.pprErrMsgBagWithLoc errs- return y---- Made this similar to tcRnGetInfo--- and a hidden function lookupInsts used there-lookupClsInsts :: InstEnvs -> TyCon -> [InstEnv.ClsInst]-lookupClsInsts ie tc =- [ ispec -- Search all- | ispec <- InstEnv.instEnvElts (InstEnv.ie_local ie)- ++ InstEnv.instEnvElts (InstEnv.ie_global ie)- , InstEnv.instIsVisible (InstEnv.ie_visible ie) ispec- , tyConName tc `elemNameSet` InstEnv.orphNamesOfClsInst ispec- ]--getInstEnvs :: ModGuts- -> CorePluginM InstEnv.InstEnvs-getInstEnvs guts = do- globalInsts <- ask globalInstEnv- return $ InstEnv.InstEnvs- { InstEnv.ie_global = globalInsts- , InstEnv.ie_local = mg_inst_env guts- , InstEnv.ie_visible = mkModuleSet . dep_orphs $ mg_deps guts- }--lookupModule :: ModuleName- -> [FastString]- -> CorePluginM Module-lookupModule mdName pkgs = do- hscEnv <- liftCoreM getHscEnv- go hscEnv $ map Just pkgs ++ [Just (fsLit "this"), Nothing]- where- go _ [] = pluginError $ hsep [ text "Could not find module", ppr mdName]- go he (x:xs) = findIt he x >>= \case- Nothing -> go he xs- Just md -> return md-- findIt he = fmap getIt . liftIO . Finder.findImportedModule he mdName- getIt (Found _ md) = Just md- getIt (FoundMultiple ((md, _):_)) = Just md- getIt _ = Nothing----- | Generate new unique type variable-newTyVar :: Kind -> CorePluginM TyVar-newTyVar k = flip mkTyVar k <$> newName tvName "gen"---- | Assign a new unique to a type variable;--- also assign a whole new name if the input is a wildcard.-freshenTyVar :: TyVar -> CorePluginM TyVar-freshenTyVar tv = do- u <- getUniqueM- nn <-- if isInternalName n- then return $ mkDerivedInternalName (repOccN (show u)) u n- else do- md <- liftCoreM getModule- loc <- liftCoreM getSrcSpanM- return $ mkExternalName u md (repOccN (show u) on) loc- return $ mkTyVar nn k- where- n = tyVarName tv- k = tyVarKind tv- on = nameOccName n- repOccN s oc = case occNameString oc of- "_" -> mkOccName (occNameSpace oc) ("fresh_" ++ s)- _ -> on---- | Generate a new unique local var (not be exported!)-newLocalVar :: Type -> String -> CorePluginM Var-newLocalVar ty nameStr = do- loc <- liftCoreM getSrcSpanM- u <- getUniqueM- return $- mkLocalId (mkInternalName u (mkOccName OccName.varName nameStr) loc) ty---- | Generate new unique name-newName :: NameSpace -> String -> CorePluginM Name-newName nspace nameStr = do- md <- liftCoreM getModule- loc <- liftCoreM getSrcSpanM- u <- getUniqueM- return $ mkExternalName u md occname loc- where- occname = mkOccName nspace nameStr---pluginError :: SDoc -> CorePluginM a-pluginError = pluginProblemMsg Nothing ErrUtils.SevError--pluginLocatedError :: SrcSpan -> SDoc -> CorePluginM a-pluginLocatedError loc = pluginProblemMsg (Just loc) ErrUtils.SevError--pluginWarning :: SDoc -> CorePluginM ()-pluginWarning = try' . pluginProblemMsg Nothing ErrUtils.SevWarning--pluginLocatedWarning :: SrcSpan -> SDoc -> CorePluginM ()-pluginLocatedWarning loc = try' . pluginProblemMsg (Just loc) ErrUtils.SevWarning--pluginDebug :: SDoc -> CorePluginM ()-#if PLUGIN_DEBUG-pluginDebug = try' . pluginProblemMsg Nothing ErrUtils.SevDump-#else-pluginDebug = const (pure ())-#endif-{-# INLINE pluginDebug #-}----pluginTrace :: HasCallStack => SDoc -> a -> a-#if PLUGIN_DEBUG-pluginTrace = withFrozenCallStack pprSTrace-#else-pluginTrace = const id-#endif-{-# INLINE pluginTrace #-}--pluginProblemMsg :: Maybe SrcSpan- -> ErrUtils.Severity- -> SDoc- -> CorePluginM a-pluginProblemMsg mspan sev msg = do- dflags <- liftCoreM getDynFlags- loc <- case mspan of- Just sp -> pure sp- Nothing -> liftCoreM getSrcSpanM- unqual <- liftCoreM getPrintUnqualified- CorePluginM $ const $ pure $ Left $- putLogMsg dflags NoReason sev loc (mkErrStyle dflags unqual) msg--#if __GLASGOW_HASKELL__ < 802-putLogMsg :: DynFlags -> WarnReason -> ErrUtils.Severity- -> SrcSpan -> PprStyle -> SDoc -> IO ()-putLogMsg dflags = log_action dflags dflags-#endif--filterAvails :: (Name -> Bool) -> [Avail.AvailInfo] -> [Avail.AvailInfo]-#if __GLASGOW_HASKELL__ < 802-filterAvails _ [] = []-filterAvails keep (a:as) = case go a of- Nothing -> filterAvails keep as- Just fa -> fa : filterAvails keep as- where- go x@(Avail.Avail _ n)- | keep n = Just x- | otherwise = Nothing- go (Avail.AvailTC n ns fs) =- let ns' = filter keep ns- fs' = filter (keep . flSelector) fs- in if null ns' && null fs'- then Nothing- else Just $ Avail.AvailTC n ns' fs'-#else-filterAvails = Avail.filterAvails-#endif--#if __GLASGOW_HASKELL__ < 802-bullet :: SDoc-bullet = unicodeSyntax (char '•') (char '*')-#endif----- This function was moved and renamed in GHC 8.6--- | Check if this kind is Constraint, as seen to the typechecker.-isConstraintKind :: Kind -> Bool-#if __GLASGOW_HASKELL__ < 806-isConstraintKind = Kind.isConstraintKind-#else-isConstraintKind = tcIsConstraintKind-#endif---- | Similar to `getAnnotations`, but keeps the annotation target.--- Also, it is hardcoded to `deserializeWithData`.--- Looks only for annotations defined in this module.--- Ignores module annotations.-getModuleAnns :: forall a . Data a => ModGuts -> UniqFM [(Name, a)]-getModuleAnns = go . mg_anns- where- valTRep = typeRep (Proxy :: Proxy a)- go :: [Annotation] -> UniqFM [(Name, a)]- go [] = emptyUFM- go (Annotation- (NamedTarget n) -- ignore module targets- (Serialized trep bytes)- : as)- | trep == valTRep -- match type representations- = addToUFM_Acc (:) (:[]) (go as) n (n, deserializeWithData bytes)- -- ignore non-matching annotations- go (_:as) = go as------ | Similar to Unify.tcMatchTyKis, but looks if there is a non-trivial subtype--- in the first type that matches the second.--- Non-trivial means not a TyVar.-recMatchTyKi :: Bool -- ^ Whether to do inverse match (instance is more conrete)- -> Type -> Type -> Maybe TCvSubst-recMatchTyKi inverse tsearched ttemp = go tsearched- where- go :: Type -> Maybe TCvSubst- go t- -- ignore plain TyVars- | isTyVarTy t- = Nothing- -- found a good substitution- | Just sub <- if inverse- then matchIt ttemp t- else matchIt t ttemp- = Just sub- -- split type constructors- | Just (_, tys) <- splitTyConApp_maybe t- = getFirst $ foldMap (First . go) tys- -- split foralls- | (_:_, t') <- splitForAllTys t- = go t'- -- split arrow types- | Just (at, rt) <- splitFunTy_maybe t- = go at <|> go rt- | otherwise- = Nothing-#if __GLASGOW_HASKELL__ >= 802- matchIt = Unify.tcMatchTyKi-#else- matchIt = Unify.tcMatchTy-#endif---- | Replace all occurrences of one type in another.-replaceTypeOccurrences :: Type -> Type -> Type -> Type-replaceTypeOccurrences told tnew = replace- where- replace :: Type -> Type- replace t- -- found occurrence- | eqType t told- = tnew- -- split type constructors- | Just (tyCon, tys) <- splitTyConApp_maybe t- = mkTyConApp tyCon $ map replace tys- -- split foralls- | (bndrs@(_:_), t') <- splitForAllTys t- = mkSpecForAllTys bndrs $ replace t'- -- split arrow types- | Just (at, rt) <- splitFunTy_maybe t- = mkFunTy (replace at) (replace rt)- -- could not find anything- | otherwise- = t----- | Replace instance in ModGuts if its duplicate already exists there;--- otherwise just add this instance.-replaceInstance :: InstEnv.ClsInst -> CoreBind -> ModGuts -> ModGuts-replaceInstance newI newB guts- | NonRec _ newE <- newB- , First (Just oldI) <- foldMap sameInst $ mg_insts guts- , newDFunId <- InstEnv.instanceDFunId newI- , origDFunId <- InstEnv.instanceDFunId oldI- , dFunId <- newDFunId `setVarName` idName origDFunId- `setVarUnique` varUnique origDFunId- , bind <- NonRec dFunId newE- , inst <- newI { InstEnv.is_dfun = dFunId-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(8,0,2,0)- , InstEnv.is_dfun_name = idName dFunId-#endif-#endif- }- = guts- { mg_insts = replInst origDFunId inst $ mg_insts guts- , mg_inst_env = mg_inst_env guts- `InstEnv.deleteFromInstEnv` oldI- `InstEnv.extendInstEnv` inst- , mg_binds = bind : remBind origDFunId (mg_binds guts)- }- | otherwise- = guts- { mg_insts = newI : mg_insts guts- , mg_inst_env = InstEnv.extendInstEnv (mg_inst_env guts) newI- , mg_binds = newB : mg_binds guts- }- where- remBind _ [] = []- remBind i' (b@(NonRec i _):bs)- | i == i' = remBind i' bs- | otherwise = b : remBind i' bs- remBind i' (Rec rb :bs) = Rec (filter ((i' /=) . fst) rb) : remBind i' bs- replInst _ _ [] = []- replInst d' i' (i:is)- | InstEnv.instanceDFunId i == d' = i' : is- | otherwise = i : replInst d' i' is- sameInst i- = First $ if InstEnv.identicalClsInstHead newI i then Just i else Nothing------- | Define the behavior for the instance selection.--- Mirrors `BasicTypes.OverlapMode`, but does not have a `SourceText` field.-data OverlapMode- = NoOverlap- -- ^ This instance must not overlap another `NoOverlap` instance.- -- However, it may be overlapped by `Overlapping` instances,- -- and it may overlap `Overlappable` instances.- | Overlappable- -- ^ Silently ignore this instance if you find a- -- more specific one that matches the constraint- -- you are trying to resolve- | Overlapping- -- ^ Silently ignore any more general instances that may be- -- used to solve the constraint.- | Overlaps- -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.- | Incoherent- -- ^ Behave like Overlappable and Overlapping, and in addition pick- -- an an arbitrary one if there are multiple matching candidates, and- -- don't worry about later instantiation- deriving (Eq, Show, Read, Data)--instance Sem.Semigroup OverlapMode where- NoOverlap <> m = m- m <> NoOverlap = m- Incoherent <> _ = Incoherent- _ <> Incoherent = Incoherent- Overlaps <> _ = Overlaps- _ <> Overlaps = Overlaps- Overlappable <> Overlappable = Overlappable- Overlapping <> Overlapping = Overlapping- Overlappable <> Overlapping = Overlaps- Overlapping <> Overlappable = Overlaps--instance Mon.Monoid OverlapMode where- mempty = NoOverlap-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif---toOverlapFlag :: OverlapMode -> OverlapFlag-toOverlapFlag m = OverlapFlag (getOMode m) False- where- getOMode NoOverlap = GhcPlugins.NoOverlap noSourceText- getOMode Overlapping = GhcPlugins.Overlapping noSourceText- getOMode Overlappable = GhcPlugins.Overlappable noSourceText- getOMode Overlaps = GhcPlugins.Overlaps noSourceText- getOMode Incoherent = GhcPlugins.Incoherent noSourceText--#if __GLASGOW_HASKELL__ >= 802- noSourceText = GhcPlugins.NoSourceText-#else- noSourceText = "[plugin-generated code]"-#endif--instanceOverlapMode :: InstEnv.ClsInst -> OverlapMode-instanceOverlapMode i = case InstEnv.overlapMode (InstEnv.is_flag i) of- GhcPlugins.NoOverlap {} -> NoOverlap- GhcPlugins.Overlapping {} -> Overlapping- GhcPlugins.Overlappable {} -> Overlappable- GhcPlugins.Overlaps {} -> Overlaps- GhcPlugins.Incoherent {} -> Incoherent----pnConstraintsDeriving :: FastString-pnConstraintsDeriving = mkFastString "constraints-deriving"--pnConstraints :: FastString-pnConstraints = mkFastString "constraints"--pnBase :: FastString-pnBase = mkFastString "base"--mnConstraint :: ModuleName-mnConstraint = mkModuleName "Data.Constraint"--mnConstraintBare :: ModuleName-mnConstraintBare = mkModuleName "Data.Constraint.Bare"--mnDeriveAll :: ModuleName-mnDeriveAll = mkModuleName "Data.Constraint.Deriving.DeriveAll"--mnToInstance :: ModuleName-mnToInstance = mkModuleName "Data.Constraint.Deriving.ToInstance"--mnDataTypeEquality :: ModuleName-mnDataTypeEquality = mkModuleName "Data.Type.Equality"--tnDict :: OccName-tnDict = mkTcOcc "Dict"--tnBareConstraint :: OccName-tnBareConstraint = mkTcOcc "BareConstraint"--tnDeriveContext :: OccName-tnDeriveContext = mkTcOcc "DeriveContext"--vnDictToBare :: OccName-vnDictToBare = mkVarOcc "dictToBare"--cnTypeEq :: OccName-cnTypeEq = mkTcOcc "~"+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ < 802 +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#endif +module Data.Constraint.Deriving.CorePluginM + ( CorePluginM (), runCorePluginM + , CorePluginEnv (), CorePluginEnvRef, initCorePluginEnv + , liftCoreM, runTcM, liftIO, lookupName + -- * Error handling + , try, exception + -- * Accessing read-only on-demand variables + , ask + , tyConDict, tyConBareConstraint, tyConDeriveContext + , funDictToBare, tyEmptyConstraint, classTypeEq + -- * Reporting + , pluginWarning, pluginLocatedWarning + , pluginError, pluginLocatedError + -- * Tools + , newName, newTyVar, freshenTyVar, newLocalVar + , bullet, isConstraintKind, getModuleAnns + , filterAvails + , recMatchTyKi, replaceTypeOccurrences + , OverlapMode (..), toOverlapFlag, instanceOverlapMode + , lookupClsInsts, getInstEnvs, replaceInstance + -- * Debugging + , pluginDebug, pluginTrace + , HasCallStack + ) where + +import qualified Avail +import Class (Class) +import Control.Applicative (Alternative (..)) +import Control.Monad (join, (>=>)) +import Data.Data (Data, typeRep) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Maybe (catMaybes) +import Data.Monoid as Mon (First (..), Monoid (..)) +import Data.Proxy (Proxy (..)) +import Data.Semigroup as Sem (Semigroup (..)) +import qualified ErrUtils +import qualified Finder +import GhcPlugins hiding (OverlapMode (..), empty, + overlapMode, (<>)) +import qualified GhcPlugins +import qualified IfaceEnv +import InstEnv (InstEnv, InstEnvs) +import qualified InstEnv +import qualified LoadIface +import MonadUtils (MonadIO (..)) +import qualified OccName (varName) +import TcRnMonad (getEps, initTc) +import TcRnTypes (TcM) +import qualified Unify +#if __GLASGOW_HASKELL__ < 806 +import qualified Kind (isConstraintKind) +import qualified TcRnMonad (initTcForLookup) +#endif +#if __GLASGOW_HASKELL__ < 802 +import GHC.Stack (HasCallStack) +#endif +#if PLUGIN_DEBUG +import GHC.Stack (withFrozenCallStack) +#endif + +-- | Since I do not have access to the guts of CoreM monad, +-- I implement a wrapper on top of it here. +-- +-- It provides two pieces of functionality: +-- +-- * Possibility to fail a computation with IO error action +-- (to show a nice error to a user and continue the work if possible); +-- +-- * An environment with things that computed on demand, once at most. +-- +newtype CorePluginM a = CorePluginM + { _runCorePluginM :: IORef CorePluginEnv -> CoreM (Either (IO ()) a) } + +runCorePluginM :: CorePluginM a -> IORef CorePluginEnv -> CoreM (Maybe a) +runCorePluginM m e = _runCorePluginM m e >>= \case + Left er -> Nothing <$ liftIO er + Right a -> pure $ Just a + +instance Functor CorePluginM where + fmap f m = CorePluginM $ fmap (fmap f) . _runCorePluginM m + +instance Applicative CorePluginM where + pure = CorePluginM . const . pure . Right + mf <*> ma = CorePluginM $ \e -> (<*>) <$> _runCorePluginM mf e <*> _runCorePluginM ma e + +instance Alternative CorePluginM where + empty = CorePluginM . const $ pure $ Left $ pure () + ma <|> mb = CorePluginM $ \e -> f <$> _runCorePluginM ma e <*> _runCorePluginM mb e + where + f (Left _) = id + f rx = const rx + +instance Monad CorePluginM where + return = pure + ma >>= k = CorePluginM $ \e -> _runCorePluginM ma e >>= \case + Left a -> pure (Left a) + Right a -> _runCorePluginM (k a) e + +instance MonadIO CorePluginM where + liftIO = liftCoreM . liftIO + +instance MonadThings CorePluginM where + lookupThing = liftCoreM . lookupThing + +instance MonadUnique CorePluginM where + getUniqueSupplyM = CorePluginM $ const $ Right <$> getUniqueSupplyM + + +-- | Wrap CoreM action +liftCoreM :: CoreM a -> CorePluginM a +liftCoreM = CorePluginM . const . fmap Right + +-- | Synonym for `fail` +exception :: CorePluginM a +exception = empty + +-- | Return `Nothing` if the computation fails +try :: CorePluginM a -> CorePluginM (Maybe a) +try m = CorePluginM $ _runCorePluginM m >=> f + where + f (Left e) = Right Nothing <$ liftIO e + f (Right a) = pure . Right $ Just a + +-- | Try and ignore the result +try' :: CorePluginM a -> CorePluginM () +try' m = () <$ try m + +-- | Reference to the plugin environment variables. +type CorePluginEnvRef = IORef CorePluginEnv + +-- | Plugin environment +-- +-- Its components are supposed to be computed at most once, when they are needed. +data CorePluginEnv = CorePluginEnv + { modConstraint :: CorePluginM Module + , modConstraintBare :: CorePluginM Module + , modDeriveAll :: CorePluginM Module + , modToInstance :: CorePluginM Module + , modDataTypeEquality :: CorePluginM Module + , tyConDict :: CorePluginM TyCon + , tyConBareConstraint :: CorePluginM TyCon + , tyConDeriveContext :: CorePluginM TyCon + , funDictToBare :: CorePluginM Id + , tyEmptyConstraint :: CorePluginM Type + , classTypeEq :: CorePluginM Class + , globalInstEnv :: CorePluginM InstEnv + } + +-- | Ask a field of the CorePluginEnv environment. +ask :: (CorePluginEnv -> CorePluginM a) -> CorePluginM a +ask f = join $ CorePluginM $ liftIO . fmap (Right . f) . readIORef + +-- | Init the `CorePluginM` environment and save it to IORef. +initCorePluginEnv :: CoreM (IORef CorePluginEnv) +initCorePluginEnv = do + env <- liftIO $ newIORef defCorePluginEnv + -- need to force globalInstEnv as early as possible to make sure + -- that ExternalPackageState var is not yet contaminated with + -- many unrelated modules. + gie <- _runCorePluginM (ask globalInstEnv) env + seq gie $ return env + + +-- | Lookup necessary environment components on demand. +defCorePluginEnv :: CorePluginEnv +defCorePluginEnv = CorePluginEnv + { modConstraint = do + mm <- try $ lookupModule mnConstraint [pnConstraintsDeriving, pnConstraints] + saveAndReturn mm $ \a e -> e { modConstraint = a } + + , modConstraintBare = do + mm <- try $ lookupModule mnConstraintBare [pnConstraintsDeriving] + saveAndReturn mm $ \a e -> e { modConstraintBare = a } + + , modDeriveAll = do + mm <- try $ lookupModule mnDeriveAll [pnConstraintsDeriving] + saveAndReturn mm $ \a e -> e { modDeriveAll = a } + + , modToInstance = do + mm <- try $ lookupModule mnToInstance [pnConstraintsDeriving] + saveAndReturn mm $ \a e -> e { modToInstance = a } + + , modDataTypeEquality = do + mm <- try $ lookupModule mnDataTypeEquality [pnBase] + saveAndReturn mm $ \a e -> e { modDataTypeEquality = a } + + , tyConDict = do + m <- ask modConstraint + mtc <- try $ lookupName m tnDict >>= lookupTyCon + saveAndReturn mtc $ \a e -> e { tyConDict = a } + + , tyConBareConstraint = do + m <- ask modConstraintBare + mtc <- try $ lookupName m tnBareConstraint >>= lookupTyCon + saveAndReturn mtc $ \a e -> e { tyConBareConstraint = a } + + , tyConDeriveContext = do + m <- ask modDeriveAll + mtc <- try $ lookupName m tnDeriveContext >>= lookupTyCon + saveAndReturn mtc $ \a e -> e { tyConDeriveContext = a } + + , funDictToBare = do + m <- ask modConstraintBare + mf <- try $ lookupName m vnDictToBare >>= lookupId + saveAndReturn mf $ \a e -> e { funDictToBare = a } + + , tyEmptyConstraint = do + ec <- flip mkTyConApp [] <$> lookupTyCon (cTupleTyConName 0) + saveAndReturn (Just ec) $ \a e -> e { tyEmptyConstraint = a } + + , classTypeEq = do + m <- ask modDataTypeEquality + mc <- try $ lookupName m cnTypeEq >>= lookupThing >>= \case + ATyCon tc | Just cls <- tyConClass_maybe tc + -> return cls + _ -> exception + saveAndReturn mc $ \a e -> e { classTypeEq = a } + + , globalInstEnv = do + hscEnv <- liftCoreM getHscEnv + mn <- moduleName <$> liftCoreM getModule + + mdesc + <- case [ m | m <- mgModSummaries $ hsc_mod_graph hscEnv + , ms_mod_name m == mn + , not (isBootSummary m) ] of + [] -> pluginError $ hsep + [ text "Could not find" + , ppr mn + , text "in the module graph." + ] + [md] -> return md + _ -> pluginError $ hsep + [ text "Found multiple modules" + , ppr mn + , text "in the module graph." + ] + -- direct module dependencies + modsDirect <- fmap catMaybes + . traverse (lookupDep hscEnv) + $ ms_srcimps mdesc ++ ms_textual_imps mdesc + let -- direct dependencies; must be in the explicit depenencies anyway + mSetDirect = mkUniqSet $ filter notMyOwn modsDirect + -- Modules that we definitely need to look through, + -- even if they are from other, hidden packages + reexportedDeps i = mkUniqSet $ do + a@Avail.AvailTC{} <- mi_exports i + let m = nameModule $ Avail.availName a + [ m | m /= mi_module i, notMyOwn m] + -- Load reexportedDeps recursively. + -- This enumerate all modules that export some type constructors + -- visible from the current module; + -- this includes our base types and also all classes in scope. + loadRec ms = do + ifs <- traverse (LoadIface.loadModuleInterface reason) + $ backToList ms + let ms' = foldr (unionUniqSets . reexportedDeps) ms ifs + if isEmptyUniqSet $ ms' `minusUniqSet` ms + then return ms + else loadRec ms' + gie <- runTcM $ do + mods <- backToList <$> loadRec mSetDirect + LoadIface.loadModuleInterfaces reason mods + eps_inst_env <$> getEps + saveAndReturn (Just gie) $ \a e -> e { globalInstEnv = a } + + } + where + saveAndReturn Nothing f = CorePluginM $ \eref -> + Left (pure ()) <$ liftIO (modifyIORef' eref $ f exception) + saveAndReturn (Just x) f = CorePluginM $ \eref -> + Right x <$ liftIO (modifyIORef' eref $ f (pure x)) + maybeFound (Found _ m) = Just m + maybeFound _ = Nothing + lookupDep hsce (mpn, mn) + = maybeFound <$> + liftIO (Finder.findImportedModule hsce (unLoc mn) mpn) + reason = text $ "Constraints.Deriving.CorePluginM " + ++ "itinialization of global InstEnv" + -- Ignore my own modules: they do not contain any classes. + notMyOwn m = moduleNameString (moduleName m) `notElem` + [ "Data.Constraint.Deriving" + , "Data.Constraint.Deriving.DeriveAll" + , "Data.Constraint.Deriving.ToInstance" + , "Data.Constraint.Deriving.ToInstance" + , "Data.Constraint.Deriving.CorePluginM" + ] +#if __GLASGOW_HASKELL__ < 804 + mgModSummaries = id +#endif +#if __GLASGOW_HASKELL__ >= 802 + backToList = nonDetEltsUniqSet +#else + backToList = uniqSetToList +#endif + + +lookupName :: Module -> OccName -> CorePluginM Name +lookupName m occn = do + hscEnv <- liftCoreM getHscEnv + liftIO +#if __GLASGOW_HASKELL__ < 806 + $ TcRnMonad.initTcForLookup hscEnv + $ IfaceEnv.lookupOrig m occn +#else + $ IfaceEnv.lookupOrigIO hscEnv m occn +#endif + +runTcM :: TcM a -> CorePluginM a +runTcM mx = do + hsce <- liftCoreM getHscEnv + modu <- liftCoreM getModule + let sp = realSrcLocSpan $ mkRealSrcLoc (fsLit "<CorePluginM.runTcM>") 1 1 + ((warns, errs), my) <- liftIO $ initTc hsce HsSrcFile False modu sp mx + mapM_ pluginWarning $ ErrUtils.pprErrMsgBagWithLoc warns + case my of + Nothing -> + let f [] = pluginError $ text "runTcM failed" + f [x] = pluginError x + f (x:xs) = pluginWarning x >> f xs + in f $ ErrUtils.pprErrMsgBagWithLoc errs + Just y -> do + mapM_ pluginWarning $ ErrUtils.pprErrMsgBagWithLoc errs + return y + +-- Made this similar to tcRnGetInfo +-- and a hidden function lookupInsts used there +lookupClsInsts :: InstEnvs -> TyCon -> [InstEnv.ClsInst] +lookupClsInsts ie tc = + [ ispec -- Search all + | ispec <- InstEnv.instEnvElts (InstEnv.ie_local ie) + ++ InstEnv.instEnvElts (InstEnv.ie_global ie) + , InstEnv.instIsVisible (InstEnv.ie_visible ie) ispec + , tyConName tc `elemNameSet` InstEnv.orphNamesOfClsInst ispec + ] + +getInstEnvs :: ModGuts + -> CorePluginM InstEnv.InstEnvs +getInstEnvs guts = do + globalInsts <- ask globalInstEnv + return $ InstEnv.InstEnvs + { InstEnv.ie_global = globalInsts + , InstEnv.ie_local = mg_inst_env guts + , InstEnv.ie_visible = mkModuleSet . dep_orphs $ mg_deps guts + } + +lookupModule :: ModuleName + -> [FastString] + -> CorePluginM Module +lookupModule mdName pkgs = do + hscEnv <- liftCoreM getHscEnv + go hscEnv $ map Just pkgs ++ [Just (fsLit "this"), Nothing] + where + go _ [] = pluginError $ hsep [ text "Could not find module", ppr mdName] + go he (x:xs) = findIt he x >>= \case + Nothing -> go he xs + Just md -> return md + + findIt he = fmap getIt . liftIO . Finder.findImportedModule he mdName + getIt (Found _ md) = Just md + getIt (FoundMultiple ((md, _):_)) = Just md + getIt _ = Nothing + + +-- | Generate new unique type variable +newTyVar :: Kind -> CorePluginM TyVar +newTyVar k = flip mkTyVar k <$> newName tvName "gen" + +-- | Assign a new unique to a type variable; +-- also assign a whole new name if the input is a wildcard. +freshenTyVar :: TyVar -> CorePluginM TyVar +freshenTyVar tv = do + u <- getUniqueM + nn <- + if isInternalName n + then return $ mkDerivedInternalName (repOccN (show u)) u n + else do + md <- liftCoreM getModule + loc <- liftCoreM getSrcSpanM + return $ mkExternalName u md (repOccN (show u) on) loc + return $ mkTyVar nn k + where + n = tyVarName tv + k = tyVarKind tv + on = nameOccName n + repOccN s oc = case occNameString oc of + "_" -> mkOccName (occNameSpace oc) ("fresh_" ++ s) + _ -> on + +-- | Generate a new unique local var (not be exported!) +newLocalVar :: Type -> String -> CorePluginM Var +newLocalVar ty nameStr = do + loc <- liftCoreM getSrcSpanM + u <- getUniqueM + return $ + mkLocalId (mkInternalName u (mkOccName OccName.varName nameStr) loc) ty + +-- | Generate new unique name +newName :: NameSpace -> String -> CorePluginM Name +newName nspace nameStr = do + md <- liftCoreM getModule + loc <- liftCoreM getSrcSpanM + u <- getUniqueM + return $ mkExternalName u md occname loc + where + occname = mkOccName nspace nameStr + + +pluginError :: SDoc -> CorePluginM a +pluginError = pluginProblemMsg Nothing ErrUtils.SevError + +pluginLocatedError :: SrcSpan -> SDoc -> CorePluginM a +pluginLocatedError loc = pluginProblemMsg (Just loc) ErrUtils.SevError + +pluginWarning :: SDoc -> CorePluginM () +pluginWarning = try' . pluginProblemMsg Nothing ErrUtils.SevWarning + +pluginLocatedWarning :: SrcSpan -> SDoc -> CorePluginM () +pluginLocatedWarning loc = try' . pluginProblemMsg (Just loc) ErrUtils.SevWarning + +pluginDebug :: SDoc -> CorePluginM () +#if PLUGIN_DEBUG +pluginDebug = try' . pluginProblemMsg Nothing ErrUtils.SevDump +#else +pluginDebug = const (pure ()) +#endif +{-# INLINE pluginDebug #-} + + + +pluginTrace :: HasCallStack => SDoc -> a -> a +#if PLUGIN_DEBUG +pluginTrace = withFrozenCallStack pprSTrace +#else +pluginTrace = const id +#endif +{-# INLINE pluginTrace #-} + +pluginProblemMsg :: Maybe SrcSpan + -> ErrUtils.Severity + -> SDoc + -> CorePluginM a +pluginProblemMsg mspan sev msg = do + dflags <- liftCoreM getDynFlags + loc <- case mspan of + Just sp -> pure sp + Nothing -> liftCoreM getSrcSpanM + unqual <- liftCoreM getPrintUnqualified + CorePluginM $ const $ pure $ Left $ + putLogMsg dflags NoReason sev loc (mkErrStyle dflags unqual) msg + +#if __GLASGOW_HASKELL__ < 802 +putLogMsg :: DynFlags -> WarnReason -> ErrUtils.Severity + -> SrcSpan -> PprStyle -> SDoc -> IO () +putLogMsg dflags = log_action dflags dflags +#endif + +filterAvails :: (Name -> Bool) -> [Avail.AvailInfo] -> [Avail.AvailInfo] +#if __GLASGOW_HASKELL__ < 802 +filterAvails _ [] = [] +filterAvails keep (a:as) = case go a of + Nothing -> filterAvails keep as + Just fa -> fa : filterAvails keep as + where + go x@(Avail.Avail _ n) + | keep n = Just x + | otherwise = Nothing + go (Avail.AvailTC n ns fs) = + let ns' = filter keep ns + fs' = filter (keep . flSelector) fs + in if null ns' && null fs' + then Nothing + else Just $ Avail.AvailTC n ns' fs' +#else +filterAvails = Avail.filterAvails +#endif + +#if __GLASGOW_HASKELL__ < 802 +bullet :: SDoc +bullet = unicodeSyntax (char '•') (char '*') +#endif + + +-- This function was moved and renamed in GHC 8.6 +-- | Check if this kind is Constraint, as seen to the typechecker. +isConstraintKind :: Kind -> Bool +#if __GLASGOW_HASKELL__ < 806 +isConstraintKind = Kind.isConstraintKind +#else +isConstraintKind = tcIsConstraintKind +#endif + +-- | Similar to `getAnnotations`, but keeps the annotation target. +-- Also, it is hardcoded to `deserializeWithData`. +-- Looks only for annotations defined in this module. +-- Ignores module annotations. +getModuleAnns :: forall a . Data a => ModGuts -> UniqFM [(Name, a)] +getModuleAnns = go . mg_anns + where + valTRep = typeRep (Proxy :: Proxy a) + go :: [Annotation] -> UniqFM [(Name, a)] + go [] = emptyUFM + go (Annotation + (NamedTarget n) -- ignore module targets + (Serialized trep bytes) + : as) + | trep == valTRep -- match type representations + = addToUFM_Acc (:) (:[]) (go as) n (n, deserializeWithData bytes) + -- ignore non-matching annotations + go (_:as) = go as + + + +-- | Similar to Unify.tcMatchTyKis, but looks if there is a non-trivial subtype +-- in the first type that matches the second. +-- Non-trivial means not a TyVar. +recMatchTyKi :: Bool -- ^ Whether to do inverse match (instance is more conrete) + -> Type -> Type -> Maybe TCvSubst +recMatchTyKi inverse tsearched ttemp = go tsearched + where + go :: Type -> Maybe TCvSubst + go t + -- ignore plain TyVars + | isTyVarTy t + = Nothing + -- found a good substitution + | Just sub <- if inverse + then matchIt ttemp t + else matchIt t ttemp + = Just sub + -- split type constructors + | Just (_, tys) <- splitTyConApp_maybe t + = getFirst $ foldMap (First . go) tys + -- split foralls + | (_:_, t') <- splitForAllTys t + = go t' + -- split arrow types + | Just (at, rt) <- splitFunTy_maybe t + = go at <|> go rt + | otherwise + = Nothing +#if __GLASGOW_HASKELL__ >= 802 + matchIt = Unify.tcMatchTyKi +#else + matchIt = Unify.tcMatchTy +#endif + +-- | Replace all occurrences of one type in another. +replaceTypeOccurrences :: Type -> Type -> Type -> Type +replaceTypeOccurrences told tnew = replace + where + replace :: Type -> Type + replace t + -- found occurrence + | eqType t told + = tnew + -- split type constructors + | Just (tyCon, tys) <- splitTyConApp_maybe t + = mkTyConApp tyCon $ map replace tys + -- split foralls + | (bndrs@(_:_), t') <- splitForAllTys t + = mkSpecForAllTys bndrs $ replace t' + -- split arrow types + | Just (at, rt) <- splitFunTy_maybe t + = mkFunTy (replace at) (replace rt) + -- could not find anything + | otherwise + = t + + +-- | Replace instance in ModGuts if its duplicate already exists there; +-- otherwise just add this instance. +replaceInstance :: InstEnv.ClsInst -> CoreBind -> ModGuts -> ModGuts +replaceInstance newI newB guts + | NonRec _ newE <- newB + , First (Just oldI) <- foldMap sameInst $ mg_insts guts + , newDFunId <- InstEnv.instanceDFunId newI + , origDFunId <- InstEnv.instanceDFunId oldI + , dFunId <- newDFunId `setVarName` idName origDFunId + `setVarUnique` varUnique origDFunId + , bind <- NonRec dFunId newE + , inst <- newI { InstEnv.is_dfun = dFunId +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(8,0,2,0) + , InstEnv.is_dfun_name = idName dFunId +#endif +#endif + } + = guts + { mg_insts = replInst origDFunId inst $ mg_insts guts + , mg_inst_env = mg_inst_env guts + `InstEnv.deleteFromInstEnv` oldI + `InstEnv.extendInstEnv` inst + , mg_binds = bind : remBind origDFunId (mg_binds guts) + } + | otherwise + = guts + { mg_insts = newI : mg_insts guts + , mg_inst_env = InstEnv.extendInstEnv (mg_inst_env guts) newI + , mg_binds = newB : mg_binds guts + } + where + remBind _ [] = [] + remBind i' (b@(NonRec i _):bs) + | i == i' = remBind i' bs + | otherwise = b : remBind i' bs + remBind i' (Rec rb :bs) = Rec (filter ((i' /=) . fst) rb) : remBind i' bs + replInst _ _ [] = [] + replInst d' i' (i:is) + | InstEnv.instanceDFunId i == d' = i' : is + | otherwise = i : replInst d' i' is + sameInst i + = First $ if InstEnv.identicalClsInstHead newI i then Just i else Nothing + + + + +-- | Define the behavior for the instance selection. +-- Mirrors `BasicTypes.OverlapMode`, but does not have a `SourceText` field. +data OverlapMode + = NoOverlap + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + | Overlappable + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + | Overlapping + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + | Overlaps + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + | Incoherent + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + deriving (Eq, Show, Read, Data) + +instance Sem.Semigroup OverlapMode where + NoOverlap <> m = m + m <> NoOverlap = m + Incoherent <> _ = Incoherent + _ <> Incoherent = Incoherent + Overlaps <> _ = Overlaps + _ <> Overlaps = Overlaps + Overlappable <> Overlappable = Overlappable + Overlapping <> Overlapping = Overlapping + Overlappable <> Overlapping = Overlaps + Overlapping <> Overlappable = Overlaps + +instance Mon.Monoid OverlapMode where + mempty = NoOverlap +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + + +toOverlapFlag :: OverlapMode -> OverlapFlag +toOverlapFlag m = OverlapFlag (getOMode m) False + where + getOMode NoOverlap = GhcPlugins.NoOverlap noSourceText + getOMode Overlapping = GhcPlugins.Overlapping noSourceText + getOMode Overlappable = GhcPlugins.Overlappable noSourceText + getOMode Overlaps = GhcPlugins.Overlaps noSourceText + getOMode Incoherent = GhcPlugins.Incoherent noSourceText + +#if __GLASGOW_HASKELL__ >= 802 + noSourceText = GhcPlugins.NoSourceText +#else + noSourceText = "[plugin-generated code]" +#endif + +instanceOverlapMode :: InstEnv.ClsInst -> OverlapMode +instanceOverlapMode i = case InstEnv.overlapMode (InstEnv.is_flag i) of + GhcPlugins.NoOverlap {} -> NoOverlap + GhcPlugins.Overlapping {} -> Overlapping + GhcPlugins.Overlappable {} -> Overlappable + GhcPlugins.Overlaps {} -> Overlaps + GhcPlugins.Incoherent {} -> Incoherent + + + +pnConstraintsDeriving :: FastString +pnConstraintsDeriving = mkFastString "constraints-deriving" + +pnConstraints :: FastString +pnConstraints = mkFastString "constraints" + +pnBase :: FastString +pnBase = mkFastString "base" + +mnConstraint :: ModuleName +mnConstraint = mkModuleName "Data.Constraint" + +mnConstraintBare :: ModuleName +mnConstraintBare = mkModuleName "Data.Constraint.Bare" + +mnDeriveAll :: ModuleName +mnDeriveAll = mkModuleName "Data.Constraint.Deriving.DeriveAll" + +mnToInstance :: ModuleName +mnToInstance = mkModuleName "Data.Constraint.Deriving.ToInstance" + +mnDataTypeEquality :: ModuleName +mnDataTypeEquality = mkModuleName "Data.Type.Equality" + +tnDict :: OccName +tnDict = mkTcOcc "Dict" + +tnBareConstraint :: OccName +tnBareConstraint = mkTcOcc "BareConstraint" + +tnDeriveContext :: OccName +tnDeriveContext = mkTcOcc "DeriveContext" + +vnDictToBare :: OccName +vnDictToBare = mkVarOcc "dictToBare" + +cnTypeEq :: OccName +cnTypeEq = mkTcOcc "~"
src/Data/Constraint/Deriving/DeriveAll.hs view
@@ -1,924 +1,930 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-module Data.Constraint.Deriving.DeriveAll- ( DeriveAll (..), DeriveContext- , deriveAllPass- , CorePluginEnvRef, initCorePluginEnv- ) where---import Class (Class, classTyCon)-import CoAxiom (CoAxBranch, coAxBranchIncomps,- coAxBranchLHS, coAxBranchRHS,- coAxiomBranches, coAxiomSingleBranch,- fromBranches)-import Control.Applicative (Alternative (..))-import Control.Arrow (second)-import Control.Monad (join, unless)-import Data.Data (Data)-import Data.Either (partitionEithers)-import qualified Data.Kind (Constraint, Type)-import Data.List (groupBy, isPrefixOf, nubBy, sortOn)-import Data.Maybe (catMaybes, fromMaybe)-import Data.Monoid (First (..), Monoid (..))-import qualified FamInstEnv-import GhcPlugins hiding (OverlapMode (..), overlapMode,- (<>))-import qualified GhcPlugins-import InstEnv (ClsInst, DFunInstType)-import qualified InstEnv-import qualified OccName-import Panic (panicDoc)-import TcType (tcSplitDFunTy)-import qualified Unify--import Data.Constraint.Deriving.CorePluginM---- | A marker to tell the core plugin to derive all visible class instances--- for a given newtype.------ The deriving logic is to simply re-use existing instance dictionaries--- by type-casting.-data DeriveAll- = DeriveAll- -- ^ Same as @DeriveAllBut []@.- | DeriveAllBut [String]- -- ^ Specify a list of class names to ignore.- deriving (Eq, Show, Read, Data)----- | This type family is used to impose constraints on type parameters when--- looking up type instances for the `DeriveAll` core plugin.------ `DeriveAll` uses only those instances that satisfy the specified constraint.--- If the constraint is not specified, it is assumed to be `()`.-type family DeriveContext (t :: Data.Kind.Type) :: Data.Kind.Constraint---- | Run `DeriveAll` plugin pass-deriveAllPass :: CorePluginEnvRef -> CoreToDo-deriveAllPass eref = CoreDoPluginPass "Data.Constraint.Deriving.DeriveAll"- -- if a plugin pass totally fails to do anything useful,- -- copy original ModGuts as its output, so that next passes can do their jobs.- (\x -> fromMaybe x <$> runCorePluginM (deriveAllPass' x) eref)--{-- Derive all specific instances of a type for its newtype wrapper.-- Steps:-- 1. Lookup a type or type family instances (branches of CoAxiom)- of referenced by the newtype decl-- 2. For every type instance:-- 2.1 Lookup all class instances-- 2.2 For every class instance:-- * Use mkLocalInstance with parameters of found instance- and replaced RHS types- * Create a corresponding top-level binding (DFunId),- add it to mg_binds of ModGuts.- * Add new instance to (mg_insts :: [ClsInst]) of ModGuts- * Update mg_inst_env of ModGuts accordingly.-- -}-deriveAllPass' :: ModGuts -> CorePluginM ModGuts-deriveAllPass' gs = go (mg_tcs gs) annotateds gs- where- annotateds :: UniqFM [(Name, DeriveAll)]- annotateds = getModuleAnns gs-- go :: [TyCon] -> UniqFM [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts- -- All exports are processed, just return ModGuts- go [] anns guts = do- unless (isNullUFM anns) $- pluginWarning $ "One or more DeriveAll annotations are ignored:"- $+$ vcat- (map (pprBulletNameLoc . fst) . join $ eltsUFM anns)- $+$ "Note, DeriveAll is meant to be used only on type declarations."- return guts-- -- process type definitions present in the set of annotations- go (x:xs) anns guts- | Just ((xn, da):ds) <- lookupUFM anns x = do- unless (null ds) $- pluginLocatedWarning (nameSrcSpan xn) $- "Ignoring redundant DeriveAll annotions" $$- hcat- [ "(the plugin needs only one annotation per type declaration, but got "- , speakN (length ds + 1)- , ")"- ]- pluginDebug $ "DeriveAll invoked on TyCon" <+> ppr x- (newInstances, newBinds) <- unzip . fromMaybe [] <$> try (deriveAll da x guts)- -- add new definitions and continue- go xs (delFromUFM anns x) guts- { mg_insts = newInstances ++ mg_insts guts- -- I decided to not modify mg_inst_env so that DeriveAll-derived instances- -- do not refer to each other.- -- Overwise, the result of the plugin would depend on the order of- -- type declaration, which would be not good at all.- -- , mg_inst_env = InstEnv.extendInstEnvList (mg_inst_env guts) newInstances- , mg_binds = newBinds ++ mg_binds guts- }-- -- ignore the rest of type definitions- go (_:xs) anns guts = go xs anns guts-- pprBulletNameLoc n = hsep- [" ", bullet, ppr $ occName n, ppr $ nameSrcSpan n]----{- |- At this point, the plugin has found a candidate type.- The first thing I do here is to make sure this- is indeed a proper newtype declaration.- Then, lookup the DeriveContext-specified constraints.- Then, enumerate specific type instances (based on constraints- and type families in the newtype def.)- Then, lookup all class instances for the found type instances.- -}-deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(InstEnv.ClsInst, CoreBind)]-deriveAll da tyCon guts--- match good newtypes only- | True <- isNewTyCon tyCon- , False <- isClassTyCon tyCon- , [dataCon] <- tyConDataCons tyCon- = do- dcInsts <- lookupDeriveContextInstances guts tyCon- pluginDebug- . hang "DeriveAll (1): DeriveContext instances:" 2- . vcat $ map ppr dcInsts- unpackedInsts <-- if null dcInsts- then (:[]) <$> mockInstance tyCon- else return $ map unpackInstance dcInsts- pluginDebug- . hang "DeriveAll (1): DeriveContext instance parameters and RHSs:" 2- . vcat $ map ppr unpackedInsts- allMatchingTypes <- join <$>- traverse (lookupMatchingBaseTypes guts tyCon dataCon) unpackedInsts- pluginDebug- . hang "DeriveAll (2): matching base types:" 2- . vcat $ map ppr allMatchingTypes- r <- join <$> traverse (lookupMatchingInstances da guts) allMatchingTypes- pluginDebug- . hang "DeriveAll (3): matching class instances:" 2- . vcat $ map (ppr . fst) r- return $ filterDupInsts r---- not a good newtype declaration- | otherwise- = pluginLocatedError- (nameSrcSpan $ tyConName tyCon)- "DeriveAll works only on plain newtype declarations"-- where- -- O(n^2) search for duplicates. Slow, but what else can I do?..- filterDupInsts = nubBy $ \(x,_) (y, _) -> InstEnv.identicalClsInstHead x y- mockInstance tc = do- let tvs = tyConTyVars tc- tys = mkTyVarTys tvs- rhs <- ask tyEmptyConstraint- return (tys, rhs)- unpackInstance i- = let tys = case tyConAppArgs_maybe <$> FamInstEnv.fi_tys i of- [Just ts] -> ts- _ -> panicDoc "DeriveAll" $- hsep- [ "I faced an impossible type when"- <+> "matching an instance of type family DeriveContext:"- , ppr i, "at"- , ppr $ nameSrcSpan $ getName i]- rhs = FamInstEnv.fi_rhs i- in (tys, rhs)----- | Find all instance of a type family in scope by its TyCon.-lookupTyFamInstances :: ModGuts -> TyCon -> CorePluginM [FamInstEnv.FamInst]-lookupTyFamInstances guts fTyCon = do- pkgFamInstEnv <- liftCoreM getPackageFamInstEnv- return $ FamInstEnv.lookupFamInstEnvByTyCon- (pkgFamInstEnv, mg_fam_inst_env guts) fTyCon---- | Find all possible instances of DeriveContext type family for a given TyCon-lookupDeriveContextInstances :: ModGuts -> TyCon -> CorePluginM [FamInstEnv.FamInst]-lookupDeriveContextInstances guts tyCon = do- allInsts <- ask tyConDeriveContext >>= lookupTyFamInstances guts- return $ filter check allInsts- where- check fi = case tyConAppTyCon_maybe <$> FamInstEnv.fi_tys fi of- Just tc : _ -> tc == tyCon- _ -> False----- | Result of base type lookup, matching, and expanding-data MatchingType- = MatchingType- { mtCtxEqs :: [(TyVar, Type)]- -- ^ Current list of constraints that I may want to process- -- during type expansion or substitution- , mtTheta :: ThetaType- -- ^ Irreducible constraints- -- (I can prepend them in the class instance declarations)- , mtOverlapMode :: OverlapMode- -- ^ How to declare a class instance- , mtBaseType :: Type- -- ^ The type behind the newtype wrapper- , mtNewType :: Type- -- ^ The newtype with instantiated type arguments- , mtIgnoreList :: [Type]- -- ^ A list of type families I have already attempted to expand once- -- (e.g. wired-in type families or closed families with no equations- -- or something recursive).- }--instance Outputable MatchingType where- ppr MatchingType {..} = vcat- [ "MatchingType"- , "{ mtCtxEqs = " GhcPlugins.<> ppr mtCtxEqs- , ", mtTheta = " GhcPlugins.<> ppr mtTheta- , ", mtOverlapMode = " GhcPlugins.<> text (show mtOverlapMode)- , ", mtBaseType = " GhcPlugins.<> ppr mtBaseType- , ", mtNewType = " GhcPlugins.<> ppr mtNewType- , ", mtIgnorelist = " GhcPlugins.<> ppr mtIgnoreList- , "}"- ]----- | Replace TyVar in all components of a MatchingType-substMatchingType :: TCvSubst -> MatchingType -> MatchingType-substMatchingType sub MatchingType {..} = MatchingType- { mtCtxEqs = map (second $ substTyAddInScope sub) mtCtxEqs- , mtTheta = map (substTyAddInScope sub) mtTheta- , mtOverlapMode = mtOverlapMode- , mtBaseType = substTyAddInScope sub mtBaseType- , mtNewType = substTyAddInScope sub mtNewType- , mtIgnoreList = map (substTyAddInScope sub) mtIgnoreList- }--replaceTyMatchingType :: Type -> Type -> MatchingType -> MatchingType-replaceTyMatchingType oldt newt MatchingType {..} = MatchingType- { mtCtxEqs = map (second rep) mtCtxEqs- , mtTheta = map rep mtTheta- , mtOverlapMode = mtOverlapMode- , mtBaseType = rep mtBaseType- , mtNewType = rep mtNewType- , mtIgnoreList = map rep mtIgnoreList- }- where- rep = replaceTypeOccurrences oldt newt---- | try to get rid of mtCtxEqs by replacing tyvars--- by rhs in all components of the MatchingType-cleanupMatchingType :: MatchingType -> MatchingType-cleanupMatchingType mt0 = go (groupLists $ mtCtxEqs mt0) mt0 { mtCtxEqs = []}- where- groupOn f = groupBy (\x y -> f x == f y)- flattenSnd [] = []- flattenSnd ([]:xs) = flattenSnd xs- flattenSnd (ts@((tv,_):_):xs) = (tv, map snd ts): flattenSnd xs- groupLists = flattenSnd . groupOn fst . sortOn fst--- go :: [(TyVar, [Type])] -> MatchingType -> MatchingType- go [] mt = mt- go ((_, []):xs) mt = go xs mt- -- TyVar occurs once in mtCtxEqs: I can safely replace it in the type.- go ((tv,[ty]):xs) mt- = let sub = extendTCvSubst emptyTCvSubst tv ty- in go (map (second (map $ substTyAddInScope sub)) xs)- $ substMatchingType sub mt- -- TyVar occurs more than once: it may indicate- -- a trivial substition or contradiction- go ((tv, tys):xs) mt- = case removeEqualTypes tys of- [] -> go xs mt -- redundant, but compiler is happy- [t] -> go ((tv, [t]):xs) mt- ts -> go xs mt { mtCtxEqs = mtCtxEqs mt ++ map ((,) tv) ts }-- removeEqualTypes [] = []- removeEqualTypes [t] = [t]- removeEqualTypes (t:ts)- | any (eqType t) ts = removeEqualTypes ts- | otherwise = t : removeEqualTypes ts----- | Try to strip trailing TyVars from the base and newtypes,--- thus matching higher-kinded types.--- This way I can also derive things like Monad & co-tryHigherRanks :: MatchingType -> [MatchingType]-tryHigherRanks mt@MatchingType {..}- | Just (mtBaseType', bt) <- splitAppTy_maybe mtBaseType- , Just (mtNewType' , nt) <- splitAppTy_maybe mtNewType- , Just btv <- getTyVar_maybe bt- , Just ntv <- getTyVar_maybe nt- , btv == ntv- -- No constraints or anything else involving our TyVar- , not . elem btv- . (map fst mtCtxEqs ++)- . tyCoVarsOfTypesWellScoped- $ [mtBaseType', mtNewType']- ++ map snd mtCtxEqs- ++ mtTheta- ++ mtIgnoreList- = let mt' = mt- { mtBaseType = mtBaseType'- , mtNewType = mtNewType'- }- in mt : tryHigherRanks mt'-tryHigherRanks mt = [mt]---- | For a given type and constraints, enumerate all possible concrete types;--- specify overlapping mode if encountered with conflicting instances of--- closed type families.----lookupMatchingBaseTypes :: ModGuts- -> TyCon- -> DataCon- -> ([Type], Type)- -> CorePluginM [MatchingType]-lookupMatchingBaseTypes guts tyCon dataCon (tys, constraints) = do- ftheta <- filterTheta theta- let initMt = MatchingType- { mtCtxEqs = fst ftheta- , mtTheta = snd ftheta- , mtOverlapMode = NoOverlap- , mtBaseType = baseType- , mtNewType = newType- , mtIgnoreList = []- }- (>>= tryHigherRanks . cleanupMatchingType)- . take 1000 -- TODO: improve the logic and the termination rule- <$> go (cleanupMatchingType initMt)- where- go :: MatchingType -> CorePluginM [MatchingType]- go mt = expandOneFamily guts mt >>= \case- Nothing -> pure [mt]- Just mts -> join <$> traverse go mts-- newType = mkTyConApp tyCon tys- -- mkFunTys theta $ mkTyConApp tyCon tys- theta = splitCts constraints ++ dataConstraints-- splitCts c = case splitTyConApp_maybe c of- Nothing -> [c]- Just (tc, ts) ->- if isCTupleTyConName $ getName tc- then foldMap splitCts ts- else [c]-- (dataConstraints, baseType) = case dataConInstSig dataCon tys of- ([], cts, [bt]) -> (cts, bt)- _ -> panicDoc "DeriveAll" $ hsep- [ "Impossible happened:"- , "expected a newtype constructor"- , "with no existential tyvars and a single type argument,"- , "but got", ppr dataCon- , "at", ppr $ nameSrcSpan $ getName dataCon ]--{-- New plan for generating matching types--- Split ThetaType into two lists:-- [(TyVar, Type)] and the rest of ThetaType-- The rest of ThetaType is considered not useful;- it will be just appended to a list of constraints in the result types.- [(TyVar, Type)] is a list of equality constraints that might help the algorithm.-- I want to perform three operations related to this list:- [1] Add new tyVar ~ TypeFamily, from type family occurrences- in the base or newtypes- (but also check this type family is not present in the eqs?)- [2] Remove an item (TypeFamily) from the list by substituting- all possible type family instances- into the the base type, the newtype, and the list of constraints.- [3] Remove a non-TypeFamily item (i.e. a proper data/newtype TyCon)- by substituting TyVar with- this type in the base type, the newtype, and the list of constraints.-- Actions [1,2] may lead to an infinite expansion (recursive families)- so I need to bound the number of iterations. An approximate implementation plan:- 1. Apply [1] until no type families present in the basetype or the newtype- 2. Apply [2] or [3] until no esq left???-- -}----- | Split constraints into two groups:--- 1. The ones used as substitutions--- 2. Irreducible ones w.r.t. the type expansion algorithm-filterTheta :: ThetaType -> CorePluginM ([(TyVar, Type)], ThetaType)-filterTheta = fmap (partitionEithers . join) . traverse- (\t -> do- teqClass <- ask classTypeEq- filterTheta' teqClass t- )---- "worker" part of filterTheta (with a provided reference to "~")-filterTheta' :: Class -> Type -> CorePluginM [Either (TyVar, Type) PredType]-filterTheta' teqClass t = go (classifyPredType t)- where- go (EqPred _ t1 t2)- | Just tv <- getTyVar_maybe t1- = return [Left (tv, t2)]- | Just tv <- getTyVar_maybe t2- = return [Left (tv, t1)]- | otherwise- = do- tv <- newTyVar (typeKind t1)- return [Left (tv, t1), Left (tv, t2)]- go (ClassPred c ts)- | c == heqClass- , [_, _, t1, t2] <- ts- -- nominal or rep-al equality does not matter here, because- -- I don't distinguish between those a few lines above.- = go (EqPred ReprEq t1 t2)- | c == teqClass- , [_, t1, t2] <- ts- = go (EqPred ReprEq t1 t2)- | otherwise- = return [Right t]- go _ = return [Right t]--expandOneFamily :: ModGuts -> MatchingType -> CorePluginM (Maybe [MatchingType])-expandOneFamily guts mt@MatchingType{..} = case mfam of- Nothing -> return Nothing- Just (ff, t) -> expandFamily guts ff t >>= \case- Nothing -> return $ Just [mt { mtIgnoreList = t : mtIgnoreList }]- Just es -> return $ Just $ map (toMT t) es- where- -- first, substitute all type variables,- -- then substitute family occurrence with RHS of the axiom (rezt)- toMT ft (omode, rezt, subst)- = let famOcc = substTyAddInScope subst ft- newMt = substMatchingType subst mt- in if eqType ft rezt- then mt { mtIgnoreList = ft : mtIgnoreList }- else replaceTyMatchingType famOcc rezt newMt- { mtOverlapMode = omode }--- -- Lookup through all components- look = First . lookupFamily mtIgnoreList- First mfam = mconcat- [ foldMap (look . snd) mtCtxEqs- , foldMap look mtTheta- , look mtBaseType- , look mtNewType- ]----- -- TODO: Not sure if I need it at all;--- most of the API functions look through synonyms--- -- | Try to remove all occurrences of type synonyms.--- clearSynonyms :: Type -> Type--- clearSynonyms t'--- -- split type constructors--- | Just (tyCon, tys) <- splitTyConApp_maybe t--- = mkTyConApp tyCon $ map clearSynonyms tys--- -- split foralls--- | (bndrs@(_:_), t1) <- splitForAllTys t--- = mkSpecForAllTys bndrs $ clearSynonyms t1--- -- split arrow types--- | Just (at, rt) <- splitFunTy_maybe t--- = mkFunTy (clearSynonyms at) (clearSynonyms rt)--- | otherwise--- = t--- where--- stripOuter x = case tcView x of--- Nothing -> x--- Just y -> stripOuter y--- t = stripOuter t'----- | Depth-first lookup of the first occurrence of any type family.--- First argument is a list of types to ignore.-lookupFamily :: [Type] -> Type -> Maybe (FamTyConFlav, Type)-lookupFamily ignoreLst t- -- split type constructors- | Just (tyCon, tys) <- splitTyConApp_maybe t- = case foldMap (First . lookupFamily ignoreLst) tys of- First (Just r) -> Just r- First Nothing -> famTyConFlav_maybe tyCon >>= \ff ->- if any (eqType t) ignoreLst- then Nothing- else Just (ff, t)- -- split foralls- | (_:_, t') <- splitForAllTys t- = lookupFamily ignoreLst t'- -- split arrow types- | Just (at, rt) <- splitFunTy_maybe t- = lookupFamily ignoreLst at <|> lookupFamily ignoreLst rt- | otherwise- = Nothing----- | Enumerate available family instances and substitute type arguments,--- such that original type family can be replaced with any--- of the types in the output list.--- It passes a TCvSubst alongside with the substituted Type.--- The substituted Type may have TyVars from the result set of the substitution,--- thus I must be careful with using it:--- either somehow substitute back these tyvars from the result,--- or substitute the whole type that contains this family occurrence.------ return Nothing means cannot expand family (shall use it as-is);--- return (Just []) means all instances contradict family arguments.-expandFamily :: ModGuts- -> FamTyConFlav- -> Type- -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])--- cannot help here-expandFamily _ AbstractClosedSynFamilyTyCon{} _ = pure Nothing--- .. and here-expandFamily _ BuiltInSynFamTyCon{} _ = pure Nothing--- .. closed type families with no equations cannot be helped either-expandFamily _ (ClosedSynFamilyTyCon Nothing) _ = pure Nothing--- For a closed type family, equations are accessible right there-expandFamily _ (ClosedSynFamilyTyCon (Just coax)) ft- = withFamily ft (pure Nothing) $ const $ expandClosedFamily os bcs- where- bcs = fromBranches $ coAxiomBranches coax- os = if any (not . null . coAxBranchIncomps) bcs- then map overlap bcs else repeat NoOverlap- overlap cb = if null $ coAxBranchIncomps cb- then Overlapping- else Incoherent--- For a data family or an open type family, I need to lookup instances--- in the family instance environment.-expandFamily guts DataFamilyTyCon{} ft- = withFamily ft (pure Nothing) $ expandDataFamily guts-expandFamily guts OpenSynFamilyTyCon ft- = withFamily ft (pure Nothing) $ expandOpenFamily guts--withFamily :: Type -> a -> (TyCon -> [Type] -> a) -> a-withFamily ft def f = case splitTyConApp_maybe ft of- Nothing -> def- Just (tc, ts) -> f tc ts----- | The same as `expandFamily`, but I know already that the family is closed.-expandClosedFamily :: [OverlapMode]- -> [CoAxBranch]- -> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])--- empty type family -- leave it as-is-expandClosedFamily _ [] _ = pure Nothing-expandClosedFamily os bs fTyArgs = fmap (Just . catMaybes) $ traverse go $ zip os bs- where- go (om, cb) = do- let flhs' = coAxBranchLHS cb- n = length flhs'- tvs' = tyCoVarsOfTypesWellScoped flhs'- tvs <- traverse freshenTyVar tvs'- let freshenSub = zipTvSubst tvs' $ map mkTyVarTy tvs- flhs = substTys freshenSub flhs'- frhs = substTyAddInScope freshenSub $ coAxBranchRHS cb- t = foldl mkAppTy frhs $ drop n fTyArgs- msub = Unify.tcMatchTys (take n fTyArgs) flhs- return $ (,,) om t <$> msub------ | The same as `expandFamily`, but I know already that the family is open.-expandOpenFamily :: ModGuts- -> TyCon -- ^ Type family construtor- -> [Type] -- ^ Type family arguments- -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])-expandOpenFamily guts fTyCon fTyArgs = do- tfInsts <- lookupTyFamInstances guts fTyCon- if null tfInsts- then pure $ Just [] -- No mercy- else expandClosedFamily- (repeat NoOverlap)- (coAxiomSingleBranch . FamInstEnv.famInstAxiom <$> tfInsts)- fTyArgs----- | The same as `expandFamily`, but I know already that this is a data family.-expandDataFamily :: ModGuts- -> TyCon -- ^ Type family construtor- -> [Type] -- ^ Type family arguments- -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)])-expandDataFamily guts fTyCon fTyArgs = do- tfInsts <- lookupTyFamInstances guts fTyCon- if null tfInsts- then pure $ Just [] -- No mercy- else sequence <$> traverse expandDInstance tfInsts- where- expandDInstance inst- | fitvs <- FamInstEnv.fi_tvs inst- = do- tvs <- traverse freshenTyVar $ fitvs- let freshenSub = zipTvSubst fitvs $ map mkTyVarTy tvs- fitys = substTys freshenSub $ FamInstEnv.fi_tys inst- instTyArgs = align fTyArgs fitys- return $ (,,) NoOverlap (mkTyConApp fTyCon instTyArgs)- <$> Unify.tcMatchTys fTyArgs instTyArgs- align [] _ = []- align xs [] = xs- align (_:xs) (y:ys) = y : align xs ys---data MatchingInstance = MatchingInstance- { miInst :: ClsInst- -- ^ Original found instance for the base type (as declared somewhere);- -- It contains the signature and original DFunId- , miInstTyVars :: [DFunInstType]- -- ^ How TyVars of miOrigBaseClsInst should be replaced to make it as- -- an instance for the base type;- -- e.g. a TyVar may be instantiated with a concrete type- -- (which may or may not contain more type variables).- , miTheta :: [(PredType, MatchingPredType)]- -- ^ Original pred types and how they are going to be transformed- }--instance Outputable MatchingInstance where- ppr MatchingInstance {..} = hang "MatchingInstance" 2 $ vcat- [ "{ miInst =" <+> ppr miInst- , ", miInstTyVars =" <+> ppr miInstTyVars- , ", miTheta =" <+> ppr miTheta- ]--{--Resolving theta types:--1. Class constraints: every time check- a. if there is an instance, substitute corresponding DFunIds and be happy.- b. if there is no instance and no tyvars, then fail- c. otherwise propagate the constraint further.--2. Equality constraints: check equality- a. Types are equal (and tyvars inside equal as well):- Substitute mkReflCo- b. Types are unifiable:- Propagate constraint further- c. Types are non-unifiable:- Discard the whole instance declaration.- -}-data MatchingPredType- = MptInstance MatchingInstance- -- ^ Found an instance- | MptReflexive Coercion- -- ^ The equality become reflexive after a tyvar substitution- | MptPropagateAs PredType- -- ^ Could do nothing, but there is still hope due to the present tyvars--instance Outputable MatchingPredType where- ppr (MptInstance x) = "MptInstance" <+> ppr x- ppr (MptReflexive x) = "MptReflexive" <+> ppr x- ppr (MptPropagateAs x) = "MptPropagateAs" <+> ppr x--findInstance :: InstEnv.InstEnvs- -> Type- -> ClsInst- -> Maybe MatchingInstance-findInstance ie t i- | -- Most important: some part of the instance parameters must unify to arg- Just sub <- getFirst $ foldMap (First . flip (recMatchTyKi False) t) iTyPams- -- substituted type parameters of the class- , newTyPams <- map (substTyAddInScope sub) iTyPams- -- This tells us how instance tyvars change after matching the type- = matchInstance ie iClass newTyPams- | otherwise- = Nothing- where- (_, _, iClass, iTyPams) = InstEnv.instanceSig i---matchInstance :: InstEnv.InstEnvs- -> Class- -> [Type]- -> Maybe MatchingInstance-matchInstance ie cls ts- | ([(i, tyVarSubs)], _notMatchButUnify, _safeHaskellStuff)- <- InstEnv.lookupInstEnv False ie cls ts- , (iTyVars, iTheta, _, _) <- InstEnv.instanceSig i- , sub <- mkTvSubstPrs- . catMaybes $ zipWith (fmap . (,)) iTyVars tyVarSubs- = do-- mpts <- traverse (matchPredType ie . substTyAddInScope sub) iTheta- return MatchingInstance- { miInst = i- , miInstTyVars = tyVarSubs- , miTheta = zip iTheta mpts- }- | otherwise- = Nothing--matchPredType :: InstEnv.InstEnvs- -> PredType- -> Maybe MatchingPredType-matchPredType ie pt = go $ classifyPredType pt- where- go (ClassPred cls ts)- | Just mi <- matchInstance ie cls ts- = Just $ MptInstance mi- -- we could not find an instance, but also there are no tyvars (and no hope)- | [] <- tyCoVarsOfTypesWellScoped ts- = Nothing- | otherwise = Just $ MptPropagateAs pt- go (EqPred rel t1 t2)- | eqType t1 t2 = Just . MptReflexive $ case rel of- NomEq -> mkReflCo Nominal t1- ReprEq -> mkReflCo Representational t1- | Unify.typesCantMatch [(t1,t2)]- = Nothing- | otherwise = Just $ MptPropagateAs pt- go _ = Just $ MptPropagateAs pt---type TyExp = (Type, CoreExpr)-type TyBndr = (Type, CoreBndr)---mtmiToExpression :: MatchingType- -> MatchingInstance- -> CorePluginM TyExp-mtmiToExpression MatchingType {..} mi = do- (bndrs, (tOrig, e)) <- miToExpression' [] mi- let extraTheta- = filter (\t -> not $ any (eqType t . fst) bndrs) mtTheta- tRepl = replaceTypeOccurrences mtBaseType mtNewType tOrig- tFun = mkFunTys (extraTheta ++ map fst bndrs) tRepl- tvs = tyCoVarsOfTypeWellScoped tFun- return- ( mkSpecForAllTys tvs tFun- , mkCoreLams (tvs ++ map mkWildValBinder extraTheta ++ map snd bndrs)- $ mkCast e- $ mkUnsafeCo Representational tOrig tRepl- )----- | Construct a core expression and a corresponding type.--- It does not bind arguments;--- uses only types and vars present in MatchingInstance;--- may create a few vars for PredTypes, they are returned in fst.-miToExpression' :: [TyExp]- -- ^ types and expressions of the PredTypes that are in scope- -> MatchingInstance- -> CorePluginM ([TyBndr], TyExp)- -- (what to add to lambda, and the final expression)-miToExpression' availPTs MatchingInstance {..} = do- (bndrs, eArgs) <- addArgs availPTs $ map snd miTheta- return- ( bndrs- , ( newIHead- , mkCoreApps eDFunWithTyPams eArgs- )- )- where- (iTyVars, _, iClass, iTyPams) = InstEnv.instanceSig miInst- -- this is the same length as iTyVars, needs to be applied on dFunId- tyVarVals = zipWith (fromMaybe . mkTyVarTy) iTyVars miInstTyVars- sub = mkTvSubstPrs . catMaybes- $ zipWith (fmap . (,)) iTyVars miInstTyVars- newTyPams = map (substTyAddInScope sub) iTyPams- newIHead = mkTyConApp (classTyCon iClass) newTyPams- eDFun = Var $ InstEnv.instanceDFunId miInst- eDFunWithTyPams = mkTyApps eDFun tyVarVals- addArgs :: [TyExp]- -> [MatchingPredType]- -> CorePluginM ([TyBndr], [CoreExpr])- addArgs _ [] = pure ([], [])- addArgs ps (x:xs) = do- (tbdrs, e) <- mptToExpression ps x- let ps' = ps ++ map (Var <$>) tbdrs- (tbdrs', es) <- addArgs ps' xs- return- ( tbdrs ++ tbdrs'- , e:es- )----- | Construct an expression to put as a PredType argument.--- It may need to produce a new type variable.-mptToExpression :: [TyExp]- -> MatchingPredType- -> CorePluginM ([TyBndr], CoreExpr)-mptToExpression ps (MptInstance mi)- = fmap snd <$> miToExpression' ps mi-mptToExpression _ (MptReflexive c)- = pure ([], Coercion c)-mptToExpression ps (MptPropagateAs pt)- = case mte of- Just e -> pure ([], e)- Nothing -> do- loc <- liftCoreM getSrcSpanM- u <- getUniqueM- let n = mkInternalName u- (mkOccName OccName.varName $ "dFunArg_" ++ show u) loc- v = mkLocalIdOrCoVar n pt- return ([(pt,v)], Var v)- where- mte = getFirst $ foldMap getSamePT ps- getSamePT (t, e)- | eqType t pt = First $ Just e- | otherwise = First Nothing---- | For a given most concrete type, find all possible class instances.--- Derive them all by creating a new CoreBind with a casted type.------ Prerequisite: in the tripple (overlapmode, baseType, newType),--- TyVars of the newType must be a superset of TyVars of the baseType.-lookupMatchingInstances :: DeriveAll- -> ModGuts- -> MatchingType- -> CorePluginM [(ClsInst, CoreBind)]-lookupMatchingInstances da guts mt- | Just bTyCon <- tyConAppTyCon_maybe $ mtBaseType mt = do- ie <- getInstEnvs guts- let clsInsts = lookupClsInsts ie bTyCon- pluginDebug $ hang "lookupMatchingInstances candidate instances:" 2 $- vcat $ map ppr clsInsts- catMaybes <$> traverse (lookupMatchingInstance da ie mt) clsInsts- | otherwise = fmap (const []) . pluginDebug $ hcat- [ text "DeriveAll.lookupMatchingInstances found no class instances for "- , ppr (mtBaseType mt)- , text ", because it could not get the type constructor."- ]---lookupMatchingInstance :: DeriveAll- -> InstEnv.InstEnvs- -> MatchingType- -> ClsInst- -> CorePluginM (Maybe (ClsInst, CoreBind))-lookupMatchingInstance da ie mt@MatchingType {..} baseInst- | not . unwantedName da $ getName iClass- , all (noneTy (unwantedName DeriveAll)) iTyPams- = case findInstance ie mtBaseType baseInst of- Just mi -> do- (t, e) <- mtmiToExpression mt mi- newN <- newName (occNameSpace baseDFunName)- $ occNameString baseDFunName- ++ show (getUnique baseDFunId) -- unique per baseDFunId- ++ newtypeNameS -- unique per newType- let (newTyVars, _, _, newTyPams) = tcSplitDFunTy t- newDFunId = mkExportedLocalId- (DFunId isNewType) newN t- return $ Just- ( InstEnv.mkLocalInstance- newDFunId- ( toOverlapFlag $ mappend mtOverlapMode baseOM )- newTyVars iClass newTyPams- , NonRec newDFunId e- )- Nothing- -- in case if the instance is more specific than the MatchingType,- -- substitute types and try again- | Just sub <- getFirst- $ foldMap (First . flip (recMatchTyKi True) mtBaseType) iTyPams- -> lookupMatchingInstance da ie (substMatchingType sub mt) baseInst- | otherwise- -> do- pluginDebug $ hang "Ignored instance" 2- $ ppr mtBaseType <+> ppr baseInst- pure Nothing- | otherwise- = pure Nothing- where- baseOM = instanceOverlapMode baseInst- baseDFunId = InstEnv.instanceDFunId baseInst- (_, _, iClass, iTyPams) = InstEnv.instanceSig baseInst- isNewType = isNewTyCon (classTyCon iClass)- baseDFunName = occName . idName $ baseDFunId- newtypeNameS = case tyConAppTyCon_maybe mtNewType of- Nothing -> "DeriveAll-generated"- Just tc -> occNameString $ occName $ tyConName tc----- checks if none of the names in the type satisfy the predicate-noneTy :: (Name -> Bool) -> Type -> Bool-noneTy f = not . uniqSetAny f . orphNamesOfType-#if __GLASGOW_HASKELL__ < 802- where- uniqSetAny g = foldl (\a -> (||) a . g) False-#endif--unwantedName :: DeriveAll -> Name -> Bool-unwantedName da n- | modName == "GHC.Generics" = True- | modName == "Data.Typeable" = True- | modName == "Data.Data" = True- | "Language.Haskell.TH"- `isPrefixOf` modName = True- | valName == "Coercible" = True- | DeriveAllBut xs <- da- , valName `elem` xs = True- | otherwise = False- where- modName = moduleNameString . moduleName $ nameModule n- valName = occNameString $ getOccName n+{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Constraint.Deriving.DeriveAll + ( DeriveAll (..), DeriveContext + , deriveAllPass + , CorePluginEnvRef, initCorePluginEnv + ) where + + +import Class (Class, classTyCon) +import CoAxiom (CoAxBranch, coAxBranchIncomps, + coAxBranchLHS, coAxBranchRHS, + coAxiomBranches, coAxiomSingleBranch, + fromBranches) +import Control.Applicative (Alternative (..)) +import Control.Arrow (second) +import Control.Monad (join, unless) +import Data.Data (Data) +import Data.Either (partitionEithers) +import qualified Data.Kind (Constraint, Type) +import Data.List (groupBy, isPrefixOf, nubBy, sortOn) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid (First (..), Monoid (..)) +import qualified FamInstEnv +import GhcPlugins hiding (OverlapMode (..), overlapMode, + (<>)) +import qualified GhcPlugins +import InstEnv (ClsInst, DFunInstType) +import qualified InstEnv +import qualified OccName +import Panic (panicDoc) +import TcType (tcSplitDFunTy) +import qualified Unify + +import Data.Constraint.Deriving.CorePluginM + +-- | A marker to tell the core plugin to derive all visible class instances +-- for a given newtype. +-- +-- The deriving logic is to simply re-use existing instance dictionaries +-- by type-casting. +data DeriveAll + = DeriveAll + -- ^ Same as @DeriveAllBut []@. + | DeriveAllBut { _ignoreList :: [String] } + -- ^ Specify a list of class names to ignore + | DeriveAll' { _forcedMode :: OverlapMode, _ignoreList :: [String] } + -- ^ Specify an overlap mode and a list of class names to ignore + deriving (Eq, Show, Read, Data) + + +-- | This type family is used to impose constraints on type parameters when +-- looking up type instances for the `DeriveAll` core plugin. +-- +-- `DeriveAll` uses only those instances that satisfy the specified constraint. +-- If the constraint is not specified, it is assumed to be `()`. +type family DeriveContext (t :: Data.Kind.Type) :: Data.Kind.Constraint + +-- | Run `DeriveAll` plugin pass +deriveAllPass :: CorePluginEnvRef -> CoreToDo +deriveAllPass eref = CoreDoPluginPass "Data.Constraint.Deriving.DeriveAll" + -- if a plugin pass totally fails to do anything useful, + -- copy original ModGuts as its output, so that next passes can do their jobs. + (\x -> fromMaybe x <$> runCorePluginM (deriveAllPass' x) eref) + +{- + Derive all specific instances of a type for its newtype wrapper. + + Steps: + + 1. Lookup a type or type family instances (branches of CoAxiom) + of referenced by the newtype decl + + 2. For every type instance: + + 2.1 Lookup all class instances + + 2.2 For every class instance: + + * Use mkLocalInstance with parameters of found instance + and replaced RHS types + * Create a corresponding top-level binding (DFunId), + add it to mg_binds of ModGuts. + * Add new instance to (mg_insts :: [ClsInst]) of ModGuts + * Update mg_inst_env of ModGuts accordingly. + + -} +deriveAllPass' :: ModGuts -> CorePluginM ModGuts +deriveAllPass' gs = go (mg_tcs gs) annotateds gs + where + annotateds :: UniqFM [(Name, DeriveAll)] + annotateds = getModuleAnns gs + + go :: [TyCon] -> UniqFM [(Name, DeriveAll)] -> ModGuts -> CorePluginM ModGuts + -- All exports are processed, just return ModGuts + go [] anns guts = do + unless (isNullUFM anns) $ + pluginWarning $ "One or more DeriveAll annotations are ignored:" + $+$ vcat + (map (pprBulletNameLoc . fst) . join $ eltsUFM anns) + $+$ "Note, DeriveAll is meant to be used only on type declarations." + return guts + + -- process type definitions present in the set of annotations + go (x:xs) anns guts + | Just ((xn, da):ds) <- lookupUFM anns x = do + unless (null ds) $ + pluginLocatedWarning (nameSrcSpan xn) $ + "Ignoring redundant DeriveAll annotions" $$ + hcat + [ "(the plugin needs only one annotation per type declaration, but got " + , speakN (length ds + 1) + , ")" + ] + pluginDebug $ "DeriveAll invoked on TyCon" <+> ppr x + (newInstances, newBinds) <- unzip . fromMaybe [] <$> try (deriveAll da x guts) + -- add new definitions and continue + go xs (delFromUFM anns x) guts + { mg_insts = newInstances ++ mg_insts guts + -- I decided to not modify mg_inst_env so that DeriveAll-derived instances + -- do not refer to each other. + -- Overwise, the result of the plugin would depend on the order of + -- type declaration, which would be not good at all. + -- , mg_inst_env = InstEnv.extendInstEnvList (mg_inst_env guts) newInstances + , mg_binds = newBinds ++ mg_binds guts + } + + -- ignore the rest of type definitions + go (_:xs) anns guts = go xs anns guts + + pprBulletNameLoc n = hsep + [" ", bullet, ppr $ occName n, ppr $ nameSrcSpan n] + + + +{- | + At this point, the plugin has found a candidate type. + The first thing I do here is to make sure this + is indeed a proper newtype declaration. + Then, lookup the DeriveContext-specified constraints. + Then, enumerate specific type instances (based on constraints + and type families in the newtype def.) + Then, lookup all class instances for the found type instances. + -} +deriveAll :: DeriveAll -> TyCon -> ModGuts -> CorePluginM [(InstEnv.ClsInst, CoreBind)] +deriveAll da tyCon guts +-- match good newtypes only + | True <- isNewTyCon tyCon + , False <- isClassTyCon tyCon + , [dataCon] <- tyConDataCons tyCon + = do + dcInsts <- lookupDeriveContextInstances guts tyCon + pluginDebug + . hang "DeriveAll (1): DeriveContext instances:" 2 + . vcat $ map ppr dcInsts + unpackedInsts <- + if null dcInsts + then (:[]) <$> mockInstance tyCon + else return $ map unpackInstance dcInsts + pluginDebug + . hang "DeriveAll (1): DeriveContext instance parameters and RHSs:" 2 + . vcat $ map ppr unpackedInsts + allMatchingTypes <- join <$> + traverse (lookupMatchingBaseTypes guts tyCon dataCon) unpackedInsts + pluginDebug + . hang "DeriveAll (2): matching base types:" 2 + . vcat $ map ppr allMatchingTypes + r <- join <$> traverse (lookupMatchingInstances da guts) allMatchingTypes + pluginDebug + . hang "DeriveAll (3): matching class instances:" 2 + . vcat $ map (ppr . fst) r + return $ filterDupInsts r + +-- not a good newtype declaration + | otherwise + = pluginLocatedError + (nameSrcSpan $ tyConName tyCon) + "DeriveAll works only on plain newtype declarations" + + where + -- O(n^2) search for duplicates. Slow, but what else can I do?.. + filterDupInsts = nubBy $ \(x,_) (y, _) -> InstEnv.identicalClsInstHead x y + mockInstance tc = do + let tvs = tyConTyVars tc + tys = mkTyVarTys tvs + rhs <- ask tyEmptyConstraint + return (tys, rhs) + unpackInstance i + = let tys = case tyConAppArgs_maybe <$> FamInstEnv.fi_tys i of + [Just ts] -> ts + _ -> panicDoc "DeriveAll" $ + hsep + [ "I faced an impossible type when" + <+> "matching an instance of type family DeriveContext:" + , ppr i, "at" + , ppr $ nameSrcSpan $ getName i] + rhs = FamInstEnv.fi_rhs i + in (tys, rhs) + + +-- | Find all instance of a type family in scope by its TyCon. +lookupTyFamInstances :: ModGuts -> TyCon -> CorePluginM [FamInstEnv.FamInst] +lookupTyFamInstances guts fTyCon = do + pkgFamInstEnv <- liftCoreM getPackageFamInstEnv + return $ FamInstEnv.lookupFamInstEnvByTyCon + (pkgFamInstEnv, mg_fam_inst_env guts) fTyCon + +-- | Find all possible instances of DeriveContext type family for a given TyCon +lookupDeriveContextInstances :: ModGuts -> TyCon -> CorePluginM [FamInstEnv.FamInst] +lookupDeriveContextInstances guts tyCon = do + allInsts <- ask tyConDeriveContext >>= lookupTyFamInstances guts + return $ filter check allInsts + where + check fi = case tyConAppTyCon_maybe <$> FamInstEnv.fi_tys fi of + Just tc : _ -> tc == tyCon + _ -> False + + +-- | Result of base type lookup, matching, and expanding +data MatchingType + = MatchingType + { mtCtxEqs :: [(TyVar, Type)] + -- ^ Current list of constraints that I may want to process + -- during type expansion or substitution + , mtTheta :: ThetaType + -- ^ Irreducible constraints + -- (I can prepend them in the class instance declarations) + , mtOverlapMode :: OverlapMode + -- ^ How to declare a class instance + , mtBaseType :: Type + -- ^ The type behind the newtype wrapper + , mtNewType :: Type + -- ^ The newtype with instantiated type arguments + , mtIgnoreList :: [Type] + -- ^ A list of type families I have already attempted to expand once + -- (e.g. wired-in type families or closed families with no equations + -- or something recursive). + } + +instance Outputable MatchingType where + ppr MatchingType {..} = vcat + [ "MatchingType" + , "{ mtCtxEqs = " GhcPlugins.<> ppr mtCtxEqs + , ", mtTheta = " GhcPlugins.<> ppr mtTheta + , ", mtOverlapMode = " GhcPlugins.<> text (show mtOverlapMode) + , ", mtBaseType = " GhcPlugins.<> ppr mtBaseType + , ", mtNewType = " GhcPlugins.<> ppr mtNewType + , ", mtIgnorelist = " GhcPlugins.<> ppr mtIgnoreList + , "}" + ] + + +-- | Replace TyVar in all components of a MatchingType +substMatchingType :: TCvSubst -> MatchingType -> MatchingType +substMatchingType sub MatchingType {..} = MatchingType + { mtCtxEqs = map (second $ substTyAddInScope sub) mtCtxEqs + , mtTheta = map (substTyAddInScope sub) mtTheta + , mtOverlapMode = mtOverlapMode + , mtBaseType = substTyAddInScope sub mtBaseType + , mtNewType = substTyAddInScope sub mtNewType + , mtIgnoreList = map (substTyAddInScope sub) mtIgnoreList + } + +replaceTyMatchingType :: Type -> Type -> MatchingType -> MatchingType +replaceTyMatchingType oldt newt MatchingType {..} = MatchingType + { mtCtxEqs = map (second rep) mtCtxEqs + , mtTheta = map rep mtTheta + , mtOverlapMode = mtOverlapMode + , mtBaseType = rep mtBaseType + , mtNewType = rep mtNewType + , mtIgnoreList = map rep mtIgnoreList + } + where + rep = replaceTypeOccurrences oldt newt + +-- | try to get rid of mtCtxEqs by replacing tyvars +-- by rhs in all components of the MatchingType +cleanupMatchingType :: MatchingType -> MatchingType +cleanupMatchingType mt0 = go (groupLists $ mtCtxEqs mt0) mt0 { mtCtxEqs = []} + where + groupOn f = groupBy (\x y -> f x == f y) + flattenSnd [] = [] + flattenSnd ([]:xs) = flattenSnd xs + flattenSnd (ts@((tv,_):_):xs) = (tv, map snd ts): flattenSnd xs + groupLists = flattenSnd . groupOn fst . sortOn fst + + + go :: [(TyVar, [Type])] -> MatchingType -> MatchingType + go [] mt = mt + go ((_, []):xs) mt = go xs mt + -- TyVar occurs once in mtCtxEqs: I can safely replace it in the type. + go ((tv,[ty]):xs) mt + = let sub = extendTCvSubst emptyTCvSubst tv ty + in go (map (second (map $ substTyAddInScope sub)) xs) + $ substMatchingType sub mt + -- TyVar occurs more than once: it may indicate + -- a trivial substition or contradiction + go ((tv, tys):xs) mt + = case removeEqualTypes tys of + [] -> go xs mt -- redundant, but compiler is happy + [t] -> go ((tv, [t]):xs) mt + ts -> go xs mt { mtCtxEqs = mtCtxEqs mt ++ map ((,) tv) ts } + + removeEqualTypes [] = [] + removeEqualTypes [t] = [t] + removeEqualTypes (t:ts) + | any (eqType t) ts = removeEqualTypes ts + | otherwise = t : removeEqualTypes ts + + +-- | Try to strip trailing TyVars from the base and newtypes, +-- thus matching higher-kinded types. +-- This way I can also derive things like Monad & co +tryHigherRanks :: MatchingType -> [MatchingType] +tryHigherRanks mt@MatchingType {..} + | Just (mtBaseType', bt) <- splitAppTy_maybe mtBaseType + , Just (mtNewType' , nt) <- splitAppTy_maybe mtNewType + , Just btv <- getTyVar_maybe bt + , Just ntv <- getTyVar_maybe nt + , btv == ntv + -- No constraints or anything else involving our TyVar + , not . elem btv + . (map fst mtCtxEqs ++) + . tyCoVarsOfTypesWellScoped + $ [mtBaseType', mtNewType'] + ++ map snd mtCtxEqs + ++ mtTheta + ++ mtIgnoreList + = let mt' = mt + { mtBaseType = mtBaseType' + , mtNewType = mtNewType' + } + in mt : tryHigherRanks mt' +tryHigherRanks mt = [mt] + +-- | For a given type and constraints, enumerate all possible concrete types; +-- specify overlapping mode if encountered with conflicting instances of +-- closed type families. +-- +lookupMatchingBaseTypes :: ModGuts + -> TyCon + -> DataCon + -> ([Type], Type) + -> CorePluginM [MatchingType] +lookupMatchingBaseTypes guts tyCon dataCon (tys, constraints) = do + ftheta <- filterTheta theta + let initMt = MatchingType + { mtCtxEqs = fst ftheta + , mtTheta = snd ftheta + , mtOverlapMode = NoOverlap + , mtBaseType = baseType + , mtNewType = newType + , mtIgnoreList = [] + } + (>>= tryHigherRanks . cleanupMatchingType) + . take 1000 -- TODO: improve the logic and the termination rule + <$> go (cleanupMatchingType initMt) + where + go :: MatchingType -> CorePluginM [MatchingType] + go mt = expandOneFamily guts mt >>= \case + Nothing -> pure [mt] + Just mts -> join <$> traverse go mts + + newType = mkTyConApp tyCon tys + -- mkFunTys theta $ mkTyConApp tyCon tys + theta = splitCts constraints ++ dataConstraints + + splitCts c = case splitTyConApp_maybe c of + Nothing -> [c] + Just (tc, ts) -> + if isCTupleTyConName $ getName tc + then foldMap splitCts ts + else [c] + + (dataConstraints, baseType) = case dataConInstSig dataCon tys of + ([], cts, [bt]) -> (cts, bt) + _ -> panicDoc "DeriveAll" $ hsep + [ "Impossible happened:" + , "expected a newtype constructor" + , "with no existential tyvars and a single type argument," + , "but got", ppr dataCon + , "at", ppr $ nameSrcSpan $ getName dataCon ] + +{- + New plan for generating matching types + + + Split ThetaType into two lists: + + [(TyVar, Type)] and the rest of ThetaType + + The rest of ThetaType is considered not useful; + it will be just appended to a list of constraints in the result types. + [(TyVar, Type)] is a list of equality constraints that might help the algorithm. + + I want to perform three operations related to this list: + [1] Add new tyVar ~ TypeFamily, from type family occurrences + in the base or newtypes + (but also check this type family is not present in the eqs?) + [2] Remove an item (TypeFamily) from the list by substituting + all possible type family instances + into the the base type, the newtype, and the list of constraints. + [3] Remove a non-TypeFamily item (i.e. a proper data/newtype TyCon) + by substituting TyVar with + this type in the base type, the newtype, and the list of constraints. + + Actions [1,2] may lead to an infinite expansion (recursive families) + so I need to bound the number of iterations. An approximate implementation plan: + 1. Apply [1] until no type families present in the basetype or the newtype + 2. Apply [2] or [3] until no esq left??? + + -} + + +-- | Split constraints into two groups: +-- 1. The ones used as substitutions +-- 2. Irreducible ones w.r.t. the type expansion algorithm +filterTheta :: ThetaType -> CorePluginM ([(TyVar, Type)], ThetaType) +filterTheta = fmap (partitionEithers . join) . traverse + (\t -> do + teqClass <- ask classTypeEq + filterTheta' teqClass t + ) + +-- "worker" part of filterTheta (with a provided reference to "~") +filterTheta' :: Class -> Type -> CorePluginM [Either (TyVar, Type) PredType] +filterTheta' teqClass t = go (classifyPredType t) + where + go (EqPred _ t1 t2) + | Just tv <- getTyVar_maybe t1 + = return [Left (tv, t2)] + | Just tv <- getTyVar_maybe t2 + = return [Left (tv, t1)] + | otherwise + = do + tv <- newTyVar (typeKind t1) + return [Left (tv, t1), Left (tv, t2)] + go (ClassPred c ts) + | c == heqClass + , [_, _, t1, t2] <- ts + -- nominal or rep-al equality does not matter here, because + -- I don't distinguish between those a few lines above. + = go (EqPred ReprEq t1 t2) + | c == teqClass + , [_, t1, t2] <- ts + = go (EqPred ReprEq t1 t2) + | otherwise + = return [Right t] + go _ = return [Right t] + +expandOneFamily :: ModGuts -> MatchingType -> CorePluginM (Maybe [MatchingType]) +expandOneFamily guts mt@MatchingType{..} = case mfam of + Nothing -> return Nothing + Just (ff, t) -> expandFamily guts ff t >>= \case + Nothing -> return $ Just [mt { mtIgnoreList = t : mtIgnoreList }] + Just es -> return $ Just $ map (toMT t) es + where + -- first, substitute all type variables, + -- then substitute family occurrence with RHS of the axiom (rezt) + toMT ft (omode, rezt, subst) + = let famOcc = substTyAddInScope subst ft + newMt = substMatchingType subst mt + in if eqType ft rezt + then mt { mtIgnoreList = ft : mtIgnoreList } + else replaceTyMatchingType famOcc rezt newMt + { mtOverlapMode = omode } + + + -- Lookup through all components + look = First . lookupFamily mtIgnoreList + First mfam = mconcat + [ foldMap (look . snd) mtCtxEqs + , foldMap look mtTheta + , look mtBaseType + , look mtNewType + ] + + +-- -- TODO: Not sure if I need it at all; +-- most of the API functions look through synonyms +-- -- | Try to remove all occurrences of type synonyms. +-- clearSynonyms :: Type -> Type +-- clearSynonyms t' +-- -- split type constructors +-- | Just (tyCon, tys) <- splitTyConApp_maybe t +-- = mkTyConApp tyCon $ map clearSynonyms tys +-- -- split foralls +-- | (bndrs@(_:_), t1) <- splitForAllTys t +-- = mkSpecForAllTys bndrs $ clearSynonyms t1 +-- -- split arrow types +-- | Just (at, rt) <- splitFunTy_maybe t +-- = mkFunTy (clearSynonyms at) (clearSynonyms rt) +-- | otherwise +-- = t +-- where +-- stripOuter x = case tcView x of +-- Nothing -> x +-- Just y -> stripOuter y +-- t = stripOuter t' + + +-- | Depth-first lookup of the first occurrence of any type family. +-- First argument is a list of types to ignore. +lookupFamily :: [Type] -> Type -> Maybe (FamTyConFlav, Type) +lookupFamily ignoreLst t + -- split type constructors + | Just (tyCon, tys) <- splitTyConApp_maybe t + = case foldMap (First . lookupFamily ignoreLst) tys of + First (Just r) -> Just r + First Nothing -> famTyConFlav_maybe tyCon >>= \ff -> + if any (eqType t) ignoreLst + then Nothing + else Just (ff, t) + -- split foralls + | (_:_, t') <- splitForAllTys t + = lookupFamily ignoreLst t' + -- split arrow types + | Just (at, rt) <- splitFunTy_maybe t + = lookupFamily ignoreLst at <|> lookupFamily ignoreLst rt + | otherwise + = Nothing + + +-- | Enumerate available family instances and substitute type arguments, +-- such that original type family can be replaced with any +-- of the types in the output list. +-- It passes a TCvSubst alongside with the substituted Type. +-- The substituted Type may have TyVars from the result set of the substitution, +-- thus I must be careful with using it: +-- either somehow substitute back these tyvars from the result, +-- or substitute the whole type that contains this family occurrence. +-- +-- return Nothing means cannot expand family (shall use it as-is); +-- return (Just []) means all instances contradict family arguments. +expandFamily :: ModGuts + -> FamTyConFlav + -> Type + -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]) +-- cannot help here +expandFamily _ AbstractClosedSynFamilyTyCon{} _ = pure Nothing +-- .. and here +expandFamily _ BuiltInSynFamTyCon{} _ = pure Nothing +-- .. closed type families with no equations cannot be helped either +expandFamily _ (ClosedSynFamilyTyCon Nothing) _ = pure Nothing +-- For a closed type family, equations are accessible right there +expandFamily _ (ClosedSynFamilyTyCon (Just coax)) ft + = withFamily ft (pure Nothing) $ const $ expandClosedFamily os bcs + where + bcs = fromBranches $ coAxiomBranches coax + os = if any (not . null . coAxBranchIncomps) bcs + then map overlap bcs else repeat NoOverlap + overlap cb = if null $ coAxBranchIncomps cb + then Overlapping + else Incoherent +-- For a data family or an open type family, I need to lookup instances +-- in the family instance environment. +expandFamily guts DataFamilyTyCon{} ft + = withFamily ft (pure Nothing) $ expandDataFamily guts +expandFamily guts OpenSynFamilyTyCon ft + = withFamily ft (pure Nothing) $ expandOpenFamily guts + +withFamily :: Type -> a -> (TyCon -> [Type] -> a) -> a +withFamily ft def f = case splitTyConApp_maybe ft of + Nothing -> def + Just (tc, ts) -> f tc ts + + +-- | The same as `expandFamily`, but I know already that the family is closed. +expandClosedFamily :: [OverlapMode] + -> [CoAxBranch] + -> [Type] -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]) +-- empty type family -- leave it as-is +expandClosedFamily _ [] _ = pure Nothing +expandClosedFamily os bs fTyArgs = fmap (Just . catMaybes) $ traverse go $ zip os bs + where + go (om, cb) = do + let flhs' = coAxBranchLHS cb + n = length flhs' + tvs' = tyCoVarsOfTypesWellScoped flhs' + tvs <- traverse freshenTyVar tvs' + let freshenSub = zipTvSubst tvs' $ map mkTyVarTy tvs + flhs = substTys freshenSub flhs' + frhs = substTyAddInScope freshenSub $ coAxBranchRHS cb + t = foldl mkAppTy frhs $ drop n fTyArgs + msub = Unify.tcMatchTys (take n fTyArgs) flhs + return $ (,,) om t <$> msub + + + +-- | The same as `expandFamily`, but I know already that the family is open. +expandOpenFamily :: ModGuts + -> TyCon -- ^ Type family construtor + -> [Type] -- ^ Type family arguments + -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]) +expandOpenFamily guts fTyCon fTyArgs = do + tfInsts <- lookupTyFamInstances guts fTyCon + if null tfInsts + then pure $ Just [] -- No mercy + else expandClosedFamily + (repeat NoOverlap) + (coAxiomSingleBranch . FamInstEnv.famInstAxiom <$> tfInsts) + fTyArgs + + +-- | The same as `expandFamily`, but I know already that this is a data family. +expandDataFamily :: ModGuts + -> TyCon -- ^ Type family construtor + -> [Type] -- ^ Type family arguments + -> CorePluginM (Maybe [(OverlapMode, Type, TCvSubst)]) +expandDataFamily guts fTyCon fTyArgs = do + tfInsts <- lookupTyFamInstances guts fTyCon + if null tfInsts + then pure $ Just [] -- No mercy + else sequence <$> traverse expandDInstance tfInsts + where + expandDInstance inst + | fitvs <- FamInstEnv.fi_tvs inst + = do + tvs <- traverse freshenTyVar $ fitvs + let freshenSub = zipTvSubst fitvs $ map mkTyVarTy tvs + fitys = substTys freshenSub $ FamInstEnv.fi_tys inst + instTyArgs = align fTyArgs fitys + return $ (,,) NoOverlap (mkTyConApp fTyCon instTyArgs) + <$> Unify.tcMatchTys fTyArgs instTyArgs + align [] _ = [] + align xs [] = xs + align (_:xs) (y:ys) = y : align xs ys + + +data MatchingInstance = MatchingInstance + { miInst :: ClsInst + -- ^ Original found instance for the base type (as declared somewhere); + -- It contains the signature and original DFunId + , miInstTyVars :: [DFunInstType] + -- ^ How TyVars of miOrigBaseClsInst should be replaced to make it as + -- an instance for the base type; + -- e.g. a TyVar may be instantiated with a concrete type + -- (which may or may not contain more type variables). + , miTheta :: [(PredType, MatchingPredType)] + -- ^ Original pred types and how they are going to be transformed + } + +instance Outputable MatchingInstance where + ppr MatchingInstance {..} = hang "MatchingInstance" 2 $ vcat + [ "{ miInst =" <+> ppr miInst + , ", miInstTyVars =" <+> ppr miInstTyVars + , ", miTheta =" <+> ppr miTheta + ] + +{- +Resolving theta types: + +1. Class constraints: every time check + a. if there is an instance, substitute corresponding DFunIds and be happy. + b. if there is no instance and no tyvars, then fail + c. otherwise propagate the constraint further. + +2. Equality constraints: check equality + a. Types are equal (and tyvars inside equal as well): + Substitute mkReflCo + b. Types are unifiable: + Propagate constraint further + c. Types are non-unifiable: + Discard the whole instance declaration. + -} +data MatchingPredType + = MptInstance MatchingInstance + -- ^ Found an instance + | MptReflexive Coercion + -- ^ The equality become reflexive after a tyvar substitution + | MptPropagateAs PredType + -- ^ Could do nothing, but there is still hope due to the present tyvars + +instance Outputable MatchingPredType where + ppr (MptInstance x) = "MptInstance" <+> ppr x + ppr (MptReflexive x) = "MptReflexive" <+> ppr x + ppr (MptPropagateAs x) = "MptPropagateAs" <+> ppr x + +findInstance :: InstEnv.InstEnvs + -> Type + -> ClsInst + -> Maybe MatchingInstance +findInstance ie t i + | -- Most important: some part of the instance parameters must unify to arg + Just sub <- getFirst $ foldMap (First . flip (recMatchTyKi False) t) iTyPams + -- substituted type parameters of the class + , newTyPams <- map (substTyAddInScope sub) iTyPams + -- This tells us how instance tyvars change after matching the type + = matchInstance ie iClass newTyPams + | otherwise + = Nothing + where + (_, _, iClass, iTyPams) = InstEnv.instanceSig i + + +matchInstance :: InstEnv.InstEnvs + -> Class + -> [Type] + -> Maybe MatchingInstance +matchInstance ie cls ts + | ([(i, tyVarSubs)], _notMatchButUnify, _safeHaskellStuff) + <- InstEnv.lookupInstEnv False ie cls ts + , (iTyVars, iTheta, _, _) <- InstEnv.instanceSig i + , sub <- mkTvSubstPrs + . catMaybes $ zipWith (fmap . (,)) iTyVars tyVarSubs + = do + + mpts <- traverse (matchPredType ie . substTyAddInScope sub) iTheta + return MatchingInstance + { miInst = i + , miInstTyVars = tyVarSubs + , miTheta = zip iTheta mpts + } + | otherwise + = Nothing + +matchPredType :: InstEnv.InstEnvs + -> PredType + -> Maybe MatchingPredType +matchPredType ie pt = go $ classifyPredType pt + where + go (ClassPred cls ts) + | Just mi <- matchInstance ie cls ts + = Just $ MptInstance mi + -- we could not find an instance, but also there are no tyvars (and no hope) + | [] <- tyCoVarsOfTypesWellScoped ts + = Nothing + | otherwise = Just $ MptPropagateAs pt + go (EqPred rel t1 t2) + | eqType t1 t2 = Just . MptReflexive $ case rel of + NomEq -> mkReflCo Nominal t1 + ReprEq -> mkReflCo Representational t1 + | Unify.typesCantMatch [(t1,t2)] + = Nothing + | otherwise = Just $ MptPropagateAs pt + go _ = Just $ MptPropagateAs pt + + +type TyExp = (Type, CoreExpr) +type TyBndr = (Type, CoreBndr) + + +mtmiToExpression :: MatchingType + -> MatchingInstance + -> CorePluginM TyExp +mtmiToExpression MatchingType {..} mi = do + (bndrs, (tOrig, e)) <- miToExpression' [] mi + let extraTheta + = filter (\t -> not $ any (eqType t . fst) bndrs) mtTheta + tRepl = replaceTypeOccurrences mtBaseType mtNewType tOrig + tFun = mkFunTys (extraTheta ++ map fst bndrs) tRepl + tvs = tyCoVarsOfTypeWellScoped tFun + return + ( mkSpecForAllTys tvs tFun + , mkCoreLams (tvs ++ map mkWildValBinder extraTheta ++ map snd bndrs) + $ mkCast e + $ mkUnsafeCo Representational tOrig tRepl + ) + + +-- | Construct a core expression and a corresponding type. +-- It does not bind arguments; +-- uses only types and vars present in MatchingInstance; +-- may create a few vars for PredTypes, they are returned in fst. +miToExpression' :: [TyExp] + -- ^ types and expressions of the PredTypes that are in scope + -> MatchingInstance + -> CorePluginM ([TyBndr], TyExp) + -- (what to add to lambda, and the final expression) +miToExpression' availPTs MatchingInstance {..} = do + (bndrs, eArgs) <- addArgs availPTs $ map snd miTheta + return + ( bndrs + , ( newIHead + , mkCoreApps eDFunWithTyPams eArgs + ) + ) + where + (iTyVars, _, iClass, iTyPams) = InstEnv.instanceSig miInst + -- this is the same length as iTyVars, needs to be applied on dFunId + tyVarVals = zipWith (fromMaybe . mkTyVarTy) iTyVars miInstTyVars + sub = mkTvSubstPrs . catMaybes + $ zipWith (fmap . (,)) iTyVars miInstTyVars + newTyPams = map (substTyAddInScope sub) iTyPams + newIHead = mkTyConApp (classTyCon iClass) newTyPams + eDFun = Var $ InstEnv.instanceDFunId miInst + eDFunWithTyPams = mkTyApps eDFun tyVarVals + addArgs :: [TyExp] + -> [MatchingPredType] + -> CorePluginM ([TyBndr], [CoreExpr]) + addArgs _ [] = pure ([], []) + addArgs ps (x:xs) = do + (tbdrs, e) <- mptToExpression ps x + let ps' = ps ++ map (Var <$>) tbdrs + (tbdrs', es) <- addArgs ps' xs + return + ( tbdrs ++ tbdrs' + , e:es + ) + + +-- | Construct an expression to put as a PredType argument. +-- It may need to produce a new type variable. +mptToExpression :: [TyExp] + -> MatchingPredType + -> CorePluginM ([TyBndr], CoreExpr) +mptToExpression ps (MptInstance mi) + = fmap snd <$> miToExpression' ps mi +mptToExpression _ (MptReflexive c) + = pure ([], Coercion c) +mptToExpression ps (MptPropagateAs pt) + = case mte of + Just e -> pure ([], e) + Nothing -> do + loc <- liftCoreM getSrcSpanM + u <- getUniqueM + let n = mkInternalName u + (mkOccName OccName.varName $ "dFunArg_" ++ show u) loc + v = mkLocalIdOrCoVar n pt + return ([(pt,v)], Var v) + where + mte = getFirst $ foldMap getSamePT ps + getSamePT (t, e) + | eqType t pt = First $ Just e + | otherwise = First Nothing + +-- | For a given most concrete type, find all possible class instances. +-- Derive them all by creating a new CoreBind with a casted type. +-- +-- Prerequisite: in the tripple (overlapmode, baseType, newType), +-- TyVars of the newType must be a superset of TyVars of the baseType. +lookupMatchingInstances :: DeriveAll + -> ModGuts + -> MatchingType + -> CorePluginM [(ClsInst, CoreBind)] +lookupMatchingInstances da guts mt + | Just bTyCon <- tyConAppTyCon_maybe $ mtBaseType mt = do + ie <- getInstEnvs guts + let clsInsts = lookupClsInsts ie bTyCon + pluginDebug $ hang "lookupMatchingInstances candidate instances:" 2 $ + vcat $ map ppr clsInsts + catMaybes <$> traverse (lookupMatchingInstance da ie mt) clsInsts + | otherwise = fmap (const []) . pluginDebug $ hcat + [ text "DeriveAll.lookupMatchingInstances found no class instances for " + , ppr (mtBaseType mt) + , text ", because it could not get the type constructor." + ] + + +lookupMatchingInstance :: DeriveAll + -> InstEnv.InstEnvs + -> MatchingType + -> ClsInst + -> CorePluginM (Maybe (ClsInst, CoreBind)) +lookupMatchingInstance da ie mt@MatchingType {..} baseInst + | not . unwantedName da $ getName iClass + , all (noneTy (unwantedName DeriveAll)) iTyPams + = case findInstance ie mtBaseType baseInst of + Just mi -> do + (t, e) <- mtmiToExpression mt mi + newN <- newName (occNameSpace baseDFunName) + $ occNameString baseDFunName + ++ show (getUnique baseDFunId) -- unique per baseDFunId + ++ newtypeNameS -- unique per newType + let (newTyVars, _, _, newTyPams) = tcSplitDFunTy t + newDFunId = mkExportedLocalId + (DFunId isNewType) newN t + return $ Just + ( InstEnv.mkLocalInstance + newDFunId + ( deriveAllMode da $ mappend mtOverlapMode baseOM ) + newTyVars iClass newTyPams + , NonRec newDFunId e + ) + Nothing + -- in case if the instance is more specific than the MatchingType, + -- substitute types and try again + | Just sub <- getFirst + $ foldMap (First . flip (recMatchTyKi True) mtBaseType) iTyPams + -> lookupMatchingInstance da ie (substMatchingType sub mt) baseInst + | otherwise + -> do + pluginDebug $ hang "Ignored instance" 2 + $ ppr mtBaseType <+> ppr baseInst + pure Nothing + | otherwise + = pure Nothing + where + deriveAllMode (DeriveAll' m _) _ = toOverlapFlag m + deriveAllMode _ m = toOverlapFlag m + baseOM = instanceOverlapMode baseInst + baseDFunId = InstEnv.instanceDFunId baseInst + (_, _, iClass, iTyPams) = InstEnv.instanceSig baseInst + isNewType = isNewTyCon (classTyCon iClass) + baseDFunName = occName . idName $ baseDFunId + newtypeNameS = case tyConAppTyCon_maybe mtNewType of + Nothing -> "DeriveAll-generated" + Just tc -> occNameString $ occName $ tyConName tc + + +-- checks if none of the names in the type satisfy the predicate +noneTy :: (Name -> Bool) -> Type -> Bool +noneTy f = not . uniqSetAny f . orphNamesOfType +#if __GLASGOW_HASKELL__ < 802 + where + uniqSetAny g = foldl (\a -> (||) a . g) False +#endif + +unwantedName :: DeriveAll -> Name -> Bool +unwantedName da n + | modName == "GHC.Generics" = True + | modName == "Data.Typeable" = True + | modName == "Data.Data" = True + | "Language.Haskell.TH" + `isPrefixOf` modName = True + | valName == "Coercible" = True + | DeriveAllBut xs <- da + , valName `elem` xs = True + | DeriveAll' _ xs <- da + , valName `elem` xs = True + | otherwise = False + where + modName = moduleNameString . moduleName $ nameModule n + valName = occNameString $ getOccName n
src/Data/Constraint/Deriving/ToInstance.hs view
@@ -1,278 +1,278 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-module Data.Constraint.Deriving.ToInstance- ( ToInstance (..)- , OverlapMode (..)- , toInstancePass- , CorePluginEnvRef, initCorePluginEnv- ) where--import Class (Class, classTyCon)-import Control.Applicative (Alternative (..))-import Control.Monad (join, unless)-import Data.Data (Data)-import Data.Maybe (fromMaybe, isJust)-import Data.Monoid (First (..))-import GhcPlugins hiding (OverlapMode (..), overlapMode)-import qualified InstEnv-import qualified OccName-import Panic (panicDoc)-import qualified Unify--import Data.Constraint.Deriving.CorePluginM---{- | A marker to tell the core plugin to convert a top-level `Data.Constraint.Dict` binding into- an instance declaration.-- Example:--@-type family FooFam a where- FooFam Int = Int- FooFam a = Double--data FooSing a where- FooInt :: FooSing Int- FooNoInt :: FooSing a--class FooClass a where- fooSing :: FooSing a--newtype Bar a = Bar (FooFam a)--{\-\# ANN fooNum (ToInstance NoOverlap) \#-\}-fooNum :: forall a . Dict (Num (Bar a))-fooNum = mapDict (unsafeDerive Bar) $ case fooSing @a of- FooInt -> Dict- FooNoInt -> Dict-@-- Note:-- * `fooNum` should be exported by the module- (otherwise, it may be optimized-out before the core plugin pass);- * Constraints of the function become constraints of the new instance;- * The argument of `Dict` must be a single class (no constraint tuples or equality constraints);- * The instance is created in a core-to-core pass, so it does not exist for the type checker in the current module.- -}-newtype ToInstance = ToInstance { overlapMode :: OverlapMode }- deriving (Eq, Show, Read, Data)---- | Run `ToInstance` plugin pass-toInstancePass :: CorePluginEnvRef -> CoreToDo-toInstancePass eref = CoreDoPluginPass "Data.Constraint.Deriving.ToInstance"- -- if a plugin pass totally fails to do anything useful,- -- copy original ModGuts as its output, so that next passes can do their jobs.- (\x -> fromMaybe x <$> runCorePluginM (toInstancePass' x) eref)--toInstancePass' :: ModGuts -> CorePluginM ModGuts-toInstancePass' gs = go (reverse $ mg_binds gs) annotateds gs- where- annotateds :: UniqFM [(Name, ToInstance)]- annotateds = getModuleAnns gs-- go :: [CoreBind] -> UniqFM [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts- -- All exports are processed, just return ModGuts- go [] anns guts = do- unless (isNullUFM anns) $- pluginWarning $ "One or more ToInstance annotations are ignored:"- $+$ vcat- (map (pprBulletNameLoc . fst) . join $ eltsUFM anns)- $$ "Note possible issues:"- $$ pprNotes- [ "ToInstance is meant to be used only on bindings of type Ctx => Dict (Class t1 .. tn)."- , "Currently, I process non-recursive bindings only."- , sep- [ "Non-exported bindings may vanish before the plugin pass:"- , "make sure you export annotated definitions!"- ]- ]- return guts-- -- process type definitions present in the set of annotations- go (cbx@(NonRec x _):xs) anns guts- | Just ((xn, ti):ds) <- lookupUFM anns x = do- unless (null ds) $- pluginLocatedWarning (nameSrcSpan xn) $- "Ignoring redundant ToInstance annotions" $$- hcat- [ "(the plugin needs only one annotation per binding, but got "- , speakN (length ds + 1)- , ")"- ]- -- add new definitions and continue- try (toInstance ti cbx) >>= \case- Nothing- -> go xs (delFromUFM anns x) guts- Just (newInstance, newBind)- -> go xs (delFromUFM anns x)- (replaceInstance newInstance newBind guts)- { -- Remove original binding from the export list- -- if it was there.- mg_exports = filterAvails (xn /=) $ mg_exports guts- }-- -- ignore the rest of bindings- go (_:xs) anns guts = go xs anns guts-- pprBulletNameLoc n = hsep- [" " , bullet, ppr $ occName n, ppr $ nameSrcSpan n]- pprNotes = vcat . map (\x -> hsep [" ", bullet, x])---- | Transform a given CoreBind into an instance.------ The input core bind must have type `Ctx => Dict (Class t1 .. tn)`------ The output is `instance {-# overlapMode #-} Ctx => Class t1 ... tn`-toInstance :: ToInstance -> CoreBind -> CorePluginM (InstEnv.ClsInst, CoreBind)--toInstance _ (Rec xs) = do- loc <- liftCoreM getSrcSpanM- pluginLocatedError- (fromMaybe loc $ getFirst $ foldMap (First . Just . nameSrcSpan . getName . fst) xs)- $ "ToInstance plugin pass does not support recursive bindings"- $$ hsep ["(group:", pprQuotedList (map (getName . fst) xs), ")"]--toInstance (ToInstance omode) (NonRec bindVar bindExpr) = do- -- check if all type arguments are constraint arguments- unless (all (isConstraintKind . typeKind) theta) $- pluginLocatedError loc notGoodMsg-- -- get necessary definitions- tcBareConstraint <- ask tyConBareConstraint- tcDict <- ask tyConDict- fDictToBare <- ask funDictToBare- varCls <- newTyVar constraintKind- let tyMatcher = mkTyConApp tcDict [mkTyVarTy varCls]-- -- Get instance definition- match <- case Unify.tcMatchTy tyMatcher dictTy of- Nothing -> pluginLocatedError loc notGoodMsg- Just ma -> pure ma- let matchedTy = substTyVar match varCls- instSig = mkSpecForAllTys bndrs $ mkFunTys theta matchedTy- bindBareTy = mkSpecForAllTys bndrs $ mkFunTys theta $ mkTyConApp tcBareConstraint [matchedTy]-- -- check if constraint is indeed a class and get it- matchedClass <- case tyConAppTyCon_maybe matchedTy >>= tyConClass_maybe of- Nothing -> pluginLocatedError loc notGoodMsg- Just cl -> pure cl-- -- try to apply dictToBare to the expression of the found binding- mnewExpr <- try $ unwrapDictExpr dictTy fDictToBare bindExpr- newExpr <- case mnewExpr of- Nothing -> pluginLocatedError loc notGoodMsg- Just ex -> pure $ mkCast ex- $ mkUnsafeCo Representational bindBareTy instSig--- mkNewInstance omode matchedClass bindVar newExpr-- where- origBindTy = idType bindVar- (bndrs, bindTy) = splitForAllTys origBindTy- (theta, dictTy) = splitFunTys bindTy- loc = nameSrcSpan $ getName bindVar- notGoodMsg =- "ToInstance plugin pass failed to process a Dict declaraion."- $$ "The declaration must have form `forall a1..an . Ctx => Dict (Cls t1..tn)'"- $$ "Declaration:"- $$ hcat- [ " "- , ppr bindVar, " :: "- , ppr origBindTy- ]- $$ ""- $$ "Please check:"- $$ vcat- ( map (\s -> hsep [" ", bullet, s])- [ "It must not have arguments (i.e. is it not a fuction, but a value);"- , "It must have type Dict;"- , "The argument of Dict must be a single class (e.g. no constraint tuples or equalities);"- , "It must not have implicit arguments or any other complicated things."- ]- )---- This fails if the CoreExpr type is not valid instance signature.-mkNewInstance :: OverlapMode- -> Class- -> Id -- ^ Original core binding (with old type)- -> CoreExpr -- ^ implementation, with a proper new type (instance signature)- -> CorePluginM (InstEnv.ClsInst, CoreBind)-mkNewInstance omode cls bindVar bindExpr = do- n <- newName OccName.varName- $ getOccString bindVar ++ "_ToInstance"- let iDFunId = mkExportedLocalId- (DFunId $ isNewTyCon (classTyCon cls))- n itype- return- ( InstEnv.mkLocalInstance iDFunId ioflag tvs cls tys- , NonRec iDFunId bindExpr- )- where- ioflag = toOverlapFlag omode- itype = exprType bindExpr-- (tvs, itype') = splitForAllTys itype- (_, typeBody) = splitFunTys itype'- tys = fromMaybe aAaaOmg $ tyConAppArgs_maybe typeBody- aAaaOmg = panicDoc "ToInstance" $ hsep- [ "Impossible happened:"- , "expected a class constructor in mkNewInstance, but got"- , ppr typeBody- , "at", ppr $ nameSrcSpan $ getName bindVar- ]----- | Go through type applications and apply dictToBare function on `Dict c` type-unwrapDictExpr :: Type- -- ^ Dict c- --- -- Serves as stop test (if rhs expression matches the type)- -> Id- -- ^ dictToBare :: forall (c :: Constraint) . Dict c -> BareConstraint c- -> CoreExpr- -- ^ forall a1..an . (Ctx1,.. Ctxn) => Dict c- -> CorePluginM CoreExpr- -- ^ forall a1..an . (Ctx1,.. Ctxn) => BareConstraint c-unwrapDictExpr dictT unwrapFun ex = case ex of- Var _ -> testNWrap unwrapFail <|> (mkLamApp >>= proceed)- Lit _ -> testNWrap unwrapFail- App e a -> testNWrap $ (App e <$> proceed a) <|> (flip App a <$> proceed e)- Lam b e -> testNWrap $ Lam b <$> proceed e- Let b e -> testNWrap $ Let b <$> proceed e- Case{} -> testNWrap unwrapFail- Cast{} -> testNWrap unwrapFail- Tick t e -> testNWrap $ Tick t <$> proceed e- Type{} -> unwrapFail- Coercion{} -> unwrapFail- where- unwrapFail = pluginError- $ "Failed to match a definition signature."- $$ hang "Looking for a dictionary:" 2 (ppr dictT)- $$ hang "Inspecting an expression:" 2- (hsep [ppr ex, "::", ppr $ exprType ex])- proceed = unwrapDictExpr dictT unwrapFun- testNWrap go = if testType ex then wrap ex else go- wrap e = flip fmap (getClsT e) $ \t -> Var unwrapFun `App` t `App` e- -- type variables may differ, so I need to use tcMatchTy.- -- I do not check if resulting substition is not trivial. Shall I?- testType = isJust . Unify.tcMatchTy dictT . exprType- getClsT e = case tyConAppArgs_maybe $ exprType e of- Just [t] -> pure $ Type t- _ -> unwrapFail- mkThetaVar (i, ty) = newLocalVar ty ("theta" ++ show (i :: Int))- mkLamApp =- let et0 = exprType ex- (bndrs, et1) = splitForAllTys et0- (theta, _ ) = splitFunTys et1- in if null bndrs && null theta- then unwrapFail- else do- thetaVars <- traverse mkThetaVar $ zip [1 ..] theta- let allVars = bndrs ++ thetaVars- allApps = map (Type . mkTyVarTy) bndrs ++ map Var thetaVars- fullyApplied = foldl App ex allApps- return $ foldr Lam fullyApplied allVars+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.Constraint.Deriving.ToInstance + ( ToInstance (..) + , OverlapMode (..) + , toInstancePass + , CorePluginEnvRef, initCorePluginEnv + ) where + +import Class (Class, classTyCon) +import Control.Applicative (Alternative (..)) +import Control.Monad (join, unless) +import Data.Data (Data) +import Data.Maybe (fromMaybe, isJust) +import Data.Monoid (First (..)) +import GhcPlugins hiding (OverlapMode (..), overlapMode) +import qualified InstEnv +import qualified OccName +import Panic (panicDoc) +import qualified Unify + +import Data.Constraint.Deriving.CorePluginM + + +{- | A marker to tell the core plugin to convert a top-level `Data.Constraint.Dict` binding into + an instance declaration. + + Example: + +@ +type family FooFam a where + FooFam Int = Int + FooFam a = Double + +data FooSing a where + FooInt :: FooSing Int + FooNoInt :: FooSing a + +class FooClass a where + fooSing :: FooSing a + +newtype Bar a = Bar (FooFam a) + +{\-\# ANN fooNum (ToInstance NoOverlap) \#-\} +fooNum :: forall a . Dict (Num (Bar a)) +fooNum = mapDict (unsafeDerive Bar) $ case fooSing @a of + FooInt -> Dict + FooNoInt -> Dict +@ + + Note: + + * `fooNum` should be exported by the module + (otherwise, it may be optimized-out before the core plugin pass); + * Constraints of the function become constraints of the new instance; + * The argument of `Dict` must be a single class (no constraint tuples or equality constraints); + * The instance is created in a core-to-core pass, so it does not exist for the type checker in the current module. + -} +newtype ToInstance = ToInstance { overlapMode :: OverlapMode } + deriving (Eq, Show, Read, Data) + +-- | Run `ToInstance` plugin pass +toInstancePass :: CorePluginEnvRef -> CoreToDo +toInstancePass eref = CoreDoPluginPass "Data.Constraint.Deriving.ToInstance" + -- if a plugin pass totally fails to do anything useful, + -- copy original ModGuts as its output, so that next passes can do their jobs. + (\x -> fromMaybe x <$> runCorePluginM (toInstancePass' x) eref) + +toInstancePass' :: ModGuts -> CorePluginM ModGuts +toInstancePass' gs = go (reverse $ mg_binds gs) annotateds gs + where + annotateds :: UniqFM [(Name, ToInstance)] + annotateds = getModuleAnns gs + + go :: [CoreBind] -> UniqFM [(Name, ToInstance)] -> ModGuts -> CorePluginM ModGuts + -- All exports are processed, just return ModGuts + go [] anns guts = do + unless (isNullUFM anns) $ + pluginWarning $ "One or more ToInstance annotations are ignored:" + $+$ vcat + (map (pprBulletNameLoc . fst) . join $ eltsUFM anns) + $$ "Note possible issues:" + $$ pprNotes + [ "ToInstance is meant to be used only on bindings of type Ctx => Dict (Class t1 .. tn)." + , "Currently, I process non-recursive bindings only." + , sep + [ "Non-exported bindings may vanish before the plugin pass:" + , "make sure you export annotated definitions!" + ] + ] + return guts + + -- process type definitions present in the set of annotations + go (cbx@(NonRec x _):xs) anns guts + | Just ((xn, ti):ds) <- lookupUFM anns x = do + unless (null ds) $ + pluginLocatedWarning (nameSrcSpan xn) $ + "Ignoring redundant ToInstance annotions" $$ + hcat + [ "(the plugin needs only one annotation per binding, but got " + , speakN (length ds + 1) + , ")" + ] + -- add new definitions and continue + try (toInstance ti cbx) >>= \case + Nothing + -> go xs (delFromUFM anns x) guts + Just (newInstance, newBind) + -> go xs (delFromUFM anns x) + (replaceInstance newInstance newBind guts) + { -- Remove original binding from the export list + -- if it was there. + mg_exports = filterAvails (xn /=) $ mg_exports guts + } + + -- ignore the rest of bindings + go (_:xs) anns guts = go xs anns guts + + pprBulletNameLoc n = hsep + [" " , bullet, ppr $ occName n, ppr $ nameSrcSpan n] + pprNotes = vcat . map (\x -> hsep [" ", bullet, x]) + +-- | Transform a given CoreBind into an instance. +-- +-- The input core bind must have type `Ctx => Dict (Class t1 .. tn)` +-- +-- The output is `instance {-# overlapMode #-} Ctx => Class t1 ... tn` +toInstance :: ToInstance -> CoreBind -> CorePluginM (InstEnv.ClsInst, CoreBind) + +toInstance _ (Rec xs) = do + loc <- liftCoreM getSrcSpanM + pluginLocatedError + (fromMaybe loc $ getFirst $ foldMap (First . Just . nameSrcSpan . getName . fst) xs) + $ "ToInstance plugin pass does not support recursive bindings" + $$ hsep ["(group:", pprQuotedList (map (getName . fst) xs), ")"] + +toInstance (ToInstance omode) (NonRec bindVar bindExpr) = do + -- check if all type arguments are constraint arguments + unless (all (isConstraintKind . typeKind) theta) $ + pluginLocatedError loc notGoodMsg + + -- get necessary definitions + tcBareConstraint <- ask tyConBareConstraint + tcDict <- ask tyConDict + fDictToBare <- ask funDictToBare + varCls <- newTyVar constraintKind + let tyMatcher = mkTyConApp tcDict [mkTyVarTy varCls] + + -- Get instance definition + match <- case Unify.tcMatchTy tyMatcher dictTy of + Nothing -> pluginLocatedError loc notGoodMsg + Just ma -> pure ma + let matchedTy = substTyVar match varCls + instSig = mkSpecForAllTys bndrs $ mkFunTys theta matchedTy + bindBareTy = mkSpecForAllTys bndrs $ mkFunTys theta $ mkTyConApp tcBareConstraint [matchedTy] + + -- check if constraint is indeed a class and get it + matchedClass <- case tyConAppTyCon_maybe matchedTy >>= tyConClass_maybe of + Nothing -> pluginLocatedError loc notGoodMsg + Just cl -> pure cl + + -- try to apply dictToBare to the expression of the found binding + mnewExpr <- try $ unwrapDictExpr dictTy fDictToBare bindExpr + newExpr <- case mnewExpr of + Nothing -> pluginLocatedError loc notGoodMsg + Just ex -> pure $ mkCast ex + $ mkUnsafeCo Representational bindBareTy instSig + + + mkNewInstance omode matchedClass bindVar newExpr + + where + origBindTy = idType bindVar + (bndrs, bindTy) = splitForAllTys origBindTy + (theta, dictTy) = splitFunTys bindTy + loc = nameSrcSpan $ getName bindVar + notGoodMsg = + "ToInstance plugin pass failed to process a Dict declaraion." + $$ "The declaration must have form `forall a1..an . Ctx => Dict (Cls t1..tn)'" + $$ "Declaration:" + $$ hcat + [ " " + , ppr bindVar, " :: " + , ppr origBindTy + ] + $$ "" + $$ "Please check:" + $$ vcat + ( map (\s -> hsep [" ", bullet, s]) + [ "It must not have arguments (i.e. is it not a fuction, but a value);" + , "It must have type Dict;" + , "The argument of Dict must be a single class (e.g. no constraint tuples or equalities);" + , "It must not have implicit arguments or any other complicated things." + ] + ) + +-- This fails if the CoreExpr type is not valid instance signature. +mkNewInstance :: OverlapMode + -> Class + -> Id -- ^ Original core binding (with old type) + -> CoreExpr -- ^ implementation, with a proper new type (instance signature) + -> CorePluginM (InstEnv.ClsInst, CoreBind) +mkNewInstance omode cls bindVar bindExpr = do + n <- newName OccName.varName + $ getOccString bindVar ++ "_ToInstance" + let iDFunId = mkExportedLocalId + (DFunId $ isNewTyCon (classTyCon cls)) + n itype + return + ( InstEnv.mkLocalInstance iDFunId ioflag tvs cls tys + , NonRec iDFunId bindExpr + ) + where + ioflag = toOverlapFlag omode + itype = exprType bindExpr + + (tvs, itype') = splitForAllTys itype + (_, typeBody) = splitFunTys itype' + tys = fromMaybe aAaaOmg $ tyConAppArgs_maybe typeBody + aAaaOmg = panicDoc "ToInstance" $ hsep + [ "Impossible happened:" + , "expected a class constructor in mkNewInstance, but got" + , ppr typeBody + , "at", ppr $ nameSrcSpan $ getName bindVar + ] + + +-- | Go through type applications and apply dictToBare function on `Dict c` type +unwrapDictExpr :: Type + -- ^ Dict c + -- + -- Serves as stop test (if rhs expression matches the type) + -> Id + -- ^ dictToBare :: forall (c :: Constraint) . Dict c -> BareConstraint c + -> CoreExpr + -- ^ forall a1..an . (Ctx1,.. Ctxn) => Dict c + -> CorePluginM CoreExpr + -- ^ forall a1..an . (Ctx1,.. Ctxn) => BareConstraint c +unwrapDictExpr dictT unwrapFun ex = case ex of + Var _ -> testNWrap unwrapFail <|> (mkLamApp >>= proceed) + Lit _ -> testNWrap unwrapFail + App e a -> testNWrap $ (App e <$> proceed a) <|> (flip App a <$> proceed e) + Lam b e -> testNWrap $ Lam b <$> proceed e + Let b e -> testNWrap $ Let b <$> proceed e + Case{} -> testNWrap unwrapFail + Cast{} -> testNWrap unwrapFail + Tick t e -> testNWrap $ Tick t <$> proceed e + Type{} -> unwrapFail + Coercion{} -> unwrapFail + where + unwrapFail = pluginError + $ "Failed to match a definition signature." + $$ hang "Looking for a dictionary:" 2 (ppr dictT) + $$ hang "Inspecting an expression:" 2 + (hsep [ppr ex, "::", ppr $ exprType ex]) + proceed = unwrapDictExpr dictT unwrapFun + testNWrap go = if testType ex then wrap ex else go + wrap e = flip fmap (getClsT e) $ \t -> Var unwrapFun `App` t `App` e + -- type variables may differ, so I need to use tcMatchTy. + -- I do not check if resulting substition is not trivial. Shall I? + testType = isJust . Unify.tcMatchTy dictT . exprType + getClsT e = case tyConAppArgs_maybe $ exprType e of + Just [t] -> pure $ Type t + _ -> unwrapFail + mkThetaVar (i, ty) = newLocalVar ty ("theta" ++ show (i :: Int)) + mkLamApp = + let et0 = exprType ex + (bndrs, et1) = splitForAllTys et0 + (theta, _ ) = splitFunTys et1 + in if null bndrs && null theta + then unwrapFail + else do + thetaVars <- traverse mkThetaVar $ zip [1 ..] theta + let allVars = bndrs ++ thetaVars + allApps = map (Type . mkTyVarTy) bndrs ++ map Var thetaVars + fullyApplied = foldl App ex allApps + return $ foldr Lam fullyApplied allVars
test/Spec.hs view
@@ -1,232 +1,232 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-module Main (main) where--import Control.Monad (when)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS-import Data.Char (isSpace)-import Data.Foldable (fold)-import Data.List (sort)-import Data.Maybe (mapMaybe)-import Data.Monoid-import Data.Traversable (for)-import DynFlags-import ErrUtils (mkLocMessageAnn)-import GHC-import GHC.Paths (libdir)-import MonadUtils (liftIO)-import Outputable-import Path-import Path.IO-import System.Exit-import System.FilePath (isPathSeparator)-import System.IO---- | Folder with test modules to be compiled-specDir :: Path Rel Dir-specDir = [reldir|test/Spec/|]---- | Folder with expected compiler output dumps-outDir :: Path Rel Dir-outDir = [reldir|test/out/|]--correspondingStdOut :: Path a File -> Maybe (Path Rel File)-correspondingStdOut f = setFileExtension "stdout" $ outDir </> filename f--correspondingStdErr :: Path a File -> Maybe (Path Rel File)-correspondingStdErr f = setFileExtension "stderr" $ outDir </> filename f--data TargetPaths = TargetPaths- { targetName :: String- , targetPath :: FilePath- , stdoutPath :: FilePath- , stderrPath :: FilePath- } deriving (Eq, Ord)--lookupTargetPaths :: Path a File -> Maybe TargetPaths-lookupTargetPaths p = do- if fileExtension p == ".hs" then Just () else Nothing- targetPath <- Just $ toFilePath p- targetName <- toFilePath <$> setFileExtension "" (filename p)- stdoutPath <- toFilePath <$> correspondingStdOut p- stderrPath <- toFilePath <$> correspondingStdErr p- return TargetPaths {..}---main :: IO ()-main = do- targetPaths <- sort . mapMaybe lookupTargetPaths <$>- (listDir specDir >>= traverse makeRelativeToCurrentDir . snd)- withSystemTempFile "constraints-deriving-stdout" $ \_ outH ->- withSystemTempFile "constraints-deriving-stderr" $ \_ errH ->- withSystemTempDir "constraints-deriving-tests" $ \tempDir -> do- r <- defaultErrorHandler defaultFatalMessager defaultFlushOut $- runGhc (Just libdir) $ do- dflags' <- makeSimpleAndFast <$> getSessionDynFlags- (dflags, _, _) <- parseDynamicFlags dflags'- { log_action = manualLogAction outH errH}- [ noLoc "-Wall"- , noLoc "-hide-all-packages"- , noLoc "-package ghc"- , noLoc "-package base"- , noLoc "-package constraints-deriving"- , noLoc "-dcore-lint"- , noLoc $ "-outputdir " ++ toFilePath tempDir]- _ <- setSessionDynFlags dflags- ghc800StaticFlagsFix- fmap fold $- for targetPaths $ \TargetPaths{..} -> do- -- compile the module- target <- guessTarget targetPath Nothing- setTargets [target]- outPos <- liftIO $ hGetPosn outH- errPos <- liftIO $ hGetPosn errH- resCompile <- isSucceeded <$> load LoadAllTargets- liftIO $ do- -- flush logging handles to make sure logs are written- hFlush outH- hFlush errH- hSetPosn outPos- hSetPosn errPos- -- compare logs against templates- outExpectedBS <- trimBS <$> BS.readFile stdoutPath- errExpectedBS <- trimBS <$> BS.readFile stderrPath- sameOut <- getSameBytes outExpectedBS outH- >>= reportSameBytes targetName "stdout" outExpectedBS- sameErr <- getSameBytes errExpectedBS errH- >>= reportSameBytes targetName "stderr" errExpectedBS- let rez = fold [sameOut, sameErr, resCompile]- when (rez == All True) $ do- putStrLn ""- putStrLn $ targetName ++ ": OK"- return rez- if getAll r- then exitSuccess- else exitFailure- where- isSucceeded Succeeded = All True- isSucceeded Failed = All False-- reportSameBytes _ _ _ SameBytes = pure $ All True- reportSameBytes modN ch temBs (Different resBs) = do- BS.putStrLn $ BS.unlines- [ "", ""- , "Failure testing module " `mappend` BS.pack modN `mappend` ":"- , " GHC " `mappend` ch `mappend` " does not match the expected output!"- , ""- , "---- Expected " `mappend` ch `mappend` " -----------------------------"- , temBs- , "---- Content of " `mappend` ch `mappend` " ---------------------------"- , resBs- , "--------------------------------------------------"- , ""- ]- return $ All False---data SameBytes = SameBytes | Different ByteString---- | Read a ByteString from a handle and compare it to the template------ Prerequisite: the template ByteString is trimmed (e.g. using trimBS)-getSameBytes :: ByteString -> Handle -> IO SameBytes-getSameBytes template handle =- checkSame . trimBS <$> getAvailableBytes (max 1024 (BS.length template + 16))- where- checkSame bs- | eqStar template bs = SameBytes- | otherwise = Different bs- getAvailableBytes k = do- bs <- BS.hGetNonBlocking handle k- if BS.length bs < k- then return bs- else mappend bs <$> getAvailableBytes (k * 2)---- | Eliminate whitespace characters on both sides of a ByteString-trimBS :: ByteString -> ByteString-trimBS = BS.map f . fst . BS.spanEnd isSpace . snd . BS.span isSpace- where- -- fix tests for Windows- f c = if isPathSeparator c then '/' else c---- | compare two ByteStrings such that the first can have wildcards '*'-eqStar :: ByteString -> ByteString -> Bool-eqStar template bs- -- empty output- | BS.null template = BS.null bs- -- template allows anything- | BS.all ('*' ==) template = True- -- template starts with a wildcard- | BS.null t1 = case BS.breakSubstring t21 bs of- (_, bs')- | BS.null bs' -> False- | otherwise -> eqStar t22- $ BS.drop (BS.length t21) bs'- -- otherwise match prefix- | otherwise = case BS.stripPrefix t1 bs of- -- could not match- Nothing -> False- -- could match a segment, continue- Just bs' -> eqStar t2 bs'- where- (t1 , t2 ) = BS.span ('*' /=) template- (t21, t22) = BS.span ('*' /=) $ BS.dropWhile ('*' ==) t2----makeSimpleAndFast :: DynFlags -> DynFlags-makeSimpleAndFast flags = flags- { ghcMode = OneShot- , ghcLink = NoLink- , verbosity = 1- , optLevel = 0- , ways = []- , useUnicode = False- } `gopt_set` Opt_DoCoreLinting- `gopt_set` Opt_ForceRecomp- `gopt_unset` Opt_PrintUnicodeSyntax---ghc800StaticFlagsFix :: Ghc ()-#if __GLASGOW_HASKELL__ >= 802-ghc800StaticFlagsFix = return ()-#else-ghc800StaticFlagsFix = do- decl <- parseImportDecl "import StaticFlags (initStaticOpts)"- setContext [IIDecl decl]- _ <- execStmt "initStaticOpts" execOptions- return ()-#endif---- | I've adapted the defaultLogAction from DynFlags with two goals in mind:------ 1. Make output as simple as possible (in particular, no utf-8)--- 2. Redirect stdout and stderr into dedicated handles------ These all is to make testing output easy across different GHC versions.-manualLogAction :: Handle -> Handle -> LogAction-manualLogAction outH errH dflags _reason severity srcSpan style msg- = case severity of- SevOutput -> printOut msg style- SevDump -> printOut (msg $$ blankLine) style- SevInteractive -> putStrSDoc msg style- SevInfo -> printErrs msg style- SevFatal -> printErrs msg style- SevWarning -> printWarns- SevError -> printWarns- where- printOut = defaultLogActionHPrintDoc dflags outH- printErrs = defaultLogActionHPrintDoc dflags errH- putStrSDoc = defaultLogActionHPutStrDoc dflags outH- message = mkLocMessageAnn Nothing severity srcSpan msg- printWarns = do- hPutChar errH '\n'- printErrs message-#if __GLASGOW_HASKELL__ >= 802- (setStyleColoured False style)-#else- style-#endif+{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Control.Monad (when) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Char (isSpace) +import Data.Foldable (fold) +import Data.List (sort) +import Data.Maybe (mapMaybe) +import Data.Monoid +import Data.Traversable (for) +import DynFlags +import ErrUtils (mkLocMessageAnn) +import GHC +import GHC.Paths (libdir) +import MonadUtils (liftIO) +import Outputable +import Path +import Path.IO +import System.Exit +import System.FilePath (isPathSeparator) +import System.IO + +-- | Folder with test modules to be compiled +specDir :: Path Rel Dir +specDir = [reldir|test/Spec/|] + +-- | Folder with expected compiler output dumps +outDir :: Path Rel Dir +outDir = [reldir|test/out/|] + +correspondingStdOut :: Path a File -> Maybe (Path Rel File) +correspondingStdOut f = setFileExtension "stdout" $ outDir </> filename f + +correspondingStdErr :: Path a File -> Maybe (Path Rel File) +correspondingStdErr f = setFileExtension "stderr" $ outDir </> filename f + +data TargetPaths = TargetPaths + { targetName :: String + , targetPath :: FilePath + , stdoutPath :: FilePath + , stderrPath :: FilePath + } deriving (Eq, Ord) + +lookupTargetPaths :: Path a File -> Maybe TargetPaths +lookupTargetPaths p = do + if fileExtension p == ".hs" then Just () else Nothing + targetPath <- Just $ toFilePath p + targetName <- toFilePath <$> setFileExtension "" (filename p) + stdoutPath <- toFilePath <$> correspondingStdOut p + stderrPath <- toFilePath <$> correspondingStdErr p + return TargetPaths {..} + + +main :: IO () +main = do + targetPaths <- sort . mapMaybe lookupTargetPaths <$> + (listDir specDir >>= traverse makeRelativeToCurrentDir . snd) + withSystemTempFile "constraints-deriving-stdout" $ \_ outH -> + withSystemTempFile "constraints-deriving-stderr" $ \_ errH -> + withSystemTempDir "constraints-deriving-tests" $ \tempDir -> do + r <- defaultErrorHandler defaultFatalMessager defaultFlushOut $ + runGhc (Just libdir) $ do + dflags' <- makeSimpleAndFast <$> getSessionDynFlags + (dflags, _, _) <- parseDynamicFlags dflags' + { log_action = manualLogAction outH errH} + [ noLoc "-Wall" + , noLoc "-hide-all-packages" + , noLoc "-package ghc" + , noLoc "-package base" + , noLoc "-package constraints-deriving" + , noLoc "-dcore-lint" + , noLoc $ "-outputdir " ++ toFilePath tempDir] + _ <- setSessionDynFlags dflags + ghc800StaticFlagsFix + fmap fold $ + for targetPaths $ \TargetPaths{..} -> do + -- compile the module + target <- guessTarget targetPath Nothing + setTargets [target] + outPos <- liftIO $ hGetPosn outH + errPos <- liftIO $ hGetPosn errH + resCompile <- isSucceeded <$> load LoadAllTargets + liftIO $ do + -- flush logging handles to make sure logs are written + hFlush outH + hFlush errH + hSetPosn outPos + hSetPosn errPos + -- compare logs against templates + outExpectedBS <- trimBS <$> BS.readFile stdoutPath + errExpectedBS <- trimBS <$> BS.readFile stderrPath + sameOut <- getSameBytes outExpectedBS outH + >>= reportSameBytes targetName "stdout" outExpectedBS + sameErr <- getSameBytes errExpectedBS errH + >>= reportSameBytes targetName "stderr" errExpectedBS + let rez = fold [sameOut, sameErr, resCompile] + when (rez == All True) $ do + putStrLn "" + putStrLn $ targetName ++ ": OK" + return rez + if getAll r + then exitSuccess + else exitFailure + where + isSucceeded Succeeded = All True + isSucceeded Failed = All False + + reportSameBytes _ _ _ SameBytes = pure $ All True + reportSameBytes modN ch temBs (Different resBs) = do + BS.putStrLn $ BS.unlines + [ "", "" + , "Failure testing module " `mappend` BS.pack modN `mappend` ":" + , " GHC " `mappend` ch `mappend` " does not match the expected output!" + , "" + , "---- Expected " `mappend` ch `mappend` " -----------------------------" + , temBs + , "---- Content of " `mappend` ch `mappend` " ---------------------------" + , resBs + , "--------------------------------------------------" + , "" + ] + return $ All False + + +data SameBytes = SameBytes | Different ByteString + +-- | Read a ByteString from a handle and compare it to the template +-- +-- Prerequisite: the template ByteString is trimmed (e.g. using trimBS) +getSameBytes :: ByteString -> Handle -> IO SameBytes +getSameBytes template handle = + checkSame . trimBS <$> getAvailableBytes (max 1024 (BS.length template + 16)) + where + checkSame bs + | eqStar template bs = SameBytes + | otherwise = Different bs + getAvailableBytes k = do + bs <- BS.hGetNonBlocking handle k + if BS.length bs < k + then return bs + else mappend bs <$> getAvailableBytes (k * 2) + +-- | Eliminate whitespace characters on both sides of a ByteString +trimBS :: ByteString -> ByteString +trimBS = BS.map f . fst . BS.spanEnd isSpace . snd . BS.span isSpace + where + -- fix tests for Windows + f c = if isPathSeparator c then '/' else c + +-- | compare two ByteStrings such that the first can have wildcards '*' +eqStar :: ByteString -> ByteString -> Bool +eqStar template bs + -- empty output + | BS.null template = BS.null bs + -- template allows anything + | BS.all ('*' ==) template = True + -- template starts with a wildcard + | BS.null t1 = case BS.breakSubstring t21 bs of + (_, bs') + | BS.null bs' -> False + | otherwise -> eqStar t22 + $ BS.drop (BS.length t21) bs' + -- otherwise match prefix + | otherwise = case BS.stripPrefix t1 bs of + -- could not match + Nothing -> False + -- could match a segment, continue + Just bs' -> eqStar t2 bs' + where + (t1 , t2 ) = BS.span ('*' /=) template + (t21, t22) = BS.span ('*' /=) $ BS.dropWhile ('*' ==) t2 + + + +makeSimpleAndFast :: DynFlags -> DynFlags +makeSimpleAndFast flags = flags + { ghcMode = OneShot + , ghcLink = NoLink + , verbosity = 1 + , optLevel = 0 + , ways = [] + , useUnicode = False + } `gopt_set` Opt_DoCoreLinting + `gopt_set` Opt_ForceRecomp + `gopt_unset` Opt_PrintUnicodeSyntax + + +ghc800StaticFlagsFix :: Ghc () +#if __GLASGOW_HASKELL__ >= 802 +ghc800StaticFlagsFix = return () +#else +ghc800StaticFlagsFix = do + decl <- parseImportDecl "import StaticFlags (initStaticOpts)" + setContext [IIDecl decl] + _ <- execStmt "initStaticOpts" execOptions + return () +#endif + +-- | I've adapted the defaultLogAction from DynFlags with two goals in mind: +-- +-- 1. Make output as simple as possible (in particular, no utf-8) +-- 2. Redirect stdout and stderr into dedicated handles +-- +-- These all is to make testing output easy across different GHC versions. +manualLogAction :: Handle -> Handle -> LogAction +manualLogAction outH errH dflags _reason severity srcSpan style msg + = case severity of + SevOutput -> printOut msg style + SevDump -> printOut (msg $$ blankLine) style + SevInteractive -> putStrSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + SevWarning -> printWarns + SevError -> printWarns + where + printOut = defaultLogActionHPrintDoc dflags outH + printErrs = defaultLogActionHPrintDoc dflags errH + putStrSDoc = defaultLogActionHPutStrDoc dflags outH + message = mkLocMessageAnn Nothing severity srcSpan msg + printWarns = do + hPutChar errH '\n' + printErrs message +#if __GLASGOW_HASKELL__ >= 802 + (setStyleColoured False style) +#else + style +#endif
test/Spec/DeriveAll01.hs view
@@ -1,24 +1,24 @@-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-module Spec.DeriveAll01 where--import Data.Constraint.Deriving---data family FooFam a b-data instance FooFam Int b = FooInt b Int- deriving Eq-data instance FooFam Double b = FooDouble Double b b- deriving Read-data instance FooFam Float Float = FooFloats Float Float- deriving (Eq, Ord)-data instance FooFam Float String = FooString Float String- deriving Show--{-# ANN type TestNewtype1 DeriveAll #-}-newtype TestNewtype1 a b = TestNewtype1C (FooFam a b)--{-# ANN type TestNewtype2 DeriveAll #-}-newtype TestNewtype2 a b r = TestNewtype2C r-type instance DeriveContext (TestNewtype2 a b r) = FooFam a b ~ r+{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +module Spec.DeriveAll01 where + +import Data.Constraint.Deriving + + +data family FooFam a b +data instance FooFam Int b = FooInt b Int + deriving Eq +data instance FooFam Double b = FooDouble Double b b + deriving Read +data instance FooFam Float Float = FooFloats Float Float + deriving (Eq, Ord) +data instance FooFam Float String = FooString Float String + deriving Show + +{-# ANN type TestNewtype1 DeriveAll #-} +newtype TestNewtype1 a b = TestNewtype1C (FooFam a b) + +{-# ANN type TestNewtype2 DeriveAll #-} +newtype TestNewtype2 a b r = TestNewtype2C r +type instance DeriveContext (TestNewtype2 a b r) = FooFam a b ~ r
test/Spec/DeriveAll02.hs view
@@ -1,37 +1,37 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-module Spec.DeriveAll02 where--import Data.Constraint.Deriving---data FooData a b c = FooDataCon Float b- deriving (Eq, Ord)--instance (a ~ Int, Show b) => Show (FooData a b c) where- show (FooDataCon f b) = "FooDataCon " ++ show f ++ " " ++ show b---type family FooFam a b c d e f-type instance FooFam a b c Double e f = FooData Int b c--class Ord b => FooClass a b c where- fooFun :: a -> b -> c- barFun :: a -> c -> b--instance (a ~ Int, Ord b, Show a) => FooClass (FooData a b c) b Float where- fooFun (FooDataCon f _) _ = f- barFun (FooDataCon _ b) _ = b---{-# ANN type BazTy DeriveAll #-}-newtype BazTy a b c d e f = BazCon (FooFam a b c d e f)---- Type class constraints are prepended to the instance arguments.--- Thus, they can be used to impose additional (fictional) constraints--- on the generated instances.-type instance DeriveContext (BazTy a b c d e f ) = Show e+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +module Spec.DeriveAll02 where + +import Data.Constraint.Deriving + + +data FooData a b c = FooDataCon Float b + deriving (Eq, Ord) + +instance (a ~ Int, Show b) => Show (FooData a b c) where + show (FooDataCon f b) = "FooDataCon " ++ show f ++ " " ++ show b + + +type family FooFam a b c d e f +type instance FooFam a b c Double e f = FooData Int b c + +class Ord b => FooClass a b c where + fooFun :: a -> b -> c + barFun :: a -> c -> b + +instance (a ~ Int, Ord b, Show a) => FooClass (FooData a b c) b Float where + fooFun (FooDataCon f _) _ = f + barFun (FooDataCon _ b) _ = b + + +{-# ANN type BazTy DeriveAll #-} +newtype BazTy a b c d e f = BazCon (FooFam a b c d e f) + +-- Type class constraints are prepended to the instance arguments. +-- Thus, they can be used to impose additional (fictional) constraints +-- on the generated instances. +type instance DeriveContext (BazTy a b c d e f ) = Show e
test/Spec/DeriveAll03.hs view
@@ -1,34 +1,34 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-module Spec.DeriveAll03 where--import Data.Constraint.Deriving--{-- Here I test three different things:-- * Deriving instances for the types defined elsewhere- (including the base library);- it should produce a lot of instances for all transitively- reachable modules.-- * Closed, injective type families - should not be a problem.-- * Higher-kinded types;- The following should produce instances for kind `Type`- (e.g. Show, Monoid)- as well as for kind `Type -> Type`- (e.g. Functor, Monad)- -}-data ListTy-data MaybeTy--type family FooFam m = r | r -> m where- FooFam ListTy = []- FooFam MaybeTy = Maybe--{-# ANN type BazTy DeriveAll #-}-newtype BazTy m a = BazCon (FooFam m a)+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +module Spec.DeriveAll03 where + +import Data.Constraint.Deriving + +{- + Here I test three different things: + + * Deriving instances for the types defined elsewhere + (including the base library); + it should produce a lot of instances for all transitively + reachable modules. + + * Closed, injective type families - should not be a problem. + + * Higher-kinded types; + The following should produce instances for kind `Type` + (e.g. Show, Monoid) + as well as for kind `Type -> Type` + (e.g. Functor, Monad) + -} +data ListTy +data MaybeTy + +type family FooFam m = r | r -> m where + FooFam ListTy = [] + FooFam MaybeTy = Maybe + +{-# ANN type BazTy DeriveAll #-} +newtype BazTy m a = BazCon (FooFam m a)
test/Spec/DeriveAll04.hs view
@@ -1,20 +1,20 @@-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-module Spec.DeriveAll04 where--import Data.Constraint.Deriving--{-- Here, I want to test overlapping type families and their wildcards- -}--data A = ACon deriving Eq-data B = BCon deriving Eq--type family AB x where- AB A = A- AB _ = B--{-# ANN type BazTy DeriveAll #-}-newtype BazTy a = BazCon (AB a)+{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +module Spec.DeriveAll04 where + +import Data.Constraint.Deriving + +{- + Here, I want to test overlapping type families and their wildcards + -} + +data A = ACon deriving Eq +data B = BCon deriving Eq + +type family AB x where + AB A = A + AB _ = B + +{-# ANN type BazTy DeriveAll #-} +newtype BazTy a = BazCon (AB a)
test/Spec/DeriveAll05.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-module Spec.DeriveAll05 where--import Data.Constraint.Deriving--data family AB x-data instance AB _ = B deriving Eq--{-# ANN type BazTy DeriveAll #-}-newtype BazTy a = BazCon (AB a)-+{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +module Spec.DeriveAll05 where + +import Data.Constraint.Deriving + +data family AB x +data instance AB _ = B deriving Eq + +{-# ANN type BazTy DeriveAll #-} +newtype BazTy a = BazCon (AB a) +
test/Spec/DeriveAll06.hs view
@@ -1,11 +1,11 @@-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-module Spec.DeriveAll06 where--import Data.Constraint.Deriving--data Bar = Bar | Baz- deriving (Eq, Ord, Show, Read, Enum)--{-# ANN type Foo (DeriveAllBut ["Show", "Read"]) #-}-newtype Foo a b = Foo Bar+{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +module Spec.DeriveAll06 where + +import Data.Constraint.Deriving + +data Bar = Bar | Baz + deriving (Eq, Ord, Show, Read, Enum) + +{-# ANN type Foo (DeriveAllBut ["Show", "Read"]) #-} +newtype Foo a b = Foo Bar
test/Spec/ToInstance01.hs view
@@ -1,52 +1,52 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-module Spec.ToInstance01 where--{--This is a minimal example for deriving multiple instances-for a newtype over a type family.--The plugin provides two advantages over manually implementing instances using singletons:-- * No need to implement every class function manually-- * Instance elaboration at the call site happens only once for many used functions,- rather than once for every fuction usage.- -}-import Data.Constraint-import Data.Constraint.Deriving-import Data.Constraint.Unsafe--newtype Number t = Number (NumberFam t)--type family NumberFam t where- NumberFam Int = Int- NumberFam Double = Double--data NumberSing t where- NumInt :: NumberSing Int- NumDouble :: NumberSing Double--class KnownNumber t where numberSing :: NumberSing t-instance KnownNumber Int where numberSing = NumInt-instance KnownNumber Double where numberSing = NumDouble--{-# ANN deriveEq (ToInstance NoOverlap) #-}-deriveEq :: KnownNumber t => Dict (Eq (Number t))-deriveEq = deriveIt numberSing--{-# ANN deriveOrd (ToInstance NoOverlap) #-}-deriveOrd :: KnownNumber t => Dict (Ord (Number t))-deriveOrd = deriveIt numberSing--{-# ANN deriveNum (ToInstance NoOverlap) #-}-deriveNum :: KnownNumber t => Dict (Num (Number t))-deriveNum = deriveIt numberSing--deriveIt :: (c Double, c Int) => NumberSing t -> Dict (c (Number t))-deriveIt NumInt = mapDict (unsafeDerive Number) Dict-deriveIt NumDouble = mapDict (unsafeDerive Number) Dict+{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +module Spec.ToInstance01 where + +{- +This is a minimal example for deriving multiple instances +for a newtype over a type family. + +The plugin provides two advantages over manually implementing instances using singletons: + + * No need to implement every class function manually + + * Instance elaboration at the call site happens only once for many used functions, + rather than once for every fuction usage. + -} +import Data.Constraint +import Data.Constraint.Deriving +import Data.Constraint.Unsafe + +newtype Number t = Number (NumberFam t) + +type family NumberFam t where + NumberFam Int = Int + NumberFam Double = Double + +data NumberSing t where + NumInt :: NumberSing Int + NumDouble :: NumberSing Double + +class KnownNumber t where numberSing :: NumberSing t +instance KnownNumber Int where numberSing = NumInt +instance KnownNumber Double where numberSing = NumDouble + +{-# ANN deriveEq (ToInstance NoOverlap) #-} +deriveEq :: KnownNumber t => Dict (Eq (Number t)) +deriveEq = deriveIt numberSing + +{-# ANN deriveOrd (ToInstance NoOverlap) #-} +deriveOrd :: KnownNumber t => Dict (Ord (Number t)) +deriveOrd = deriveIt numberSing + +{-# ANN deriveNum (ToInstance NoOverlap) #-} +deriveNum :: KnownNumber t => Dict (Num (Number t)) +deriveNum = deriveIt numberSing + +deriveIt :: (c Double, c Int) => NumberSing t -> Dict (c (Number t)) +deriveIt NumInt = mapDict (unsafeDerive Number) Dict +deriveIt NumDouble = mapDict (unsafeDerive Number) Dict
test/Spec/ToInstance02.hs view
@@ -1,43 +1,43 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-}-{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-}-module Spec.ToInstance02 where--{--Testing that variables, such as deriveEqOrig, may have TyVars (forall t);-ToInstance pass should be able to go through the vars and theta types and match-the RHS of the arrow (deriveEqOrig signature).- -}-import Data.Constraint-import Data.Constraint.Deriving-import Data.Constraint.Unsafe--newtype Number t = Number (NumberFam t)--type family NumberFam t where- NumberFam Int = Int- NumberFam Double = Double--data NumberSing t where- NumInt :: NumberSing Int- NumDouble :: NumberSing Double--class KnownNumber t where numberSing :: NumberSing t-instance KnownNumber Int where numberSing = NumInt-instance KnownNumber Double where numberSing = NumDouble--{-# ANN deriveEq (ToInstance NoOverlap) #-}-deriveEq :: forall t . KnownNumber t => Dict (Eq (Number t))-deriveEq = deriveEqOrig--deriveEqOrig :: forall t . KnownNumber t => Dict (Eq (Number t))-deriveEqOrig = deriveIt numberSing-{-# NOINLINE deriveEqOrig #-}--deriveIt :: (c Double, c Int) => NumberSing t -> Dict (c (Number t))-deriveIt NumInt = mapDict (unsafeDerive Number) Dict-deriveIt NumDouble = mapDict (unsafeDerive Number) Dict+{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fplugin Data.Constraint.Deriving #-} +{-# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances #-} +module Spec.ToInstance02 where + +{- +Testing that variables, such as deriveEqOrig, may have TyVars (forall t); +ToInstance pass should be able to go through the vars and theta types and match +the RHS of the arrow (deriveEqOrig signature). + -} +import Data.Constraint +import Data.Constraint.Deriving +import Data.Constraint.Unsafe + +newtype Number t = Number (NumberFam t) + +type family NumberFam t where + NumberFam Int = Int + NumberFam Double = Double + +data NumberSing t where + NumInt :: NumberSing Int + NumDouble :: NumberSing Double + +class KnownNumber t where numberSing :: NumberSing t +instance KnownNumber Int where numberSing = NumInt +instance KnownNumber Double where numberSing = NumDouble + +{-# ANN deriveEq (ToInstance NoOverlap) #-} +deriveEq :: forall t . KnownNumber t => Dict (Eq (Number t)) +deriveEq = deriveEqOrig + +deriveEqOrig :: forall t . KnownNumber t => Dict (Eq (Number t)) +deriveEqOrig = deriveIt numberSing +{-# NOINLINE deriveEqOrig #-} + +deriveIt :: (c Double, c Int) => NumberSing t -> Dict (c (Number t)) +deriveIt NumInt = mapDict (unsafeDerive Number) Dict +deriveIt NumDouble = mapDict (unsafeDerive Number) Dict
test/out/DeriveAll01.stderr view
@@ -1,31 +1,31 @@-============ Class instances declared in this module ============- instance Eq b => Eq (FooFam Int b)- -- Defined at test/Spec/DeriveAll01.hs:*- instance Eq (FooFam Float Float)- -- Defined at test/Spec/DeriveAll01.hs:*- instance Eq b => Eq (TestNewtype1 Int b)- -- Defined in `Spec.DeriveAll01'- instance Eq (TestNewtype1 Float Float)- -- Defined in `Spec.DeriveAll01'- instance Eq b => Eq (TestNewtype2 Int b (FooFam Int b))- -- Defined in `Spec.DeriveAll01'- instance Eq (TestNewtype2 Float Float (FooFam Float Float))- -- Defined in `Spec.DeriveAll01'- instance Ord (FooFam Float Float)- -- Defined at test/Spec/DeriveAll01.hs:*- instance Ord (TestNewtype1 Float Float)- -- Defined in `Spec.DeriveAll01'- instance Ord (TestNewtype2 Float Float (FooFam Float Float))- -- Defined in `Spec.DeriveAll01'- instance Read b => Read (FooFam Double b)- -- Defined at test/Spec/DeriveAll01.hs:*- instance Read b => Read (TestNewtype1 Double b)- -- Defined in `Spec.DeriveAll01'- instance Read b => Read (TestNewtype2 Double b (FooFam Double b))- -- Defined in `Spec.DeriveAll01'- instance Show (FooFam Float String)- -- Defined at test/Spec/DeriveAll01.hs:*- instance Show (TestNewtype1 Float [Char])- -- Defined in `Spec.DeriveAll01'- instance Show (TestNewtype2 Float [Char] (FooFam Float String))- -- Defined in `Spec.DeriveAll01'+============ Class instances declared in this module ============ + instance Eq b => Eq (FooFam Int b) + -- Defined at test/Spec/DeriveAll01.hs:* + instance Eq (FooFam Float Float) + -- Defined at test/Spec/DeriveAll01.hs:* + instance Eq b => Eq (TestNewtype1 Int b) + -- Defined in `Spec.DeriveAll01' + instance Eq (TestNewtype1 Float Float) + -- Defined in `Spec.DeriveAll01' + instance Eq b => Eq (TestNewtype2 Int b (FooFam Int b)) + -- Defined in `Spec.DeriveAll01' + instance Eq (TestNewtype2 Float Float (FooFam Float Float)) + -- Defined in `Spec.DeriveAll01' + instance Ord (FooFam Float Float) + -- Defined at test/Spec/DeriveAll01.hs:* + instance Ord (TestNewtype1 Float Float) + -- Defined in `Spec.DeriveAll01' + instance Ord (TestNewtype2 Float Float (FooFam Float Float)) + -- Defined in `Spec.DeriveAll01' + instance Read b => Read (FooFam Double b) + -- Defined at test/Spec/DeriveAll01.hs:* + instance Read b => Read (TestNewtype1 Double b) + -- Defined in `Spec.DeriveAll01' + instance Read b => Read (TestNewtype2 Double b (FooFam Double b)) + -- Defined in `Spec.DeriveAll01' + instance Show (FooFam Float String) + -- Defined at test/Spec/DeriveAll01.hs:* + instance Show (TestNewtype1 Float [Char]) + -- Defined in `Spec.DeriveAll01' + instance Show (TestNewtype2 Float [Char] (FooFam Float String)) + -- Defined in `Spec.DeriveAll01'
test/out/DeriveAll01.stdout view
@@ -1,1 +1,1 @@-[*] Compiling Spec.DeriveAll01 ( test/Spec/DeriveAll01.hs, * )+[*] Compiling Spec.DeriveAll01 ( test/Spec/DeriveAll01.hs, * )
test/out/DeriveAll02.stderr view
@@ -1,14 +1,14 @@-============ Class instances declared in this module ============- instance (Show e, Eq b) => Eq (BazTy a b c Double e f)- -- Defined in `Spec.DeriveAll02'- instance Eq b => Eq (FooData a b c)- -- Defined at test/Spec/DeriveAll02.hs:*- instance (a ~ Int, Ord b, Show a) =>- FooClass (FooData a b c) b Float- -- Defined at test/Spec/DeriveAll02.hs:*- instance (Show e, Ord b) => Ord (BazTy a b c Double e f)- -- Defined in `Spec.DeriveAll02'- instance Ord b => Ord (FooData a b c)- -- Defined at test/Spec/DeriveAll02.hs:*- instance (a ~ Int, Show b) => Show (FooData a b c)- -- Defined at test/Spec/DeriveAll02.hs:*+============ Class instances declared in this module ============ + instance (Show e, Eq b) => Eq (BazTy a b c Double e f) + -- Defined in `Spec.DeriveAll02' + instance Eq b => Eq (FooData a b c) + -- Defined at test/Spec/DeriveAll02.hs:* + instance (a ~ Int, Ord b, Show a) => + FooClass (FooData a b c) b Float + -- Defined at test/Spec/DeriveAll02.hs:* + instance (Show e, Ord b) => Ord (BazTy a b c Double e f) + -- Defined in `Spec.DeriveAll02' + instance Ord b => Ord (FooData a b c) + -- Defined at test/Spec/DeriveAll02.hs:* + instance (a ~ Int, Show b) => Show (FooData a b c) + -- Defined at test/Spec/DeriveAll02.hs:*
test/out/DeriveAll02.stdout view
@@ -1,1 +1,1 @@-[*] Compiling Spec.DeriveAll02 ( test/Spec/DeriveAll02.hs, * )+[*] Compiling Spec.DeriveAll02 ( test/Spec/DeriveAll02.hs, * )
test/out/DeriveAll03.stderr view
@@ -1,25 +1,25 @@-============ Class instances declared in this module ============- instance *Alternative (BazTy ListTy)*- instance *Alternative (BazTy MaybeTy)*- instance *Applicative (BazTy ListTy)*- instance *Applicative (BazTy MaybeTy)*- instance Eq a => Eq (BazTy ListTy a)*- instance Eq a => Eq (BazTy MaybeTy a)*- instance Foldable (BazTy ListTy)*- instance Foldable (BazTy MaybeTy)*- instance Functor (BazTy ListTy)*- instance Functor (BazTy MaybeTy)*- instance *Monad (BazTy ListTy)*- instance *Monad (BazTy MaybeTy)*- instance *MonadPlus (BazTy ListTy)*- instance *MonadPlus (BazTy MaybeTy)*- instance *Monoid (BazTy ListTy a)*- instance *Monoid (BazTy MaybeTy a)*- instance Ord a => Ord (BazTy ListTy a)*- instance Ord a => Ord (BazTy MaybeTy a)*- instance Read a => Read (BazTy ListTy a)*- instance Read a => Read (BazTy MaybeTy a)*- instance Show a => Show (BazTy ListTy a)*- instance Show a => Show (BazTy MaybeTy a)*- instance Traversable (BazTy ListTy)*- instance Traversable (BazTy MaybeTy)*+============ Class instances declared in this module ============ + instance *Alternative (BazTy ListTy)* + instance *Alternative (BazTy MaybeTy)* + instance *Applicative (BazTy ListTy)* + instance *Applicative (BazTy MaybeTy)* + instance Eq a => Eq (BazTy ListTy a)* + instance Eq a => Eq (BazTy MaybeTy a)* + instance Foldable (BazTy ListTy)* + instance Foldable (BazTy MaybeTy)* + instance Functor (BazTy ListTy)* + instance Functor (BazTy MaybeTy)* + instance *Monad (BazTy ListTy)* + instance *Monad (BazTy MaybeTy)* + instance *MonadPlus (BazTy ListTy)* + instance *MonadPlus (BazTy MaybeTy)* + instance *Monoid (BazTy ListTy a)* + instance *Monoid (BazTy MaybeTy a)* + instance Ord a => Ord (BazTy ListTy a)* + instance Ord a => Ord (BazTy MaybeTy a)* + instance Read a => Read (BazTy ListTy a)* + instance Read a => Read (BazTy MaybeTy a)* + instance Show a => Show (BazTy ListTy a)* + instance Show a => Show (BazTy MaybeTy a)* + instance Traversable (BazTy ListTy)* + instance Traversable (BazTy MaybeTy)*
test/out/DeriveAll03.stdout view
@@ -1,1 +1,1 @@-[*] Compiling Spec.DeriveAll03 ( test/Spec/DeriveAll03.hs, * )+[*] Compiling Spec.DeriveAll03 ( test/Spec/DeriveAll03.hs, * )
test/out/DeriveAll04.stderr view
@@ -1,7 +1,7 @@-============ Class instances declared in this module ============- instance Eq A -- Defined at test/Spec/DeriveAll04.hs:*- instance Eq B -- Defined at test/Spec/DeriveAll04.hs:*- instance [overlapping] Eq (BazTy A)- -- Defined in `Spec.DeriveAll04'- instance [incoherent] Eq (BazTy fresh_*)+============ Class instances declared in this module ============ + instance Eq A -- Defined at test/Spec/DeriveAll04.hs:* + instance Eq B -- Defined at test/Spec/DeriveAll04.hs:* + instance [overlapping] Eq (BazTy A) + -- Defined in `Spec.DeriveAll04' + instance [incoherent] Eq (BazTy fresh_*) -- Defined in `Spec.DeriveAll04'
test/out/DeriveAll04.stdout view
@@ -1,1 +1,1 @@-[*] Compiling Spec.DeriveAll04 ( test/Spec/DeriveAll04.hs, * )+[*] Compiling Spec.DeriveAll04 ( test/Spec/DeriveAll04.hs, * )
test/out/DeriveAll05.stderr view
@@ -1,3 +1,3 @@-============ Class instances declared in this module ============- instance Eq (AB _) -- Defined at test/Spec/DeriveAll05.hs:*+============ Class instances declared in this module ============ + instance Eq (AB _) -- Defined at test/Spec/DeriveAll05.hs:* instance Eq (BazTy a) -- Defined in `Spec.DeriveAll05'
test/out/DeriveAll05.stdout view
@@ -1,1 +1,1 @@-[*] Compiling Spec.DeriveAll05 ( test/Spec/DeriveAll05.hs, * )+[*] Compiling Spec.DeriveAll05 ( test/Spec/DeriveAll05.hs, * )
test/out/DeriveAll06.stderr view
@@ -1,9 +1,9 @@-============ Class instances declared in this module ============- instance Enum Bar -- Defined at test/Spec/DeriveAll06.hs:*- instance Enum (Foo a b) -- Defined in `Spec.DeriveAll06'- instance Eq Bar -- Defined at test/Spec/DeriveAll06.hs:*- instance Eq (Foo a b) -- Defined in `Spec.DeriveAll06'- instance Ord Bar -- Defined at test/Spec/DeriveAll06.hs:*- instance Ord (Foo a b) -- Defined in `Spec.DeriveAll06'- instance Read Bar -- Defined at test/Spec/DeriveAll06.hs:*- instance Show Bar -- Defined at test/Spec/DeriveAll06.hs:*+============ Class instances declared in this module ============ + instance Enum Bar -- Defined at test/Spec/DeriveAll06.hs:* + instance Enum (Foo a b) -- Defined in `Spec.DeriveAll06' + instance Eq Bar -- Defined at test/Spec/DeriveAll06.hs:* + instance Eq (Foo a b) -- Defined in `Spec.DeriveAll06' + instance Ord Bar -- Defined at test/Spec/DeriveAll06.hs:* + instance Ord (Foo a b) -- Defined in `Spec.DeriveAll06' + instance Read Bar -- Defined at test/Spec/DeriveAll06.hs:* + instance Show Bar -- Defined at test/Spec/DeriveAll06.hs:*
test/out/DeriveAll06.stdout view
@@ -1,1 +1,1 @@-[*] Compiling Spec.DeriveAll06 ( test/Spec/DeriveAll06.hs, * )+[*] Compiling Spec.DeriveAll06 ( test/Spec/DeriveAll06.hs, * )
test/out/ToInstance01.stderr view
@@ -1,11 +1,11 @@-============ Class instances declared in this module ============- instance KnownNumber t => Eq (Number t)- -- Defined in `Spec.ToInstance01'- instance KnownNumber Double- -- Defined at test/Spec/ToInstance01.hs:*- instance KnownNumber Int- -- Defined at test/Spec/ToInstance01.hs:*- instance KnownNumber t => Num (Number t)- -- Defined in `Spec.ToInstance01'- instance KnownNumber t => Ord (Number t)+============ Class instances declared in this module ============ + instance KnownNumber t => Eq (Number t) + -- Defined in `Spec.ToInstance01' + instance KnownNumber Double + -- Defined at test/Spec/ToInstance01.hs:* + instance KnownNumber Int + -- Defined at test/Spec/ToInstance01.hs:* + instance KnownNumber t => Num (Number t) + -- Defined in `Spec.ToInstance01' + instance KnownNumber t => Ord (Number t) -- Defined in `Spec.ToInstance01'
test/out/ToInstance02.stderr view
@@ -1,7 +1,7 @@-============ Class instances declared in this module ============- instance KnownNumber t => Eq (Number t)- -- Defined in `Spec.ToInstance02'- instance KnownNumber Double- -- Defined at test/Spec/ToInstance02.hs:*- instance KnownNumber Int- -- Defined at test/Spec/ToInstance02.hs:*+============ Class instances declared in this module ============ + instance KnownNumber t => Eq (Number t) + -- Defined in `Spec.ToInstance02' + instance KnownNumber Double + -- Defined at test/Spec/ToInstance02.hs:* + instance KnownNumber Int + -- Defined at test/Spec/ToInstance02.hs:*
test/out/ToInstance02.stdout view
@@ -1,1 +1,1 @@-[*] Compiling Spec.ToInstance02 ( test/Spec/ToInstance02.hs, * )+[*] Compiling Spec.ToInstance02 ( test/Spec/ToInstance02.hs, * )