diff --git a/hpath/README.md b/hpath/README.md index de9c917..a2bb792 100644 --- a/hpath/README.md +++ b/hpath/README.md @@ -36,4 +36,3 @@ Note: this library was written for __posix__ systems and it will probably not su * allows pattern matching via unidirectional PatternSynonym * uses simple doctest for testing * allows `~/` as relative path, because on posix level `~` is just a regular filename that does _NOT_ point to `$HOME` -* remove TH, it sucks diff --git a/hpath/hpath.cabal b/hpath/hpath.cabal index d9be763..f08202a 100644 --- a/hpath/hpath.cabal +++ b/hpath/hpath.cabal @@ -36,6 +36,8 @@ library , deepseq , exceptions , hpath-filepath >= 0.10 && < 0.11 + , template-haskell + , utf8-string , word8 source-repository head diff --git a/hpath/run-doctests.sh b/hpath/run-doctests.sh index 37d1638..48c6640 100755 --- a/hpath/run-doctests.sh +++ b/hpath/run-doctests.sh @@ -18,4 +18,4 @@ fi set -x -cabal exec doctest -- -ihpath/src -XOverloadedStrings HPath +cabal exec doctest -- -ihpath/src -XOverloadedStrings -XQuasiQuotes HPath diff --git a/hpath/src/HPath.hs b/hpath/src/HPath.hs index f6369ea..bdbdf5f 100644 --- a/hpath/src/HPath.hs +++ b/hpath/src/HPath.hs @@ -16,6 +16,8 @@ #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms #-} #endif +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module HPath ( @@ -50,6 +52,10 @@ module HPath ,withAbsPath ,withRelPath ,withFnPath + -- * Quasiquoters + ,abs + ,rel + ,fn ) where @@ -62,10 +68,15 @@ import Data.ByteString(ByteString) import qualified Data.List as L #endif import qualified Data.ByteString as BS +import Data.ByteString.UTF8 import Data.Data import Data.Maybe import Data.Word8 import HPath.Internal +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Exp(..), Lift(..), lift) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Prelude hiding (abs) import System.Posix.FilePath hiding (()) @@ -374,3 +385,63 @@ withFnPath (MkPath p) action = action p stripPrefix :: ByteString -> ByteString -> Maybe ByteString stripPrefix a b = BS.pack `fmap` L.stripPrefix (BS.unpack a) (BS.unpack b) #endif + + +------------------------ +-- QuasiQuoters + +instance Lift (Path a) where + lift (MkPath bs) = AppE <$> [| MkPath . BS.pack |] <*> lift (BS.unpack bs) + + +qq :: (ByteString -> Q Exp) -> QuasiQuoter +qq quoteExp' = + QuasiQuoter + { quoteExp = (\s -> quoteExp' . fromString $ s) + , quotePat = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quoteType = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a type)" + , quoteDec = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" + } + +mkAbs :: ByteString -> Q Exp +mkAbs = either (error . show) lift . parseAbs + +mkRel :: ByteString -> Q Exp +mkRel = either (error . show) lift . parseRel + +mkFN :: ByteString -> Q Exp +mkFN = either (error . show) lift . parseFn + +-- | Quasiquote an absolute Path. This accepts Unicode Chars and will encode as UTF-8. +-- +-- >>> [abs|/etc/profile|] :: Path Abs +-- "/etc/profile" +-- >>> [abs|/|] :: Path Abs +-- "/" +-- >>> [abs|/|] :: Path Abs +-- "/\239\131\144" +abs :: QuasiQuoter +abs = qq mkAbs + +-- | Quasiquote a relative Path. This accepts Unicode Chars and will encode as UTF-8. +-- +-- >>> [rel|etc|] :: Path Rel +-- "etc" +-- >>> [rel|bar/baz|] :: Path Rel +-- "bar/baz" +-- >>> [rel||] :: Path Rel +-- "\239\131\144" +rel :: QuasiQuoter +rel = qq mkRel + +-- | Quasiquote a file name. This accepts Unicode Chars and will encode as UTF-8. +-- +-- >>> [fn|etc|] :: Path Fn +-- "etc" +-- >>> [fn||] :: Path Fn +-- "\239\131\144" +fn :: QuasiQuoter +fn = qq mkFN