codet (empty) → 0.1
raw patch · 9 files changed
+552/−0 lines, 9 filesdep +basedep +bytestringdep +codet
Dependencies added: base, bytestring, codet, containers, directory, filepath, syb, tasty, tasty-golden, template-haskell, text, time, transformers
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- codet.cabal +58/−0
- src/Language/Haskell/TH/CodeT.hs +15/−0
- src/Language/Haskell/TH/CodeT/Unsafe.hs +315/−0
- tests/codet-tests-900.txt +14/−0
- tests/codet-tests-902.txt +16/−0
- tests/codet-tests-906.txt +16/−0
- tests/codet-tests.hs +85/−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.cabal view
@@ -0,0 +1,58 @@+cabal-version: 2.4+name: codet+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: CodeT+description: CodeT.+extra-source-files: tests/*.txt++source-repository head+ type: git+ location: https://github.com/phadej/codet.git+ subdir: codet++common language+ default-language: Haskell2010++library+ import: language+ hs-source-dirs: src+ exposed-modules:+ Language.Haskell.TH.CodeT+ Language.Haskell.TH.CodeT.Unsafe++ -- 4.16.4.0 to allow ghc-9.2.3 used by Hackage docbuilder 2023-12+ build-depends:+ , base ^>=4.15.1.0 || ^>=4.16.3.0 || ^>=4.17.2.1 || ^>=4.18.1.0 || ^>=4.19.0.0+ , bytestring ^>=0.10.2.1 || ^>=0.11.4.0 || ^>=0.12.0.2+ , containers ^>=0.6.4.1+ , template-haskell ^>=2.17.0.0 || ^>=2.18.0.0 || ^>=2.19.0.0 || ^>=2.20.0.0 || ^>=2.21.0.0+ , text ^>=1.2.5.0 || ^>=2.0.2 || ^>=2.1+ , time ^>=1.9.3 || ^>=1.11.1 || ^>=1.12.2++test-suite codet-tests+ import: language+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: codet-tests.hs+ build-depends:+ , base+ , codet+ , 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/Language/Haskell/TH/CodeT.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+module Language.Haskell.TH.CodeT (+ -- * CodeT+ CodeT,+ unTypeCodeT,+ appCodeT,+ sigCode,+ sigCodeT,+ CodeTQ,+ -- * LiftT+ LiftT (..),+) where++import Language.Haskell.TH.CodeT.Unsafe
+ src/Language/Haskell/TH/CodeT/Unsafe.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE Unsafe #-}+#if __GLASGOW_HASKELL__ <908+{-# LANGUAGE UndecidableInstances #-}+#endif+{-# OPTIONS_HADDOCK not-home #-}+module Language.Haskell.TH.CodeT.Unsafe (+ -- * CodeT+ CodeT (..),+ unsafeCodeTCoerce,+ unTypeCodeT,+ appCodeT,+ sigCode,+ sigCodeT,+ CodeTQ,+ unsafeCodeTName,+ unsafeCodeTNameD,+ unsafeCodeTNameTC,+ -- * LiftT+ LiftT (..),+) where++import Data.Int (Int16, Int32, Int64, Int8)+import Data.Proxy (Proxy (..))+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal)++#if MIN_VERSION_base(4,16,0)+import GHC.TypeLits (KnownChar, charVal)+#endif++import qualified GHC.Exts as Ki+import qualified Data.Kind as Ki++import Language.Haskell.TH+ (Code, Name, Q, Quote, TyLit (..), Type, appT, conT, litT, sigE, sigT, unTypeCode, unsafeCodeCoerce)+import Language.Haskell.TH.Syntax (mkNameG_d, mkNameG_tc)++-- instances+import qualified Data.ByteString+import qualified Data.ByteString.Builder+import qualified Data.ByteString.Lazy+import qualified Data.Functor.Compose+import qualified Data.Functor.Const+import qualified Data.Functor.Identity+import qualified Data.IntMap+import qualified Data.IntSet+import qualified Data.Map+import qualified Data.Sequence+import qualified Data.Set+import qualified Data.Text+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Builder+import qualified Data.Time+import qualified Data.Tree++-- $setup+-- >>> :set -XTemplateHaskell -XTypeApplications+-- >>> import Language.Haskell.TH++-------------------------------------------------------------------------------+-- CodeT+-------------------------------------------------------------------------------++-- | 'CodeT' is to 'Type' what 'Code' is to 'Exp'.+--+-- Because current GHC Haskell doesn't have true dependent types,+-- we often use singletons pattern to emulate them.+-- To a first approximation @'CodeT' q a -> ...@ type emulates+-- dependent function @forall (a :: 'Code' q 'Data.Kind.Type') -> ...@.+--+-- There aren't typed type quotes, i.e. we cannot write @[t|| Int ||]@,+-- instead we have to resort to unsafe interface for now:+--+-- >>> let ty = UnsafeCodeT [t| Int |] :: Quote q => CodeT q Int+-- >>> unTypeCodeT ty >>= print . ppr+-- GHC.Types.Int+--+-- ... or we can "safely" create many 'CodeT' values using 'LiftT' type-class:+--+-- >>> let ty' = codeT :: Quote q => CodeT q Int+-- >>> unTypeCodeT ty' >>= print . ppr+-- GHC.Types.Int+--+type CodeT :: (Ki.Type -> Ki.Type) -> forall k. k -> Ki.Type+newtype CodeT q a =+ -- | Unsafely convert an untyped code representation into a typed code representation.+ --+ -- Prefer using 'unsafeCodeTCoerce'.+ UnsafeCodeT (q Type)++type role CodeT representational nominal++-- | Extract the untyped representation from the typed representation.+unTypeCodeT :: CodeT m a -> m Type+unTypeCodeT (UnsafeCodeT ty) = ty++-- | Unsafely convert an untyped code representation into a typed code representation.+unsafeCodeTCoerce :: Quote q => q Type -> CodeT q a+unsafeCodeTCoerce = UnsafeCodeT++-- |+--+-- >>> let ty = appCodeT (codeT @Maybe) (codeT @Char)+-- >>> unTypeCodeT ty >>= print . ppr+-- GHC.Maybe.Maybe GHC.Types.Char+--+appCodeT :: Quote m => CodeT m f -> CodeT m x -> CodeT m (f x)+appCodeT (UnsafeCodeT f) (UnsafeCodeT x) = UnsafeCodeT (appT f x)++-- |+--+-- >>> let e = sigCode [|| 'x' ||] codeT+-- >>> unTypeCode e >>= print . ppr+-- 'x' :: GHC.Types.Char+--+sigCode :: Quote q => Code q a -> CodeT q a -> Code q a+sigCode e t = unsafeCodeCoerce (sigE (unTypeCode e) (unTypeCodeT t))++-- |+--+-- >>> let ty = sigCodeT (codeT @Bool) codeT+-- >>> unTypeCodeT ty >>= print . ppr+-- (GHC.Types.Bool :: GHC.Prim.TYPE (GHC.Types.BoxedRep GHC.Types.Lifted))+--+sigCodeT :: Quote q => CodeT q (a :: k) -> CodeT q k -> CodeT q a+sigCodeT (UnsafeCodeT t) (UnsafeCodeT k) = UnsafeCodeT (k >>= sigT t)++type CodeTQ :: forall k. k -> Ki.Type+type CodeTQ = CodeT Q++-- | Unsafely convert a (type) name into a typed code representation.+--+-- The namespace of 'Name' is not checked.+--+-- >>> let ty = unsafeCodeTName ''Bool+-- >>> unTypeCodeT ty >>= print . ppr+-- GHC.Types.Bool+--+unsafeCodeTName :: Quote m => Name -> CodeT m a+unsafeCodeTName n = UnsafeCodeT (conT n)++-- | Unsafely create a data constructor name and convert it into a typed code representation.+unsafeCodeTNameD :: String -> String -> String -> forall m. Quote m => CodeT m a+unsafeCodeTNameD x y z = unsafeCodeTName (mkNameG_d x y z)++-- | Unsafely create a type constructor name and convert it into a typed code representation.+unsafeCodeTNameTC :: String -> String -> String -> forall m. Quote m => CodeT m a+unsafeCodeTNameTC x y z = unsafeCodeTName (mkNameG_tc x y z)++-------------------------------------------------------------------------------+-- LiftT+-------------------------------------------------------------------------------++-- | Implicitly create 'CodeT' values.+--+-- This packages provides some 'LiftT' instances for types in GHC bundled libs.+--+-- There is no instance for 'Data.Kind.Constraint', as @Constraint@ is not apart from 'Data.Kind.Type'.+-- See the GHC issue https://gitlab.haskell.org/ghc/ghc/-/issues/24279.+--+-- The [codet-plugin](https://hackage.haskell.org/package/codet-plugin) can automatically+-- create instances for type constructors. (The provided @f x@ instance does most of the work).+--+type LiftT :: forall {k}. k -> Ki.Constraint+class LiftT a where+ codeT :: Quote m => CodeT m a++instance (LiftT f, LiftT x) => LiftT (f x) where+ codeT = appCodeT codeT codeT++-------------------------------------------------------------------------------+-- instances: TypeLits+-------------------------------------------------------------------------------++instance KnownSymbol s => LiftT s where codeT = UnsafeCodeT $ litT $ return $ StrTyLit $ symbolVal (Proxy @s)+instance KnownNat n => LiftT n where codeT = UnsafeCodeT $ litT $ return $ NumTyLit $ natVal (Proxy @n)++#if MIN_VERSION_base(4,16,0)+instance KnownChar c => LiftT c where codeT = UnsafeCodeT $ litT $ return $ CharTyLit $ charVal (Proxy @c)+#endif++-------------------------------------------------------------------------------+-- instances: Type+-------------------------------------------------------------------------------++instance LiftT Int where codeT = unsafeCodeTName ''Int+instance LiftT Word where codeT = unsafeCodeTName ''Word+instance LiftT Float where codeT = unsafeCodeTName ''Float+instance LiftT Double where codeT = unsafeCodeTName ''Double++instance LiftT Int8 where codeT = unsafeCodeTName ''Int8+instance LiftT Int16 where codeT = unsafeCodeTName ''Int16+instance LiftT Int32 where codeT = unsafeCodeTName ''Int32+instance LiftT Int64 where codeT = unsafeCodeTName ''Int64++instance LiftT Word8 where codeT = unsafeCodeTName ''Word8+instance LiftT Word16 where codeT = unsafeCodeTName ''Word16+instance LiftT Word32 where codeT = unsafeCodeTName ''Word32+instance LiftT Word64 where codeT = unsafeCodeTName ''Word64++instance LiftT Bool where codeT = unsafeCodeTName ''Bool+instance LiftT Ordering where codeT = unsafeCodeTName ''Ordering+instance LiftT Char where codeT = unsafeCodeTName ''Char++-------------------------------------------------------------------------------+-- instances: Tuples+-------------------------------------------------------------------------------++instance LiftT () where codeT = unsafeCodeTName ''()+instance LiftT (,) where codeT = unsafeCodeTName ''(,)+instance LiftT (,,) where codeT = unsafeCodeTName ''(,,)+instance LiftT (,,,) where codeT = unsafeCodeTName ''(,,,)+instance LiftT (,,,,) where codeT = unsafeCodeTName ''(,,,,)+instance LiftT (,,,,,) where codeT = unsafeCodeTName ''(,,,,,)+instance LiftT (,,,,,,) where codeT = unsafeCodeTName ''(,,,,,,)++-------------------------------------------------------------------------------+-- instances: Type -> Type+-------------------------------------------------------------------------------++instance LiftT [] where codeT = unsafeCodeTName ''[]+instance LiftT Maybe where codeT = unsafeCodeTName ''Maybe+instance LiftT IO where codeT = unsafeCodeTName ''IO++-------------------------------------------------------------------------------+-- instances: Type -> Type -> Type+-------------------------------------------------------------------------------++instance LiftT Either where codeT = unsafeCodeTName ''Either++-------------------------------------------------------------------------------+-- instances: kinds+-------------------------------------------------------------------------------++instance LiftT (->) where codeT = unsafeCodeTName ''(->) -- perfectly, we want LiftT.FUN+instance LiftT Ki.TYPE where codeT = unsafeCodeTName ''Ki.TYPE++{-++We don't have an instance for Constraint. GHC is tricky.+https://gitlab.haskell.org/ghc/ghc/-/issues/24279++This works in GHC-9.8, but probably will be "fixed" in GHC-9.10,+so we don't bother with Constraint at all.++#if MIN_VERSION_base(4,18,0)+instance LiftT Ki.CONSTRAINT where codeT = unsafeCodeTName ''Ki.CONSTRAINT+#else+instance LiftT Ki.Constraint where codeT = unsafeCodeTName ''Ki.Constraint+#endif+-}++#if MIN_VERSION_base(4,16,0)+instance LiftT Ki.RuntimeRep where codeT = unsafeCodeTName ''Ki.RuntimeRep+instance LiftT Ki.BoxedRep where codeT = unsafeCodeTName 'Ki.BoxedRep++instance LiftT Ki.Levity where codeT = unsafeCodeTName ''Ki.Levity+instance LiftT Ki.Lifted where codeT = unsafeCodeTName 'Ki.Lifted+instance LiftT Ki.Unlifted where codeT = unsafeCodeTName 'Ki.Unlifted+#else+instance LiftT Ki.LiftedRep where codeT = unsafeCodeTName 'Ki.LiftedRep+instance LiftT Ki.UnliftedRep where codeT = unsafeCodeTName 'Ki.UnliftedRep+#endif++-------------------------------------------------------------------------------+-- instances: bytestring+-------------------------------------------------------------------------------++instance LiftT Data.ByteString.ByteString where codeT = unsafeCodeTName ''Data.ByteString.ByteString+instance LiftT Data.ByteString.Lazy.ByteString where codeT = unsafeCodeTName ''Data.ByteString.Lazy.ByteString+instance LiftT Data.ByteString.Builder.Builder where codeT = unsafeCodeTName ''Data.ByteString.Builder.Builder++-------------------------------------------------------------------------------+-- instances: containers+-------------------------------------------------------------------------------++instance LiftT Data.IntMap.IntMap where codeT = unsafeCodeTName ''Data.IntMap.IntMap+instance LiftT Data.IntSet.IntSet where codeT = unsafeCodeTName ''Data.IntSet.IntSet+instance LiftT Data.Map.Map where codeT = unsafeCodeTName ''Data.Map.Map+instance LiftT Data.Sequence.Seq where codeT = unsafeCodeTName ''Data.Sequence.Seq+instance LiftT Data.Set.Set where codeT = unsafeCodeTName ''Data.IntSet.IntSet+instance LiftT Data.Tree.Tree where codeT = unsafeCodeTName ''Data.Tree.Tree++-------------------------------------------------------------------------------+-- instances: text+-------------------------------------------------------------------------------++instance LiftT Data.Text.Text where codeT = unsafeCodeTName ''Data.Text.Text+instance LiftT Data.Text.Lazy.Text where codeT = unsafeCodeTName ''Data.Text.Lazy.Text+instance LiftT Data.Text.Lazy.Builder.Builder where codeT = unsafeCodeTName ''Data.Text.Lazy.Builder.Builder++-------------------------------------------------------------------------------+-- instances: transformers+-------------------------------------------------------------------------------++instance LiftT Data.Functor.Identity.Identity where codeT = unsafeCodeTName ''Data.Functor.Identity.Identity+instance LiftT Data.Functor.Compose.Compose where codeT = unsafeCodeTName ''Data.Functor.Compose.Compose+instance LiftT Data.Functor.Const.Const where codeT = unsafeCodeTName ''Data.Functor.Const.Const++-------------------------------------------------------------------------------+-- instances: time+-------------------------------------------------------------------------------++instance LiftT Data.Time.UTCTime where codeT = unsafeCodeTName ''Data.Time.UTCTime+instance LiftT Data.Time.Day where codeT = unsafeCodeTName ''Data.Time.Day
+ tests/codet-tests-900.txt view
@@ -0,0 +1,14 @@+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+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")))))+1+(LitT (NumTyLit (1)))+"string"+(LitT (StrTyLit "string"))+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+(GHC.Types.->)+(ConT (Name (OccName "->") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+GHC.Prim.TYPE GHC.Types.LiftedRep+(AppT (ConT (Name (OccName "TYPE") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Prim")))) (ConT (Name (OccName "LiftedRep") (NameG (DataName) (PkgName "ghc-prim") (ModName "GHC.Types")))))
+ tests/codet-tests-902.txt view
@@ -0,0 +1,16 @@+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+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")))))+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"))))+(GHC.Types.->)+(ConT (Name (OccName "->") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+GHC.Prim.TYPE (GHC.Types.BoxedRep GHC.Types.Lifted)+(AppT (ConT (Name (OccName "TYPE") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Prim")))) (AppT (ConT (Name (OccName "BoxedRep") (NameG (DataName) (PkgName "ghc-prim") (ModName "GHC.Types")))) (ConT (Name (OccName "Lifted") (NameG (DataName) (PkgName "ghc-prim") (ModName "GHC.Types"))))))
+ tests/codet-tests-906.txt view
@@ -0,0 +1,16 @@+GHC.Types.Int+(ConT (Name (OccName "Int") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+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")))))+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"))))+(GHC.Types.->)+(ConT (Name (OccName "->") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Types"))))+GHC.Prim.TYPE (GHC.Types.BoxedRep GHC.Types.Lifted)+(AppT (ConT (Name (OccName "TYPE") (NameG (TcClsName) (PkgName "ghc-prim") (ModName "GHC.Prim")))) (AppT (ConT (Name (OccName "BoxedRep") (NameG (DataName) (PkgName "ghc-prim") (ModName "GHC.Types")))) (ConT (Name (OccName "Lifted") (NameG (DataName) (PkgName "ghc-prim") (ModName "GHC.Types"))))))
+ tests/codet-tests.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeApplications #-}+module Main (main) where++import Control.Monad.Trans.State (State, evalState, get, put)+import Data.Generics (gshow)+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++import qualified Data.Kind++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"+ cabalFile = "codet.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-tests-" ++ show (ghcVer __GLASGOW_HASKELL__) ++ ".txt"+ defaultMain $ testGroup "codet"+ [ goldenVsStringDiff "basic" diff output $ do+ return $ fromString $ unlines $ concat+ [ dispType (codeT @Int)+ , dispType (codeT @[Int])+ , dispType (codeT @1)+ , dispType (codeT @"string")+#if MIN_VERSION_base(4,16,0)+ , dispType (codeT @'c')+#endif+ , dispType (codeT @MyInt) -- Int+ , dispType (codeT @(->))+ , dispType (codeT @Data.Kind.Type)+ ]+ ]++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)