{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}

-- Module      : Data.Text.Manipulate.Internal.Fusion
-- Copyright   : (c) 2014-2020 Brendan Hay <brendan.g.hay@gmail.com>
-- License     : This Source Code Form is subject to the terms of
--               the Mozilla Public License, v. 2.0.
--               A copy of the MPL can be found in the LICENSE file or
--               you can obtain it at http://mozilla.org/MPL/2.0/.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)

module Data.Text.Manipulate.Internal.Fusion where

import qualified Data.Char as Char
import Data.Text (Text)
import qualified Data.Text.Internal.Fusion as Fusion
import Data.Text.Internal.Fusion.CaseMapping (lowerMapping, upperMapping)
import Data.Text.Internal.Fusion.Common
import Data.Text.Internal.Fusion.Types
import qualified Data.Text.Internal.Lazy.Fusion as LFusion
import qualified Data.Text.Lazy as LText
import Data.Text.Manipulate.Internal.Types

takeWord :: Stream Char -> Stream Char
takeWord = transform (const Done) yield . tokenise
{-# INLINE [0] takeWord #-}

dropWord :: Stream Char -> Stream Char
dropWord (tokenise -> Stream next0 s0 len) = Stream next (True :*: s0) len
  where
    next (skip :*: s) =
      case next0 s of
        Done -> Done
        Skip s' -> Skip (skip :*: s')
        Yield t s' ->
          case t of
            B '\0' -> Skip (False :*: s')
            B _ | skip -> Skip (False :*: s')
            B c -> Yield c (False :*: s')
            _ | skip -> Skip (skip :*: s')
            U c -> Yield c (skip :*: s')
            L c -> Yield c (skip :*: s')
{-# INLINE [0] dropWord #-}

toTitle :: Stream Char -> Stream Char
toTitle = mapHead toUpper . transformWith (yield ' ') upper lower . tokenise
{-# INLINE [0] toTitle #-}

toCamel :: Stream Char -> Stream Char
toCamel = mapHead toLower . transformWith skip' upper lower . tokenise
{-# INLINE [0] toCamel #-}

toPascal :: Stream Char -> Stream Char
toPascal = mapHead toUpper . transformWith skip' upper lower . tokenise
{-# INLINE [0] toPascal #-}

toSnake :: Stream Char -> Stream Char
toSnake = transform (yield '_') lower . tokenise
{-# INLINE [0] toSnake #-}

toSpinal :: Stream Char -> Stream Char
toSpinal = transform (yield '-') lower . tokenise
{-# INLINE [0] toSpinal #-}

toTrain :: Stream Char -> Stream Char
toTrain = mapHead toUpper . transformWith (yield '-') upper lower . tokenise
{-# INLINE [0] toTrain #-}

strict :: (Stream Char -> Stream Char) -> Text -> Text
strict f t = Fusion.unstream (f (Fusion.stream t))
{-# INLINE [0] strict #-}

lazy :: (Stream Char -> Stream Char) -> LText.Text -> LText.Text
lazy f t = LFusion.unstream (f (LFusion.stream t))
{-# INLINE [0] lazy #-}

skip' :: forall s. s -> Step (CC s) Char
skip' s = Skip (CC s '\0' '\0')

yield, upper, lower :: forall s. Char -> s -> Step (CC s) Char
yield !c s = Yield c (CC s '\0' '\0')
upper !c s = upperMapping c s
lower !c s = lowerMapping c s

-- | Step across word boundaries using a custom action, and transform
-- both subsequent uppercase and lowercase characters uniformly.
--
-- /See:/ 'transformWith'
transform ::
  -- | Boundary action.
  (forall s. s -> Step (CC s) Char) ->
  -- | Character mapping.
  (forall s. Char -> s -> Step (CC s) Char) ->
  -- | Input stream.
  Stream Token ->
  Stream Char
transform s m = transformWith s m m
{-# INLINE [0] transform #-}

-- | Step across word boundaries using a custom action, and transform
-- subsequent characters after the word boundary is encountered with a mapping
-- depending on case.
transformWith ::
  -- | Boundary action.
  (forall s. s -> Step (CC s) Char) ->
  -- | Boundary mapping.
  (forall s. Char -> s -> Step (CC s) Char) ->
  -- | Subsequent character mapping.
  (forall s. Char -> s -> Step (CC s) Char) ->
  -- | Input stream.
  Stream Token ->
  Stream Char
transformWith md mu mc (Stream next0 s0 len) =
  -- HINT: len incorrect when the boundary replacement yields a char.
  Stream next (CC (False :*: False :*: s0) '\0' '\0') len
  where
    next (CC (up :*: prev :*: s) '\0' _) =
      case next0 s of
        Done -> Done
        Skip s' -> Skip (CC (up :*: prev :*: s') '\0' '\0')
        Yield t s' ->
          case t of
            B _ -> md (False :*: True :*: s')
            U c | prev -> mu c (True :*: False :*: s')
            L c | prev -> mu c (False :*: False :*: s')
            U c | up -> mu c (True :*: False :*: s')
            U c -> mc c (True :*: False :*: s')
            L c -> mc c (False :*: False :*: s')
    next (CC s a b) = Yield a (CC s b '\0')
{-# INLINE [0] transformWith #-}

-- | A token representing characters and boundaries in a stream.
data Token
  = -- | Word boundary.
    B {-# UNPACK #-} !Char
  | -- | Upper case character.
    U {-# UNPACK #-} !Char
  | -- | Lower case character.
    L {-# UNPACK #-} !Char
  deriving (Show)

-- | Tokenise a character stream using the default 'isBoundary' predicate.
--
-- /See:/ 'tokeniseWith'
tokenise ::
  -- | Input stream.
  Stream Char ->
  Stream Token
tokenise = tokeniseWith isBoundary
{-# INLINE [0] tokenise #-}

-- | Tokenise a character stream using a custom boundary predicate.
tokeniseWith ::
  -- | Boundary predicate.
  (Char -> Bool) ->
  -- | Input stream.
  Stream Char ->
  Stream Token
tokeniseWith f (Stream next0 s0 len) =
  -- HINT: len incorrect if there are adjacent boundaries, which are skipped.
  Stream next (CC (True :*: False :*: False :*: s0) '\0' '\0') len
  where
    next (CC (start :*: up :*: prev :*: s) '\0' _) =
      case next0 s of
        Done -> Done
        Skip s' -> Skip (CC (start :*: up :*: prev :*: s') '\0' '\0')
        Yield c s'
          | not b, start -> push
          | up -> push
          | b, prev -> Skip (step start)
          | otherwise -> push
          where
            push
              | b = Yield (B c) (step False)
              | u, skip = Yield (U c) (step False)
              | u = Yield (B '\0') (CC (False :*: u :*: b :*: s') c '\0')
              | otherwise = Yield (L c) (step False)

            step p = CC (p :*: u :*: b :*: s') '\0' '\0'

            skip = up || start || prev

            b = f c
            u = Char.isUpper c
    next (CC s a b) = Yield (U a) (CC s b '\0')
{-# INLINE [0] tokeniseWith #-}

mapHead :: (Stream Char -> Stream Char) -> Stream Char -> Stream Char
mapHead f s = maybe s (\(x, s') -> f (singleton x) `append` s') (uncons s)
{-# INLINE [0] mapHead #-}