diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## 0.1 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/codet-plugin.cabal b/codet-plugin.cabal new file mode 100644 --- /dev/null +++ b/codet-plugin.cabal @@ -0,0 +1,57 @@ +cabal-version: 2.4 +name: codet-plugin +version: 0.1 +license: BSD-3-Clause +license-file: LICENSE +author: Oleg Grenrus +maintainer: Oleg Grenrus +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 diff --git a/src-plugin/Plugin/GHC.hs b/src-plugin/Plugin/GHC.hs new file mode 100644 --- /dev/null +++ b/src-plugin/Plugin/GHC.hs @@ -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!" diff --git a/src/Language/Haskell/TH/CodeT/Plugin.hs b/src/Language/Haskell/TH/CodeT/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/CodeT/Plugin.hs @@ -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 diff --git a/tests/codet-plugin-tests-900.txt b/tests/codet-plugin-tests-900.txt new file mode 100644 --- /dev/null +++ b/tests/codet-plugin-tests-900.txt @@ -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")))) diff --git a/tests/codet-plugin-tests-902.txt b/tests/codet-plugin-tests-902.txt new file mode 100644 --- /dev/null +++ b/tests/codet-plugin-tests-902.txt @@ -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")))) diff --git a/tests/codet-plugin-tests-906.txt b/tests/codet-plugin-tests-906.txt new file mode 100644 --- /dev/null +++ b/tests/codet-plugin-tests-906.txt @@ -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")))) diff --git a/tests/codet-plugin-tests.hs b/tests/codet-plugin-tests.hs new file mode 100644 --- /dev/null +++ b/tests/codet-plugin-tests.hs @@ -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)