{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}

module Nix.TH where

import           Data.Fix                       ( Fix(Fix) )
import           Data.Generics.Aliases          ( extQ )
import qualified Data.Set                      as Set
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import           Nix.Atoms
import           Nix.Expr.Types
import           Nix.Expr.Types.Annotated
import           Nix.Parser
import           Nix.Prelude

removeMissingNames :: Set VarName -> Q (Set VarName)
removeMissingNames :: Set VarName -> Q (Set VarName)
removeMissingNames =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Eq a => [a] -> Set a
Set.fromAscList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q (Maybe Name)
lookupValueName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toAscList

quoteExprExp :: String -> ExpQ
quoteExprExp :: String -> ExpQ
quoteExprExp String
s = do
  NExpr
expr <- forall (m :: * -> *). MonadFail m => Text -> m NExpr
parseExpr forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
s
  Set VarName
vars <- Set VarName -> Q (Set VarName)
removeMissingNames forall a b. (a -> b) -> a -> b
$ NExpr -> Set VarName
getFreeVars NExpr
expr
  forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ (forall b loc q.
(Typeable b, Typeable loc) =>
(Set VarName -> loc -> Maybe q) -> Set VarName -> b -> Maybe q
extQOnFreeVars Set VarName -> NExpr -> Maybe ExpQ
metaExp Set VarName
vars) NExpr
expr

quoteExprPat :: String -> PatQ
quoteExprPat :: String -> PatQ
quoteExprPat String
s = do
  NExpr
expr <- forall (m :: * -> *). MonadFail m => Text -> m NExpr
parseExpr @Q forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
s
  Set VarName
vars <- Set VarName -> Q (Set VarName)
removeMissingNames forall a b. (a -> b) -> a -> b
$ NExpr -> Set VarName
getFreeVars NExpr
expr
  forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Pat)) -> a -> m Pat
dataToPatQ (forall b loc q.
(Typeable b, Typeable loc) =>
(Set VarName -> loc -> Maybe q) -> Set VarName -> b -> Maybe q
extQOnFreeVars @_ @NExprLoc @PatQ Set VarName -> NExprLoc -> Maybe PatQ
metaPat Set VarName
vars) NExpr
expr

-- | Helper function.
extQOnFreeVars
  :: (Typeable b, Typeable loc)
  => (Set VarName -> loc -> Maybe q)
  -> Set VarName
  -> b
  -> Maybe q
extQOnFreeVars :: forall b loc q.
(Typeable b, Typeable loc) =>
(Set VarName -> loc -> Maybe q) -> Set VarName -> b -> Maybe q
extQOnFreeVars Set VarName -> loc -> Maybe q
f = forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
extQ (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set VarName -> loc -> Maybe q
f

class ToExpr a where
  toExpr :: a -> NExpr

instance ToExpr NExpr where
  toExpr :: NExpr -> NExpr
toExpr = forall a. a -> a
id

instance ToExpr VarName where
  toExpr :: VarName -> NExpr
toExpr = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. VarName -> NExprF r
NSym

instance {-# OVERLAPPING #-} ToExpr String where
  toExpr :: String -> NExpr
toExpr = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. NString r -> NExprF r
NStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

instance ToExpr Text where
  toExpr :: Text -> NExpr
toExpr = forall a. ToExpr a => a -> NExpr
toExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString

instance ToExpr Int where
  toExpr :: Int -> NExpr
toExpr = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. NAtom -> NExprF r
NConstant forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> NAtom
NInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance ToExpr Bool where
  toExpr :: Bool -> NExpr
toExpr = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. NAtom -> NExprF r
NConstant forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> NAtom
NBool

instance ToExpr Integer where
  toExpr :: Integer -> NExpr
toExpr = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. NAtom -> NExprF r
NConstant forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> NAtom
NInt

instance ToExpr Float where
  toExpr :: Float -> NExpr
toExpr = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. NAtom -> NExprF r
NConstant forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> NAtom
NFloat

instance (ToExpr a) => ToExpr [a] where
  toExpr :: [a] -> NExpr
toExpr = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. [r] -> NExprF r
NList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToExpr a => a -> NExpr
toExpr

instance (ToExpr a) => ToExpr (NonEmpty a) where
  toExpr :: NonEmpty a -> NExpr
toExpr = forall a. ToExpr a => a -> NExpr
toExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance ToExpr () where
  toExpr :: () -> NExpr
toExpr () = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall a b. (a -> b) -> a -> b
$ forall r. NAtom -> NExprF r
NConstant NAtom
NNull

instance (ToExpr a) => ToExpr (Maybe a) where
  toExpr :: Maybe a -> NExpr
toExpr = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. ToExpr a => a -> NExpr
toExpr ()) forall a. ToExpr a => a -> NExpr
toExpr

instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where
  toExpr :: Either a b -> NExpr
toExpr = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. ToExpr a => a -> NExpr
toExpr forall a. ToExpr a => a -> NExpr
toExpr

metaExp :: Set VarName -> NExpr -> Maybe ExpQ
metaExp :: Set VarName -> NExpr -> Maybe ExpQ
metaExp Set VarName
fvs (Fix (NSym VarName
x)) | VarName
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set VarName
fvs =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [| toExpr $(varE (mkName $ toString x)) |]
metaExp Set VarName
_ NExpr
_ = forall a. Maybe a
Nothing

metaPat :: Set VarName -> NExprLoc -> Maybe PatQ
metaPat :: Set VarName -> NExprLoc -> Maybe PatQ
metaPat Set VarName
fvs (NSymAnn SrcSpan
_ VarName
x) | VarName
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set VarName
fvs =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a. ToString a => a -> String
toString VarName
x
metaPat Set VarName
_ NExprLoc
_ = 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 { quoteExp :: String -> ExpQ
quoteExp = String -> ExpQ
quoteExprExp, quotePat :: String -> PatQ
quotePat = String -> PatQ
quoteExprPat }