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

import Text.Show (showString)

import Exon.Data.Result (Result (Empty, Result))
import qualified Exon.Data.Segment as Segment
import Exon.Data.Segment (Segment)

-- |The tag for the default quoter 'Exon.exon'.
data ExonDefault

-- |The tag for the quoter 'Exon.exonws', keeping whitespace verbatim.
data KeepWhitespace

{- |
This class is responsible for combining segments of an interpolated string, allowing users to define their own rules
for how the result is constructed.
The default implementation converts each literal part with 'IsString' and uses the result type's 'Monoid' to
concatenate them.

The raw parts are encoded as 'Segment', getting combined into a 'Result'.

The default for 'convertSegment' skips whitespace by encoding it into the 'Result' constructor 'Empty', which is a
unit object.
To change this behavior, it can be easily overridden:

@
newtype Thing = Thing String deriving newtype (IsString, Semigroup, Monoid, Show)

instance Exon ExonDefault Thing where
  convertSegment = \case
    Segment.String s -> Result (Thing s)
    Segment.Expression thing -> Result thing
    Segment.Whitespace _ -> Result (Thing " >>> ")

  insertWhitespace s1 ws s2 =
    appendSegment @ExonDefault (appendSegment @ExonDefault s1 (Segment.Whitespace ws)) s2
@
-}
class Exon (tag :: Type) (a :: Type) where

  -- |This check is used to allow empty expression segments to be skipped when they are empty.
  -- The default is to never skip expressions.
  isEmpty :: a -> Bool
  isEmpty =
    Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False

  -- |Convert a 'Segment' to a 'Result'.
  -- The default implementation uses 'IsString' and ignores whitespace, returning 'Empty'.
  convertSegment :: Segment a -> Result a

  default convertSegment :: IsString a => Segment a -> Result a
  convertSegment = \case
    Segment.String String
a ->
      a -> Result a
forall a. a -> Result a
Result (String -> a
forall a. IsString a => String -> a
fromString String
a)
    Segment.Expression a
a | a -> Bool
forall tag a. Exon tag a => a -> Bool
isEmpty @tag a
a ->
      Result a
forall a. Result a
Empty
    Segment.Expression a
a ->
      a -> Result a
forall a. a -> Result a
Result a
a
    Segment.Whitespace String
_ ->
      Result a
forall a. Result a
Empty

  -- |Append a 'Segment' to a 'Result'.
  -- The default implementation uses '(<>)'.
  appendSegment :: Result a -> Segment a -> Result a

  default appendSegment :: Semigroup a => Result a -> Segment a -> Result a
  appendSegment Result a
z Segment a
a =
    Result a
z Result a -> Result a -> Result a
forall a. Semigroup a => a -> a -> a
<> Segment a -> Result a
forall tag a. Exon tag a => Segment a -> Result a
convertSegment @tag Segment a
a

  -- |Append whitespace and a 'Segment' to a 'Result', i.e. joining two parts of the interpolation by whitespace.
  -- The default implementation ignores the whitespace, calling 'appendSegment' with the second argument.
  insertWhitespace :: Result a -> String -> Segment a -> Result a

  default insertWhitespace :: Result a -> String -> Segment a -> Result a
  insertWhitespace Result a
s1 String
_ Segment a
s2 =
    Result a -> Segment a -> Result a
forall tag a. Exon tag a => Result a -> Segment a -> Result a
appendSegment @tag Result a
s1 Segment a
s2

  -- |The entry point for concatenation, taking a list of segments parsed from the interpolation.
  -- The default implementation skips leading whitespace and calls 'appendSegment' and 'insertWhitespace' to
  -- concatenate.
  concatSegments :: NonEmpty (Segment a) -> a

  default concatSegments :: Monoid a => NonEmpty (Segment a) -> a
  concatSegments (Segment a
h :| [Segment a]
t) =
    Result a -> a
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Result a -> [Segment a] -> Result a
spin (Segment a -> Result a
forall tag a. Exon tag a => Segment a -> Result a
convertSegment @tag Segment a
h) [Segment a]
t)
    where
      spin :: Result a -> [Segment a] -> Result a
      spin :: Result a -> [Segment a] -> Result a
spin Result a
Empty = \case
        [] ->
          Result a
forall a. Result a
Empty
        Segment.Whitespace String
_ : [Segment a]
ss ->
          Result a -> [Segment a] -> Result a
spin Result a
forall a. Result a
Empty [Segment a]
ss
        Segment a
s1 : [Segment a]
ss ->
          Result a -> [Segment a] -> Result a
spin (Segment a -> Result a
forall tag a. Exon tag a => Segment a -> Result a
convertSegment @tag Segment a
s1) [Segment a]
ss
      spin (Result a
s1) = \case
        [] ->
          a -> Result a
forall a. a -> Result a
Result a
s1
        Segment.Whitespace String
_ : (Segment.Expression a
a) : [Segment a]
ss | a -> Bool
forall tag a. Exon tag a => a -> Bool
isEmpty @tag a
a ->
          Result a -> [Segment a] -> Result a
spin (a -> Result a
forall a. a -> Result a
Result a
s1) [Segment a]
ss
        Segment.Whitespace String
ws : Segment a
s2 : [Segment a]
ss ->
          Result a -> [Segment a] -> Result a
spin (Result a -> String -> Segment a -> Result a
forall tag a.
Exon tag a =>
Result a -> String -> Segment a -> Result a
insertWhitespace @tag (a -> Result a
forall a. a -> Result a
Result a
s1) String
ws Segment a
s2) [Segment a]
ss
        [Segment.Whitespace _] ->
          (a -> Result a
forall a. a -> Result a
Result a
s1)
        Segment a
s2 : [Segment a]
ss ->
          Result a -> [Segment a] -> Result a
spin (Result a -> Segment a -> Result a
forall tag a. Exon tag a => Result a -> Segment a -> Result a
appendSegment @tag (a -> Result a
forall a. a -> Result a
Result a
s1) Segment a
s2) [Segment a]
ss

instance {-# overlappable #-} (
    Monoid a,
    IsString a
  ) => Exon ExonDefault a where

-- |Variant of 'convertSegment' that preserves whitespace verbatim.
convertKeepWs ::
  IsString a =>
  Segment a ->
  Result a
convertKeepWs :: Segment a -> Result a
convertKeepWs = \case
  Segment.String String
a ->
    a -> Result a
forall a. a -> Result a
Result (String -> a
forall a. IsString a => String -> a
fromString String
a)
  Segment.Expression a
a ->
    a -> Result a
forall a. a -> Result a
Result a
a
  Segment.Whitespace String
a ->
    a -> Result a
forall a. a -> Result a
Result (String -> a
forall a. IsString a => String -> a
fromString String
a)

-- |Variant of 'concatSegments' that preserves whitespace verbatim.
concatKeepWs ::
  ∀ tag a .
  Monoid a =>
  Exon tag a =>
  NonEmpty (Segment a) ->
  a
concatKeepWs :: NonEmpty (Segment a) -> a
concatKeepWs =
  Result a -> a
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Result a -> a)
-> (NonEmpty (Segment a) -> Result a) -> NonEmpty (Segment a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result a -> Segment a -> Result a)
-> Result a -> NonEmpty (Segment a) -> Result a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a. Exon tag a => Result a -> Segment a -> Result a
forall tag a. Exon tag a => Result a -> Segment a -> Result a
appendSegment @tag) Result a
forall a. Result a
Empty

instance (
    Monoid a,
    IsString a
  ) => Exon KeepWhitespace a where
  convertSegment :: Segment a -> Result a
convertSegment =
    Segment a -> Result a
forall a. IsString a => Segment a -> Result a
convertKeepWs

  concatSegments :: NonEmpty (Segment a) -> a
concatSegments =
    forall a.
(Monoid a, Exon KeepWhitespace a) =>
NonEmpty (Segment a) -> a
forall tag a. (Monoid a, Exon tag a) => NonEmpty (Segment a) -> a
concatKeepWs @KeepWhitespace

instance Exon ExonDefault String where
  convertSegment :: Segment String -> Result String
convertSegment =
    Segment String -> Result String
forall a. IsString a => Segment a -> Result a
convertKeepWs

  concatSegments :: NonEmpty (Segment String) -> String
concatSegments =
    forall a.
(Monoid a, Exon ExonDefault a) =>
NonEmpty (Segment a) -> a
forall tag a. (Monoid a, Exon tag a) => NonEmpty (Segment a) -> a
concatKeepWs @ExonDefault

instance Exon ExonDefault Text where
  convertSegment :: Segment Text -> Result Text
convertSegment =
    forall a. Exon KeepWhitespace a => Segment a -> Result a
forall tag a. Exon tag a => Segment a -> Result a
convertSegment @KeepWhitespace

  concatSegments :: NonEmpty (Segment Text) -> Text
concatSegments =
    forall a. Exon KeepWhitespace a => NonEmpty (Segment a) -> a
forall tag a. Exon tag a => NonEmpty (Segment a) -> a
concatSegments @KeepWhitespace

instance Exon ExonDefault LText where
  convertSegment :: Segment LText -> Result LText
convertSegment =
    forall a. Exon KeepWhitespace a => Segment a -> Result a
forall tag a. Exon tag a => Segment a -> Result a
convertSegment @KeepWhitespace

  concatSegments :: NonEmpty (Segment LText) -> LText
concatSegments =
    forall a. Exon KeepWhitespace a => NonEmpty (Segment a) -> a
forall tag a. Exon tag a => NonEmpty (Segment a) -> a
concatSegments @KeepWhitespace

instance Exon ExonDefault ByteString where
  convertSegment :: Segment ByteString -> Result ByteString
convertSegment =
    forall a. Exon KeepWhitespace a => Segment a -> Result a
forall tag a. Exon tag a => Segment a -> Result a
convertSegment @KeepWhitespace

  concatSegments :: NonEmpty (Segment ByteString) -> ByteString
concatSegments =
    forall a. Exon KeepWhitespace a => NonEmpty (Segment a) -> a
forall tag a. Exon tag a => NonEmpty (Segment a) -> a
concatSegments @KeepWhitespace

instance Exon ExonDefault LByteString where
  convertSegment :: Segment LByteString -> Result LByteString
convertSegment =
    forall a. Exon KeepWhitespace a => Segment a -> Result a
forall tag a. Exon tag a => Segment a -> Result a
convertSegment @KeepWhitespace

  concatSegments :: NonEmpty (Segment LByteString) -> LByteString
concatSegments =
    forall a. Exon KeepWhitespace a => NonEmpty (Segment a) -> a
forall tag a. Exon tag a => NonEmpty (Segment a) -> a
concatSegments @KeepWhitespace

instance Exon ExonDefault (String -> String) where
  convertSegment :: Segment (String -> String) -> Result (String -> String)
convertSegment = \case
    Segment.String String
a ->
      (String -> String) -> Result (String -> String)
forall a. a -> Result a
Result (String -> String -> String
showString String
a)
    Segment.Expression String -> String
a | (String -> String) -> Bool
forall tag a. Exon tag a => a -> Bool
isEmpty @ExonDefault String -> String
a ->
      Result (String -> String)
forall a. Result a
Empty
    Segment.Expression String -> String
a ->
      (String -> String) -> Result (String -> String)
forall a. a -> Result a
Result String -> String
a
    Segment.Whitespace String
ws ->
      (String -> String) -> Result (String -> String)
forall a. a -> Result a
Result (String -> String -> String
showString String
ws)

  appendSegment :: Result (String -> String)
-> Segment (String -> String) -> Result (String -> String)
appendSegment Result (String -> String)
z Segment (String -> String)
a =
    case (Result (String -> String)
z, Segment (String -> String) -> Result (String -> String)
forall tag a. Exon tag a => Segment a -> Result a
convertSegment @ExonDefault Segment (String -> String)
a) of
      (Result String -> String
z', Result 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')
      (Result (String -> String)
z', Result (String -> String)
Empty) ->
        Result (String -> String)
z'
      (Result (String -> String)
Empty, Result (String -> String)
a') ->
        Result (String -> String)
a'

  concatSegments :: NonEmpty (Segment (String -> String)) -> String -> String
concatSegments =
    forall a.
(Monoid a, Exon ExonDefault a) =>
NonEmpty (Segment a) -> a
forall tag a. (Monoid a, Exon tag a) => NonEmpty (Segment a) -> a
concatKeepWs @ExonDefault