diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for constraints-emerge + +## 0.1 -- 2018-04-18 + +* First version. Released on an unsuspecting world. diff --git a/Data/Constraint/Emerge.hs b/Data/Constraint/Emerge.hs new file mode 100644 --- /dev/null +++ b/Data/Constraint/Emerge.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Constraint.Emerge + ( Emerge + , emerge + , Dict (..) + ) where + +import Data.Constraint + + +------------------------------------------------------------------------------ +-- | Typeclass asserting we can determine the existence of the constraint 'c' +-- at runtime. +class Emerge (c :: Constraint) where + emerge' :: Maybe (Dict c) + + +------------------------------------------------------------------------------ +-- | Get a dictionary for 'c' if it exists. +emerge :: Emerge c => Maybe (Dict c) +emerge = emerge' + + +------------------------------------------------------------------------------ +-- | A typeclass whose dictionaries we can coerce into those for 'Emerge' if +-- our constraint wasn't satisfied. +class AlwaysFail where + alwaysFail :: Maybe (Dict a) + +instance AlwaysFail where + alwaysFail = Nothing + + +------------------------------------------------------------------------------ +-- | A typeclass whose dictionaries we can coerce into those for 'Emerge' if +-- our constraint was satisfied. +class Succeed (a :: Constraint) where + succeed :: Maybe (Dict a) + +instance c => Succeed c where + succeed = Just Dict + diff --git a/Data/Constraint/Emerge/Plugin.hs b/Data/Constraint/Emerge/Plugin.hs new file mode 100644 --- /dev/null +++ b/Data/Constraint/Emerge/Plugin.hs @@ -0,0 +1,168 @@ +{-# OPTIONS_GHC -Wall #-} + +module Data.Constraint.Emerge.Plugin (plugin) where + +import Control.Exception (throw) +import Control.Monad +import Data.Maybe +import Prelude hiding (pred) + +import Class hiding (className) +import GHC (GhcException (..)) +import InstEnv (ClsInst (..), lookupUniqueInstEnv) +import Module (mkModuleName) +import OccName (mkTcOcc) +import Outputable +import Plugins (Plugin (..), defaultPlugin) +import TcEvidence (EvTerm (EvDFunApp)) +import TcPluginM +import TcRnTypes +import TyCon (TyCon, tyConName) +import Type (Type, splitTyConApp_maybe, isTyVarTy) + + +------------------------------------------------------------------------------ +-- | The exported 'Emerge' plugin. +plugin :: Plugin +plugin = defaultPlugin { tcPlugin = const $ Just emergePlugin } + + +------------------------------------------------------------------------------ +-- | Actual implementation of the plugin. +emergePlugin :: TcPlugin +emergePlugin = TcPlugin + { tcPluginInit = lookupEmergeTyCons + , tcPluginSolve = solveEmerge + , tcPluginStop = const (return ()) + } + + +------------------------------------------------------------------------------ +-- | Class instances from 'Data.Constraint.Emerge' necessary for us to know +-- about. +data EmergeData = EmergeData + { emergeEmerge :: Class + , emergeFail :: Class + , emergeSucceed :: Class + } + + +------------------------------------------------------------------------------ +-- | Lookup the classes from 'Data.Constraint.Emerge' and build an +-- 'EmergeData'. +lookupEmergeTyCons :: TcPluginM EmergeData +lookupEmergeTyCons = do + Found _ md <- findImportedModule emergeModule Nothing + emergeTcNm <- lookupOrig md $ mkTcOcc "Emerge" + failTcNm <- lookupOrig md $ mkTcOcc "AlwaysFail" + succeedTcNm <- lookupOrig md $ mkTcOcc "Succeed" + + EmergeData + <$> tcLookupClass emergeTcNm + <*> tcLookupClass failTcNm + <*> tcLookupClass succeedTcNm + where + emergeModule = mkModuleName "Data.Constraint.Emerge" + + +------------------------------------------------------------------------------ +-- | 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 c ct = do + let pred = ctev_pred $ cc_ev ct + case splitTyConApp_maybe pred of + Just (x, preds) -> + case x == classTyCon c of + True -> Just (ct, preds) + False -> Nothing + _ -> Nothing + + +------------------------------------------------------------------------------ +-- | 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 + -> [Ct] -- ^ [G]iven constraints + -> [Ct] -- ^ [D]erived constraints + -> [Ct] -- ^ [W]anted constraints + -> TcPluginM TcPluginResult +solveEmerge emerge _ _ allWs = do + let ws = mapMaybe (findEmergePred (emergeEmerge emerge)) $ allWs + case length ws of + 0 -> pure $ TcPluginOk [] [] + _ -> do + z <- traverse (discharge emerge) ws + pure $ TcPluginOk z [] + + +------------------------------------------------------------------------------ +-- | Discharge an 'Emerge' constraint. +discharge + :: EmergeData + -> (Ct, [Type]) + -> TcPluginM (EvTerm, Ct) +discharge emerge (ct, ts) = do + let [wantedDict] = ts + loc = getLoc ct + + (className, classParams) <- + case splitTyConApp_maybe wantedDict of + Just a -> pure a + Nothing -> throw $ PprProgramError "" $ helpMe2 loc + + myclass <- tcLookupClass (tyConName className) + envs <- getInstEnvs + case lookupUniqueInstEnv envs myclass classParams of + -- success! + Right (clsInst, _) -> do + let dfun = is_dfun clsInst + case lookupUniqueInstEnv envs (emergeSucceed emerge) ts of + Right (successInst, _) -> pure + (EvDFunApp (is_dfun successInst) ts [EvDFunApp dfun [] []], 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 + + case lookupUniqueInstEnv envs (emergeFail emerge) [] of + Right (clsInst, _) -> + pure (EvDFunApp (is_dfun clsInst) [] [], ct) + Left err -> + 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 'JustDoIt'" $$ hang empty 2 (ppr (ctl_origin loc)) + ) + , hang empty 2 $ (char '•') <+> text "Probable fix: add an explicit 'JustDoIt (" + <> 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 'JustDoIt'" $$ hang empty 2 (ppr (ctl_origin loc)) + ) + , hang empty 2 $ (char '•') <+> text "Probable fix: add an explicit 'JustDoIt c'" + <+> text "constraint to the type signature" + ] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Sandy Maguire + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,71 @@ +# constraints-emerge: defer instance lookups until runtime + +[![Build Status](https://api.travis-ci.org/isovector/constraints-emerge.svg?branch=master)](https://travis-ci.org/isovector/constraints-emerge) | [Hackage][hackage] + +[hackage]: https://hackage.haskell.org/package/constraints-emerge + + +## Dedication + +> Failure should be our teacher, not our undertaker. Failure is delay, not +> defeat. It is a temporary detour, not a dead end. Failure is something we can +> avoid only by saying nothing, doing nothing, and being nothing. +> +> Denis Waitley + + +## Synopsis + +```haskell +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fplugin=Data.Constraint.Emerge.Plugin #-} + +module Test where + +import Data.Constraint.Emerge + +showAnything :: forall c. Emerge (Show c) => c -> String +showAnything c = + case emerge @(Show c) of + Just Dict -> show c + Nothing -> "<>" + + +showBool = showAnything True -- "True" +showId = showAnything id -- "<>" +``` + + +## Known Bugs + +* `constraints-emerge` will generate type-equality dictionaries any types (even + ones that aren't equal :scream: :scream: :scream:) +* It fails to provide `Emerge c` dictionaries at runtime. +* The generated error messages mention mangled type variables; it would be cool + if they didn't. + +If someone wants to pick it up from here, that’d be great! + + +## Related Work + + * [union-constraints](https://github.com/rampion/constraint-unions) + * [Data.Constraint.Deferrable](https://github.com/ekmett/constraints/) + + +## Contact + +Please reports bugs and missing features at the [GitHub bugtracker][issues]. This is +also where you can find the [source code][source]. + +`constraints-emerge` was written by [Sandy Maguire][me] and is licensed under a +permissive MIT [license][lic]. + +[me]: http://reasonablypolymorphic.me +[lic]: https://github.com/isovector/constraints-emerge/blob/LICENSE +[issues]: https://github.com/isovector/constraints-emerge/issues +[source]: https://github.com/isovector/constraints-emerge + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/constraints-emerge.cabal b/constraints-emerge.cabal new file mode 100644 --- /dev/null +++ b/constraints-emerge.cabal @@ -0,0 +1,54 @@ +name: constraints-emerge +version: 0.1 +synopsis: Defer instance lookups until runtime +description: + This plugin allows you to write + . + @ + {-\# OPTIONS_GHC -fplugin Data.Constraint.Emerge.Plugin \#-} + module Test where + . + import Data.Constraint.Emerge + . + showAnything :: forall c. Emerge (Show c) => c -> String + showAnything c = + case emerge @(Show c) of + Just Dict -> show c + Nothing -> "<>" + @ + . + See + for a few examples of what this plugin can do for you. + +homepage: https://github.com/isovector/constraints-emerge +license: MIT +license-file: LICENSE +author: Sandy Maguire +maintainer: sandy@sandymaguire.me +copyright: 2018 Sandy Maguire +category: Constraints +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 +tested-with: GHC ==8.0.1, GHC ==8.0.2, GHC ==8.2.2 + +library + exposed-modules: Data.Constraint.Emerge.Plugin + exposed-modules: Data.Constraint.Emerge + build-depends: base >=4.9 && <5 + build-depends: hashable + build-depends: ghc >=8.0.1 + build-depends: constraints + default-language: Haskell2010 + +Test-Suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + other-modules: EmergeSpec + hs-Source-Dirs: test + main-is: Main.hs + build-depends: base >=4.9 && <5, constraints, hspec, constraints-emerge + +source-repository head + type: git + location: git://github.com/isovector/constraints-emerge.git diff --git a/test/EmergeSpec.hs b/test/EmergeSpec.hs new file mode 100644 --- /dev/null +++ b/test/EmergeSpec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fplugin=Data.Constraint.Emerge.Plugin #-} + +module EmergeSpec where + +import Data.Constraint.Emerge +import Test.Hspec + + +getMultiParam :: forall a b. Emerge (MultiParam a b) => Maybe (a, b) +getMultiParam = + case emerge @(MultiParam a b) of + Just Dict -> Just multiParam + Nothing -> Nothing + + +showAnything :: forall c. Emerge (Show c) => c -> String +showAnything c = + case emerge @(Show c) of + Just Dict -> show c + Nothing -> "<>" + + +brokenToInt :: forall c. Emerge (c ~ Int) => c -> Int +brokenToInt c = + case emerge @(c ~ Int) of + Just Dict -> c + Nothing -> 17 + + +spec :: Spec +spec = do + describe "dictionary lookups" $ do + it "Show Int" $ do + emerge @(Show Int) `shouldBe` Just Dict + + it "Show function" $ do + emerge @(Show (Bool -> Int)) `shouldBe` Nothing + + it "Show locally defined instance" $ do + emerge @(Show (MyType -> MyType)) `shouldBe` Just Dict + + it "Show orphan instance" $ do + emerge @(Show (String -> String)) `shouldBe` Just Dict + + + describe "dictionary usages" $ do + it "showAnything 5" $ do + showAnything (5 :: Int) `shouldBe` show (5 :: Int) + + it "showAnything True" $ do + showAnything True `shouldBe` show True + + it "showAnything id" $ do + showAnything id `shouldBe` "<>" + + it "getMultiParam @Int @Bool" $ do + getMultiParam `shouldBe` Just (1 :: Int, True) + getMultiParam @Int @Bool `shouldBe` Just (1, True) + + it "getMutliParam @Bool @Bool" $ do + getMultiParam @Bool @Bool `shouldBe` Nothing + + it "lookup overlapping instances" $ do + isOverlapping "hello" `shouldBe` False + isOverlapping True `shouldBe` True + + + describe "bugs" $ do + it "BROKEN: bool to int" $ do + brokenToInt True `shouldNotBe` 17 + + it "WORKS: int to int" $ do + brokenToInt 5 `shouldBe` 5 + + it "BROKEN: get self" $ do + emerge @(Emerge (Emerge (Show Int))) `shouldBe` Nothing + + + +-- local instance of 'Show' +data MyType +instance Show (MyType -> MyType) where + show = const "mytype function" + +-- orphan instance of 'Show' +instance Show (String -> String) where + show _ = "orphan show" + + +-- overlapping instances +class Overlapping z where + isOverlapping :: z -> Bool + +instance Overlapping a where + isOverlapping = const False + +instance {-# OVERLAPPING #-} Overlapping Bool where + isOverlapping = const True + + +-- multi param typeclasses +class MultiParam a b where + multiParam :: (a, b) + +instance MultiParam Int Bool where + multiParam = (1, True) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}