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

-- |
-- Module      : Text.EDE.Internal.Quoting
-- Copyright   : (c) 2013-2020 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 (Array, Object, Value (..))
import qualified Data.Bifunctor as Bifunctor
import qualified Data.ByteString.Char8 as ByteString.Char8
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.Text.Prettyprint.Doc (Pretty (..), (<+>))
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Vector as Vector
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

default (AnsiDoc, Double, Integer)

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

instance AnsiPretty Term where
  apretty :: Term -> AnsiDoc
apretty = \case
    TLam Term -> Result Term
_ -> AnsiDoc
"Function"
    TVal Value
v -> AnsiDoc -> AnsiDoc
bold (Value -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Value
v)

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

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

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

instance Unquote Value

instance Unquote Text

instance Unquote [Text]

instance Unquote Text.Lazy.Text

instance Unquote Bool

instance Unquote Double

instance Unquote Scientific

instance Unquote Object

instance Unquote Array

instance Unquote Int where
  unquote :: Id -> Int -> Term -> Result Int
unquote Id
k Int
n =
    Id -> Int -> Term -> Result Scientific
forall a. Unquote a => Id -> Int -> Term -> Result a
unquote Id
k Int
n
      (Term -> Result Scientific)
-> (Scientific -> Result Int) -> Term -> Result Int
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Result Int -> (Int -> Result Int) -> Maybe Int -> Result Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Id -> Int -> AnsiDoc -> AnsiDoc -> Result Int
forall a. Id -> Int -> AnsiDoc -> AnsiDoc -> Result a
typeErr Id
k Int
n AnsiDoc
"Double" AnsiDoc
"Int") Int -> Result Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Maybe Int -> Result Int)
-> (Scientific -> Maybe Int) -> Scientific -> Result Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Scientific.toBoundedInteger
  {-# INLINEABLE unquote #-}

instance Unquote Integer where
  unquote :: Id -> Int -> Term -> Result Integer
unquote Id
k Int
n =
    Id -> Int -> Term -> Result Scientific
forall a. Unquote a => Id -> Int -> Term -> Result a
unquote Id
k Int
n
      (Term -> Result Scientific)
-> (Scientific -> Result Integer) -> Term -> Result Integer
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Double -> Result Integer)
-> (Integer -> Result Integer)
-> Either Double Integer
-> Result Integer
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result Integer -> Double -> Result Integer
forall a b. a -> b -> a
const (Id -> Int -> AnsiDoc -> AnsiDoc -> Result Integer
forall a. Id -> Int -> AnsiDoc -> AnsiDoc -> Result a
typeErr Id
k Int
n AnsiDoc
"Double" AnsiDoc
"Integral")) Integer -> Result Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either Double Integer -> Result Integer)
-> (Scientific -> Either Double Integer)
-> Scientific
-> Result Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger :: Scientific -> Either Double Integer)
  {-# INLINEABLE unquote #-}

instance Unquote Collection where
  unquote :: Id -> Int -> Term -> Result Collection
unquote Id
k Int
n Term
q =
    Id -> Collection
text (Id -> Collection) -> Result Id -> Result Collection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Int -> Term -> Result Id
forall a. Unquote a => Id -> Int -> Term -> Result a
unquote Id
k Int
n Term
q
      Result Collection -> Result Collection -> Result Collection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object -> Collection
hashMap (Object -> Collection) -> Result Object -> Result Collection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Int -> Term -> Result Object
forall a. Unquote a => Id -> Int -> Term -> Result a
unquote Id
k Int
n Term
q
      Result Collection -> Result Collection -> Result Collection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Array -> Collection
vector (Array -> Collection) -> Result Array -> Result Collection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Int -> Term -> Result Array
forall a. Unquote a => Id -> Int -> Term -> Result a
unquote Id
k Int
n Term
q
    where
      text :: Id -> Collection
text Id
t =
        Int -> [(Maybe Id, Value)] -> Collection
forall (f :: * -> *).
Foldable f =>
Int -> f (Maybe Id, Value) -> Collection
Col (Id -> Int
Text.length Id
t)
          ([(Maybe Id, Value)] -> Collection)
-> (String -> [(Maybe Id, Value)]) -> String -> Collection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> (Maybe Id, Value)) -> String -> [(Maybe Id, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> (Maybe Id
forall a. Maybe a
Nothing, Id -> Value
String (Char -> Id
Text.singleton Char
c)))
          (String -> Collection) -> String -> Collection
forall a b. (a -> b) -> a -> b
$ Id -> String
Text.unpack Id
t

      hashMap :: Object -> Collection
hashMap Object
m =
        Int -> [(Maybe Id, Value)] -> Collection
forall (f :: * -> *).
Foldable f =>
Int -> f (Maybe Id, Value) -> Collection
Col (Object -> Int
forall k v. HashMap k v -> Int
HashMap.size Object
m)
          ([(Maybe Id, Value)] -> Collection)
-> ([(Id, Value)] -> [(Maybe Id, Value)])
-> [(Id, Value)]
-> Collection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Id, Value) -> (Maybe Id, Value))
-> [(Id, Value)] -> [(Maybe Id, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Id -> Maybe Id) -> (Id, Value) -> (Maybe Id, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first Id -> Maybe Id
forall a. a -> Maybe a
Just)
          ([(Id, Value)] -> [(Maybe Id, Value)])
-> ([(Id, Value)] -> [(Id, Value)])
-> [(Id, Value)]
-> [(Maybe Id, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Id, Value) -> (Id, Value) -> Ordering)
-> [(Id, Value)] -> [(Id, Value)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Id, Value) -> Id) -> (Id, Value) -> (Id, Value) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Id, Value) -> Id
forall a b. (a, b) -> a
fst)
          ([(Id, Value)] -> Collection) -> [(Id, Value)] -> Collection
forall a b. (a -> b) -> a -> b
$ Object -> [(Id, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList Object
m

      vector :: Array -> Collection
vector Array
v = Int -> Vector (Maybe Id, Value) -> Collection
forall (f :: * -> *).
Foldable f =>
Int -> f (Maybe Id, Value) -> Collection
Col (Array -> Int
forall a. Vector a -> Int
Vector.length Array
v) ((Value -> (Maybe Id, Value)) -> Array -> Vector (Maybe Id, Value)
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map (Maybe Id
forall a. Maybe a
Nothing,) Array
v)
  {-# INLINEABLE unquote #-}

class Quote a where
  quote :: Id -> Int -> a -> Term
  default quote :: ToJSON a => Id -> Int -> a -> Term
  quote Id
_ Int
_ = Value -> Term
TVal (Value -> Term) -> (a -> Value) -> a -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON
  {-# INLINEABLE quote #-}

instance (Unquote a, Quote b) => Quote (a -> b) where
  quote :: Id -> Int -> (a -> b) -> Term
quote Id
k Int
n a -> b
f = (Term -> Result Term) -> Term
TLam ((Term -> Result Term) -> Term) -> (Term -> Result Term) -> Term
forall a b. (a -> b) -> a -> b
$ \Term
x -> Id -> Int -> b -> Term
forall a. Quote a => Id -> Int -> a -> Term
quote Id
k Int
n' (b -> Term) -> (a -> b) -> a -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> Term) -> Result a -> Result Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Int -> Term -> Result a
forall a. Unquote a => Id -> Int -> Term -> Result a
unquote Id
k Int
n' Term
x
    where
      n' :: Int
n' = Int -> Int
forall a. Enum a => a -> a
succ Int
n
  {-# INLINEABLE quote #-}

instance Quote Term where
  quote :: Id -> Int -> Term -> Term
quote Id
_ Int
_ = Term -> Term
forall a. a -> a
id
  {-# INLINEABLE quote #-}

instance Quote 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 Object

instance Quote Array

instance Quote Builder where
  quote :: Id -> Int -> Builder -> Term
quote Id
k Int
n = Id -> Int -> Text -> Term
forall a. Quote a => Id -> Int -> a -> Term
quote Id
k Int
n (Text -> Term) -> (Builder -> Text) -> Builder -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Text.Builder.toLazyText
  {-# INLINEABLE quote #-}

typeErr :: Id -> Int -> AnsiDoc -> AnsiDoc -> Result a
typeErr :: Id -> Int -> AnsiDoc -> AnsiDoc -> Result a
typeErr Id
k Int
n AnsiDoc
x AnsiDoc
y = AnsiDoc -> Result a
forall a. AnsiDoc -> Result a
Failure (AnsiDoc -> Result a) -> AnsiDoc -> Result a
forall a b. (a -> b) -> a -> b
$ AnsiDoc
"type" AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Id -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Id
k AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> AnsiDoc
forall a ann. Pretty a => a -> Doc ann
pretty Int
n AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
x AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"::" AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
y

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

    arg :: AnsiDoc
arg =
      AnsiDoc
"invalid"
        AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc -> AnsiDoc
bold (Id -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp (Id -> AnsiDoc) -> Id -> AnsiDoc
forall a b. (a -> b) -> a -> b
$ Int -> Id
forall a. Integral a => a -> Id
toOrdinal (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
        AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc
"argument to"
        AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiDoc -> AnsiDoc
bold (Id -> AnsiDoc
forall a. AnsiPretty (PP a) => a -> AnsiDoc
pp Id
k)
        AnsiDoc -> AnsiDoc -> AnsiDoc
forall a. Semigroup a => a -> a -> a
<> AnsiDoc
":"
        AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
</> Int -> AnsiDoc -> AnsiDoc
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
4 (a -> AnsiDoc
forall a ann. Pretty a => a -> Doc ann
pretty a
e AnsiDoc -> AnsiDoc -> AnsiDoc
forall ann. Doc ann -> Doc ann -> Doc ann
</> Rendering -> AnsiDoc
Trifecta.Rendering.prettyRendering Rendering
mark)

    mark :: Rendering
mark =
      Delta -> ByteString -> Rendering
Trifecta.Rendering.renderingCaret (Int64 -> Int64 -> Delta
Trifecta.Delta.Columns Int64
col Int64
col) (ByteString -> Rendering) -> ByteString -> Rendering
forall a b. (a -> b) -> a -> b
$
        ByteString
"... | " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Id -> ByteString
Text.Encoding.encodeUtf8 Id
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
line

    col :: Int64
col
      | Bool
self = Int64
1
      | Bool
otherwise = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Id -> Int
Text.length Id
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2))

    line :: ByteString
line
      | Bool
self = ByteString
"\n"
      | Bool
otherwise =
        ByteString
"(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
ByteString.Char8.intercalate ByteString
", " (Int -> ByteString -> [ByteString]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ByteString
"...") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"

    self :: Bool
self = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1