codet-plugin (empty) → 0.1
raw patch · 9 files changed
+460/−0 lines, 9 filesdep +basedep +codetdep +codet-plugin
Dependencies added: base, codet, codet-plugin, directory, filepath, ghc, syb, tasty, tasty-golden, template-haskell, transformers
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- codet-plugin.cabal +57/−0
- src-plugin/Plugin/GHC.hs +88/−0
- src/Language/Haskell/TH/CodeT/Plugin.hs +124/−0
- tests/codet-plugin-tests-900.txt +20/−0
- tests/codet-plugin-tests-902.txt +22/−0
- tests/codet-plugin-tests-906.txt +22/−0
- tests/codet-plugin-tests.hs +94/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.1++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Oleg Grenrus, Well-Typed LLP++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 Oleg Grenrus 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.
+ codet-plugin.cabal view
@@ -0,0 +1,57 @@+cabal-version: 2.4+name: codet-plugin+version: 0.1+license: BSD-3-Clause+license-file: LICENSE+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+copyright: 2023 Oleg Grenrus, Well-Typed LLP+category: Data+build-type: Simple+extra-doc-files: CHANGELOG.md+tested-with: GHC ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.3 || ==9.8.1+synopsis:+ GHC type-checker plugin for solving LiftT instances from codet++description:+ GHC type-checker plugin for solving LiftT instances from [codet](https://hackage.haskell.org/package/codet) package.++extra-source-files: tests/*.txt++source-repository head+ type: git+ location: https://github.com/phadej/codet.git+ subdir: codet-plugin++common language+ default-language: Haskell2010++library+ import: language+ hs-source-dirs: src src-plugin+ exposed-modules: Language.Haskell.TH.CodeT.Plugin+ other-modules: Plugin.GHC+ build-depends:+ , base ^>=4.15.1.0 || ^>=4.16.3.0 || ^>=4.17.2.1 || ^>=4.18.1.0 || ^>=4.19.0.0+ , codet ^>=0.1+ , ghc ^>=9.0.2 || ^>=9.2.3 || ^>=9.4.8 || ^>=9.6.3 || ^>=9.8.1++test-suite codet-plugin-tests+ import: language+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: codet-plugin-tests.hs+ build-depends:+ , base+ , codet+ , codet-plugin+ , template-haskell++ -- test dependencies+ build-depends:+ , directory ^>=1.3.6.2+ , filepath ^>=1.4.2.1+ , syb ^>=0.7.2.4+ , tasty ^>=1.5+ , tasty-golden ^>=2.3.5+ , transformers ^>=0.5.6.2 || ^>=0.6.1.0
+ src-plugin/Plugin/GHC.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE CPP #-}+module Plugin.GHC (+ module X,+ findClassConstraint,+ makeClassEvidence,+ findModulePluginM,+) where++import GHC.Core as X+import GHC.Core.Class as X+import GHC.Core.DataCon as X+import GHC.Core.Make as X+import GHC.Core.Predicate as X+import GHC.Core.TyCon as X+import GHC.Core.Type as X+import GHC.Core.Utils as X+import GHC.Data.FastString as X (FastString)+import GHC.Driver.Session as X+import GHC.Tc.Plugin as X+import GHC.Tc.Types as X+import GHC.Tc.Types.Constraint as X+import GHC.Tc.Types.Evidence as X+import GHC.Types.Id as X+import GHC.Types.Name as X+import GHC.Unit.Types as X+import GHC.Utils.Error as X+import GHC.Utils.Outputable as X++++#if __GLASGOW_HASKELL__ >= 906+import Language.Haskell.Syntax.Module.Name as X (ModuleName, mkModuleName, moduleNameString)+#else+import GHC.Unit.Module.Name as X (ModuleName, mkModuleName, moduleNameString)+#endif++#if __GLASGOW_HASKELL__ >=904+import GHC.Driver.Env (hsc_unit_env)+import GHC.Rename.Names (renamePkgQual)+#endif++#if __GLASGOW_HASKELL__ >=902+import GHC.Utils.Logger+#endif++import Control.Monad (guard)++findClassConstraint :: Class -> Ct -> Maybe (Ct, [Type])+findClassConstraint cls ct = do+ (cls', args) <- getClassPredTys_maybe (ctPred ct)+ guard (cls' == cls)+ return (ct, args)++makeClassEvidence :: Class -> [Type] -> CoreExpr -> EvTerm+makeClassEvidence cls args e = EvExpr appDc where+ tyCon = classTyCon cls+ dc = tyConSingleDataCon tyCon+ appDc = mkCoreConApps dc $ map Type args ++ [e]++fatal :: SDoc -> TcPluginM ()+fatal doc = do+#if __GLASGOW_HASKELL__ >=902+ logger <- unsafeTcPluginTcM getLogger+#if __GLASGOW_HASKELL__ >= 904+ tcPluginIO $ fatalErrorMsg logger doc+#else+ dflags <- unsafeTcPluginTcM getDynFlags+ tcPluginIO $ fatalErrorMsg logger dflags doc+#endif+#else+ dflags <- unsafeTcPluginTcM getDynFlags+ tcPluginIO $ fatalErrorMsg dflags doc+#endif++findModulePluginM :: ModuleName -> FastString -> TcPluginM Module+findModulePluginM m pkg = do+#if __GLASGOW_HASKELL__ >=904+ hscEnv <- getTopEnv+ let pkgQual = renamePkgQual (hsc_unit_env hscEnv) m (Just pkg)+#else+ let pkgQual = Just pkg+#endif+ im <- findImportedModule m pkgQual+ case im of+ Found _ md -> return md+ _ -> do+ fatal $ text "Cannot find module" <+> ppr m+ fail "panic!"
+ src/Language/Haskell/TH/CodeT/Plugin.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+module Language.Haskell.TH.CodeT.Plugin (+ plugin,+) where++import Control.Monad (forM)+import Data.Maybe (catMaybes)+import Data.String (fromString)++import qualified GHC.Plugins as Plugins++import Plugin.GHC++-- | A GHC type-checker plugin which solves 'Language.Haskell.TH.CodeT.LiftT' instances.+--+-- At the moment plugin solves only type constructor instances,+-- e.g. for a data type+--+-- @+-- data Foo a = MkFoo a+-- @+--+-- the plugin will solve needed instances in @'Language.Hsakell.TH.CodeT.codeT' \@Foo@ and @'Language.Hsakell.TH.CodeT.codeT' \@('MkFoo)@.+-- (There is @(LiftT f, LiftT x) => LiftT (f x)@ existing instance, so plugin doesn't need to).+--+-- Noteably, the plugin solves only for algebraic type constructors (@data@, @newtype@, @class@) and+-- promoted data constructors. Specifically it doesn't solve for type-family type constructors.+--+-- Enable plugin with:+--+-- @+-- \{-# OPTIONS_GHC -fplugin=Language.Haskell.TH.CodeT.Plugin #-\}+-- @+--+plugin :: Plugins.Plugin+plugin = Plugins.defaultPlugin+ { Plugins.tcPlugin = Just . tcPlugin+ }++tcPlugin :: a -> TcPlugin+tcPlugin _ = TcPlugin+ { tcPluginInit = tcPluginInit_+ , tcPluginSolve = tcPluginSolve_+ , tcPluginStop = const (return ())+#if __GLASGOW_HASKELL__ >=904+ , tcPluginRewrite = \_ -> Plugins.emptyUFM+#endif+ }++data PluginCtx = PluginCtx+ { liftTClass :: Class+ , unsafeCodeTNameD :: Id+ , unsafeCodeTNameTC :: Id+ }++tcPluginInit_ :: TcPluginM PluginCtx+tcPluginInit_ = do+ let codet :: FastString+ codet = fromString "codet"++ let codeTModuleName :: ModuleName+ codeTModuleName = mkModuleName "Language.Haskell.TH.CodeT.Unsafe"++ liftTClass <- do+ md <- findModulePluginM codeTModuleName codet+ tcLookupClass =<< lookupOrig md (mkTcOcc "LiftT")++ unsafeCodeTNameD <- do+ md <- findModulePluginM codeTModuleName codet+ lookupOrig md (mkVarOcc "unsafeCodeTNameD") >>= tcLookupId++ unsafeCodeTNameTC <- do+ md <- findModulePluginM codeTModuleName codet+ lookupOrig md (mkVarOcc "unsafeCodeTNameTC") >>= tcLookupId++ return PluginCtx {..}++tcPluginSolve_ :: PluginCtx -> TcPluginSolver+tcPluginSolve_ ctx _evBindsVar _given wanteds = do+ solved' <- unsafeTcPluginTcM $ forM wanteds $ \wanted -> solveLiftT ctx wanted++ let solved :: [(EvTerm, Ct)]+ solved = catMaybes solved'++ let new :: [Ct]+ new = []+ return $ TcPluginOk solved new++solveLiftT :: PluginCtx -> Ct -> TcM (Maybe (EvTerm, Ct))+solveLiftT ctx wanted+ | Just (ct, [k, x]) <- findClassConstraint (liftTClass ctx) wanted+ , Just (xTyCon, _args) <- splitTyConApp_maybe x+ , isAlgTyCon xTyCon || isPromotedDataCon xTyCon+ -- , let ki = tyConKind xTyCon+ -- in 9.0 splitPiTysInvisible+ -- , (_invPis, _) <- splitInvisPiTys ki+ , let xTyConName = getName xTyCon+ , Just tcMod <- nameModule_maybe xTyConName+ -- TODO: check that 'args' count matches 'invPis'?++ = do+ let occ = nameOccName xTyConName++ -- tcPluginIO $ logOutput logger $ text "wanted:" <+> ppr x+ let pkg_str = unitString (moduleUnit tcMod)+ mod_str = moduleNameString (moduleName tcMod)+ occ_str = occNameString occ++ pkg_str' <- mkStringExpr pkg_str+ mod_str' <- mkStringExpr mod_str+ occ_str' <- mkStringExpr occ_str++ let fun | isDataOcc occ = unsafeCodeTNameD ctx+ | isTcOcc occ = unsafeCodeTNameTC ctx+ | otherwise = Plugins.pprPanic "solveLiftT" (ppr xTyConName)++ let ev = mkCoreApps (Var fun) [Type k, Type x, pkg_str', mod_str', occ_str']+ let evidence = makeClassEvidence (liftTClass ctx) [k, x] ev++ return (Just (evidence, ct))++ | otherwise+ = return Nothing
+ tests/codet-plugin-tests-900.txt view
@@ -0,0 +1,20 @@+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+Data.Proxy.Proxy+(ConT (Name (OccName "Proxy") (NameG (TcClsName) (PkgName "base") (ModName "Data.Proxy"))))+GHC.Maybe.Just+(ConT (Name (OccName "Just") (NameG (DataName) (PkgName "base") (ModName "GHC.Maybe"))))+Main.Foo+(ConT (Name (OccName "Foo") (NameG (TcClsName) (PkgName "main") (ModName "Main"))))+Main.Foo+(ConT (Name (OccName "Foo") (NameG (DataName) (PkgName "main") (ModName "Main"))))+GHC.Types.[] GHC.Types.Int+(AppT (ConT (Name (OccName "[]") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types")))) (ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types")))))+GHC.Show.Show+(ConT (Name (OccName "Show") (NameG (TcClsName) (PkgName "base") (ModName "GHC.Show"))))+1+(LitT (NumTyLit (1)))+"string"+(LitT (StrTyLit "string"))+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))
+ tests/codet-plugin-tests-902.txt view
@@ -0,0 +1,22 @@+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+Data.Proxy.Proxy+(ConT (Name (OccName "Proxy") (NameG (TcClsName) (PkgName "base") (ModName "Data.Proxy"))))+GHC.Maybe.Just+(ConT (Name (OccName "Just") (NameG (DataName) (PkgName "base") (ModName "GHC.Maybe"))))+Main.Foo+(ConT (Name (OccName "Foo") (NameG (TcClsName) (PkgName "main") (ModName "Main"))))+Main.Foo+(ConT (Name (OccName "Foo") (NameG (DataName) (PkgName "main") (ModName "Main"))))+GHC.Types.[] GHC.Types.Int+(AppT (ConT (Name (OccName "[]") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types")))) (ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types")))))+GHC.Show.Show+(ConT (Name (OccName "Show") (NameG (TcClsName) (PkgName "base") (ModName "GHC.Show"))))+1+(LitT (NumTyLit (1)))+"string"+(LitT (StrTyLit "string"))+'c'+(LitT (CharTyLit ('c')))+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))
+ tests/codet-plugin-tests-906.txt view
@@ -0,0 +1,22 @@+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+Data.Proxy.Proxy+(ConT (Name (OccName "Proxy") (NameG (TcClsName) (PkgName "base") (ModName "Data.Proxy"))))+GHC.Maybe.Just+(ConT (Name (OccName "Just") (NameG (DataName) (PkgName "base") (ModName "GHC.Maybe"))))+Main.Foo+(ConT (Name (OccName "Foo") (NameG (TcClsName) (PkgName "main") (ModName "Main"))))+Main.Foo+(ConT (Name (OccName "Foo") (NameG (DataName) (PkgName "main") (ModName "Main"))))+GHC.Types.List GHC.Types.Int+(AppT (ConT (Name (OccName "List") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types")))) (ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types")))))+GHC.Show.Show+(ConT (Name (OccName "Show") (NameG (TcClsName) (PkgName "base") (ModName "GHC.Show"))))+1+(LitT (NumTyLit (1)))+"string"+(LitT (StrTyLit "string"))+'c'+(LitT (CharTyLit ('c')))+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))
+ tests/codet-plugin-tests.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fplugin=Language.Haskell.TH.CodeT.Plugin #-}+{-# OPTIONS_GHC -dcore-lint #-}+module Main (main, Stuck) where++import Control.Monad.Trans.State (State, evalState, get, put)+import Data.Generics (gshow)+import Data.Proxy (Proxy)+import Data.String (fromString)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import System.Directory (doesFileExist, setCurrentDirectory)+import System.FilePath ((</>))+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.Golden (goldenVsStringDiff)++import Language.Haskell.TH.CodeT++type family Stuck where++data Foo a = Foo a+type MyInt = Int++findPackageDir :: IO ()+findPackageDir = do+ try1 <- doesFileExist cabalFile+ if try1 then return () else do+ try2 <- doesFileExist (directory </> cabalFile)+ if try2 then setCurrentDirectory directory else fail $ "cannot find directory with " ++ cabalFile+ where+ directory = "codet-plugin"+ cabalFile = "codet-plugin.cabal"++ghcVer :: Int -> Int+ghcVer v+ | v >= 906 = 906 -- 9.6+ prints GHC.Types.List, not []+ | v >= 902 = 902 -- 9.2+ has Char kind+ | otherwise = 900++main :: IO ()+main = do+ findPackageDir+ let output = "tests/codet-plugin-tests-" ++ show (ghcVer __GLASGOW_HASKELL__) ++ ".txt"+ defaultMain $ testGroup "codet"+ [ goldenVsStringDiff "basic" diff output $ do+ return $ fromString $ unlines $ concat+ [ dispType (codeT @Int)+ , dispType (codeT @Proxy)+ , dispType (codeT @Just)+ , dispType (codeT @Foo)+ , dispType (codeT @('Foo))+ , dispType (codeT @[Int])+ , dispType (codeT @Show)+ , dispType (codeT @1)+ , dispType (codeT @"string")+#if MIN_VERSION_base(4,16,0)+ , dispType (codeT @'c')+#endif+ , dispType (codeT @MyInt) -- Int+ -- , dispType (codeT @Stuck) -- fails+ ]+ ]++diff :: FilePath -> FilePath -> [String]+diff ref new = ["diff", "-u", ref, new]++dispType :: CodeT P a -> [String]+dispType c =+ [ show (ppr ty)+ , gshow ty+ ]+ where+ ty = runP (unTypeCodeT c)++newtype P a = P (State Uniq a)+ deriving stock Functor+ deriving newtype (Applicative, Monad)++runP :: P a -> a+runP (P s) = evalState s 0++instance Quote P where+ newName s = do+ u <- P get+ P (put (u + 1))+ return (mkNameU s u)