diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Data/Constraint/Emerge/Plugin.hs b/Data/Constraint/Emerge/Plugin.hs --- a/Data/Constraint/Emerge/Plugin.hs +++ b/Data/Constraint/Emerge/Plugin.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ ```haskell {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleConstraints #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin=Data.Constraint.Emerge.Plugin #-} diff --git a/constraints-emerge.cabal b/constraints-emerge.cabal --- a/constraints-emerge.cabal +++ b/constraints-emerge.cabal @@ -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 -> "<>" + Nothing -> "{{unshowable}}" @ . + where the 'Emerge (Show c)' will automatically be discharged for any monomorphic 'c'. + . See 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 diff --git a/test/EmergeSpec.hs b/test/EmergeSpec.hs --- a/test/EmergeSpec.hs +++ b/test/EmergeSpec.hs @@ -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` "<>" + showAnything (id @Int) `shouldBe` "<>" + 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