constraints-emerge 0.1.1 → 0.1.2
raw patch · 5 files changed
+199/−59 lines, 5 filesdep +containersdep +transformersPVP ok
version bump matches the API change (PVP)
Dependencies added: containers, transformers
API changes (from Hackage documentation)
Files
- ChangeLog.md +13/−1
- Data/Constraint/Emerge/Plugin.hs +152/−49
- README.md +1/−1
- constraints-emerge.cabal +6/−3
- test/EmergeSpec.hs +27/−5
ChangeLog.md view
@@ -1,8 +1,20 @@ # Revision history for constraints-emerge +## 0.1.2 -- 2018-04-19++* Significantly better dictionary generation; the plugin will now build+ dictionaries that depend on subdicts.+* Fixed a bug where dictionaries depending on subdicts would cause segfaults at+ runtime.+* The plugin will now refuse to discharge 'Emerge c' constraints if 'c' is not+ fully monomorphic.+* The plugin will now fail to generate equality dicts, even for types that are,+ in fact, equal. This is bad, but much less disastrous than the old behavior+ which would generate dictionaries for non-equal types...+ ## 0.1.1 -- 2018-04-18 -* Fix some error messages.+* Updated some misleading error messages. ## 0.1 -- 2018-04-18
Data/Constraint/Emerge/Plugin.hs view
@@ -2,13 +2,19 @@ module Data.Constraint.Emerge.Plugin (plugin) where -import Control.Exception (throw)-import Control.Monad-import Data.Maybe-import Prelude hiding (pred)+import Control.Exception (throw)+import Control.Monad+import Data.Bifunctor (second)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Traversable (for)+import Data.Tuple (swap)+import Prelude hiding (pred) +import TcType import Class hiding (className)-import GHC (GhcException (..))+import GHC (GhcException (..), idType) import InstEnv (ClsInst (..), lookupUniqueInstEnv) import Module (mkModuleName) import OccName (mkTcOcc)@@ -18,10 +24,91 @@ import TcPluginM import TcRnTypes import TyCon (TyCon, tyConName)-import Type (Type, splitTyConApp_maybe, isTyVarTy)+import Type (Type, TyVar, splitTyConApp_maybe, isTyVarTy, splitAppTy_maybe, getTyVar_maybe, splitAppTys) ------------------------------------------------------------------------------+-- | Match an instance head against a concrete type; returning a substitution+-- from one to the other. If this returns 'mempty', there were no type+-- variables to match.+match+ :: PredType -- class inst+ -> PredType -- concrete type+ -> Map TyVar Type+match instClass concClass =+ let Just (_, instHead) = splitAppTy_maybe instClass+ Just (_, concHead) = splitAppTy_maybe concClass+ (_, instTys) = splitAppTys instHead+ (_, concTys) = splitAppTys concHead+ in M.fromList . mapMaybe (fmap swap . sequence . second getTyVar_maybe)+ $ zip concTys instTys+++------------------------------------------------------------------------------+-- | Determine if a 'PredType' is fully monomorphic (ie. has no type+-- variables.)+isMonomorphicCtx+ :: PredType+ -> Bool+isMonomorphicCtx t = isJust $ do+ (_, instHead) <- splitAppTy_maybe t+ let (_, instTys) = splitAppTys instHead+ case null $ mapMaybe getTyVar_maybe instTys of+ True -> Just ()+ False -> Nothing+++------------------------------------------------------------------------------+-- | Substitute all type variables in a 'Type'.+-- TODO(sandy): this should probably operate over a 'PredType' and explicily+-- split and fold, rather than assuming a shape of 'C a b c'.+instantiateHead+ :: Map TyVar Type+ -> Type+ -> Type+instantiateHead mmap t =+ let (tc, tys) = splitAppTys t+ tys' = fmap (\ty -> maybe ty (mmap M.!) $ getTyVar_maybe ty) tys+ in mkAppTys tc tys'+++------------------------------------------------------------------------------+-- | Construct an 'EvTerm' witnessing an instance of 'wantedDict' by+-- recursively finding instances, and building dicts for their contexts.+buildDict+ :: CtLoc+ -> PredType+ -> TcPluginM (Maybe EvTerm)+buildDict loc wantedDict = do+ (className, classParams) <-+ case splitTyConApp_maybe wantedDict of+ Just a -> pure a+ Nothing -> errMissingSig loc++ myclass <- tcLookupClass $ tyConName className+ envs <- getInstEnvs++ case lookupUniqueInstEnv envs myclass classParams of+ -- success!+ Right (clsInst, _) -> do+ let dfun = is_dfun clsInst+ (vars, subclasses, inst) = tcSplitSigmaTy $ idType dfun+ mmap = match inst wantedDict++ if null subclasses+ then pure . Just $ EvDFunApp dfun [] []+ else do+ mayDicts <- traverse (buildDict loc . instantiateHead mmap) subclasses++ for (sequence mayDicts) $ \dicts ->+ pure $ EvDFunApp dfun (fmap (mmap M.!) vars) dicts++ Left _ -> do+ -- check givens?+ pure Nothing+++------------------------------------------------------------------------------ -- | The exported 'Emerge' plugin. plugin :: Plugin plugin = defaultPlugin { tcPlugin = const $ Just emergePlugin }@@ -68,7 +155,7 @@ ------------------------------------------------------------------------------ -- | Determines if 'ct' is an instance of the 'c' class, and if so, splits out -- its applied types.-findEmergePred :: Class -> Ct -> Maybe (Ct, [Type])+findEmergePred :: Class -> Ct -> Maybe (Ct, [PredType]) findEmergePred c ct = do let pred = ctev_pred $ cc_ev ct case splitTyConApp_maybe pred of@@ -80,13 +167,6 @@ --------------------------------------------------------------------------------- | Get the original source location a 'Ct' came from. Used to generate error--- messages.-getLoc :: Ct -> CtLoc-getLoc = ctev_loc . cc_ev--------------------------------------------------------------------------------- -- | Discharge all wanted 'Emerge' constraints. solveEmerge :: EmergeData@@ -95,45 +175,48 @@ -> [Ct] -- ^ [W]anted constraints -> TcPluginM TcPluginResult solveEmerge emerge _ _ allWs = do- let ws = mapMaybe (findEmergePred (emergeEmerge emerge)) $ allWs+ let ws = mapMaybe (findEmergePred $ emergeEmerge emerge) allWs case length ws of 0 -> pure $ TcPluginOk [] [] _ -> do- z <- traverse (discharge emerge) ws- pure $ TcPluginOk z []+ evs <- for ws $ discharge emerge+ pure $ TcPluginOk evs [] ------------------------------------------------------------------------------ -- | Discharge an 'Emerge' constraint. discharge :: EmergeData- -> (Ct, [Type])+ -> (Ct, [PredType]) -> TcPluginM (EvTerm, Ct) discharge emerge (ct, ts) = do let [wantedDict] = ts- loc = getLoc ct+ loc = ctev_loc $ cc_ev ct + when (not $ isMonomorphicCtx wantedDict) $+ errPolyUsage loc+ (className, classParams) <- case splitTyConApp_maybe wantedDict of Just a -> pure a- Nothing -> throw $ PprProgramError "" $ helpMe2 loc+ Nothing -> errMissingSig loc - myclass <- tcLookupClass (tyConName className)- envs <- getInstEnvs- case lookupUniqueInstEnv envs myclass classParams of- -- success!- Right (clsInst, _) -> do- let dfun = is_dfun clsInst+ envs <- getInstEnvs+ mayMyDict <- buildDict loc wantedDict++ case mayMyDict of+ -- we successfully built a dict+ Just myDict -> case lookupUniqueInstEnv envs (emergeSucceed emerge) ts of- Right (successInst, _) -> pure- (EvDFunApp (is_dfun successInst) ts [EvDFunApp dfun [] []], ct)+ Right (successInst, _) ->+ pure (EvDFunApp (is_dfun successInst) ts [myDict], ct) Left err -> pprPanic "couldn't get a unique instance for Success" err -- couldn't find the instance- Left _ -> do- when (any isTyVarTy classParams) $ do- throw $ PprProgramError "" $ helpMe className classParams loc+ Nothing -> do+ when (any isTyVarTy classParams) $+ errPolyClassTys className classParams loc case lookupUniqueInstEnv envs (emergeFail emerge) [] of Right (clsInst, _) ->@@ -142,30 +225,50 @@ pprPanic "couldn't get a unique instance for AlwaysFail" err -helpMe :: TyCon -> [Type] -> CtLoc -> SDoc-helpMe c ts loc = foldl ($$) empty- [ ppr (tcl_loc $ ctl_env loc)- , hang empty 2 $ (char '•') <+>- (- hang empty 2 $ text "Polymorphic type variables bound in the implicit constraint of 'Emerge'"- $$ hang empty 2 (ppr (ctl_origin loc))- )- , hang empty 2 $ (char '•') <+> text "Probable fix: add an explicit 'Emerge ("+------------------------------------------------------------------------------+-- | Error out complaining about polymorphic type variables in the implicit+-- context.+errPolyClassTys :: TyCon -> [Type] -> CtLoc -> a+errPolyClassTys c ts loc = errHelper loc+ [ text "Polymorphic type variables bound in the implicit constraint of 'Emerge'"+ $$ hang empty 2 (ppr (ctl_origin loc))+ , text "Probable fix: add an explicit 'Emerge (" <> ppr c <+> foldl (<+>) empty (fmap ppr $ ts ) <> text ")' constraint to the type signature" ] -helpMe2 :: CtLoc -> SDoc-helpMe2 loc = foldl ($$) empty- [ ppr (tcl_loc $ ctl_env loc)- , hang empty 2 $ (char '•') <+>- (- hang empty 2 $ text "Polymorphic constraint bound in the implicit constraint of 'Emerge'"- $$ hang empty 2 (ppr (ctl_origin loc))- )- , hang empty 2 $ (char '•') <+> text "Probable fix: add an explicit 'Emerge c'"+------------------------------------------------------------------------------+-- | Erorr out complaining about a polymorphic constraint.+errMissingSig :: CtLoc -> a+errMissingSig loc = errHelper loc+ [ text "Polymorphic constraint bound in the implicit constraint of 'Emerge'"+ $$ hang empty 2 (ppr (ctl_origin loc))+ , text "Probable fix: add an explicit 'Emerge c'" <+> text "constraint to the type signature" ]+++------------------------------------------------------------------------------+-- | Error out complaining about a polymorphic usage.+errPolyUsage :: CtLoc -> a+errPolyUsage loc = errHelper loc+ [ text "Polymorphic usage of function bound with an implicit 'Emerge' constraint"+ $$ hang empty 2 (ppr (ctl_origin loc))+ , text "'Emerge' can only be discharged when it is fully monomorphic"+ , text "Fix: make the call-site monomorphic, or add an explicit 'Emerge c'"+ $$ hang empty 2 (text "constraint to the type-signature.")+ ]+++------------------------------------------------------------------------------+-- | Helper function to generate pretty error messages.+errHelper :: CtLoc -> [SDoc] -> a+errHelper loc ss+ = throw+ . PprProgramError ""+ . hang (ppr . tcl_loc $ ctl_env loc) 2+ . foldl ($$) empty+ $ fmap (\z -> hang empty 0 $ char '•' <+> z) ss
README.md view
@@ -18,7 +18,7 @@ ```haskell {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleConstraints #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin=Data.Constraint.Emerge.Plugin #-}
constraints-emerge.cabal view
@@ -1,5 +1,5 @@ name: constraints-emerge-version: 0.1.1+version: 0.1.2 synopsis: Defer instance lookups until runtime description: This plugin allows you to write@@ -14,9 +14,11 @@ showAnything c = case emerge @(Show c) of Just Dict -> show c- Nothing -> "<<unshowable>>"+ Nothing -> "{{unshowable}}" @ .+ where the 'Emerge (Show c)' will automatically be discharged for any monomorphic 'c'.+ . See <https://github.com/isovector/constraints-emerge/blob/master/test/EmergeSpec.hs test/EmergeSpec.hs> for a few examples of what this plugin can do for you. @@ -39,6 +41,7 @@ build-depends: hashable build-depends: ghc >=8.0.1 build-depends: constraints+ build-depends: containers default-language: Haskell2010 Test-Suite tests@@ -47,7 +50,7 @@ other-modules: EmergeSpec hs-Source-Dirs: test main-is: Main.hs- build-depends: base >=4.9 && <5, constraints, hspec, constraints-emerge+ build-depends: base >=4.9 && <5, constraints, hspec, constraints-emerge, transformers source-repository head type: git
test/EmergeSpec.hs view
@@ -10,10 +10,20 @@ module EmergeSpec where +import Control.Monad.Trans.Writer (WriterT) import Data.Constraint.Emerge import Test.Hspec +getWriterTMonad+ :: forall e m z+ . ( z ~ Monad (WriterT e m)+ , Emerge z+ )+ => Maybe (Dict z)+getWriterTMonad = emerge @z++ getMultiParam :: forall a b. Emerge (MultiParam a b) => Maybe (a, b) getMultiParam = case emerge @(MultiParam a b) of@@ -34,7 +44,11 @@ Just Dict -> c Nothing -> 17 +-- showTree :: Emerge (Show a) => a -> Int -> String+-- showTree v 0 = showAnything v+-- showTree v n = showTree (v, v) (n - 1) + spec :: Spec spec = do describe "dictionary lookups" $ do@@ -50,7 +64,11 @@ it "Show orphan instance" $ do emerge @(Show (String -> String)) `shouldBe` Just Dict + it "complicated subdicts for WriterT" $ do+ getWriterTMonad @[Int] @IO `shouldBe` Just Dict+ getWriterTMonad @Int @IO `shouldBe` Nothing + describe "dictionary usages" $ do it "showAnything 5" $ do showAnything (5 :: Int) `shouldBe` show (5 :: Int)@@ -59,8 +77,12 @@ showAnything True `shouldBe` show True it "showAnything id" $ do- showAnything id `shouldBe` "<<unshowable>>"+ showAnything (id @Int) `shouldBe` "<<unshowable>>" + it "showAnything (5, (6, True)" $ do+ showAnything (5 :: Double, (6 :: Int, True))+ `shouldBe` show (5 :: Double, (6 :: Int, True))+ it "getMultiParam @Int @Bool" $ do getMultiParam `shouldBe` Just (1 :: Int, True) getMultiParam @Int @Bool `shouldBe` Just (1, True)@@ -74,11 +96,11 @@ describe "bugs" $ do- it "BROKEN: bool to int" $ do- brokenToInt True `shouldNotBe` 17+ it "WORKS: bool to int" $ do+ brokenToInt True `shouldBe` 17 - it "WORKS: int to int" $ do- brokenToInt 5 `shouldBe` 5+ it "BROKEN: int to int" $ do+ brokenToInt (5 :: Int) `shouldNotBe` 5 it "BROKEN: get self" $ do emerge @(Emerge (Emerge (Show Int))) `shouldBe` Nothing