{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Language.Jsonnet.TH where

import Control.Monad.Except hiding (lift)
import Data.Data
import Data.Functor.Product
import Data.Scientific (Scientific)
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Jsonnet.Common
import qualified Language.Jsonnet.Parser as Parser
import Language.Jsonnet.Parser.SrcSpan
import Language.Jsonnet.Pretty ()
import Language.Jsonnet.Syntax
import Language.Jsonnet.Syntax.Annotated
import Text.PrettyPrint.ANSI.Leijen (pretty)

instance Data a => Lift (Arg a) where
  lift :: forall (m :: * -> *). Quote m => Arg a -> m Exp
lift = Arg a -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Data a => Lift (Hideable a) where
  lift :: forall (m :: * -> *). Quote m => Hideable a -> m Exp
lift = Hideable a -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift SrcSpan where
  lift :: forall (m :: * -> *). Quote m => SrcSpan -> m Exp
lift = SrcSpan -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift Visibility where
  lift :: forall (m :: * -> *). Quote m => Visibility -> m Exp
lift = Visibility -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Data a => Lift (Args a) where
  lift :: forall (m :: * -> *). Quote m => Args a -> m Exp
lift = Args a -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift Strictness where
  lift :: forall (m :: * -> *). Quote m => Strictness -> m Exp
lift = Strictness -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift Literal where
  lift :: forall (m :: * -> *). Quote m => Literal -> m Exp
lift = Literal -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift Scientific where
  lift :: forall (m :: * -> *). Quote m => Scientific -> m Exp
lift Scientific
s = [|fromRational $(return $ LitE $ RationalL (toRational s))|]

instance Lift BinOp where
  lift :: forall (m :: * -> *). Quote m => BinOp -> m Exp
lift = BinOp -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift ArithOp where
  lift :: forall (m :: * -> *). Quote m => ArithOp -> m Exp
lift = ArithOp -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift CompOp where
  lift :: forall (m :: * -> *). Quote m => CompOp -> m Exp
lift = CompOp -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift BitwiseOp where
  lift :: forall (m :: * -> *). Quote m => BitwiseOp -> m Exp
lift = BitwiseOp -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift LogicalOp where
  lift :: forall (m :: * -> *). Quote m => LogicalOp -> m Exp
lift = LogicalOp -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift UnyOp where
  lift :: forall (m :: * -> *). Quote m => UnyOp -> m Exp
lift = UnyOp -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Data a => Lift (Field a) where
  lift :: forall (m :: * -> *). Quote m => Field a -> m Exp
lift = Field a -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Data a => Lift (Assert a) where
  lift :: forall (m :: * -> *). Quote m => Assert a -> m Exp
lift = Assert a -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Data a => Lift (CompSpec a) where
  lift :: forall (m :: * -> *). Quote m => CompSpec a -> m Exp
lift = CompSpec a -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Data a => Lift (ExprF a) where
  lift :: forall (m :: * -> *). Quote m => ExprF a -> m Exp
lift = ExprF a -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance
  ( Typeable a,
    Typeable f,
    Typeable g,
    Data (f a),
    Data (g a)
  ) =>
  Lift (Product f g a)
  where
  lift :: forall (m :: * -> *). Quote m => Product f g a -> m Exp
lift = Product f g a -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

instance Lift Expr where
  lift :: forall (m :: * -> *). Quote m => Expr -> m Exp
lift = Expr -> m Exp
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData

liftText :: Text -> Q Exp
liftText :: Text -> Q Exp
liftText Text
txt = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.pack) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (Text -> String
T.unpack Text
txt)

-- ouch: https://gitlab.haskell.org/ghc/ghc/-/issues/12596
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText :: forall a. Data a => a -> Q Exp
liftDataWithText = (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ (\b
a -> Text -> Q Exp
liftText (Text -> Q Exp) -> Maybe Text -> Maybe (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> Maybe Text
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
a)

parse :: FilePath -> Text -> Q Exp
parse :: String -> Text -> Q Exp
parse String
path Text
str = do
  Expr
res <-
    IO Expr -> Q Expr
forall a. IO a -> Q a
runIO (IO Expr -> Q Expr) -> IO Expr -> Q Expr
forall a b. (a -> b) -> a -> b
$
      Text -> IO (Either Error Expr)
parse' Text
str IO (Either Error Expr) -> (Either Error Expr -> IO Expr) -> IO Expr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Error
err -> String -> IO Expr
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Error -> Doc
forall a. Pretty a => a -> Doc
pretty Error
err)
        Right Expr
res -> Expr -> IO Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
res
  Expr -> Q Exp
forall a. Data a => a -> Q Exp
liftDataWithText Expr
res
  where
    parse' :: Text -> IO (Either Error Expr)
parse' =
      ExceptT Error IO Expr -> IO (Either Error Expr)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (ExceptT Error IO Expr -> IO (Either Error Expr))
-> (Text -> ExceptT Error IO Expr)
-> Text
-> IO (Either Error Expr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( String -> Text -> ExceptT Error IO Expr'
forall (m :: * -> *).
MonadError Error m =>
String -> Text -> m Expr'
Parser.parse String
path
              (Text -> ExceptT Error IO Expr')
-> (Expr' -> ExceptT Error IO Expr)
-> Text
-> ExceptT Error IO Expr
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> Expr' -> ExceptT Error IO Expr
forall (m :: * -> *).
(MonadError Error m, MonadIO m) =>
String -> Expr' -> m Expr
Parser.resolveImports String
path
          )