{-# language QuasiQuotes #-}
{-# language TemplateHaskell #-}

{-# options_ghc -Wno-missing-fields #-}

module Nix.TH where

import           Nix.Prelude
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.Types
import           Nix.Expr.Types.Annotated
import           Nix.Parser

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
    (forall b. Data b => b -> Maybe ExpQ) -> NExpr -> ExpQ
forall a.
Data a =>
(forall b. Data b => b -> Maybe ExpQ) -> a -> ExpQ
dataToExpQ
      ((Set VarName -> NExprLoc -> Maybe ExpQ) -> NExpr -> b -> Maybe ExpQ
forall b loc q.
(Typeable b, Typeable loc) =>
(Set VarName -> loc -> Maybe q) -> NExpr -> b -> Maybe q
extQOnFreeVars Set VarName -> NExprLoc -> Maybe ExpQ
metaExp 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 -> ExpQ)))
      NExpr
expr

quoteExprPat :: String -> PatQ
quoteExprPat :: String -> PatQ
quoteExprPat String
s =
  do
    NExpr
expr <- MonadFail Q => Text -> Q NExpr
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
    (forall b. Data b => b -> Maybe PatQ) -> NExpr -> PatQ
forall a.
Data a =>
(forall b. Data b => b -> Maybe PatQ) -> a -> PatQ
dataToPatQ
      ((Set VarName -> NExprLoc -> Maybe PatQ) -> NExpr -> b -> Maybe PatQ
forall b loc q.
(Typeable b, Typeable loc) =>
(Set VarName -> loc -> Maybe q) -> NExpr -> b -> Maybe q
extQOnFreeVars @_ @NExprLoc @PatQ Set VarName -> NExprLoc -> Maybe PatQ
metaPat NExpr
expr)
      NExpr
expr


-- | Helper function.
extQOnFreeVars
  :: ( Typeable b
    , Typeable loc
    )
  => ( Set VarName
    -> loc
    -> Maybe q
    )
  -> NExpr
  -> b
  -> Maybe q
extQOnFreeVars :: (Set VarName -> loc -> Maybe q) -> NExpr -> b -> Maybe q
extQOnFreeVars Set VarName -> loc -> Maybe q
f = (b -> Maybe q) -> (loc -> Maybe q) -> b -> Maybe q
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
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)
-> (NExpr -> loc -> Maybe q) -> NExpr -> b -> Maybe q
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set VarName -> loc -> Maybe q
f (Set VarName -> loc -> Maybe q)
-> (NExpr -> Set VarName) -> NExpr -> loc -> Maybe q
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExpr -> Set VarName
getFreeVars

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 :: VarName -> NExprLoc
toExpr = SrcSpan -> VarName -> NExprLoc
NSymAnn SrcSpan
nullSpan

instance ToExpr Int where
  toExpr :: Int -> NExprLoc
toExpr = SrcSpan -> NAtom -> NExprLoc
NConstantAnn SrcSpan
nullSpan (NAtom -> NExprLoc) -> (Int -> NAtom) -> Int -> 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 = SrcSpan -> NAtom -> NExprLoc
NConstantAnn SrcSpan
nullSpan (NAtom -> NExprLoc) -> (Integer -> NAtom) -> Integer -> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> NAtom
NInt

instance ToExpr Float where
  toExpr :: Float -> NExprLoc
toExpr = SrcSpan -> NAtom -> NExprLoc
NConstantAnn SrcSpan
nullSpan (NAtom -> NExprLoc) -> (Float -> NAtom) -> Float -> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> NAtom
NFloat

metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ
metaExp 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 =
  ExpQ -> Maybe ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [| toExpr $(varE (mkName $ toString x)) |]
metaExp Set VarName
_ NExprLoc
_ = 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 (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
$ 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 :: (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 }