Allow Nix quasi-quoter to refer to and promote Haskell variables
This commit is contained in:
parent
f59a17db72
commit
13edc1da30
|
@ -1,32 +1,57 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-missing-fields #-}
|
||||
|
||||
module Nix.TH where
|
||||
|
||||
import Data.Fix
|
||||
import Data.Foldable
|
||||
import Data.Generics.Aliases
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Nix.Atoms
|
||||
import Nix.Expr
|
||||
import Nix.Parser
|
||||
|
||||
quoteExprExp :: String -> ExpQ
|
||||
quoteExprExp s = do
|
||||
expr <- case parseNixText (Text.pack s) of
|
||||
expr <- case parseNixTextLoc (Text.pack s) of
|
||||
Failure err -> fail $ show err
|
||||
Success e -> return e
|
||||
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
|
||||
|
||||
freeVars :: NExpr -> Set VarName
|
||||
freeVars = error "NYI: Implement an evaluator to find free variables"
|
||||
freeVars :: NExprLoc -> Set VarName
|
||||
freeVars = cata $ \case
|
||||
NSym_ _ var -> Set.singleton var
|
||||
Compose (Ann _ x) -> fold x
|
||||
|
||||
metaExp :: Set VarName -> NExpr -> Maybe ExpQ
|
||||
metaExp fvs (Fix (NSym x)) | x `Set.member` fvs =
|
||||
class ToExpr a where
|
||||
toExpr :: a -> NExprLoc
|
||||
|
||||
instance ToExpr NExprLoc where
|
||||
toExpr = id
|
||||
|
||||
instance ToExpr VarName where
|
||||
toExpr = Fix . NSym_ nullSpan
|
||||
|
||||
instance ToExpr Int where
|
||||
toExpr = Fix . NConstant_ nullSpan . NInt . fromIntegral
|
||||
|
||||
instance ToExpr Integer where
|
||||
toExpr = Fix . NConstant_ nullSpan . NInt
|
||||
|
||||
instance ToExpr Float where
|
||||
toExpr = Fix . NConstant_ nullSpan . NFloat
|
||||
|
||||
metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
|
||||
metaExp fvs (Fix (NSym_ _ x)) | x `Set.member` fvs =
|
||||
Just [| toExpr $(varE (mkName (Text.unpack x))) |]
|
||||
metaExp _ _ = Nothing
|
||||
|
||||
|
|
Loading…
Reference in a new issue