{-# 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 Language.Jsonnet.Desugar
import Language.Jsonnet.Core
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)
import Data.Binary (Binary, encode)
import Language.Jsonnet.Annotate (annMap)
import Instances.TH.Lift ()
instance Data a => Lift (Arg a) where
lift :: Arg a -> Q Exp
lift = Arg a -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Lift SrcSpan where
lift :: SrcSpan -> Q Exp
lift = SrcSpan -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Lift Visibility where
lift :: Visibility -> Q Exp
lift = Visibility -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Data a => Lift (Args a) where
lift :: Args a -> Q Exp
lift = Args a -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Lift Strictness where
lift :: Strictness -> Q Exp
lift = Strictness -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Lift Literal where
lift :: Literal -> Q Exp
lift = Literal -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Lift Prim where
lift :: Prim -> Q Exp
lift = Prim -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Lift BinOp where
lift :: BinOp -> Q Exp
lift = BinOp -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Lift UnyOp where
lift :: UnyOp -> Q Exp
lift = UnyOp -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Data a => Lift (EField a) where
lift :: EField a -> Q Exp
lift = EField a -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Data a => Lift (Assert a) where
lift :: Assert a -> Q Exp
lift = Assert a -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Data a => Lift (CompSpec a) where
lift :: CompSpec a -> Q Exp
lift = CompSpec a -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Data a => Lift (ExprF a) where
lift :: ExprF a -> Q Exp
lift = ExprF a -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance
( Typeable a,
Typeable f,
Typeable g,
Data (f a),
Data (g a)
) =>
Lift (Product f g a)
where
lift :: Product f g a -> Q Exp
lift = Product f g a -> Q Exp
forall a. Data a => a -> Q Exp
liftData
instance Lift Expr where
lift :: Expr -> Q Exp
lift = Expr -> Q Exp
forall a. Data a => a -> Q 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. Lift t => t -> Q Exp
lift (Text -> String
T.unpack Text
txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText :: a -> Q Exp
liftDataWithText = (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
forall a.
Data a =>
(forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
dataToExpQ ((Text -> Q Exp) -> Maybe Text -> Maybe (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Q Exp
liftText (Maybe Text -> Maybe (Q Exp))
-> (b -> Maybe Text) -> b -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe Text
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast)
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
)
parse0 :: FilePath -> Text -> Q Expr
parse0 :: String -> Text -> Q Expr
parse0 String
path Text
str = do
Text -> Q (Either Error Expr)
parse' Text
str Q (Either Error Expr) -> (Either Error Expr -> Q Expr) -> Q Expr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Error
err -> String -> Q 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 -> Q Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
res
where
parse' :: Text -> Q (Either Error Expr)
parse' =
ExceptT Error Q Expr -> Q (Either Error Expr)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
(ExceptT Error Q Expr -> Q (Either Error Expr))
-> (Text -> ExceptT Error Q Expr) -> Text -> Q (Either Error Expr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( String -> Text -> ExceptT Error Q Expr'
forall (m :: * -> *).
MonadError Error m =>
String -> Text -> m Expr'
Parser.parse String
path
(Text -> ExceptT Error Q Expr')
-> (Expr' -> ExceptT Error Q Expr) -> Text -> ExceptT Error Q Expr
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> Expr' -> ExceptT Error Q Expr
forall (m :: * -> *).
(MonadError Error m, MonadIO m) =>
String -> Expr' -> m Expr
Parser.resolveImports String
path
)
compile :: FilePath -> Text -> Q Exp
compile :: String -> Text -> Q Exp
compile String
path Text
str = do
Expr
ast <- String -> Text -> Q Expr
parse0 String
path Text
str
let core :: Core
core = Ann ExprF () -> Core
forall a. Desugarer a => a -> Core
desugar ((SrcSpan -> ()) -> Expr -> Ann ExprF ()
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Ann f a -> Ann f b
annMap (() -> SrcSpan -> ()
forall a b. a -> b -> a
const ()) Expr
ast)
ByteString -> Q Exp
forall t. Lift t => t -> Q Exp
lift (ByteString -> Q Exp) -> ByteString -> Q Exp
forall a b. (a -> b) -> a -> b
$ Core -> ByteString
forall a. Binary a => a -> ByteString
encode Core
core