{-# 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 =
  ([VarName] -> Set VarName) -> Q [VarName] -> Q (Set VarName)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [VarName] -> Set VarName
forall a. Eq a => [a] -> Set a
Set.fromAscList
    (Q [VarName] -> Q (Set VarName))
-> (Set VarName -> Q [VarName]) -> Set VarName -> Q (Set VarName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarName -> Q Bool) -> [VarName] -> Q [VarName]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Maybe Name -> Bool) -> Q (Maybe Name) -> Q Bool
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Q (Maybe Name) -> Q Bool)
-> (VarName -> Q (Maybe Name)) -> VarName -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q (Maybe Name)
lookupValueName (String -> Q (Maybe Name))
-> (VarName -> String) -> VarName -> Q (Maybe Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> String
forall a. ToString a => a -> String
toString)
    ([VarName] -> Q [VarName])
-> (Set VarName -> [VarName]) -> Set VarName -> Q [VarName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set VarName -> [VarName]
forall a. Set a -> [a]
Set.toAscList

quoteExprExp :: String -> ExpQ
quoteExprExp :: String -> ExpQ
quoteExprExp String
s = do
  NExpr
expr <- Text -> Q NExpr
forall (m :: * -> *). MonadFail m => Text -> m NExpr
parseExpr (Text -> Q NExpr) -> Text -> Q NExpr
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString String
s
  Set VarName
vars <- Set VarName -> Q (Set VarName)
removeMissingNames (Set VarName -> Q (Set VarName)) -> Set VarName -> Q (Set VarName)
forall a b. (a -> b) -> a -> b
$ NExpr -> Set VarName
getFreeVars NExpr
expr
  (forall b. Data b => b -> Maybe ExpQ) -> NExpr -> ExpQ
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ ((Set VarName -> NExpr -> Maybe ExpQ)
-> Set VarName -> b -> Maybe ExpQ
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 (Text -> Q NExpr) -> Text -> Q NExpr
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString String
s
  Set VarName
vars <- Set VarName -> Q (Set VarName)
removeMissingNames (Set VarName -> Q (Set VarName)) -> Set VarName -> Q (Set VarName)
forall a b. (a -> b) -> a -> b
$ NExpr -> Set VarName
getFreeVars NExpr
expr
  (forall b. Data b => b -> Maybe PatQ) -> NExpr -> PatQ
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 = (b -> Maybe q) -> (loc -> Maybe q) -> b -> Maybe q
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
extQ (Maybe q -> b -> Maybe q
forall a b. a -> b -> a
const Maybe q
forall a. Maybe a
Nothing) ((loc -> Maybe q) -> b -> Maybe q)
-> (Set VarName -> loc -> Maybe q) -> Set VarName -> b -> Maybe q
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 = NExpr -> NExpr
forall a. a -> a
id

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

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

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

instance ToExpr Int where
  toExpr :: Int -> NExpr
toExpr = NExprF NExpr -> NExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (NExprF NExpr -> NExpr) -> (Int -> NExprF NExpr) -> Int -> NExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NAtom -> NExprF NExpr
forall r. NAtom -> NExprF r
NConstant (NAtom -> NExprF NExpr) -> (Int -> NAtom) -> Int -> NExprF NExpr
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 Bool where
  toExpr :: Bool -> NExpr
toExpr = NExprF NExpr -> NExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (NExprF NExpr -> NExpr) -> (Bool -> NExprF NExpr) -> Bool -> NExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NAtom -> NExprF NExpr
forall r. NAtom -> NExprF r
NConstant (NAtom -> NExprF NExpr) -> (Bool -> NAtom) -> Bool -> NExprF NExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> NAtom
NBool

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

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

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

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

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

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

instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where
  toExpr :: Either a b -> NExpr
toExpr = (a -> NExpr) -> (b -> NExpr) -> Either a b -> NExpr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> NExpr
forall a. ToExpr a => a -> NExpr
toExpr b -> NExpr
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 VarName -> Set VarName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set VarName
fvs =
  ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [| toExpr $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ VarName -> String
forall a. ToString a => a -> String
toString VarName
x)) |]
metaExp Set VarName
_ NExpr
_ = Maybe ExpQ
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 VarName -> Set VarName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set VarName
fvs =
  PatQ -> Maybe PatQ
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatQ -> Maybe PatQ) -> PatQ -> Maybe PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
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
$ VarName -> String
forall a. ToString a => a -> String
toString VarName
x
metaPat Set VarName
_ 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 { quoteExp :: String -> ExpQ
quoteExp = String -> ExpQ
quoteExprExp, quotePat :: String -> PatQ
quotePat = String -> PatQ
quoteExprPat }