text-manipulate-0.1.0: src/Data/Text/Manipulate/Fusion.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
-- Module : Data.Text.Manipulate.Fusion
-- Copyright : (c) 2014 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.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 (upperMapping, lowerMapping)
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.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 :: (forall s. s -> Step (CC s) Char) -- ^ Boundary action.
-> (forall s. Char -> s -> Step (CC s) Char) -- ^ Character mapping.
-> Stream Token -- ^ Input stream.
-> 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 :: (forall s. s -> Step (CC s) Char) -- ^ Boundary action.
-> (forall s. Char -> s -> Step (CC s) Char) -- ^ Boundary mapping.
-> (forall s. Char -> s -> Step (CC s) Char) -- ^ Subsequent character mapping.
-> Stream Token -- ^ Input stream.
-> 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
= B {-# UNPACK #-} !Char -- ^ Word boundary.
| U {-# UNPACK #-} !Char -- ^ Upper case character.
| L {-# UNPACK #-} !Char -- ^ Lower case character.
deriving (Show)
-- | Tokenise a character stream using the default 'isBoundary' predicate.
--
-- /See:/ 'tokeniseWith'
tokenise :: Stream Char -- ^ Input stream.
-> Stream Token
tokenise = tokeniseWith isBoundary
{-# INLINE [0] tokenise #-}
-- | Tokenise a character stream using a custom boundary predicate.
tokeniseWith :: (Char -> Bool) -- ^ Boundary predicate.
-> Stream Char -- ^ Input stream.
-> 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 #-}