th-compat 0.1.3 → 0.1.4
raw patch · 3 files changed
+95/−9 lines, 3 filesdep +directorydep +filepathdep ~base-compatdep ~template-haskell
Dependencies added: directory, filepath
Dependency ranges changed: base-compat, template-haskell
Files
- CHANGELOG.md +6/−0
- src/Language/Haskell/TH/Syntax/Compat.hs +76/−1
- th-compat.cabal +13/−8
CHANGELOG.md view
@@ -1,3 +1,9 @@+### 0.1.4 [2022.07.23]+* Backport the `getPackageRoot` and `makeRelativeToProject` functions+ introduced in `template-haskell-2.19.0.0` (GHC 9.4).+* Implement `qGetPackageRoot` in the `Quasi` instance for `QuoteToQuasi` when+ building with `template-haskell-2.19.0.0` (GHC 9.4) or later.+ ### 0.1.3 [2021.08.29] * Implement `qGetDoc` and `qPutDoc` in the `Quasi` instance for `QuoteToQuasi`. * Add `expToSplice`.
src/Language/Haskell/TH/Syntax/Compat.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 702@@ -29,6 +30,8 @@ -- -- * The 'Code' type --+-- * The 'getPackageRoot' and 'makeRelativeToProject' utility functions+-- -- Refer to the Haddocks below for examples of how to use each of these in a -- backwards-compatible way. module Language.Haskell.TH.Syntax.Compat (@@ -82,6 +85,10 @@ , unTypeSplice , expToSplice #endif++ -- * Package root functions+ , getPackageRoot+ , makeRelativeToProject ) where import qualified Control.Monad.Fail as Fail@@ -109,6 +116,13 @@ import Language.Haskell.TH (Name) #endif +#if MIN_VERSION_template_haskell(2,19,0)+import Language.Haskell.TH.Syntax (getPackageRoot, makeRelativeToProject)+#else+import System.FilePath (isRelative, takeExtension, takeDirectory, (</>))+import System.Directory (getDirectoryContents, canonicalizePath)+#endif+ ------------------------------------------------------------------------------- -- Quote -------------------------------------------------------------------------------@@ -446,6 +460,9 @@ qGetDoc = qtqError "qGetDoc" qPutDoc = qtqError "qPutDoc" #endif+#if MIN_VERSION_template_haskell(2,19,0)+ qGetPackageRoot = qtqError "qGetPackageRoot"+#endif ------------------------------------------------------------------------------- -- Code@@ -864,7 +881,7 @@ -- 'examineSplice' [|| sum $$(expToSplice (listTE ints)) ||] -- @ ----- @since ????.??.??+-- @since 0.1.3 expToSplice :: Applicative m => Syntax.TExp a -> Splice m a expToSplice a = liftSplice $ pure a @@ -1054,4 +1071,62 @@ # else unTypeSplice = unTypeQQuote # endif+#endif++-------------------------------------------------------------------------------+-- Package root+-------------------------------------------------------------------------------++#if !MIN_VERSION_template_haskell(2,19,0)++-- | Get the package root for the current package which is being compiled.+-- This can be set explicitly with the -package-root flag but is normally+-- just the current working directory.+--+-- The motivation for this flag is to provide a principled means to remove the+-- assumption from splices that they will be executed in the directory where the+-- cabal file resides. Projects such as haskell-language-server can't and don't+-- change directory when compiling files but instead set the -package-root flag+-- appropiately.+--+-- This is best-effort compatibility implementation.+-- This function looks at the source location of the Haskell file calling it,+-- finds the first parent directory with a @.cabal@ file, and uses that as the+-- root directory for fixing the relative path.+--+getPackageRoot :: Q FilePath+getPackageRoot = getPackageRootPredicate $ (==) ".cabal" . takeExtension++-- The implementation is modified from the makeRelativeToLocationPredicate+-- function in the file-embed package+-- Copyright 2008, Michael Snoyman. All rights reserved.+-- under BSD-2-Clause license.+getPackageRootPredicate :: (FilePath -> Bool) -> Q FilePath+getPackageRootPredicate isTargetFile = do+ loc <- qLocation+ (srcFP, mdir) <- Syntax.runIO $ do+ srcFP <- canonicalizePath $ Syntax.loc_filename loc+ mdir <- findProjectDir srcFP+ return (srcFP, mdir)+ case mdir of+ Nothing -> fail $ "Could not find .cabal file for path: " ++ srcFP+ Just dir -> return dir+ where+ findProjectDir x = do+ let dir = takeDirectory x+ if dir == x+ then return Nothing+ else do+ contents <- getDirectoryContents dir+ if any isTargetFile contents+ then return (Just dir)+ else findProjectDir dir++-- | The input is a filepath, which if relative is offset by the package root.+makeRelativeToProject :: FilePath -> Q FilePath+makeRelativeToProject fp | isRelative fp = do+ root <- getPackageRoot+ return (root </> fp)+makeRelativeToProject fp = return fp+ #endif
th-compat.cabal view
@@ -1,12 +1,13 @@ cabal-version: >=1.10 name: th-compat-version: 0.1.3+version: 0.1.4 synopsis: Backward- (and forward-)compatible Quote and Code types description: This package defines a "Language.Haskell.TH.Syntax.Compat" module, which backports the @Quote@ and @Code@ types to work across a wide range of @template-haskell@ versions.+ The @makeRelativeToProject@ utility is also backported. On recent versions of @template-haskell@ (2.17.0.0 or- later), this module simply reexports @Quote@ and @Code@+ later), this module simply reexports definitions from "Language.Haskell.TH.Syntax". Refer to the Haddocks for "Language.Haskell.TH.Syntax.Compat" for examples of how to use this module.@@ -31,8 +32,9 @@ , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7- , GHC == 9.0.1- , GHC == 9.2.*+ , GHC == 9.0.2+ , GHC == 9.2.3+ , GHC == 9.4.1 extra-source-files: CHANGELOG.md, README.md source-repository head@@ -42,10 +44,13 @@ library exposed-modules: Language.Haskell.TH.Syntax.Compat build-depends: base >= 4.3 && < 5- , template-haskell >= 2.5 && < 2.19+ , template-haskell >= 2.5 && < 2.20 if !impl(ghc >= 8.0) build-depends: fail == 4.9.*- , transformers >= 0.2 && < 0.6+ , transformers >= 0.2 && < 0.7+ if !impl(ghc >= 9.4)+ build-depends: filepath >= 1.2.0.0 && < 1.5+ , directory >= 1.1.0.0 && < 1.4 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -60,8 +65,8 @@ build-depends: base >= 4.3 && < 5 , base-compat >= 0.6 && < 0.13 , hspec >= 2 && < 3- , mtl >= 2.1 && < 2.3- , template-haskell >= 2.5 && < 2.19+ , mtl >= 2.1 && < 2.4+ , template-haskell >= 2.5 && < 2.20 , th-compat build-tool-depends: hspec-discover:hspec-discover >= 2 hs-source-dirs: tests