{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}
module Nix.TH where
import Data.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
import Nix.Parser
quoteExprExp :: String -> ExpQ
quoteExprExp :: String -> ExpQ
quoteExprExp String
s = do
NExpr
expr <-
(Doc Void -> Q NExpr)
-> (NExpr -> Q NExpr) -> Either (Doc Void) NExpr -> Q NExpr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(String -> Q NExpr
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q NExpr) -> (Doc Void -> String) -> Doc Void -> Q NExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Void -> String
forall b a. (Show a, IsString b) => a -> b
show)
NExpr -> Q NExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Text -> Either (Doc Void) NExpr
parseNixText (Text -> Either (Doc Void) NExpr)
-> Text -> Either (Doc Void) NExpr
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
s)
(forall b. Data b => b -> Maybe ExpQ) -> NExpr -> ExpQ
forall a.
Data a =>
(forall b. Data b => b -> Maybe ExpQ) -> a -> ExpQ
dataToExpQ
(Maybe ExpQ -> b -> Maybe ExpQ
forall a b. a -> b -> a
const Maybe ExpQ
forall a. Maybe a
Nothing (b -> Maybe ExpQ) -> (NExprLoc -> Maybe ExpQ) -> b -> Maybe ExpQ
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Set Text -> NExprLoc -> Maybe ExpQ
metaExp (NExpr -> Set Text
freeVars NExpr
expr) (b -> Maybe ExpQ) -> (Text -> Maybe ExpQ) -> b -> Maybe ExpQ
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (ExpQ -> Maybe ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpQ -> Maybe ExpQ) -> (Text -> ExpQ) -> Text -> Maybe ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> ExpQ
forall t. Lift t => t -> ExpQ
TH.lift :: Text -> Q Exp)))
NExpr
expr
quoteExprPat :: String -> PatQ
quoteExprPat :: String -> PatQ
quoteExprPat String
s = do
NExpr
expr <-
(Doc Void -> Q NExpr)
-> (NExpr -> Q NExpr) -> Either (Doc Void) NExpr -> Q NExpr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(String -> Q NExpr
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q NExpr) -> (Doc Void -> String) -> Doc Void -> Q NExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Void -> String
forall b a. (Show a, IsString b) => a -> b
show)
NExpr -> Q NExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Text -> Either (Doc Void) NExpr
parseNixText (Text -> Either (Doc Void) NExpr)
-> Text -> Either (Doc Void) NExpr
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
s)
(forall b. Data b => b -> Maybe PatQ) -> NExpr -> PatQ
forall a.
Data a =>
(forall b. Data b => b -> Maybe PatQ) -> a -> PatQ
dataToPatQ
(Maybe PatQ -> b -> Maybe PatQ
forall a b. a -> b -> a
const Maybe PatQ
forall a. Maybe a
Nothing (b -> Maybe PatQ) -> (NExprLoc -> Maybe PatQ) -> b -> Maybe PatQ
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Set Text -> NExprLoc -> Maybe PatQ
metaPat (NExpr -> Set Text
freeVars NExpr
expr))
NExpr
expr
freeVars :: NExpr -> Set VarName
freeVars :: NExpr -> Set Text
freeVars NExpr
e = case NExpr -> NExprF NExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExpr
e of
(NConstant NAtom
_ ) -> Set Text
forall a. Monoid a => a
mempty
(NStr NString NExpr
string ) -> NString NExpr -> Set Text
forall (t :: * -> *). Foldable t => t NExpr -> Set Text
mapFreeVars NString NExpr
string
(NSym Text
var ) -> OneItem (Set Text) -> Set Text
forall x. One x => OneItem x -> x
one Text
OneItem (Set Text)
var
(NList [NExpr]
list ) -> [NExpr] -> Set Text
forall (t :: * -> *). Foldable t => t NExpr -> Set Text
mapFreeVars [NExpr]
list
(NSet NRecordType
NNonRecursive [Binding NExpr]
bindings) -> [Binding NExpr] -> Set Text
forall (t :: * -> *). Foldable t => t (Binding NExpr) -> Set Text
bindFreeVars [Binding NExpr]
bindings
(NSet NRecordType
NRecursive [Binding NExpr]
bindings) -> Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.difference ([Binding NExpr] -> Set Text
forall (t :: * -> *). Foldable t => t (Binding NExpr) -> Set Text
bindFreeVars [Binding NExpr]
bindings) ([Binding NExpr] -> Set Text
forall (t :: * -> *). Foldable t => t (Binding NExpr) -> Set Text
bindDefs [Binding NExpr]
bindings)
(NLiteralPath String
_ ) -> Set Text
forall a. Monoid a => a
mempty
(NEnvPath String
_ ) -> Set Text
forall a. Monoid a => a
mempty
(NUnary NUnaryOp
_ NExpr
expr ) -> NExpr -> Set Text
freeVars NExpr
expr
(NBinary NBinaryOp
_ NExpr
left NExpr
right ) -> (Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
(<>) (Set Text -> Set Text -> Set Text)
-> (NExpr -> Set Text) -> NExpr -> NExpr -> Set Text
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NExpr -> Set Text
freeVars) NExpr
left NExpr
right
(NSelect NExpr
expr NAttrPath NExpr
path Maybe NExpr
orExpr) ->
[Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
[ NExpr -> Set Text
freeVars NExpr
expr
, NAttrPath NExpr -> Set Text
pathFree NAttrPath NExpr
path
, Set Text -> (NExpr -> Set Text) -> Maybe NExpr -> Set Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Text
forall a. Monoid a => a
mempty NExpr -> Set Text
freeVars Maybe NExpr
orExpr
]
(NHasAttr NExpr
expr NAttrPath NExpr
path) -> NExpr -> Set Text
freeVars NExpr
expr Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> NAttrPath NExpr -> Set Text
pathFree NAttrPath NExpr
path
(NAbs (Param Text
varname) NExpr
expr) -> Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.delete Text
varname (NExpr -> Set Text
freeVars NExpr
expr)
(NAbs (ParamSet ParamSet NExpr
set Bool
_ Maybe Text
varname) NExpr
expr) ->
NExpr -> Set Text
freeVars NExpr
expr Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<>
Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.difference
([Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Text] -> Set Text) -> [Set Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ NExpr -> Set Text
freeVars (NExpr -> Set Text) -> [NExpr] -> [Set Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Maybe NExpr) -> Maybe NExpr) -> ParamSet NExpr -> [NExpr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Maybe NExpr) -> Maybe NExpr
forall a b. (a, b) -> b
snd ParamSet NExpr
set)
(Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.difference
(Set Text -> (Text -> Set Text) -> Maybe Text -> Set Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Text
forall a. Monoid a => a
mempty Text -> Set Text
forall x. One x => OneItem x -> x
one Maybe Text
varname)
([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (Text, Maybe NExpr) -> Text
forall a b. (a, b) -> a
fst ((Text, Maybe NExpr) -> Text) -> ParamSet NExpr -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamSet NExpr
set)
)
(NLet [Binding NExpr]
bindings NExpr
expr ) ->
NExpr -> Set Text
freeVars NExpr
expr Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<>
Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.difference
([Binding NExpr] -> Set Text
forall (t :: * -> *). Foldable t => t (Binding NExpr) -> Set Text
bindFreeVars [Binding NExpr]
bindings)
([Binding NExpr] -> Set Text
forall (t :: * -> *). Foldable t => t (Binding NExpr) -> Set Text
bindDefs [Binding NExpr]
bindings)
(NIf NExpr
cond NExpr
th NExpr
el ) -> [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Text] -> Set Text) -> [Set Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ NExpr -> Set Text
freeVars (NExpr -> Set Text) -> [NExpr] -> [Set Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NExpr
cond, NExpr
th, NExpr
el]
(NWith NExpr
set NExpr
expr ) -> (Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
(<>) (Set Text -> Set Text -> Set Text)
-> (NExpr -> Set Text) -> NExpr -> NExpr -> Set Text
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NExpr -> Set Text
freeVars) NExpr
set NExpr
expr
(NAssert NExpr
assertion NExpr
expr ) -> (Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
(<>) (Set Text -> Set Text -> Set Text)
-> (NExpr -> Set Text) -> NExpr -> NExpr -> Set Text
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NExpr -> Set Text
freeVars) NExpr
assertion NExpr
expr
(NSynHole Text
_ ) -> Set Text
forall a. Monoid a => a
mempty
where
bindDefs :: Foldable t => t (Binding NExpr) -> Set VarName
bindDefs :: t (Binding NExpr) -> Set Text
bindDefs = (Binding NExpr -> Set Text) -> t (Binding NExpr) -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Binding NExpr -> Set Text
forall r. Binding r -> Set Text
bind1Def
where
bind1Def :: Binding r -> Set VarName
bind1Def :: Binding r -> Set Text
bind1Def (Inherit Maybe r
Nothing [NKeyName r]
_ SourcePos
_) = Set Text
forall a. Monoid a => a
mempty
bind1Def (Inherit (Just r
_ ) [NKeyName r]
keys SourcePos
_) = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (NKeyName r -> Maybe Text) -> [NKeyName r] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NKeyName r -> Maybe Text
forall r. NKeyName r -> Maybe Text
staticKey [NKeyName r]
keys
bind1Def (NamedVar (StaticKey Text
varname :| [NKeyName r]
_) r
_ SourcePos
_) = OneItem (Set Text) -> Set Text
forall x. One x => OneItem x -> x
one Text
OneItem (Set Text)
varname
bind1Def (NamedVar (DynamicKey Antiquoted (NString r) r
_ :| [NKeyName r]
_) r
_ SourcePos
_) = Set Text
forall a. Monoid a => a
mempty
bindFreeVars :: Foldable t => t (Binding NExpr) -> Set VarName
bindFreeVars :: t (Binding NExpr) -> Set Text
bindFreeVars = (Binding NExpr -> Set Text) -> t (Binding NExpr) -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Binding NExpr -> Set Text
bind1Free
where
bind1Free :: Binding NExpr -> Set VarName
bind1Free :: Binding NExpr -> Set Text
bind1Free (Inherit Maybe NExpr
Nothing [NKeyName NExpr]
keys SourcePos
_) = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (NKeyName NExpr -> Maybe Text) -> [NKeyName NExpr] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NKeyName NExpr -> Maybe Text
forall r. NKeyName r -> Maybe Text
staticKey [NKeyName NExpr]
keys
bind1Free (Inherit (Just NExpr
scope) [NKeyName NExpr]
_ SourcePos
_) = NExpr -> Set Text
freeVars NExpr
scope
bind1Free (NamedVar NAttrPath NExpr
path NExpr
expr SourcePos
_) = NAttrPath NExpr -> Set Text
pathFree NAttrPath NExpr
path Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> NExpr -> Set Text
freeVars NExpr
expr
staticKey :: NKeyName r -> Maybe VarName
staticKey :: NKeyName r -> Maybe Text
staticKey (StaticKey Text
varname) = Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
varname
staticKey (DynamicKey Antiquoted (NString r) r
_ ) = Maybe Text
forall a. Monoid a => a
mempty
pathFree :: NAttrPath NExpr -> Set VarName
pathFree :: NAttrPath NExpr -> Set Text
pathFree = (NKeyName NExpr -> Set Text) -> NAttrPath NExpr -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NKeyName NExpr -> Set Text
forall (t :: * -> *). Foldable t => t NExpr -> Set Text
mapFreeVars
mapFreeVars :: Foldable t => t NExpr -> Set VarName
mapFreeVars :: t NExpr -> Set Text
mapFreeVars = (NExpr -> Set Text) -> t NExpr -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NExpr -> Set Text
freeVars
class ToExpr a where
toExpr :: a -> NExprLoc
instance ToExpr NExprLoc where
toExpr :: NExprLoc -> NExprLoc
toExpr = NExprLoc -> NExprLoc
forall a. a -> a
id
instance ToExpr VarName where
toExpr :: Text -> NExprLoc
toExpr = Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> (Text -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> Text
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Text -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> Text -> NExprLocF r
NSym_ SrcSpan
nullSpan
instance ToExpr Int where
toExpr :: Int -> NExprLoc
toExpr = Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> (Int -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> Int
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
nullSpan (NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> (Int -> NAtom) -> Int -> Compose (Ann SrcSpan) NExprF NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> NAtom
NInt (Integer -> NAtom) -> (Int -> Integer) -> Int -> NAtom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
instance ToExpr Integer where
toExpr :: Integer -> NExprLoc
toExpr = Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> (Integer -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> Integer
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
nullSpan (NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> (Integer -> NAtom)
-> Integer
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> NAtom
NInt
instance ToExpr Float where
toExpr :: Float -> NExprLoc
toExpr = Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> (Float -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> Float
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
nullSpan (NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> (Float -> NAtom)
-> Float
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> NAtom
NFloat
metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
metaExp :: Set Text -> NExprLoc -> Maybe ExpQ
metaExp Set Text
fvs (Fix (NSym_ SrcSpan
_ Text
x)) | Text
x Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
fvs =
ExpQ -> Maybe ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [| toExpr $(varE (mkName $ toString x)) |]
metaExp Set Text
_ NExprLoc
_ = Maybe ExpQ
forall a. Maybe a
Nothing
metaPat :: Set VarName -> NExprLoc -> Maybe PatQ
metaPat :: Set Text -> NExprLoc -> Maybe PatQ
metaPat Set Text
fvs (Fix (NSym_ SrcSpan
_ Text
x)) | Text
x Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
fvs =
PatQ -> Maybe PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatQ -> Maybe PatQ) -> PatQ -> Maybe PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
x
metaPat Set Text
_ NExprLoc
_ = Maybe PatQ
forall a. Maybe a
Nothing
nix :: QuasiQuoter
nix :: QuasiQuoter
nix = QuasiQuoter :: (String -> ExpQ)
-> (String -> PatQ)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> ExpQ
quoteExp = String -> ExpQ
quoteExprExp, quotePat :: String -> PatQ
quotePat = String -> PatQ
quoteExprPat }