-- | Description: Internal
module Exon.Class.Exon where

import qualified Data.ByteString.Builder as ByteString
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.Text.Lazy.Builder as Text
import Data.Text.Lazy.Builder (toLazyText)

import Exon.Class.Newtype (OverNewtypes, overNewtypes)
import Exon.Data.Result (Result (Empty, Result))
import qualified Exon.Data.Segment as Segment
import Exon.Data.Segment (Segment)

-- | Wrapping a quote type with this causes @a@ to be used irrespective of whether it is an unwrappable newtype.
--
-- @since 1.0.0.0
newtype ExonUse a =
  ExonUse a
  deriving stock (ExonUse a -> ExonUse a -> Bool
(ExonUse a -> ExonUse a -> Bool)
-> (ExonUse a -> ExonUse a -> Bool) -> Eq (ExonUse a)
forall a. Eq a => ExonUse a -> ExonUse a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => ExonUse a -> ExonUse a -> Bool
== :: ExonUse a -> ExonUse a -> Bool
$c/= :: forall a. Eq a => ExonUse a -> ExonUse a -> Bool
/= :: ExonUse a -> ExonUse a -> Bool
Eq, Int -> ExonUse a -> ShowS
[ExonUse a] -> ShowS
ExonUse a -> String
(Int -> ExonUse a -> ShowS)
-> (ExonUse a -> String)
-> ([ExonUse a] -> ShowS)
-> Show (ExonUse a)
forall a. Show a => Int -> ExonUse a -> ShowS
forall a. Show a => [ExonUse a] -> ShowS
forall a. Show a => ExonUse a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ExonUse a -> ShowS
showsPrec :: Int -> ExonUse a -> ShowS
$cshow :: forall a. Show a => ExonUse a -> String
show :: ExonUse a -> String
$cshowList :: forall a. Show a => [ExonUse a] -> ShowS
showList :: [ExonUse a] -> ShowS
Show)
  deriving newtype (String -> ExonUse a
(String -> ExonUse a) -> IsString (ExonUse a)
forall a. IsString a => String -> ExonUse a
forall a. (String -> a) -> IsString a
$cfromString :: forall a. IsString a => String -> ExonUse a
fromString :: String -> ExonUse a
IsString)

exonUse :: ExonUse a -> a
exonUse :: forall a. ExonUse a -> a
exonUse = ExonUse a -> a
forall a b. Coercible a b => a -> b
coerce

-- | This class converts a segment into a builder.
--
-- A builder is an auxiliary data type that may improve performance when concatenating segments, like 'Text.Builder'.
-- The default instance uses no builder and is implemented as 'id'.
--
-- @since 1.0.0.0
class ExonBuilder (inner :: Type) (builder :: Type) | inner -> builder where
  -- | Construct a builder from the newtype-unwrapped result type.
  exonBuilder :: inner -> builder

  default exonBuilder :: inner ~ builder => inner -> builder
  exonBuilder =
    inner -> inner
inner -> builder
forall a. a -> a
id
  {-# inline exonBuilder #-}

  -- | Convert the result of the builder concatenation back to the newtype-unwrapped result type.
  exonBuilderExtract :: Result builder -> inner

  default exonBuilderExtract ::
    Monoid builder =>
    inner ~ builder =>
    Result builder ->
    inner
  exonBuilderExtract =
    Result builder -> inner
Result builder -> builder
forall m. Monoid m => Result m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
  {-# inline exonBuilderExtract #-}

instance {-# overlappable #-} (
    Monoid builder,
    inner ~ builder
  ) => ExonBuilder inner builder where

instance (
    ExonBuilder a builder
  ) => ExonBuilder (ExonUse a) builder where
  exonBuilder :: ExonUse a -> builder
exonBuilder =
    forall inner builder. ExonBuilder inner builder => inner -> builder
exonBuilder @a (a -> builder) -> (ExonUse a -> a) -> ExonUse a -> builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExonUse a -> a
forall a. ExonUse a -> a
exonUse
  exonBuilderExtract :: Result builder -> ExonUse a
exonBuilderExtract =
    a -> ExonUse a
forall a. a -> ExonUse a
ExonUse (a -> ExonUse a)
-> (Result builder -> a) -> Result builder -> ExonUse a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result builder -> a
forall inner builder.
ExonBuilder inner builder =>
Result builder -> inner
exonBuilderExtract

instance ExonBuilder Text Text.Builder where
  exonBuilder :: Text -> Builder
exonBuilder =
    Text -> Builder
Text.fromText
  {-# inline exonBuilder #-}
  exonBuilderExtract :: Result Builder -> Text
exonBuilderExtract =
    (Builder -> Text) -> Result Builder -> Text
forall m a. Monoid m => (a -> m) -> Result a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text -> Text
forall l s. LazyStrict l s => l -> s
toStrict (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText)
  {-# inline exonBuilderExtract #-}

instance ExonBuilder LText Text.Builder where
  exonBuilder :: Text -> Builder
exonBuilder =
    Text -> Builder
Text.fromLazyText
  {-# inline exonBuilder #-}
  exonBuilderExtract :: Result Builder -> Text
exonBuilderExtract =
    (Builder -> Text) -> Result Builder -> Text
forall m a. Monoid m => (a -> m) -> Result a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Builder -> Text
toLazyText
  {-# inline exonBuilderExtract #-}

instance ExonBuilder ByteString ByteString.Builder where
  exonBuilder :: ByteString -> Builder
exonBuilder =
    ByteString -> Builder
ByteString.byteString
  {-# inline exonBuilder #-}
  exonBuilderExtract :: Result Builder -> ByteString
exonBuilderExtract =
    (Builder -> ByteString) -> Result Builder -> ByteString
forall m a. Monoid m => (a -> m) -> Result a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString)
  {-# inline exonBuilderExtract #-}

instance ExonBuilder LByteString ByteString.Builder where
  exonBuilder :: ByteString -> Builder
exonBuilder =
    ByteString -> Builder
ByteString.lazyByteString
  {-# inline exonBuilder #-}
  exonBuilderExtract :: Result Builder -> ByteString
exonBuilderExtract =
    (Builder -> ByteString) -> Result Builder -> ByteString
forall m a. Monoid m => (a -> m) -> Result a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Builder -> ByteString
toLazyByteString
  {-# inline exonBuilderExtract #-}

-- | This class generalizes 'IsString' for use in 'ExonSegment'.
--
-- When a plain text segment (not interpolated) is processed, it is converted to the result type, which usually happens
-- via 'fromString'.
--
-- For the type of 'Text.Show.showsPrec' (@'String' -> 'String'@), there is no instance of 'IsString', so this class
-- provides an instance that works around that by calling 'showString'.
--
-- @since 1.0.0.0
class ExonString (result :: Type) (builder :: Type) where
  -- | Convert a 'String' to the builder type.
  exonString :: String -> Result builder

  default exonString :: IsString builder => String -> Result builder
  exonString =
    builder -> Result builder
forall a. a -> Result a
Result (builder -> Result builder)
-> (String -> builder) -> String -> Result builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> builder
forall a. IsString a => String -> a
fromString
  {-# inline exonString #-}

  -- | Convert a 'String' containing whitespace to the builder type.
  -- This is only used by whitespace-aware quoters, like 'Exon.exonws' or 'Exon.intron'.
  exonWhitespace :: String -> Result builder

  default exonWhitespace :: String -> Result builder
  exonWhitespace =
    forall result builder.
ExonString result builder =>
String -> Result builder
exonString @result @builder
  {-# inline exonWhitespace #-}

instance {-# overlappable #-} IsString a => ExonString result a where

-- | The instance for the type used by 'Text.Show.showsPrec'.
instance ExonString result (String -> String) where
  exonString :: String -> Result ShowS
exonString =
    ShowS -> Result ShowS
forall a. a -> Result a
Result (ShowS -> Result ShowS)
-> (String -> ShowS) -> String -> Result ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString
  {-# inline exonString #-}

-- | This class allows manipulation of interpolated expressions before they are processed, for example to replace empty
-- strings with 'Empty' for the purpose of collapsing multiple whitespaces.
--
-- The default instance does nothing.
class ExonExpression (result :: Type) (inner :: Type) (builder :: Type) where
  -- | Process a builder value constructed from an expression before concatenation.
  exonExpression :: (inner -> builder) -> inner -> Result builder
  exonExpression inner -> builder
builder =
    builder -> Result builder
forall a. a -> Result a
Result (builder -> Result builder)
-> (inner -> builder) -> inner -> Result builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. inner -> builder
builder
  {-# inline exonExpression #-}

instance {-# overlappable #-} ExonExpression result inner builder where

-- | This class converts a 'Segment' to a builder.
--
-- The default implementation performs the following conversions for the different segment variants:
--
-- - [Segment.String]('Segment.String') and [Segment.Whitespace]('Segment.Whitespace') are plain 'String's parsed
-- literally from the quasiquote.
-- They are converted to the builder type by 'fromString' (handled by 'ExonString').
--
-- - [Segment.Whitespace]('Segment.Whitespace') is ignored when the quoter 'Exon.intron' was used (default behaviour of
-- 'ExonString').
--
-- - [Segment.Expression]('Segment.Expression') contains a value of the unwrapped type and is converted to a builder
-- using the function in the first argument, which is usually 'exonBuilder', supplied by 'exonBuild'.
--
-- @since 1.0.0.0
class ExonSegment (result :: Type) (inner :: Type) (builder :: Type) where
  -- | Convert literal string segments to the result type.
  exonSegment :: (inner -> builder) -> Segment inner -> Result builder

instance {-# overlappable #-} (
    ExonString result builder,
    ExonExpression result inner builder
  ) => ExonSegment result inner builder where
    exonSegment :: (inner -> builder) -> Segment inner -> Result builder
exonSegment inner -> builder
builder = \case
      Segment.String String
a ->
        forall result builder.
ExonString result builder =>
String -> Result builder
exonString @result String
a
      Segment.Expression inner
a ->
        forall result inner builder.
ExonExpression result inner builder =>
(inner -> builder) -> inner -> Result builder
exonExpression @result inner -> builder
builder inner
a
      Segment.Whitespace String
a ->
        forall result builder.
ExonString result builder =>
String -> Result builder
exonWhitespace @result String
a
    {-# inline exonSegment #-}

-- | This class handles concatenation of segments, which might be a builder or the result type.
--
-- The default instance simply uses '(<>)', and there is only one special instance for @'String' -> 'String'@, the type
-- used by 'Text.Show.showsPrec'.
--
-- @since 1.0.0.0
class ExonAppend (result :: Type) (builder :: Type) where
  -- | Concatenate two segments of the builder type.
  exonAppend :: builder -> builder -> Result builder

  default exonAppend :: Semigroup builder => builder -> builder -> Result builder
  exonAppend builder
z builder
a =
    builder -> Result builder
forall a. a -> Result a
Result (builder
z builder -> builder -> builder
forall a. Semigroup a => a -> a -> a
<> builder
a)
  {-# inline exonAppend #-}

  -- | Concatenate a list of segments of the result type.
  --
  -- Folds the list over 'exonAppend', skipping over 'Empty' segments.
  --
  -- A possible overload may implement lookahead to skip whitespace.
  --
  -- @since 1.1.0.0
  exonConcat :: NonEmpty (Result builder) -> Result builder
  exonConcat (Result builder
h :| [Result builder]
t) =
    (Result builder -> Result builder -> Result builder)
-> Result builder -> [Result builder] -> Result builder
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Result builder -> Result builder -> Result builder
folder Result builder
h [Result builder]
t
    where
      folder :: Result builder -> Result builder -> Result builder
folder = \case
        Result builder
Empty -> Result builder -> Result builder
forall a. a -> a
id
        Result builder
z -> \case
          Result builder
Empty -> builder -> Result builder
forall a. a -> Result a
Result builder
z
          Result builder
a -> forall result builder.
ExonAppend result builder =>
builder -> builder -> Result builder
exonAppend @result @builder builder
z builder
a
  {-# inline exonConcat #-}

instance {-# overlappable #-} (
    Semigroup builder
  ) => ExonAppend result builder where

instance ExonAppend result (String -> String) where
  exonAppend :: ShowS -> ShowS -> Result ShowS
exonAppend ShowS
z ShowS
a =
    ShowS -> Result ShowS
forall a. a -> Result a
Result (ShowS
z ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
a)
  {-# inline exonAppend #-}

-- | This class implements the 'Segment' concatenation logic.
--
-- 1. Each 'Segment' is converted to the builder type by 'ExonSegment' using 'exonBuilder' to construct the builder from
--    expressions.
-- 2. The segments are folded over 'ExonAppend'.
-- 3. The result is converted from the builder type to the original type by 'ExonBuilder'.
--
-- Each step may be overridden individually by writing overlapping instances for the involved classes.
--
-- @since 1.0.0.0
class ExonBuild (result :: Type) (inner :: Type) where
  -- | Concatenate a list of 'Segment's.
  exonBuild :: NonEmpty (Segment inner) -> inner

instance {-# overlappable #-} (
    ExonAppend result builder,
    ExonSegment result inner builder,
    ExonBuilder inner builder
  ) => ExonBuild result inner where
  exonBuild :: NonEmpty (Segment inner) -> inner
exonBuild =
    Result builder -> inner
forall inner builder.
ExonBuilder inner builder =>
Result builder -> inner
exonBuilderExtract (Result builder -> inner)
-> (NonEmpty (Segment inner) -> Result builder)
-> NonEmpty (Segment inner)
-> inner
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall result builder.
ExonAppend result builder =>
NonEmpty (Result builder) -> Result builder
exonConcat @result (NonEmpty (Result builder) -> Result builder)
-> (NonEmpty (Segment inner) -> NonEmpty (Result builder))
-> NonEmpty (Segment inner)
-> Result builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Segment inner -> Result builder)
-> NonEmpty (Segment inner) -> NonEmpty (Result builder)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall result inner builder.
ExonSegment result inner builder =>
(inner -> builder) -> Segment inner -> Result builder
exonSegment @result inner -> builder
forall inner builder. ExonBuilder inner builder => inner -> builder
exonBuilder)
  {-# inline exonBuild #-}

-- | This class is the main entry point for Exon.
--
-- The default instance unwraps all newtypes that are 'Generic' and passes the innermost type to 'ExonBuild'.
--
-- The original type is also used as a parameter to 'ExonBuild', so customizations can be based on it.
class Exon (result :: Type) where
  -- | Concatenate a list of 'Segment's.
  --
  -- @since 1.0.0.0
  exonProcess :: NonEmpty (Segment result) -> result

instance {-# overlappable #-} (
    OverNewtypes result inner,
    ExonBuild result inner
  ) => Exon result where
    exonProcess :: NonEmpty (Segment result) -> result
exonProcess =
      forall result inner.
OverNewtypes result inner =>
(NonEmpty (Segment inner) -> inner)
-> NonEmpty (Segment result) -> result
overNewtypes @result (forall result inner.
ExonBuild result inner =>
NonEmpty (Segment inner) -> inner
exonBuild @result)
    {-# inline exonProcess #-}

-- | Call 'exonProcess', but unwrap the arguments and rewrap the result using the supplied functions.
--
-- @since 1.0.0.0
exonProcessWith ::
  ∀ wrapped result .
  Exon wrapped =>
  (result -> wrapped) ->
  (wrapped -> result) ->
  NonEmpty (Segment result) ->
  result
exonProcessWith :: forall wrapped result.
Exon wrapped =>
(result -> wrapped)
-> (wrapped -> result) -> NonEmpty (Segment result) -> result
exonProcessWith result -> wrapped
unwrap wrapped -> result
wrap =
  wrapped -> result
wrap (wrapped -> result)
-> (NonEmpty (Segment result) -> wrapped)
-> NonEmpty (Segment result)
-> result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall result. Exon result => NonEmpty (Segment result) -> result
exonProcess @wrapped (NonEmpty (Segment wrapped) -> wrapped)
-> (NonEmpty (Segment result) -> NonEmpty (Segment wrapped))
-> NonEmpty (Segment result)
-> wrapped
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Segment result -> Segment wrapped)
-> NonEmpty (Segment result) -> NonEmpty (Segment wrapped)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((result -> wrapped) -> Segment result -> Segment wrapped
forall a b. (a -> b) -> Segment a -> Segment b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap result -> wrapped
unwrap)
{-# inline exonProcessWith #-}