From 931851c8c14ee0b350b36c33eafb63b028e68ff8 Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@posteo.de>
Date: Mon, 13 Jan 2020 17:06:27 +0100
Subject: [PATCH] Add quasi quoters for hpath

---
 hpath/README.md       |  1 -
 hpath/hpath.cabal     |  2 ++
 hpath/run-doctests.sh |  2 +-
 hpath/src/HPath.hs    | 71 +++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 74 insertions(+), 2 deletions(-)

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