constraints-emerge (empty) → 0.1
raw patch · 9 files changed
+482/−0 lines, 9 filesdep +basedep +constraintsdep +constraints-emergesetup-changed
Dependencies added: base, constraints, constraints-emerge, ghc, hashable, hspec
Files
- ChangeLog.md +5/−0
- Data/Constraint/Emerge.hs +47/−0
- Data/Constraint/Emerge/Plugin.hs +168/−0
- LICENSE +20/−0
- README.md +71/−0
- Setup.hs +2/−0
- constraints-emerge.cabal +54/−0
- test/EmergeSpec.hs +114/−0
- test/Main.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for constraints-emerge++## 0.1 -- 2018-04-18++* First version. Released on an unsuspecting world.
+ Data/Constraint/Emerge.hs view
@@ -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+
+ Data/Constraint/Emerge/Plugin.hs view
@@ -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"+ ]
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,71 @@+# constraints-emerge: defer instance lookups until runtime++[](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 -> "<<unshowable>>"+++showBool = showAnything True -- "True"+showId = showAnything id -- "<<unshowable>>"+```+++## 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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ constraints-emerge.cabal view
@@ -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 -> "<<unshowable>>"+ @+ .+ 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.++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
+ test/EmergeSpec.hs view
@@ -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 -> "<<unshowable>>"+++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` "<<unshowable>>"++ 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)
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}