{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}

{-# OPTIONS_GHC -Wno-missing-fields #-}

module Nix.TH where

import           Data.Fix
import           Data.Generics.Aliases
import           Data.Set                       ( Set
                                                , (\\)
                                                )
import qualified Data.Set                      as Set
import qualified Data.Text                     as Text
import           Data.List.NonEmpty             ( NonEmpty(..) )
import           Data.Maybe                     ( mapMaybe )
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import           Nix.Atoms
import           Nix.Expr
import           Nix.Parser

quoteExprExp :: String -> ExpQ
quoteExprExp :: String -> ExpQ
quoteExprExp s :: String
s = do
  NExpr
expr <- case Text -> Result NExpr
parseNixText (String -> Text
Text.pack String
s) of
    Failure err :: Doc Void
err -> String -> Q NExpr
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q NExpr) -> String -> Q NExpr
forall a b. (a -> b) -> a -> b
$ Doc Void -> String
forall a. Show a => a -> String
show Doc Void
err
    Success e :: NExpr
e   -> NExpr -> Q NExpr
forall (m :: * -> *) a. Monad m => a -> m a
return NExpr
e
  (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)) NExpr
expr

quoteExprPat :: String -> PatQ
quoteExprPat :: String -> PatQ
quoteExprPat s :: String
s = do
  NExpr
expr <- case Text -> Result NExpr
parseNixText (String -> Text
Text.pack String
s) of
    Failure err :: Doc Void
err -> String -> Q NExpr
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q NExpr) -> String -> Q NExpr
forall a b. (a -> b) -> a -> b
$ Doc Void -> String
forall a. Show a => a -> String
show Doc Void
err
    Success e :: NExpr
e   -> NExpr -> Q NExpr
forall (m :: * -> *) a. Monad m => a -> m a
return NExpr
e
  (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 e :: NExpr
e = case NExpr -> NExprF NExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExpr
e of
  (NConstant    _       ) -> Set Text
forall a. Set a
Set.empty
  (NStr         string :: NString NExpr
string  ) -> (NExpr -> Set Text) -> NString NExpr -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NExpr -> Set Text
freeVars NString NExpr
string
  (NSym         var :: Text
var     ) -> Text -> Set Text
forall a. a -> Set a
Set.singleton Text
var
  (NList        list :: [NExpr]
list    ) -> (NExpr -> Set Text) -> [NExpr] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NExpr -> Set Text
freeVars [NExpr]
list
  (NSet NNonRecursive bindings :: [Binding NExpr]
bindings) -> (Binding NExpr -> Set Text) -> [Binding NExpr] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Binding NExpr -> Set Text
bindFree [Binding NExpr]
bindings
  (NSet NRecursive bindings :: [Binding NExpr]
bindings) -> (Binding NExpr -> Set Text) -> [Binding NExpr] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Binding NExpr -> Set Text
bindFree [Binding NExpr]
bindings Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
\\ (Binding NExpr -> Set Text) -> [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
bindDefs [Binding NExpr]
bindings
  (NLiteralPath _       ) -> Set Text
forall a. Set a
Set.empty
  (NEnvPath     _       ) -> Set Text
forall a. Set a
Set.empty
  (NUnary _ expr :: NExpr
expr        ) -> NExpr -> Set Text
freeVars NExpr
expr
  (NBinary _ left :: NExpr
left right :: NExpr
right ) -> NExpr -> Set Text
freeVars NExpr
left Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` NExpr -> Set Text
freeVars NExpr
right
  (NSelect expr :: NExpr
expr path :: NAttrPath NExpr
path orExpr :: Maybe NExpr
orExpr) ->
    NExpr -> Set Text
freeVars NExpr
expr
      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
      Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Text -> (NExpr -> Set Text) -> Maybe NExpr -> Set Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Text
forall a. Set a
Set.empty NExpr -> Set Text
freeVars Maybe NExpr
orExpr
  (NHasAttr expr :: NExpr
expr            path :: NAttrPath NExpr
path) -> NExpr -> Set Text
freeVars NExpr
expr 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
  (NAbs     (Param varname :: Text
varname) expr :: 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 set :: ParamSet NExpr
set _ varname :: Maybe Text
varname) expr :: NExpr
expr) ->
    -- Include all free variables from the expression and the default arguments
    NExpr -> Set Text
freeVars NExpr
expr
      Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (((Text, Maybe NExpr) -> Maybe (Set Text))
-> ParamSet NExpr -> [Set Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((NExpr -> Set Text) -> Maybe NExpr -> Maybe (Set Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NExpr -> Set Text
freeVars (Maybe NExpr -> Maybe (Set Text))
-> ((Text, Maybe NExpr) -> Maybe NExpr)
-> (Text, Maybe NExpr)
-> Maybe (Set Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Maybe NExpr) -> Maybe NExpr
forall a b. (a, b) -> b
snd) ParamSet NExpr
set)
    -- 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 Text -> (Text -> Set Text) -> Maybe Text -> Set Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Text
forall a. Set a
Set.empty Text -> Set Text
forall a. a -> Set a
Set.singleton Maybe Text
varname
      Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
\\          [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList (((Text, Maybe NExpr) -> Text) -> ParamSet NExpr -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe NExpr) -> Text
forall a b. (a, b) -> a
fst ParamSet NExpr
set)
  (NLet bindings :: [Binding NExpr]
bindings expr :: NExpr
expr) ->
    NExpr -> Set Text
freeVars NExpr
expr
      Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (Binding NExpr -> Set Text) -> [Binding NExpr] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Binding NExpr -> Set Text
bindFree [Binding NExpr]
bindings
      Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
\\          (Binding NExpr -> Set Text) -> [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
bindDefs [Binding NExpr]
bindings
  (NIf cond :: NExpr
cond th :: NExpr
th el :: NExpr
el) ->
    NExpr -> Set Text
freeVars NExpr
cond Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` NExpr -> Set Text
freeVars NExpr
th Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` NExpr -> Set Text
freeVars 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   set :: NExpr
set       expr :: NExpr
expr) -> NExpr -> Set Text
freeVars NExpr
set Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` NExpr -> Set Text
freeVars NExpr
expr
  (NAssert assertion :: NExpr
assertion expr :: NExpr
expr) -> NExpr -> Set Text
freeVars NExpr
assertion Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` NExpr -> Set Text
freeVars NExpr
expr
  (NSynHole _            ) -> Set Text
forall a. Set a
Set.empty

 where

  staticKey :: NKeyName r -> Maybe VarName
  staticKey :: NKeyName r -> Maybe Text
staticKey (StaticKey  varname :: Text
varname) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
varname
  staticKey (DynamicKey _      ) = Maybe Text
forall a. Maybe a
Nothing

  bindDefs :: Binding r -> Set VarName
  bindDefs :: Binding r -> Set Text
bindDefs (Inherit  Nothing                   _    _) = Set Text
forall a. Set a
Set.empty
  bindDefs (Inherit (Just _) keys :: [NKeyName r]
keys _) = [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
  bindDefs (NamedVar (StaticKey  varname :: Text
varname :| _) _    _) = Text -> Set Text
forall a. a -> Set a
Set.singleton Text
varname
  bindDefs (NamedVar (DynamicKey _       :| _) _    _) = Set Text
forall a. Set a
Set.empty

  bindFree :: Binding NExpr -> Set VarName
  bindFree :: Binding NExpr -> Set Text
bindFree (Inherit Nothing keys :: [NKeyName NExpr]
keys _) = [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
  bindFree (Inherit (Just scope :: NExpr
scope) _ _) = NExpr -> Set Text
freeVars NExpr
scope
  bindFree (NamedVar path :: NAttrPath NExpr
path expr :: NExpr
expr _) = NAttrPath NExpr -> Set Text
pathFree 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

  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 ((NExpr -> Set Text) -> NKeyName 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 fvs :: Set Text
fvs (Fix (NSym_ _ x :: 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 a. a -> Maybe a
Just [| toExpr $(varE (mkName (Text.unpack x))) |]
metaExp _ _ = Maybe ExpQ
forall a. Maybe a
Nothing

metaPat :: Set VarName -> NExprLoc -> Maybe PatQ
metaPat :: Set Text -> NExprLoc -> Maybe PatQ
metaPat fvs :: Set Text
fvs (Fix (NSym_ _ x :: 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 a. a -> Maybe a
Just (Name -> PatQ
varP (String -> Name
mkName (Text -> String
Text.unpack Text
x)))
metaPat _ _ = 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 }