diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ghc-definitions-th + +## 0.1.0.0 -- 2021-09-08 + +* Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021, Anthony Vandikas + +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 Anthony Vandikas 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/ghc-definitions-th.cabal b/ghc-definitions-th.cabal new file mode 100644 --- /dev/null +++ b/ghc-definitions-th.cabal @@ -0,0 +1,43 @@ +cabal-version: 3.0 +name: ghc-definitions-th +version: 0.1 +synopsis: Automatically generate GHC API counterparts to Haskell + declarations. +description: Template Haskell functions for automatically generating + definitions for @TyCon@s, @Var@s, and @DataCon@s of known + type constructors, functions, and data constructors. + Primarily intended for the development of type checker + plugins. +homepage: https://github.com/YellPika/ghc-definitions-th +bug-reports: https://github.com/YellPika/ghc-definitions-th/issues +license: BSD-3-Clause +license-file: LICENSE +author: Anthony Vandikas +maintainer: yellpika@gmail.com +copyright: © 2021 Anthony Vandikas +category: GHC, Template Haskell +extra-source-files: CHANGELOG.md + +library + exposed-modules: GHC.Definitions.TH, + GHC.Definitions.TH.Example + other-extensions: BlockArguments, + ConstraintKinds, + PatternSynonyms, + TemplateHaskell, + UnicodeSyntax, + ViewPatterns + build-depends: base >=4.14 && <4.17, + constraints >=0.13 && <0.15, + ghc >=8.10 && <9.3, + template-haskell >=2.16 && <2.19 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + if impl(ghc < 9.0) + mixins: + ghc ( Class as GHC.Core.Class + , GhcPlugins as GHC.Plugins + , TcPluginM as GHC.Tc.Plugin + , TysWiredIn as GHC.Builtin.Types + ) diff --git a/src/GHC/Definitions/TH.hs b/src/GHC/Definitions/TH.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Definitions/TH.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Definitions.TH ( + Config (..), autoConfig, defaultConfig, + makeDefinitions, makeDefinitionsWithConfig, + makePattern +) where + +import Data.Char (toLower) +import Data.Constraint (Dict (..)) +import Data.Maybe (fromJust, fromMaybe) + +import Language.Haskell.TH.Lib (appE, bang, bangType, bindS, clause, conT, + cxt, dataD, doE, explBidir, fieldExp, + forallT, funD, implicitParamBindD, + implicitParamT, implicitParamVarE, letS, + noBindS, noSourceStrictness, + noSourceUnpackedness, normalB, patSynD, + patSynSigD, prefixPatSyn, recC, recConE, + sigD, tySynD, varBangType, varE, varP, varT) +import Language.Haskell.TH.Syntax (Dec, Exp, Info (..), Lift (..), Name, Pat, Q, + Quasi (..), Stmt, Type (..), VarBangType, + mkName, nameBase, nameModule) + +import qualified GHC.Core.Class as GHC +import qualified GHC.Plugins as GHC +import qualified GHC.Tc.Plugin as GHC + +data Config = Config + { recordName ∷ String + , implicitName ∷ String + , constraintName ∷ String + , functionName ∷ String + , operatorTable ∷ [(Char, String)] + } + +autoConfig ∷ String → Config +autoConfig name = Config + { recordName = name ++ "Record" + , implicitName = lower name + , constraintName = name + , functionName = "find" ++ name + , operatorTable = + [ ('+', "Plus") + , ('-', "Minus") + , ('*', "Star") + , ('=', "Equals") + , ('#', "Hash") + , ('!', "Bang") + , ('@', "At") + , ('$', "Dollar") + , ('%', "Percent") + , ('^', "Accent") + , ('&', "And") + , ('<', "Less") + , ('>', "Greater") + , ('?', "Question") + , ('|', "Pipe") + , ('/', "Slash") + , ('\\', "Backslash") + , ('.', "Dot") + , ('~', "Tilde") + ] + } + +defaultConfig ∷ Config +defaultConfig = autoConfig "Definitions" + +-- | Given a list of names @names@, @makeDefinitions@ constructs the following: +-- +-- 1. A constraint @Definitions@. +-- 2. A function @findDefinitions ∷ 'GHC.TcPluginM' ('Dict' Definitions)@ +-- 3. For each @name ∈ names@, a function @name⟨type⟩ ∷ Definitions ⇒ +-- ⟨type⟩@, where @⟨type⟩@ is determined by whatever @name@ refers to, i.e. a +-- data constructor @('GHC.DataCon')@, function or value @('GHC.Var')@, or +-- type constructor @('GHC.TyCon')@. +makeDefinitions ∷ [Name] → Q [Dec] +makeDefinitions = makeDefinitionsWithConfig defaultConfig + +-- | Like 'makeDefinitions', but allows some control over the generated names. +makeDefinitionsWithConfig ∷ Config → [Name] → Q [Dec] +makeDefinitionsWithConfig + Config + { recordName = (mkName → recordN) + , implicitName = implicitN + , constraintName = (mkName → constraintN) + , functionName = (mkName → functionN) + , operatorTable = opTable + } + names = + mkConstraintTy +: + mkRecordTy +: + mkFunction +++ + concatMapM mkAccessor names + where + concatMapM ∷ Monad m ⇒ (a → m [b]) → [a] → m [b] + concatMapM f = fmap concat . traverse f + + mkConstraintTy ∷ Q Dec + mkConstraintTy = tySynD constraintN [] (implicitParamT implicitN (conT recordN)) + + mkRecordTy ∷ Q Dec + mkRecordTy = dataD (cxt []) recordN [] Nothing [recC recordN (map mkField names)] [] + + mkFieldName ∷ Name → Q Name + mkFieldName = fmap (mkName . ("_" ++) . nameBase) . mkAccessorName + + mkFieldName' ∷ Name → Q Name + mkFieldName' = fmap (mkName . ("__" ++) . nameBase) . mkAccessorName + + mkField ∷ Name → Q VarBangType + mkField name = do + name' ← mkFieldName name + varBangType name' (bangType + (bang noSourceUnpackedness noSourceStrictness) + (mkFieldType name)) + + mkFieldType ∷ Name → Q Type + mkFieldType name = do + info ← qReify name + case info of + ClassI {} → [t|GHC.Class|] + ClassOpI {} → [t|GHC.Var|] + TyConI {} → [t|GHC.TyCon|] + FamilyI {} → [t|GHC.TyCon|] + PrimTyConI {} → [t|GHC.TyCon|] + DataConI {} → [t|GHC.DataCon|] + VarI {} → [t|GHC.Var|] + PatSynI {} → error "Don't know what to do with pattern synonyms yet..." + TyVarI {} → error "Unexpected type variable name" + + mkFunction ∷ Q [Dec] + mkFunction = sequence + [ sigD functionN [t| GHC.TcPluginM (Dict $(conT constraintN)) |] + , funD functionN [clause [] + (normalB (doE + ( map mkFunctionStmt names ++ + [ letS [implicitParamBindD implicitN (recConE recordN (map mkRecordExp names))] + , noBindS [e|return Dict|] + ] ))) + []] + ] + + mkFunctionStmt ∷ Name → Q Stmt + mkFunctionStmt name = do + name' ← mkFieldName' name + bindS (varP name') (mkFunctionExp name) + + mkFunctionExp ∷ Name → Q Exp + mkFunctionExp name = do + let md = lift (fromJust (nameModule name)) + on = lift (alphaNumNameBase name) + info ← qReify name + case info of + ClassI {} → [e|lookupClass $md $on|] + ClassOpI {} → [e|lookupVar $md $on|] + TyConI {} → [e|lookupTyCon $md $on|] + FamilyI {} → [e|lookupTyCon $md $on|] + PrimTyConI {} → [e|lookupTyCon $md $on|] + DataConI {} → [e|lookupDataCon $md $on|] + VarI {} → [e|lookupVar $md $on|] + PatSynI {} → error "Don't know what to do with pattern synonyms yet..." + TyVarI {} → error "Unexpeced type variable name" + + mkRecordExp ∷ Name → Q (Name, Exp) + mkRecordExp name = do + name' ← mkFieldName name + name'' ← mkFieldName' name + fieldExp name' (varE name'') + + mkAccessor ∷ Name → Q [Dec] + mkAccessor name = do + acc ← mkAccessorName name + promote ← isDataCon name + name' ← mkFieldName name + let defaultDefs = + [ sigD acc [t| $(conT constraintN) ⇒ $(mkFieldType name) |] + , funD acc [clause [] + (normalB + (appE (varE name') (implicitParamVarE implicitN))) + []] + ] + promotedDefs = + [ sigD (mkPromotedAccessorName name) [t| $(conT constraintN) ⇒ GHC.TyCon |] + , funD (mkPromotedAccessorName name) [clause [] (normalB [e| GHC.promoteDataCon $(varE acc)|]) []] + ] + sequence (defaultDefs ++ (if promote then promotedDefs else [])) + + mkAccessorName ∷ Quasi m ⇒ Name → m Name + mkAccessorName name = do + info ← qReify name + return . mkName . lower $ case info of + ClassI {} → alphaNumNameBase name ++ "Class" + ClassOpI {} → alphaNumNameBase name ++ "Var" + TyConI {} → alphaNumNameBase name ++ "TyCon" + FamilyI {} → alphaNumNameBase name ++ "TyCon" + PrimTyConI {} → alphaNumNameBase name ++ "TyCon" + DataConI {} → alphaNumNameBase name ++ "DataCon" + VarI {} → alphaNumNameBase name ++ "Var" + PatSynI {} → error "Don't know what to do with pattern synonyms yet..." + TyVarI {} → error "Unexpected type variable name" + + mkPromotedAccessorName ∷ Name → Name + mkPromotedAccessorName name = mkName ("promoted" ++ alphaNumNameBase name ++ "TyCon") + + isDataCon ∷ Quasi m ⇒ Name → m Bool + isDataCon name = do + info ← qReify name + case info of + DataConI {} → return True + _ → return False + + alphaNumNameBase ∷ Name → String + alphaNumNameBase = concatMap (\c → fromMaybe [c] (lookup c opTable)) . nameBase + +-- | Constructs a pattern synonym for a given 'GHC.TyCon', 'GHC.DataCon', or +-- 'GHC.Var'. +makePattern ∷ String → Name → Q [Dec] +makePattern (mkName → patName) valName = do + x ← qNewName "x" + ty ← qReifyType valName + sequence + [ patSynSigD patName (mkPatternType ty) + , patSynD patName (prefixPatSyn [x]) + (explBidir [clause [varP x] (normalB (mkPatternExp ty (varE x))) []]) + (mkPatternPat ty (varP x)) + ] + where + mkPatternType ∷ Type → Q Type + mkPatternType (ForallT _ ctxt ty) = forallT [] (pure ctxt) (mkPatternType ty) + mkPatternType (ConT name) + | name == ''GHC.TyCon + || name == ''GHC.Class = [t| [GHC.Type] → GHC.Type |] + | name == ''GHC.Var + || name == ''GHC.DataCon = qNewName "a" >>= \a → [t| [GHC.Expr $(varT a)] → GHC.Expr $(varT a) |] + mkPatternType ty = error ("Unexpected type: " ++ show ty) + + mkPatternPat ∷ Type → Q Pat → Q Pat + mkPatternPat (ForallT _ _ ty) pat = mkPatternPat ty pat + mkPatternPat (ConT name) pat + | name == ''GHC.TyCon = [p|(GHC.splitTyConApp_maybe → Just ((== $(varE valName)) → True, $pat))|] + | name == ''GHC.Class = [p|(GHC.splitTyConApp_maybe → Just ((== GHC.classTyCon $(varE valName)) → True, $pat))|] + | name == ''GHC.Var = [p|(GHC.collectArgs → (GHC.Var ((== $(varE valName)) → True), $pat))|] + | name == ''GHC.DataCon = [p|(GHC.collectArgs → (GHC.Var ((== GHC.dataConWorkId $(varE valName)) → True), $pat))|] + mkPatternPat ty _ = error ("Unexpected type: " ++ show ty) + + mkPatternExp ∷ Type → Q Exp → Q Exp + mkPatternExp (ForallT _ _ ty) pat = mkPatternExp ty pat + mkPatternExp (ConT name) pat + | name == ''GHC.TyCon = [e|GHC.mkTyConApp $(varE valName) $pat|] + | name == ''GHC.Class = [e|GHC.mkTyConApp (GHC.classTyCon $(varE valName)) $pat|] + | name == ''GHC.Var = [e|GHC.mkApps (GHC.Var $(varE valName)) $pat|] + | name == ''GHC.DataCon = [e|GHC.mkConApp $(varE valName) $pat|] + mkPatternExp ty _ = error ("Unexpected type: " ++ show ty) + +lookupClass ∷ String → String → GHC.TcPluginM GHC.Class +lookupClass mn on = do + md ← lookupModule mn + GHC.tcLookupClass =<< GHC.lookupOrig md (GHC.mkClsOcc on) + +lookupTyCon ∷ String → String → GHC.TcPluginM GHC.TyCon +lookupTyCon mn on = do + md ← lookupModule mn + GHC.tcLookupTyCon =<< GHC.lookupOrig md (GHC.mkTcOcc on) + +lookupDataCon ∷ String → String → GHC.TcPluginM GHC.DataCon +lookupDataCon mn on = do + md ← lookupModule mn + GHC.tcLookupDataCon =<< GHC.lookupOrig md (GHC.mkDataOcc on) + +lookupVar ∷ String → String → GHC.TcPluginM GHC.Var +lookupVar mn on = do + md ← lookupModule mn + GHC.tcLookupId =<< GHC.lookupOrig md (GHC.mkVarOcc on) + +lookupModule ∷ String → GHC.TcPluginM GHC.Module +lookupModule mn = do + result ← GHC.findImportedModule (GHC.mkModuleName mn) Nothing + case result of + GHC.Found _ md → return md + _ → do + GHC.tcPluginTrace "[ghc-definitions-th]" (GHC.text ("Could not locate module " ++ mn)) + error "lookupModule: failed" + +lower ∷ String → String +lower "" = "" +lower (x:xs) = toLower x : xs + +infixr +:, +++ + +(+:) ∷ Applicative m ⇒ m a → m [a] → m [a] +x +: xs = (:) <$> x <*> xs + +(+++) ∷ Applicative m ⇒ m [a] → m [a] → m [a] +xs +++ ys = (++) <$> xs <*> ys diff --git a/src/GHC/Definitions/TH/Example.hs b/src/GHC/Definitions/TH/Example.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Definitions/TH/Example.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Definitions.TH.Example where + +import GHC.Builtin.Types (eqTyCon) +import GHC.Definitions.TH (makeDefinitions, makePattern) +import GHC.TypeNats (type (-)) + +makeDefinitions + [ 'id + , ''Maybe + , 'Nothing + , '(+) + , ''(-) + , ''Ord + ] + +makePattern "MaybeTy" 'maybeTyCon +makePattern "IdExpr" 'idVar +makePattern "NothingExpr" 'nothingDataCon +makePattern "NothingTy" 'promotedNothingTyCon +makePattern "EqTy" 'eqTyCon +makePattern "MinusTy" 'minusTyCon +makePattern "OrdTy" 'ordClass