-- |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 Text.Show (showString)

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 whitespace to be ignored.
--
-- @since 1.0.0.0
newtype SkipWs a =
  SkipWs a
  deriving stock (SkipWs a -> SkipWs a -> Bool
(SkipWs a -> SkipWs a -> Bool)
-> (SkipWs a -> SkipWs a -> Bool) -> Eq (SkipWs a)
forall a. Eq a => SkipWs a -> SkipWs a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SkipWs a -> SkipWs a -> Bool
$c/= :: forall a. Eq a => SkipWs a -> SkipWs a -> Bool
== :: SkipWs a -> SkipWs a -> Bool
$c== :: forall a. Eq a => SkipWs a -> SkipWs a -> Bool
Eq, Int -> SkipWs a -> String -> String
[SkipWs a] -> String -> String
SkipWs a -> String
(Int -> SkipWs a -> String -> String)
-> (SkipWs a -> String)
-> ([SkipWs a] -> String -> String)
-> Show (SkipWs a)
forall a. Show a => Int -> SkipWs a -> String -> String
forall a. Show a => [SkipWs a] -> String -> String
forall a. Show a => SkipWs a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SkipWs a] -> String -> String
$cshowList :: forall a. Show a => [SkipWs a] -> String -> String
show :: SkipWs a -> String
$cshow :: forall a. Show a => SkipWs a -> String
showsPrec :: Int -> SkipWs a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> SkipWs a -> String -> String
Show, (forall x. SkipWs a -> Rep (SkipWs a) x)
-> (forall x. Rep (SkipWs a) x -> SkipWs a) -> Generic (SkipWs a)
forall x. Rep (SkipWs a) x -> SkipWs a
forall x. SkipWs a -> Rep (SkipWs a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (SkipWs a) x -> SkipWs a
forall a x. SkipWs a -> Rep (SkipWs a) x
$cto :: forall a x. Rep (SkipWs a) x -> SkipWs a
$cfrom :: forall a x. SkipWs a -> Rep (SkipWs a) x
Generic)
  deriving newtype (String -> SkipWs a
(String -> SkipWs a) -> IsString (SkipWs a)
forall a. IsString a => String -> SkipWs a
forall a. (String -> a) -> IsString a
fromString :: String -> SkipWs a
$cfromString :: forall a. IsString a => String -> SkipWs a
IsString)

-- |Defined separately because TH chokes on the selector.
--
-- @since 1.0.0.0
skipWs :: SkipWs a -> a
skipWs :: forall a. SkipWs a -> a
skipWs (SkipWs a
a) =
  a
a

-- |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 { forall a. ExonUse a -> 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
/= :: 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
[ExonUse a] -> String -> String
ExonUse a -> String
(Int -> ExonUse a -> String -> String)
-> (ExonUse a -> String)
-> ([ExonUse a] -> String -> String)
-> Show (ExonUse a)
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
(String -> ExonUse a) -> IsString (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)

-- |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

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

instance {-# overlappable #-} (
    Monoid builder,
    result ~ builder
  ) => ExonBuilder result builder where
  exonBuilder :: result -> builder
exonBuilder =
    result -> builder
forall a. a -> a
id
  {-# inline exonBuilder #-}
  exonBuilderExtract :: Result builder -> result
exonBuilderExtract =
    Result builder -> result
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
  {-# inline exonBuilderExtract #-}

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 (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
  exonBuilderExtract :: Result Builder -> Text
exonBuilderExtract =
    (Builder -> Text) -> Result Builder -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Builder -> Text
toLazyText

instance ExonBuilder ByteString ByteString.Builder where
  exonBuilder :: ByteString -> Builder
exonBuilder =
    ByteString -> Builder
ByteString.byteString
  exonBuilderExtract :: Result Builder -> ByteString
exonBuilderExtract =
    (Builder -> ByteString) -> Result Builder -> ByteString
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)

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

-- |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 (String -> String)
exonString =
    (String -> String) -> Result (String -> String)
forall a. a -> Result a
Result ((String -> String) -> Result (String -> String))
-> (String -> String -> String)
-> String
-> Result (String -> String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString
  {-# inline exonString #-}

-- |The instance used when the result type is wrapped in 'SkipWs', which is done by 'Exon.intron'.
--
-- It returns 'Empty' for any whitespace.
instance (
    IsString builder
  ) => ExonString (SkipWs result) builder where
  exonWhitespace :: String -> Result builder
exonWhitespace String
_ =
    Result builder
forall a. Result a
Empty
  {-# inline exonWhitespace #-}

-- |This class converts a 'Segment' to a builder.
--
-- The default implementation performs the following conversions for the differnet 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.
--
-- - [Segment.Expression]('Segment.Expression') contains a value of the builder type, which is returned as-is.
--
-- @since 1.0.0.0
class ExonSegment (result :: Type) (builder :: Type) where
  -- |Convert literal string segments to the result type.
  exonSegment :: Segment builder -> Result builder

instance {-# overlappable #-} (
    ExonString result builder
  ) => ExonSegment result builder where
    exonSegment :: Segment builder -> Result builder
exonSegment = \case
      Segment.String String
a ->
        forall result builder.
ExonString result builder =>
String -> Result builder
exonString @result String
a
      Segment.Expression builder
a ->
        builder -> Result builder
forall a. a -> Result a
Result builder
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

instance {-# overlappable #-} (
    Semigroup builder
  ) => ExonAppend result builder where
  exonAppend :: 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 #-}

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

-- |Wrapper for 'exonAppend' that handles the 'Empty' case.
--
-- @since 1.0.0.0
exonAppendResult ::
  ∀ result builder .
  ExonAppend result builder =>
  Result builder ->
  Result builder ->
  Result builder
exonAppendResult :: forall result builder.
ExonAppend result builder =>
Result builder -> Result builder -> Result builder
exonAppendResult (Result builder
z) (Result builder
a) =
  forall result builder.
ExonAppend result builder =>
builder -> builder -> Result builder
exonAppend @result builder
z builder
a
exonAppendResult Result builder
z Result builder
Empty =
  Result builder
z
exonAppendResult Result builder
Empty Result builder
a =
  Result builder
a
{-# inline exonAppendResult #-}

-- |This class implements the 'Segment' concatenation logic.
--
-- 1. Each 'Segment.Expression' is converted to the builder type by 'ExonBuilder'.
-- 2. Each 'Segment.String' and 'Segment.Whitespace' is converted to the builder type by 'ExonSegment' and 'ExonString'.
-- 3. The segments are folded over 'ExonAppend'.
-- 4. The result is converted from the builder type to the original type by 'ExonBuilder'.
--
-- Each step may be overridden individually
--
-- @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 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
.
    (Result builder -> Result builder -> Result builder)
-> NonEmpty (Result builder) -> Result builder
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (forall result builder.
ExonAppend result builder =>
Result builder -> Result builder -> Result builder
exonAppendResult @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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall result builder.
ExonSegment result builder =>
Segment builder -> Result builder
exonSegment @result (Segment builder -> Result builder)
-> (Segment inner -> Segment builder)
-> Segment inner
-> Result builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (inner -> builder) -> Segment inner -> Segment builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((result -> wrapped) -> Segment result -> Segment wrapped
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap result -> wrapped
unwrap)
{-# inline exonProcessWith #-}