-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Morley.Util.Text
  ( headToLower
  , surround
  , dquotes
  , stripFieldPrefix
  , dropPrefix
  , toCamel
  , Manip.toPascal
  , toSnake
  , toSpinal
  , lowerCaseCluster
  ) where

import Data.Char (isLower, isUpper, toLower)
import Data.Text qualified as T
import Data.Text.Manipulate qualified as Manip

-- | Leads first character of text to lower case.
--
-- For empty text this will throw an error.
headToLower :: HasCallStack => Text -> Text
headToLower :: HasCallStack => Text -> Text
headToLower Text
txt = case Text -> Maybe (Char, Text)
T.uncons Text
txt of
  Maybe (Char, Text)
Nothing -> Text -> Text
forall a. HasCallStack => Text -> a
error Text
"Empty text"
  Just (Char
c, Text
cs) -> Char -> Text -> Text
T.cons (Char -> Char
toLower Char
c) Text
cs

surround :: Semigroup a => a -> a -> a -> a
surround :: forall a. Semigroup a => a -> a -> a -> a
surround a
pre a
post a
content = a
pre a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
content a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
post

dquotes :: (Semigroup a, IsString a) => a -> a
dquotes :: forall a. (Semigroup a, IsString a) => a -> a
dquotes = a -> a -> a -> a
forall a. Semigroup a => a -> a -> a -> a
surround a
"\"" a
"\""

-- | Drops the field name prefix from a field.
--
-- We assume a convention of the prefix always being non-uppercase, and the
-- first letter of the actual field name being uppercase.
dropPrefix :: Text -> Text
dropPrefix :: Text -> Text
dropPrefix = (Char -> Bool) -> Text -> Text
T.dropWhile (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper)

-- | Transform text to @camelCase@.
--
-- If the text starts with a single uppercase letter, it is lowercased. If it
-- starts with a cluster of non-lowercase letters, all but the last in the
-- cluster are lowercased.
--
-- >>> toCamel "MyField"
-- "myField"
-- >>> toCamel "USPosition"
-- "usPosition"
-- >>> toCamel "FA2Config"
-- "fa2Config"
toCamel :: Text -> Text
toCamel :: Text -> Text
toCamel = Text -> Text
Manip.toCamel (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
lowerCaseCluster

-- | Transform text to @snake_case@.
--
-- Non-lowercase clusters starting with an uppercase letter are treated as
-- separate words, except the last letter in the cluster.
--
-- >>> toSnake "MyField"
-- "my_field"
-- >>> toSnake "USPosition"
-- "us_position"
-- >>> toSnake "FA2Config"
-- "fa2_config"
-- >>> toSnake "MyUSPosition"
-- "my_us_position"
-- >>> toSnake "MyFie123d"
-- "my_fie123d"
toSnake :: Text -> Text
toSnake :: Text -> Text
toSnake = Text -> [Text] -> Text
T.intercalate Text
"_" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
Manip.toSnake (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
lowerCaseCluster) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Manip.splitWords

-- | Transform text to @spinal-case@.
--
-- Non-lowercase clusters starting with an uppercase letter are treated as
-- separate words, except the last letter in the cluster.
--
-- >>> toSpinal "MyField"
-- "my-field"
-- >>> toSpinal "USPosition"
-- "us-position"
-- >>> toSpinal "FA2Config"
-- "fa2-config"
-- >>> toSpinal "MyUSPosition"
-- "my-us-position"
-- >>> toSpinal "MyFie123d"
-- "my-fie123d"
toSpinal :: Text -> Text
toSpinal :: Text -> Text
toSpinal = Text -> [Text] -> Text
T.intercalate Text
"-" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
Manip.toSpinal (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
lowerCaseCluster) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Manip.splitWords

-- | If text starts with a cluster of non-lowercase letters, lowercase them except
-- the last one.
--
-- >>> lowerCaseCluster "USPosition"
-- "usPosition"
-- >>> lowerCaseCluster "Position"
-- "Position"
-- >>> lowerCaseCluster "FA2Config"
-- "fa2Config"
lowerCaseCluster :: Text -> Text
lowerCaseCluster :: Text -> Text
lowerCaseCluster Text
x = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
x do
  (Char
c1, Text
xs) <- Text -> Maybe (Char, Text)
T.uncons Text
x
  (Char
c2, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
xs
  if Char -> Bool
notLower Char
c1 Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& Char -> Bool
notLower Char
c2
  then do
    let (Text
ucs, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
notLower Text
x
    (Text
ucs', Char
lastuc) <- Text -> Maybe (Text, Char)
T.unsnoc Text
ucs
    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> Text -> Text
T.map Char -> Char
toLower Text
ucs' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text -> Text
T.cons Char
lastuc Text
rest
  else Maybe Text
forall a. Maybe a
Nothing
  where
    notLower :: Char -> Bool
notLower = Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isLower

-- | Cut fields prefixes which we use according to the style guide.
--
-- >>> stripFieldPrefix "cmMyField"
-- "myField"
stripFieldPrefix :: Text -> Text
stripFieldPrefix :: Text -> Text
stripFieldPrefix = Text -> Text
toCamel (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropPrefix