{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# 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             ) -> Text -> Set Text
forall a. a -> Set a
Set.singleton 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. Ord a => Set a -> Set a -> Set a
Set.union (NExpr -> Set Text
freeVars NExpr
left) (NExpr -> Set Text
freeVars 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) -> Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union (NExpr -> Set Text
freeVars NExpr
expr) (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) ->
    Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union
      -- Include all free variables from the expression and the default arguments
      (NExpr -> Set Text
freeVars NExpr
expr)
      -- But remove the argument name if existing, and all arguments in the parameter set
      (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 a. a -> Set a
Set.singleton 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) -> ParamSet NExpr -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Maybe NExpr) -> Text
forall a b. (a, b) -> a
fst ParamSet NExpr
set)
        )
      )
  (NLet         [Binding NExpr]
bindings NExpr
expr   ) ->
    Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union
      (NExpr -> Set Text
freeVars NExpr
expr)
      (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]
  -- Evaluation is needed to find out whether x is a "real" free variable in `with y; x`, we just include it
  -- This also makes sense because its value can be overridden by `x: with y; x`
  (NWith        NExpr
set  NExpr
expr       ) -> Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union (NExpr -> Set Text
freeVars NExpr
set      ) (NExpr -> Set Text
freeVars NExpr
expr)
  (NAssert      NExpr
assertion NExpr
expr  ) -> Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union (NExpr -> Set Text
freeVars NExpr
assertion) (NExpr -> Set Text
freeVars 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
_) = Text -> Set Text
forall a. a -> Set a
Set.singleton 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
_) = Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union (NAttrPath NExpr -> Set Text
pathFree NAttrPath NExpr
path) (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

-- Use of @QuasiQuoter@ requires @String@.
-- After @Text -> String@ migrations done, _maybe_ think to use @QuasiText@.
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 }