-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
module Util.Texts where
import           Prelude hiding (lines)
import           Control.Arrow (first)
import           Control.Monad (liftM)
import qualified Control.Monad.Identity as Identity

import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as ByteString.Lazy
import qualified Data.Char as Char
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.String as String
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.Encoding as Encoding
import qualified Data.Text.Encoding.Error as Encoding.Error
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Encoding as Lazy.Encoding

import qualified System.FilePath as FilePath
import           System.FilePath ((</>))

import qualified Util.Lists as Lists
import qualified Util.Regex as Regex


-- * conversion

class Textlike a where
    toText :: a -> Text
    fromText :: Text -> a

    toString :: a -> String
    toString = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Textlike a => a -> Text
toText

    toByteString :: a -> ByteString.ByteString
    toByteString = Text -> ByteString
Encoding.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Textlike a => a -> Text
toText

    toLazyByteString :: a -> ByteString.Lazy.ByteString
    toLazyByteString = Text -> ByteString
Lazy.Encoding.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.Lazy.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Textlike a => a -> Text
toText

instance Textlike Text where
    toText :: Text -> Text
toText = forall a. a -> a
id
    fromText :: Text -> Text
fromText = forall a. a -> a
id

instance Textlike String where
    toText :: String -> Text
toText = String -> Text
Text.pack
    fromText :: Text -> String
fromText = Text -> String
Text.unpack

instance Textlike ByteString.ByteString where
    toText :: ByteString -> Text
toText = OnDecodeError -> ByteString -> Text
Encoding.decodeUtf8With OnDecodeError
Encoding.Error.lenientDecode
    fromText :: Text -> ByteString
fromText = forall a. Textlike a => a -> ByteString
toByteString
    toByteString :: ByteString -> ByteString
toByteString = forall a. a -> a
id
    toLazyByteString :: ByteString -> ByteString
toLazyByteString = ByteString -> ByteString
ByteString.Lazy.fromStrict

instance Textlike ByteString.Lazy.ByteString where
    toText :: ByteString -> Text
toText = forall a. Textlike a => a -> Text
toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
ByteString.Lazy.toStrict
    fromText :: Text -> ByteString
fromText = ByteString -> ByteString
ByteString.Lazy.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Textlike a => Text -> a
fromText
    toByteString :: ByteString -> ByteString
toByteString = ByteString -> ByteString
ByteString.Lazy.toStrict
    toLazyByteString :: ByteString -> ByteString
toLazyByteString = forall a. a -> a
id


-- * operations

-- | Replace substrings simultaneously.
replaceMany :: [(Text, Text)] -> Text -> Text
replaceMany :: [(Text, Text)] -> Text -> Text
replaceMany [(Text, Text)]
replace = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
go
    where
    go :: Text -> [Text]
go Text
text
        | Text -> Bool
Text.null Text
text = []
        | Bool
otherwise = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Text
text] ((Text, Text), (Text, Text)) -> [Text]
continue forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn (Text -> Int
Text.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                [(HasCallStack => Text -> Text -> (Text, Text)
Text.breakOn (forall a b. (a, b) -> a
fst (Text, Text)
r) Text
text, (Text, Text)
r) | (Text, Text)
r <- [(Text, Text)]
replace]
    continue :: ((Text, Text), (Text, Text)) -> [Text]
continue ((Text
pre, Text
post), (Text
from, Text
to))
        | Text -> Bool
Text.null Text
post = [Text
pre]
        | Bool
otherwise = Text
pre forall a. a -> [a] -> [a]
: Text
to forall a. a -> [a] -> [a]
: Text -> [Text]
go (Int -> Text -> Text
Text.drop (Text -> Int
Text.length Text
from) Text
post)

-- | Join the two pieces with a space, if they are non-empty.
unwords2 :: Textlike a => a -> a -> a
unwords2 :: forall a. Textlike a => a -> a -> a
unwords2 = forall a. Textlike a => a -> a -> a -> a
join2 (forall a. Textlike a => Text -> a
fromText Text
" ")

unlines2 :: Textlike a => a -> a -> a
unlines2 :: forall a. Textlike a => a -> a -> a
unlines2 = forall a. Textlike a => a -> a -> a -> a
join2 (forall a. Textlike a => Text -> a
fromText Text
"\n")

-- | The 2 variants join two texts, but omit the separator if one is null.
join2 :: Textlike a => a -> a -> a -> a
join2 :: forall a. Textlike a => a -> a -> a -> a
join2 a
sep a
a a
b = forall a. Textlike a => a -> [a] -> a
join a
sep forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Textlike a => a -> Text
toText) [a
a, a
b]

join :: Textlike a => a -> [a] -> a
join :: forall a. Textlike a => a -> [a] -> a
join a
sep = forall a. Textlike a => Text -> a
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate (forall a. Textlike a => a -> Text
toText a
sep) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Textlike a => a -> Text
toText

unlines :: Textlike a => [a] -> a
unlines :: forall a. Textlike a => [a] -> a
unlines = forall a. Textlike a => Text -> a
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Textlike a => a -> Text
toText

split1 :: Text -> Text -> (Text, Text)
split1 :: Text -> Text -> (Text, Text)
split1 Text
sep Text
text = (Text
pre, Int -> Text -> Text
Text.drop (Text -> Int
Text.length Text
sep) Text
post)
    where (Text
pre, Text
post) = HasCallStack => Text -> Text -> (Text, Text)
Text.breakOn Text
sep Text
text

ellipsis :: Int -> Text -> Text
ellipsis :: Int -> Text -> Text
ellipsis Int
maxWidth Text
text
    | Text -> Int
Text.length Text
text forall a. Ord a => a -> a -> Bool
<= Int
maxWidth = Text
text
    | Bool
otherwise = Int -> Text -> Text
Text.take (Int
maxWidth forall a. Num a => a -> a -> a
- Int
3) Text
text forall a. Semigroup a => a -> a -> a
<> Text
"..."

ellipsisList :: Int -> [Text] -> [Text]
ellipsisList :: Int -> [Text] -> [Text]
ellipsisList Int
max [Text]
xs
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
post = [Text]
xs
    | Bool
otherwise = [Text]
pre forall a. [a] -> [a] -> [a]
++ [Text
"..."]
    where ([Text]
pre, [Text]
post) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
max [Text]
xs

dropPrefix :: Text -> Text -> Text
dropPrefix :: Text -> Text -> Text
dropPrefix Text
prefix Text
text = forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
text (Text -> Text -> Maybe Text
Text.stripPrefix Text
prefix Text
text)

dropSuffix :: Text -> Text -> Text
dropSuffix :: Text -> Text -> Text
dropSuffix Text
suffix Text
text = forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
text (Text -> Text -> Maybe Text
Text.stripSuffix Text
suffix Text
text)

enumeration :: (Textlike a, Monoid a, String.IsString a) => [a] -> a
enumeration :: forall a. (Textlike a, Monoid a, IsString a) => [a] -> a
enumeration = forall a. Textlike a => a -> [a] -> a
join a
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (a
"- "<>)

-- | Format the given rows into columns, aligned vertically.
columns :: Int -> [[Text]] -> [Text]
columns :: Int -> [[Text]] -> [Text]
columns Int
padding = Int -> [Either Text [Text]] -> [Text]
columnsSome Int
padding forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right

-- | Like 'columns', but some rows can opt out of formatting by being Left.
columnsSome :: Int -> [Either Text [Text]] -> [Text]
columnsSome :: Int -> [Either Text [Text]] -> [Text]
columnsSome Int
padding [Either Text [Text]]
rows = forall a b. (a -> b) -> [a] -> [b]
map Either Text [Text] -> Text
formatRow [Either Text [Text]]
rows
    where
    formatRow :: Either Text [Text] -> Text
formatRow = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (Text -> Text
Text.stripEnd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Text -> Text
pad [Int]
widths)
    pad :: Int -> Text -> Text
pad Int
w = Int -> Char -> Text -> Text
Text.justifyLeft (Int
w forall a. Num a => a -> a -> a
+ Int
padding) Char
' '
    byCol :: [[Text]]
byCol = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
Text.empty))
        (forall a. [[a]] -> [[Maybe a]]
Lists.rotate2 (forall a b. [Either a b] -> [b]
Either.rights [Either Text [Text]]
rows))
    widths :: [Int]
widths = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
List.maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
0:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
Text.length) [[Text]]
byCol

-- | Apply a function to the contents delimited by the given Char.  You can
-- quote a delimiter with a backslash.
mapDelimited :: Bool -> Char -> (Text -> Text) -> Text -> Text
mapDelimited :: Bool -> Char -> (Text -> Text) -> Text -> Text
mapDelimited Bool
withSpaces Char
delimiter Text -> Text
f =
    forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Monad m =>
Bool -> Char -> (Text -> m Text) -> Text -> m Text
mapDelimitedM Bool
withSpaces Char
delimiter (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
f)

mapDelimitedM :: Monad m => Bool -> Char -> (Text -> m Text) -> Text -> m Text
mapDelimitedM :: forall (m :: * -> *).
Monad m =>
Bool -> Char -> (Text -> m Text) -> Text -> m Text
mapDelimitedM Bool
withSpaces Char
delimiter Text -> m Text
f =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text, Maybe Text) -> m [Text]
apply
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Char -> Text -> [(Text, Maybe Text)]
extractDelimited Bool
withSpaces Char
delimiter
    where
    apply :: (Text, Maybe Text) -> m [Text]
apply (Text
text, Just Text
word) = do
        Text
replace <- Text -> m Text
f Text
word
        forall (m :: * -> *) a. Monad m => a -> m a
return [Text
text, Text
replace]
    apply (Text
text, Maybe Text
Nothing) = forall (m :: * -> *) a. Monad m => a -> m a
return [Text
text]

-- | This is more awkward than a parser, but... ok, maybe I should have used
-- a parser.
extractDelimited :: Bool -- ^ If false, a delimiter doesn't count if the text
    -- after it has a space.
    -> Char -> Text -> [(Text, Maybe Text)]
extractDelimited :: Bool -> Char -> Text -> [(Text, Maybe Text)]
extractDelimited Bool
withSpaces Char
delimiter = Text -> [(Text, Maybe Text)]
go
    where
    go :: Text -> [(Text, Maybe Text)]
go Text
text
        | Text -> Bool
Text.null Text
within Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
post = [(Text
pre forall a. Semigroup a => a -> a -> a
<> Text
within, forall a. Maybe a
Nothing)]
        | Bool -> Bool
not Bool
withSpaces Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
Text.any (forall a. Eq a => a -> a -> Bool
==Char
' ') Text
word =
            (Text
pre forall a. Semigroup a => a -> a -> a
<> Text
delim, forall a. Maybe a
Nothing) forall a. a -> [a] -> [a]
: Text -> [(Text, Maybe Text)]
go (Int -> Text -> Text
Text.drop Int
1 Text
within)
        | Bool
otherwise = (Text
pre, forall a. a -> Maybe a
Just Text
word) forall a. a -> [a] -> [a]
: Text -> [(Text, Maybe Text)]
go (Int -> Text -> Text
Text.drop Int
1 Text
post)
        where
        (Text
pre, Text
within) = Text -> (Text, Text)
break Text
text
        (Text
word, Text
post) = Text -> (Text, Text)
break forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop Int
1 Text
within
    break :: Text -> (Text, Text)
break Text
text
        | Text
"\\" Text -> Text -> Bool
`Text.isSuffixOf` Text
pre =
            forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Int -> Text -> Text
Text.take (Text -> Int
Text.length Text
pre forall a. Num a => a -> a -> a
- Int
1) Text
pre forall a. Semigroup a => a -> a -> a
<> Text
delim) <>) forall a b. (a -> b) -> a -> b
$
                Text -> (Text, Text)
break (Int -> Text -> Text
Text.drop Int
1 Text
post)
        | Bool
otherwise = (Text
pre, Text
post)
        where (Text
pre, Text
post) = HasCallStack => Text -> Text -> (Text, Text)
Text.breakOn Text
delim Text
text
    delim :: Text
delim = Char -> Text
Text.singleton Char
delimiter

-- * interpolate

-- | Replace @${variable}@.
interpolate :: Text -> Map.Map Text Text -> Either Text Text
interpolate :: Text -> Map Text Text -> Either Text Text
interpolate Text
template Map Text Text
variables
    | Set Text
notInTemplate forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"given variables not in template: "
        forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
commas (forall a. Set a -> [a]
Set.toList Set Text
notInTemplate)
    | Set Text
notInVariables forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"template variable not given: "
        forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
commas (forall a. Set a -> [a]
Set.toList Set Text
notInVariables)
    | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Text -> Text
replaceMany
        [(Text
"${" forall a. Semigroup a => a -> a -> a
<> Text
k forall a. Semigroup a => a -> a -> a
<> Text
"}", Text
v) | (Text
k, Text
v) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Text Text
variables] Text
template
    where
    inTemplate :: Set Text
inTemplate = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Regex -> Text -> [(Text, [Text])]
Regex.groups Regex
variable Text
template
    inVariables :: Set Text
inVariables = forall k a. Map k a -> Set k
Map.keysSet Map Text Text
variables
    notInTemplate :: Set Text
notInTemplate = Set Text
inVariables forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Text
inTemplate
    notInVariables :: Set Text
notInVariables = Set Text
inTemplate forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Text
inVariables
    commas :: [Text] -> Text
commas = Text -> [Text] -> Text
Text.intercalate Text
", "
    variable :: Regex
variable = HasCallStack => String -> Regex
Regex.compileUnsafe String
"\\$\\{([a-z0-9_]+)\\}"

-- * haddockUrl

type Files = Set.Set FilePath
type Url = String

-- | This doesn't really belong here, but it can't go in 'Util.Linkify' since
-- that's a main module.
haddockUrl :: Files -> FilePath -> Text -> Maybe Url
haddockUrl :: Files -> String -> Text -> Maybe String
haddockUrl Files
files String
haddockDir Text
text
    | [String] -> Bool
moduleExists [String]
components = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
moduleLink [String]
components
    | [String] -> Bool
moduleExists (forall a. Int -> [a] -> [a]
Lists.dropEnd Int
1 [String]
components) = Maybe String
symbolLink
    | Bool
otherwise = forall a. Maybe a
Nothing
    where
    components :: [String]
components = forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
Text.split (forall a. Eq a => a -> a -> Bool
==Char
'.') Text
text
    moduleExists :: [String] -> Bool
moduleExists [String]
path = String -> Bool
exists ([String] -> String
FilePath.joinPath [String]
path forall a. [a] -> [a] -> [a]
++ String
".hs")
        Bool -> Bool -> Bool
|| String -> Bool
exists ([String] -> String
FilePath.joinPath [String]
path forall a. [a] -> [a] -> [a]
++ String
".hsc")
    exists :: String -> Bool
exists = (forall a. Ord a => a -> Set a -> Bool
`Set.member` Files
files)

    moduleLink :: [String] -> String
moduleLink [String]
path = String -> String
strip forall a b. (a -> b) -> a -> b
$ String
haddockDir String -> String -> String
</> forall a. Monoid a => a -> [a] -> a
Lists.join String
"-" [String]
path forall a. [a] -> [a] -> [a]
++ String
".html"
    strip :: String -> String
strip (Char
'.' : Char
'/' : String
path) = String
path
    strip String
path = String
path
    symbolLink :: Maybe String
symbolLink = case forall a. [a] -> Maybe ([a], a)
Lists.unsnoc [String]
components of
        Just ([String]
mod, String
sym) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
moduleLink [String]
mod forall a. [a] -> [a] -> [a]
++ String -> String
symbolAnchor String
sym
        Maybe ([String], String)
Nothing -> forall a. Maybe a
Nothing

symbolAnchor :: String -> String
symbolAnchor :: String -> String
symbolAnchor String
sym = case String
sym of
    Char
c : String
_ | Char -> Bool
Char.isUpper Char
c -> String
"#t:" forall a. [a] -> [a] -> [a]
++ String
sym
    String
_ -> String
"#v:" forall a. [a] -> [a] -> [a]
++ String
sym