diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,112 +1,112 @@ -[![Hackage](https://img.shields.io/hackage/v/constraints-deriving.svg)](https://hackage.haskell.org/package/constraints-deriving) -[![Build Status](https://secure.travis-ci.org/achirkin/constraints-deriving.svg)](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). +[![Hackage](https://img.shields.io/hackage/v/constraints-deriving.svg)](https://hackage.haskell.org/package/constraints-deriving) +[![Build Status](https://secure.travis-ci.org/achirkin/constraints-deriving.svg)](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). diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/constraints-deriving.cabal b/constraints-deriving.cabal --- a/constraints-deriving.cabal +++ b/constraints-deriving.cabal @@ -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.1. -- -- see: https://github.com/sol/hpack -- --- hash: 8d0710b285a0acc454fbe87602556399bcc46f63b0fe48e5e2b02b3fde8f8be2 +-- hash: 1dd28a5dcf2104b86a3f1997734e55e702ac467521acc6e594ec01af5d11bc02 name: constraints-deriving -version: 1.0.3.0 +version: 1.0.4.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 category: Constraints diff --git a/example/Lib/BackendFamily.hs b/example/Lib/BackendFamily.hs --- a/example/Lib/BackendFamily.hs +++ b/example/Lib/BackendFamily.hs @@ -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 diff --git a/example/Lib/VecBackend.hs b/example/Lib/VecBackend.hs --- a/example/Lib/VecBackend.hs +++ b/example/Lib/VecBackend.hs @@ -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 #-} diff --git a/example/Lib/Vector.hs b/example/Lib/Vector.hs --- a/example/Lib/Vector.hs +++ b/example/Lib/Vector.hs @@ -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))) diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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 + diff --git a/src-constraints/Data/Constraint.hs b/src-constraints/Data/Constraint.hs --- a/src-constraints/Data/Constraint.hs +++ b/src-constraints/Data/Constraint.hs @@ -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 --- --- 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 -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 +-- +-- 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 +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 diff --git a/src-constraints/Data/Constraint/Unsafe.hs b/src-constraints/Data/Constraint/Unsafe.hs --- a/src-constraints/Data/Constraint/Unsafe.hs +++ b/src-constraints/Data/Constraint/Unsafe.hs @@ -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 --- --- 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 +-- +-- 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 diff --git a/src/Data/Constraint/Bare.hs b/src/Data/Constraint/Bare.hs --- a/src/Data/Constraint/Bare.hs +++ b/src/Data/Constraint/Bare.hs @@ -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) diff --git a/src/Data/Constraint/Deriving.hs b/src/Data/Constraint/Deriving.hs --- a/src/Data/Constraint/Deriving.hs +++ b/src/Data/Constraint/Deriving.hs @@ -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 diff --git a/src/Data/Constraint/Deriving/CorePluginM.hs b/src/Data/Constraint/Deriving/CorePluginM.hs --- a/src/Data/Constraint/Deriving/CorePluginM.hs +++ b/src/Data/Constraint/Deriving/CorePluginM.hs @@ -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 "") 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 "") 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 "~" diff --git a/src/Data/Constraint/Deriving/DeriveAll.hs b/src/Data/Constraint/Deriving/DeriveAll.hs --- a/src/Data/Constraint/Deriving/DeriveAll.hs +++ b/src/Data/Constraint/Deriving/DeriveAll.hs @@ -1,930 +1,939 @@ -{-# 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 +{-# 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 + -- the following line checks if constraints are solvable and fails otherwise + 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 + , not $ isEmptyTCvSubst sub + -> do + pluginDebug $ hang "Could not find an instance, trying again:" 2 $ + vcat $ [ text "Base type:" <+> ppr mtBaseType + , text "Instance:" <+> ppr baseInst + , text "Substitution:" <+> ppr sub + ] + lookupMatchingInstance da ie (substMatchingType sub mt) baseInst + | otherwise + -> do + pluginDebug $ hang "Ignored instance" 2 $ + vcat $ [ text "Base type:" <+> ppr mtBaseType + , text "Instance:" <+> 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 diff --git a/src/Data/Constraint/Deriving/ToInstance.hs b/src/Data/Constraint/Deriving/ToInstance.hs --- a/src/Data/Constraint/Deriving/ToInstance.hs +++ b/src/Data/Constraint/Deriving/ToInstance.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Spec/DeriveAll01.hs b/test/Spec/DeriveAll01.hs --- a/test/Spec/DeriveAll01.hs +++ b/test/Spec/DeriveAll01.hs @@ -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 diff --git a/test/Spec/DeriveAll02.hs b/test/Spec/DeriveAll02.hs --- a/test/Spec/DeriveAll02.hs +++ b/test/Spec/DeriveAll02.hs @@ -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 diff --git a/test/Spec/DeriveAll03.hs b/test/Spec/DeriveAll03.hs --- a/test/Spec/DeriveAll03.hs +++ b/test/Spec/DeriveAll03.hs @@ -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) diff --git a/test/Spec/DeriveAll04.hs b/test/Spec/DeriveAll04.hs --- a/test/Spec/DeriveAll04.hs +++ b/test/Spec/DeriveAll04.hs @@ -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) diff --git a/test/Spec/DeriveAll05.hs b/test/Spec/DeriveAll05.hs --- a/test/Spec/DeriveAll05.hs +++ b/test/Spec/DeriveAll05.hs @@ -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) + diff --git a/test/Spec/DeriveAll06.hs b/test/Spec/DeriveAll06.hs --- a/test/Spec/DeriveAll06.hs +++ b/test/Spec/DeriveAll06.hs @@ -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 diff --git a/test/Spec/ToInstance01.hs b/test/Spec/ToInstance01.hs --- a/test/Spec/ToInstance01.hs +++ b/test/Spec/ToInstance01.hs @@ -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 diff --git a/test/Spec/ToInstance02.hs b/test/Spec/ToInstance02.hs --- a/test/Spec/ToInstance02.hs +++ b/test/Spec/ToInstance02.hs @@ -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 diff --git a/test/out/DeriveAll01.stderr b/test/out/DeriveAll01.stderr --- a/test/out/DeriveAll01.stderr +++ b/test/out/DeriveAll01.stderr @@ -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' diff --git a/test/out/DeriveAll01.stdout b/test/out/DeriveAll01.stdout --- a/test/out/DeriveAll01.stdout +++ b/test/out/DeriveAll01.stdout @@ -1,1 +1,1 @@ -[*] Compiling Spec.DeriveAll01 ( test/Spec/DeriveAll01.hs, * ) +[*] Compiling Spec.DeriveAll01 ( test/Spec/DeriveAll01.hs, * ) diff --git a/test/out/DeriveAll02.stderr b/test/out/DeriveAll02.stderr --- a/test/out/DeriveAll02.stderr +++ b/test/out/DeriveAll02.stderr @@ -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:* diff --git a/test/out/DeriveAll02.stdout b/test/out/DeriveAll02.stdout --- a/test/out/DeriveAll02.stdout +++ b/test/out/DeriveAll02.stdout @@ -1,1 +1,1 @@ -[*] Compiling Spec.DeriveAll02 ( test/Spec/DeriveAll02.hs, * ) +[*] Compiling Spec.DeriveAll02 ( test/Spec/DeriveAll02.hs, * ) diff --git a/test/out/DeriveAll03.stderr b/test/out/DeriveAll03.stderr --- a/test/out/DeriveAll03.stderr +++ b/test/out/DeriveAll03.stderr @@ -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)* diff --git a/test/out/DeriveAll03.stdout b/test/out/DeriveAll03.stdout --- a/test/out/DeriveAll03.stdout +++ b/test/out/DeriveAll03.stdout @@ -1,1 +1,1 @@ -[*] Compiling Spec.DeriveAll03 ( test/Spec/DeriveAll03.hs, * ) +[*] Compiling Spec.DeriveAll03 ( test/Spec/DeriveAll03.hs, * ) diff --git a/test/out/DeriveAll04.stderr b/test/out/DeriveAll04.stderr --- a/test/out/DeriveAll04.stderr +++ b/test/out/DeriveAll04.stderr @@ -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' diff --git a/test/out/DeriveAll04.stdout b/test/out/DeriveAll04.stdout --- a/test/out/DeriveAll04.stdout +++ b/test/out/DeriveAll04.stdout @@ -1,1 +1,1 @@ -[*] Compiling Spec.DeriveAll04 ( test/Spec/DeriveAll04.hs, * ) +[*] Compiling Spec.DeriveAll04 ( test/Spec/DeriveAll04.hs, * ) diff --git a/test/out/DeriveAll05.stderr b/test/out/DeriveAll05.stderr --- a/test/out/DeriveAll05.stderr +++ b/test/out/DeriveAll05.stderr @@ -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' diff --git a/test/out/DeriveAll05.stdout b/test/out/DeriveAll05.stdout --- a/test/out/DeriveAll05.stdout +++ b/test/out/DeriveAll05.stdout @@ -1,1 +1,1 @@ -[*] Compiling Spec.DeriveAll05 ( test/Spec/DeriveAll05.hs, * ) +[*] Compiling Spec.DeriveAll05 ( test/Spec/DeriveAll05.hs, * ) diff --git a/test/out/DeriveAll06.stderr b/test/out/DeriveAll06.stderr --- a/test/out/DeriveAll06.stderr +++ b/test/out/DeriveAll06.stderr @@ -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:* diff --git a/test/out/DeriveAll06.stdout b/test/out/DeriveAll06.stdout --- a/test/out/DeriveAll06.stdout +++ b/test/out/DeriveAll06.stdout @@ -1,1 +1,1 @@ -[*] Compiling Spec.DeriveAll06 ( test/Spec/DeriveAll06.hs, * ) +[*] Compiling Spec.DeriveAll06 ( test/Spec/DeriveAll06.hs, * ) diff --git a/test/out/ToInstance01.stderr b/test/out/ToInstance01.stderr --- a/test/out/ToInstance01.stderr +++ b/test/out/ToInstance01.stderr @@ -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' diff --git a/test/out/ToInstance02.stderr b/test/out/ToInstance02.stderr --- a/test/out/ToInstance02.stderr +++ b/test/out/ToInstance02.stderr @@ -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:* diff --git a/test/out/ToInstance02.stdout b/test/out/ToInstance02.stdout --- a/test/out/ToInstance02.stdout +++ b/test/out/ToInstance02.stdout @@ -1,1 +1,1 @@ -[*] Compiling Spec.ToInstance02 ( test/Spec/ToInstance02.hs, * ) +[*] Compiling Spec.ToInstance02 ( test/Spec/ToInstance02.hs, * )