From 660ed4bd9f37ce1ffea7fb083f0a17a634f1c95b Mon Sep 17 00:00:00 2001
From: ners <ners@gmx.ch>
Date: Sun, 8 Oct 2023 13:12:02 +0200
Subject: [PATCH] fix quasiquote interpolation

Co-authored-by: Viktor Kleen <viktor@kleen.org>
Co-authored-by: Tom Westerhout <14264576+twesterhout@users.noreply.github.com>
---
 src/Nix/TH.hs | 77 ++++++++++++++++++++++++++++-----------------------
 1 file changed, 43 insertions(+), 34 deletions(-)

diff --git a/src/Nix/TH.hs b/src/Nix/TH.hs
index 5dc9a290c..a7bf13238 100644
--- a/src/Nix/TH.hs
+++ b/src/Nix/TH.hs
@@ -1,72 +1,81 @@
-{-# language QuasiQuotes #-}
-{-# language TemplateHaskell #-}
-
-{-# options_ghc -Wno-missing-fields #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-missing-fields #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
 
 module Nix.TH where
 
-import           Nix.Prelude
+import           Data.Fix                       ( Fix(Fix) )
 import           Data.Generics.Aliases          ( extQ )
 import qualified Data.Set                      as Set
 import           Language.Haskell.TH
-import qualified Language.Haskell.TH.Syntax    as TH
 import           Language.Haskell.TH.Quote
 import           Nix.Atoms
 import           Nix.Expr.Types
 import           Nix.Expr.Types.Annotated
 import           Nix.Parser
+import           Nix.Prelude
 
 quoteExprExp :: String -> ExpQ
-quoteExprExp s =
-  do
-    expr <- parseExpr $ fromString s
-    dataToExpQ
-      (extQOnFreeVars metaExp expr `extQ` (pure . (TH.lift :: Text -> ExpQ)))
-      expr
+quoteExprExp s = do
+  expr <- parseExpr $ fromString s
+  dataToExpQ (extQOnFreeVars metaExp expr) expr
 
 quoteExprPat :: String -> PatQ
-quoteExprPat s =
-  do
-    expr <- parseExpr @Q $ fromString s
-    dataToPatQ
-      (extQOnFreeVars @_ @NExprLoc @PatQ metaPat expr)
-      expr
-
+quoteExprPat s = do
+  expr <- parseExpr @Q $ fromString s
+  dataToPatQ (extQOnFreeVars @_ @NExprLoc @PatQ metaPat expr) expr
 
 -- | Helper function.
 extQOnFreeVars
-  :: ( Typeable b
-    , Typeable loc
-    )
-  => ( Set VarName
-    -> loc
-    -> Maybe q
-    )
+  :: (Typeable b, Typeable loc)
+  => (Set VarName -> loc -> Maybe q)
   -> NExpr
   -> b
   -> Maybe q
 extQOnFreeVars f = extQ (const Nothing) . f . getFreeVars
 
 class ToExpr a where
-  toExpr :: a -> NExprLoc
+  toExpr :: a -> NExpr
 
-instance ToExpr NExprLoc where
+instance ToExpr NExpr where
   toExpr = id
 
 instance ToExpr VarName where
-  toExpr = NSymAnn nullSpan
+  toExpr = Fix . NSym
+
+instance {-# OVERLAPPING #-} ToExpr String where
+  toExpr = Fix . NStr . fromString
+
+instance ToExpr Text where
+  toExpr = toExpr . toString
 
 instance ToExpr Int where
-  toExpr = NConstantAnn nullSpan . NInt . fromIntegral
+  toExpr = Fix . NConstant . NInt . fromIntegral
+
+instance ToExpr Bool where
+  toExpr = Fix . NConstant . NBool
 
 instance ToExpr Integer where
-  toExpr = NConstantAnn nullSpan . NInt
+  toExpr = Fix . NConstant . NInt
 
 instance ToExpr Float where
-  toExpr = NConstantAnn nullSpan . NFloat
+  toExpr = Fix . NConstant . NFloat
+
+instance (ToExpr a) => ToExpr [a] where
+  toExpr = Fix . NList . fmap toExpr
+
+instance (ToExpr a) => ToExpr (NonEmpty a) where
+  toExpr = toExpr . toList
+
+instance (ToExpr a) => ToExpr (Maybe a) where
+  toExpr = maybe (Fix $ NConstant NNull) toExpr
+
+instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where
+  toExpr = either toExpr toExpr
 
-metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
-metaExp fvs (NSymAnn _ x) | x `Set.member` fvs =
+metaExp :: Set VarName -> NExpr -> Maybe ExpQ
+metaExp fvs (Fix (NSym x)) | x `Set.member` fvs =
   pure [| toExpr $(varE (mkName $ toString x)) |]
 metaExp _ _ = Nothing