if-instance 0.3.0.0 → 0.3.1.0

raw patch · 7 files changed

+47/−26 lines, 7 filesdep ~basedep ~ghcdep ~ghc-tcplugin-apiPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, ghc, ghc-tcplugin-api

API changes (from Hackage documentation)

- Data.Constraint.If: class c || d

- Data.Constraint.If: dispatch :: (||) c d => ((IsSat c ~ True, c) => r) -> ((IsSat c ~ False, IsSat d ~ True, d) => r) -> r

- Data.Constraint.If: ifSat :: forall ct r. IfSat ct => ((IsSat ct ~ True, ct) => r) -> (IsSat ct ~ False => r) -> r

- Data.Constraint.If: type IfSat ct = (ct || ())

- Data.Constraint.If: type family IsSat ct

- IfSat.Plugin: plugin :: Plugin

+ M2: instance GHC.Show.Show (GHC.Types.Bool -> GHC.Types.Bool)

+ M2: instance M1.C

+ M2: test :: String

+ M2: test2 :: (a -> a) -> String

+ M2: test3 :: (Bool -> Bool) -> String

+ M2: unsafeCoerce :: Float -> String

Files

changelog.md +5/−0
example/M1.hs +15/−1
example/M2.hs +6/−0
if-instance.cabal +4/−4
src/Data/Constraint/If.hs +2/−2
src/IfSat/Plugin.hs +13/−17
test/Main.hs +2/−2

changelog.md view

@@ -1,4 +1,9 @@ 
+# Version 0.3.1.0 (2023-01-24)
+
+- Bumping of version bounds, and support for GHC 9.4 and GHC 9.6.
+  Now requires `ghc-tcplugin-api` 0.9 or above.
+
 # Version 0.3.0.0 (2021-09-01)
 
 - Add the `(||)` constraint disjunction mechanism, with

example/M1.hs view

@@ -1,8 +1,12 @@ 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -fplugin=IfSat.Plugin #-}
 
@@ -14,7 +18,7 @@ 
 -- if-instance
 import Data.Constraint.If
-  ( IfSat, ifSat )
+  ( IfSat, ifSat, IsSat )
 
 --------------------------------------------------------------------------------
 
@@ -23,3 +27,13 @@ 
 test1 :: ( Bool -> Bool ) -> String
 test1 fun = showFun fun
+
+class C
+
+type F :: Bool -> Type
+type family F b where
+  F False = Float
+  F True  = String
+
+foo :: Float -> F (IsSat C)
+foo x = x

example/M2.hs view

@@ -1,5 +1,6 @@ 
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -30,3 +31,8 @@     , test3 not
     , showFun not
     ]
+
+instance C
+
+unsafeCoerce :: Float -> String
+unsafeCoerce x = foo x

if-instance.cabal view

@@ -1,6 +1,6 @@ cabal-version:  3.0
 name:           if-instance
-version:        0.3.0.0
+version:        0.3.1.0
 synopsis:       Branch on whether a constraint is satisfied
 license:        BSD-3-Clause
 build-type:     Simple
@@ -60,9 +60,9 @@ 
   build-depends:
     base
-      >= 4.15.0 && < 4.18,
+      >= 4.15.0 && < 4.19,
     ghc
-      >= 9.0    && < 9.6,
+      >= 9.0    && < 9.8,
 
   default-language:
     Haskell2010
@@ -85,7 +85,7 @@ 
   build-depends:
     ghc-tcplugin-api
-      >= 0.5.1.0 && < 0.6,
+      >= 0.9 && < 0.10,
 
   exposed-modules:
     Data.Constraint.If

src/Data/Constraint/If.hs view

@@ -30,8 +30,8 @@ 
 > ifSat :: IfSat c => ( c => r ) -> r -> r
 
-This is the special case of 'dispatch' which taes @d@ to be the trivial constraint,
-@d ~ ( () :: Constraint)@.
+This is the special case of 'dispatch' which takes @d@ to be the trivial constraint,
+@d ~ ( () :: Constraint )@.
 
 This module also provides the type family @'IsSat' :: Constraint -> Bool@, which, when reduced,
 will check whether the constraint provided as an argument is satisfied.

src/IfSat/Plugin.hs view

@@ -19,9 +19,7 @@ 
 -- ghc
 import GHC.Plugins
-  ( Plugin(..)
-  , defaultPlugin, purePlugin
-  )
+  hiding ( TcPlugin, (<>) )
 import GHC.Data.Bag
   ( unitBag )
 import GHC.Tc.Solver.Interact
@@ -37,8 +35,6 @@   ( TcM )
 import GHC.Tc.Types.Constraint
   ( isEmptyWC )
-import GHC.Utils.Outputable
-  ( (<+>), ($$), empty, text, vcat )
 
 -- ghc-tcplugin-api
 import GHC.TcPlugin.API
@@ -88,9 +84,9 @@     , isSatTyCon :: !TyCon
     }
 
-findModule :: MonadTcPlugin m => Maybe String -> String -> m Module
-findModule mb_pkg modName = do
-  findResult <- findImportedModule ( mkModuleName modName ) ( fmap fsLit mb_pkg )
+findModule :: MonadTcPlugin m => String -> m Module
+findModule modName = do
+  findResult <- findImportedModule ( mkModuleName modName ) NoPkgQual
   case findResult of
     Found _ res     -> pure res
     FoundMultiple _ -> error $ "IfSat plugin: found multiple modules named " <> modName <> "."
@@ -98,7 +94,7 @@ 
 initPlugin :: TcPluginM Init PluginDefs
 initPlugin = do
-  ifSatModule <- findModule Nothing "Data.Constraint.If"
+  ifSatModule <- findModule "Data.Constraint.If"
   orClass     <- tcLookupClass =<< lookupOrig ifSatModule ( mkClsOcc "||"    )
   isSatTyCon  <- tcLookupTyCon =<< lookupOrig ifSatModule ( mkTcOcc  "IsSat" )
   pure $ PluginDefs { orClass, isSatTyCon }
@@ -213,10 +209,10 @@   let
     r, a, b :: CoreBndr
     r = mkTyVar r_name liftedTypeKind
-    a = mkLocalId a_name Many
-        ( mkInvisFunTysMany [ sat_eqTy defs ct_l_ty True, ct_l_ty ] r_ty )
-    b = mkWildValBinder  Many
-        ( mkInvisFunTysMany [ sat_eqTy defs ct_l_ty False, sat_eqTy defs ct_r_ty True, ct_r_ty ] r_ty )
+    a = mkLocalId a_name ManyTy
+        ( mkInvisFunTys [ sat_eqTy defs ct_l_ty True, ct_l_ty ] r_ty )
+    b = mkWildValBinder  ManyTy
+        ( mkInvisFunTys [ sat_eqTy defs ct_l_ty False, sat_eqTy defs ct_r_ty True, ct_r_ty ] r_ty )
     r_ty :: Type
     r_ty = mkTyVarTy r
   pure . EvExpr $
@@ -245,10 +241,10 @@   let
     r, a, b :: CoreBndr
     r = mkTyVar r_name liftedTypeKind
-    a = mkWildValBinder  Many
-        ( mkInvisFunTysMany [ sat_eqTy defs ct_l_ty True, ct_l_ty ] r_ty )
-    b = mkLocalId b_name Many
-        ( mkInvisFunTysMany [ sat_eqTy defs ct_l_ty False, sat_eqTy defs ct_r_ty True, ct_r_ty ] r_ty )
+    a = mkWildValBinder  ManyTy
+        ( mkInvisFunTys [ sat_eqTy defs ct_l_ty True, ct_l_ty ] r_ty )
+    b = mkLocalId b_name ManyTy
+        ( mkInvisFunTys [ sat_eqTy defs ct_l_ty False, sat_eqTy defs ct_r_ty True, ct_r_ty ] r_ty )
     r_ty :: Type
     r_ty = mkTyVarTy r
   pure . EvExpr $

test/Main.hs view

@@ -78,13 +78,13 @@ -- Should use the instance locally provided by "withDict".
 test3 :: String
 test3 =
-  withDict @( A -> String ) @( MyShow A )
+  withDict @( MyShow A ) @( A -> String )
     ( \ _ -> "A" )
     myShowA
 
 test3b :: Bool
 test3b =
-  withDict @( A -> String ) @( MyShow A )
+  withDict @( MyShow A ) @( A -> String )
     ( \ _ -> "A" )
     ( boolI @( IsSat ( MyShow A ) ) )
 #endif