Fix quasiquote free variable interpolation

src/Nix/TH.hs

@@ -1,72 +1,92 @@
-{-# 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
+
+removeMissingNames :: Set VarName -> Q (Set VarName)
+removeMissingNames =
+  fmap Set.fromAscList
+    . filterM (fmap isJust . lookupValueName . toString)
+    . Set.toAscList
 
 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
+  vars <- removeMissingNames $ getFreeVars expr
+  dataToExpQ (extQOnFreeVars metaExp vars) 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
+  vars <- removeMissingNames $ getFreeVars expr
+  dataToPatQ (extQOnFreeVars @_ @NExprLoc @PatQ metaPat vars) expr
 
 -- | Helper function.
 extQOnFreeVars
-  :: ( Typeable b
-    , Typeable loc
-    )
-  => ( Set VarName
-    -> loc
-    -> Maybe q
-    )
-  -> NExpr
+  :: (Typeable b, Typeable loc)
+  => (Set VarName -> loc -> Maybe q)
+  -> Set VarName
   -> b
   -> Maybe q
-extQOnFreeVars f = extQ (const Nothing) . f . getFreeVars
+extQOnFreeVars f = extQ (const Nothing) . f
 
 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 () where
+  toExpr () = Fix $ NConstant NNull
+
+instance (ToExpr a) => ToExpr (Maybe a) where
+  toExpr = maybe (toExpr ()) 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