Quoting.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      : Text.EDE.Internal.Quoting
-- Copyright   : (c) 2013-2022 Brendan Hay <brendan.g.hay@gmail.com>
-- License     : This Source Code Form is subject to the terms of
--               the Mozilla Public License, v. 2.0.
--               A copy of the MPL can be found in the LICENSE file or
--               you can obtain it at http://mozilla.org/MPL/2.0/.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- /Warning/: this is an internal module, and does not have a stable
-- API or name. Functions in this module may not check or enforce
-- preconditions expected by public modules. Use at your own risk!
module Text.EDE.Internal.Quoting where

import Control.Applicative ((<|>))
import Control.Monad ((>=>))
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (Value (..))
import qualified Data.Bifunctor as Bifunctor
import qualified Data.ByteString.Char8 as ByteString.Char8
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Scientific (Scientific)
import qualified Data.Scientific as Scientific
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text.Encoding
import qualified Data.Text.Lazy as Text.Lazy
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Text.Builder
import Data.Text.Manipulate (toOrdinal)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Prettyprinter (Pretty (..), (<+>))
import qualified Prettyprinter as PP
import Text.EDE.Internal.Types
import Text.Trifecta.Delta (Delta)
import qualified Text.Trifecta.Delta as Trifecta.Delta
import qualified Text.Trifecta.Rendering as Trifecta.Rendering

#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.KeyMap (KeyMap)
#endif

-- | A HOAS representation of (possibly partially applied) values
-- in the environment.
data Term
  = TVal !Value
  | TLam (Term -> Result Term)

instance AnsiPretty Term where
  apretty = \case
    TLam _ -> "Function"
    TVal v -> bold (pp v)

-- | Fully apply two 'Term's.
qapply :: Delta -> Term -> Term -> Result Term
qapply d a b = case (a, b) of
  (TLam f, x) ->
    case f x of
      Failure e -> Failure (Trifecta.Delta.prettyDelta d <+> red "error:" <+> e)
      Success y -> pure y
  (TVal x, _) ->
    Failure $
      "unable to apply literal"
        <+> apretty a
        <+> "->"
        <+> apretty b
        </> pp x
{-# INLINEABLE qapply #-}

-- | Quote a primitive 'Value' from the top-level.
qprim :: (ToJSON a, Quote a) => a -> Term
qprim = quote "Value" 0
{-# INLINEABLE qprim #-}

class Unquote a where
  unquote :: Id -> Int -> Term -> Result a
  default unquote :: FromJSON a => Id -> Int -> Term -> Result a
  unquote k n = \case
    f@TLam {} -> typeErr k n (apretty f) "Value"
    TVal v ->
      case Aeson.fromJSON v of
        Aeson.Success x -> pure x
        Aeson.Error e -> argumentErr k n e
  {-# INLINEABLE unquote #-}

instance Unquote Value

#if MIN_VERSION_aeson(2,0,0)
instance Unquote (KeyMap Value)
#endif

instance Unquote (HashMap Text Value)

instance Unquote (Vector Value)

instance Unquote Text

instance Unquote [Text]

instance Unquote Text.Lazy.Text

instance Unquote Bool

instance Unquote Double

instance Unquote Scientific

instance Unquote Int where
  unquote k n =
    unquote k n
      >=> maybe (typeErr k n "Double" "Int") pure
        . Scientific.toBoundedInteger
  {-# INLINEABLE unquote #-}

instance Unquote Integer where
  unquote k n =
    unquote k n
      >=> either (const (typeErr k n "Double" "Integral")) pure
        . (Scientific.floatingOrInteger :: Scientific -> Either Double Integer)
  {-# INLINEABLE unquote #-}

instance Unquote Collection where
  unquote k n q =
    text <$> unquote k n q
      <|> hashMap <$> unquote k n q
      <|> vector <$> unquote k n q
    where
      text t =
        Col (Text.length t)
          . map (\c -> (Nothing, String (Text.singleton c)))
          $ Text.unpack t

      hashMap m =
        Col (HashMap.size m)
          . map (Bifunctor.first Just)
          . sortBy (comparing fst)
          $ HashMap.toList m

      vector v = Col (Vector.length v) (Vector.map (Nothing,) v)
  {-# INLINEABLE unquote #-}

class Quote a where
  quote :: Id -> Int -> a -> Term
  default quote :: ToJSON a => Id -> Int -> a -> Term
  quote _ _ = TVal . Aeson.toJSON
  {-# INLINEABLE quote #-}

instance (Unquote a, Quote b) => Quote (a -> b) where
  quote k n f = TLam $ \x -> quote k n' . f <$> unquote k n' x
    where
      n' = succ n
  {-# INLINEABLE quote #-}

instance Quote Term where
  quote _ _ = id
  {-# INLINEABLE quote #-}

instance Quote Value

#if MIN_VERSION_aeson(2,0,0)
instance Quote (KeyMap Value)
#endif

instance Quote (HashMap Text Value)

instance Quote (Vector Value)

instance Quote [Value]

instance Quote Text

instance Quote [Text]

instance Quote Text.Lazy.Text

instance Quote Bool

instance Quote Int

instance Quote Integer

instance Quote Double

instance Quote Scientific

instance Quote Builder where
  quote k n = quote k n . Text.Builder.toLazyText
  {-# INLINEABLE quote #-}

typeErr :: Id -> Int -> AnsiDoc -> AnsiDoc -> Result a
typeErr k n x y = Failure $ "type" <+> pp k <+> pretty n <+> x <+> "::" <+> y

argumentErr :: Pretty a => Id -> Int -> a -> Result b
argumentErr k n e = Failure $ if self then app else arg
  where
    app =
      "unable to apply"
        <+> bold (pp k)
        <+> "to left hand side:"
        </> PP.indent 4 (pretty e </> Trifecta.Rendering.prettyRendering mark)

    arg =
      "invalid"
        <+> bold (pp $ toOrdinal (n - 1))
        <+> "argument to"
        <+> bold (pp k)
        <> ":"
        </> PP.indent 4 (pretty e </> Trifecta.Rendering.prettyRendering mark)

    mark =
      Trifecta.Rendering.renderingCaret (Trifecta.Delta.Columns col col) $
        "... | " <> Text.Encoding.encodeUtf8 k <> line

    col
      | self = 1
      | otherwise = fromIntegral (Text.length k + 4 + (n * 2))

    line
      | self = "\n"
      | otherwise =
        "(" <> ByteString.Char8.intercalate ", " (replicate (n - 1) "...") <> "\n"

    self = n <= 1