-- |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
forall a. Eq a => ExonUse a -> ExonUse a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExonUse a -> ExonUse a -> Bool
$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
Eq, Int -> ExonUse a -> String -> String
forall a. Show a => Int -> ExonUse a -> String -> String
forall a. Show a => [ExonUse a] -> String -> String
forall a. Show a => ExonUse a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ExonUse a] -> String -> String
$cshowList :: forall a. Show a => [ExonUse a] -> String -> String
show :: ExonUse a -> String
$cshow :: forall a. Show a => ExonUse a -> String
showsPrec :: Int -> ExonUse a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> ExonUse a -> String -> String
Show)
  deriving newtype (String -> ExonUse a
forall a. IsString a => String -> ExonUse a
forall a. (String -> a) -> IsString a
fromString :: String -> ExonUse a
$cfromString :: forall a. IsString a => String -> ExonUse a
IsString)

exonUse :: ExonUse a -> a
exonUse :: forall a. ExonUse a -> a
exonUse = coerce :: 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 =
    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 =
    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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ExonUse a -> a
exonUse
  exonBuilderExtract :: Result builder -> ExonUse a
exonBuilderExtract =
    forall a. a -> ExonUse a
ExonUse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l s. LazyStrict l s => l -> s
toStrict 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 =
    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 =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall l s. LazyStrict l s => l -> s
toStrict 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 =
    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 =
    forall a. a -> Result a
Result forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (String -> String)
exonString =
    forall a. a -> Result a
Result forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
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 =
    forall a. a -> Result a
Result 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 =
    forall a. a -> Result a
Result (builder
z 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) =
    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 -> forall a. a -> a
id
        Result builder
z -> \case
          Result builder
Empty -> 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 :: (String -> String)
-> (String -> String) -> Result (String -> String)
exonAppend String -> String
z String -> String
a =
    forall a. a -> Result a
Result (String -> String
z forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
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 =
    forall inner builder.
ExonBuilder inner builder =>
Result builder -> inner
exonBuilderExtract forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall result builder.
ExonAppend result builder =>
NonEmpty (Result builder) -> Result builder
exonConcat @result forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall result. Exon result => NonEmpty (Segment result) -> result
exonProcess @wrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap result -> wrapped
unwrap)
{-# inline exonProcessWith #-}