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

data ExonDefault

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

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)

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 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 =
    Segment Text -> Result Text
forall a. IsString a => Segment a -> Result a
convertKeepWs

  concatSegments :: NonEmpty (Segment Text) -> Text
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 LText where
  convertSegment :: Segment LText -> Result LText
convertSegment =
    Segment LText -> Result LText
forall a. IsString a => Segment a -> Result a
convertKeepWs

  concatSegments :: NonEmpty (Segment LText) -> LText
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 ByteString where
  convertSegment :: Segment ByteString -> Result ByteString
convertSegment =
    Segment ByteString -> Result ByteString
forall a. IsString a => Segment a -> Result a
convertKeepWs

  concatSegments :: NonEmpty (Segment ByteString) -> ByteString
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 LByteString where
  convertSegment :: Segment LByteString -> Result LByteString
convertSegment =
    Segment LByteString -> Result LByteString
forall a. IsString a => Segment a -> Result a
convertKeepWs

  concatSegments :: NonEmpty (Segment LByteString) -> LByteString
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 (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