{-# 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
-- Copyright               : (c) 2020-2021 Alexandre Moreno
-- SPDX-License-Identifier : BSD-3-Clause OR Apache-2.0
-- Maintainer              : Alexandre Moreno <alexmorenocano@gmail.com>
-- Stability               : experimental
-- Portability             : non-portable
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)

-- ouch: https://gitlab.haskell.org/ghc/ghc/-/issues/12596
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
          )

-- | compiles a Jsonnet program down to a Core expression stripped of
--   annotations
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