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