ghc-definitions-th (empty) → 0.1
raw patch · 5 files changed
+406/−0 lines, 5 filesdep +basedep +constraintsdep +ghc
Dependencies added: base, constraints, ghc, template-haskell
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- ghc-definitions-th.cabal +43/−0
- src/GHC/Definitions/TH.hs +299/−0
- src/GHC/Definitions/TH/Example.hs +29/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for ghc-definitions-th++## 0.1.0.0 -- 2021-09-08++* Initial version.
+ LICENSE view
@@ -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.
+ ghc-definitions-th.cabal view
@@ -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+ )
+ src/GHC/Definitions/TH.hs view
@@ -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
+ src/GHC/Definitions/TH/Example.hs view
@@ -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