magic-tyfams (empty) → 0.1.0.0

raw patch · 6 files changed

+227/−0 lines, 6 filesdep +basedep +ghcdep +ghc-tcplugins-extrasetup-changed

Dependencies added: base, ghc, ghc-tcplugins-extra, syb

Files

• ChangeLog.md +7/−0
• LICENSE +30/−0
• README.md +33/−0
• Setup.hs +2/−0
• magic-tyfams.cabal +42/−0
• src/Plugin/MagicTyFam.hs +113/−0

@@ -0,0 +1,7 @@+# Changelog for type-sets++## 0.1.0.0 --- 2019-08-05++Initial release!++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Sandy Maguire (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sandy Maguire nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,33 @@+# cmptype++## Dedication++> Comparison is an act of violence against the self.+>+> Iyanla Vanzant+++## Overview++`cmptype` provides a magical type family that lets you compare types:++```haskell+type family CmpType (a :: k) (b :: k) :: Ordering+```++When you turn on the `-fplugin=Type.Compare.Plugin` flag, it will let you+compare arbitrary types. Why would you want such a thing? Probably because you+want to write a type-level container that isn't a fucking list!+++## Acknowledgments++Big thanks to [Boris Rozinov][oofp] for the initial idea, and for making as much+coffee as I could drink while I wrote it. Also thanks to [Christiaan+Baaij][chistiaanb] and [Matt Pickering][mpickering] for their indispensable help+convincing GHC to do the right thing here.++[oofp]: https://github.com/oofp+[chistiaanb]: https://christiaanb.github.io/+[mpickering]: http://mpickering.github.io/+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,42 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: d2d7b9baf0c8c55312fee132eb5e0fbb0487626c4739f5510005a60ed17a8cd4++name:           magic-tyfams+version:        0.1.0.0+synopsis:       Write plugins for magic type families with ease+description:    Please see the README on GitHub at <https://github.com/isovector/type-sets/tree/master/cmptype#readme>+category:       Compiler Plugin+homepage:       https://github.com/https://github.com/isovector/type-sets/tree/master/cmptype#readme+bug-reports:    https://github.com/https://github.com/isovector/type-sets/tree/master/cmptype/issues+author:         Sandy Maguire+maintainer:     sandy@sandymaguire.me+copyright:      2019 Sandy Maguire+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/https://github.com/isovector/type-sets/tree/master/cmptype++library+  exposed-modules:+      Plugin.MagicTyFam+  other-modules:+      Paths_magic_tyfams+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , ghc >=8.6.3 && <8.8+    , ghc-tcplugins-extra >=0.3 && <0.4+    , syb >=0.7 && <0.8+  default-language: Haskell2010

@@ -0,0 +1,113 @@+{-# LANGUAGE BangPatterns  #-}+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall      #-}++module Plugin.MagicTyFam+  ( magicTyFamPlugin++    -- * Semantics+  , withStuckSemantics+  , isTyFamFree++    -- * Low level stuff+  , solveWanteds+  , loadTyCon++    -- * Re-exports+  , Plugin+  , TyCon+  , Type+  ) where++import Control.Monad (guard)+import Data.Generics (everything, mkQ)+import Data.Traversable (for)+import GHC.TcPluginM.Extra (lookupModule, lookupName, evByFiat)+import GhcPlugins+import TcEvidence (EvTerm (..))+import TcPluginM (TcPluginM, tcLookupTyCon, newGiven)+import TcRnTypes+import TcType (isTyFamFree)+++------------------------------------------------------------------------------+-- | Get your hands on the type constructor for your type family.+loadTyCon+    :: String  -- ^ package+    -> String  -- ^ module+    -> String  -- ^ identifier+    -> TcPluginM TyCon+loadTyCon p m i = do+  md <- lookupModule (mkModuleName m) $ fsLit p+  nm <- lookupName md $ mkTcOcc i+  tcLookupTyCon nm+++------------------------------------------------------------------------------+-- | Generate a plugin that solves instances of the type family pointed at by+-- the three strings, via the function.+magicTyFamPlugin+    :: String  -- ^ package+    -> String  -- ^ module+    -> String  -- ^ identifier+    -> ([Type] -> Maybe Type)+    -> Plugin+magicTyFamPlugin p m i f = defaultPlugin+  { tcPlugin = const $ Just $ TcPlugin+      { tcPluginInit = loadTyCon p m i+      , tcPluginSolve = \cmp_type _ _ w ->+          TcPluginOk [] <$> solveWanteds f cmp_type w+      , tcPluginStop = const $ pure ()+      }+  , pluginRecompile = const $ pure NoForceRecompile+  }+++------------------------------------------------------------------------------+-- | Ensure that your resulting type family preserves the stuckness property,+-- namely that it is stuck if any of its children are stuck.+--+-- You can use 'isTyFamFree' instead of 'withStuckSemantics' if you want tigher+-- control over when your magic type family should be stuck.+withStuckSemantics :: ([Type] -> Maybe Type) -> [Type] -> Maybe Type+withStuckSemantics f ts = do+  guard $ all isTyFamFree ts+  f ts+++------------------------------------------------------------------------------+-- | @solveWanteds f tyfam cts@ finds all instaces of @tyfam@ inside the wanted+-- constraints @cts@, and evaluates them via @f@. The result is a set of+-- 'CNonCanonical' constraints, which should be emitted as the second parameter+-- of 'TcPluginOk'.+solveWanteds :: ([Type] -> Maybe Type) -> TyCon -> [Ct] -> TcPluginM [Ct]+solveWanteds _ _ [] = pure []+solveWanteds f cmp_type wanted = do+  let rel = fmap (findRelevant f cmp_type . ctLoc <*> ctev_pred . cc_ev) wanted++  gs <- for (concat rel) $ \(MagicTyFamResult loc t res) -> do+    let EvExpr ev = evByFiat "magic-tyfams" t res+    newGiven loc (mkPrimEqPred t res) ev++  pure $ fmap CNonCanonical gs+++------------------------------------------------------------------------------+-- | Locate and expand the use of any type families.+findRelevant :: ([Type] -> Maybe Type) -> TyCon -> CtLoc -> Type -> [MagicTyFamResult]+findRelevant f cmp_type loc = everything (++) $ mkQ [] findCmpType+  where+    findCmpType t =+      case splitTyConApp_maybe t of+        Just (tc, ts) | tc == cmp_type ->+           maybe [] (pure . MagicTyFamResult loc t) $ f ts+        _ -> []+++data MagicTyFamResult = MagicTyFamResult+  { _mtfrLoc      :: CtLoc+  , _mtfrOriginal :: Type+  , _mtfrSolved   :: Type+  }+