{- © 2019 Serokell <hi@serokell.io>
 - © 2019 Lars Jellema <lars.jellema@gmail.com>
 -
 - SPDX-License-Identifier: MPL-2.0
 -}

{-# LANGUAGE TupleSections #-}

module Nixfmt.Util
    ( manyP
    , someP
    , manyText
    , someText
    , commonPrefix
    , commonIndentation
    , dropCommonIndentation
    , identChar
    , isSpaces
    , pathChar
    , replaceMultiple
    , schemeChar
    , uriChar
    ) where

import Control.Applicative ((<|>))
import Data.Char (isAlpha, isDigit, isSpace)
import Data.Foldable (asum)
import Data.List (unfoldr)
import Data.Maybe (fromMaybe)
import Data.Text as Text
  (Text, all, commonPrefixes, concat, empty, null, splitAt, stripEnd, stripPrefix, takeWhile)
import Text.Megaparsec
  (ParsecT, Stream, Token, Tokens, many, some, takeWhile1P, takeWhileP)

charClass :: [Char] -> Char -> Bool
charClass :: [Char] -> Char -> Bool
charClass [Char]
s Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c [Char]
s

identChar :: Char -> Bool
identChar :: Char -> Bool
identChar = [Char] -> Char -> Bool
charClass [Char]
"_'-"

pathChar :: Char -> Bool
pathChar :: Char -> Bool
pathChar = [Char] -> Char -> Bool
charClass [Char]
"._-+~"

schemeChar :: Char -> Bool
schemeChar :: Char -> Bool
schemeChar = [Char] -> Char -> Bool
charClass [Char]
"-.+"

uriChar :: Char -> Bool
uriChar :: Char -> Bool
uriChar = [Char] -> Char -> Bool
charClass [Char]
"~!@$%&*-=_+:',./?"

-- | Match one or more characters that match a predicate.
someP :: (Stream s, Ord e) => (Token s -> Bool) -> ParsecT e s m (Tokens s)
someP :: (Token s -> Bool) -> ParsecT e s m (Tokens s)
someP = Maybe [Char] -> (Token s -> Bool) -> ParsecT e s m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing

-- | Match zero or more characters that match a predicate.
manyP :: (Stream s, Ord e) => (Token s -> Bool) -> ParsecT e s m (Tokens s)
manyP :: (Token s -> Bool) -> ParsecT e s m (Tokens s)
manyP = Maybe [Char] -> (Token s -> Bool) -> ParsecT e s m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing

-- | Match one or more texts and return the concatenation.
someText :: (Stream s, Ord e) => ParsecT e s m Text -> ParsecT e s m Text
someText :: ParsecT e s m Text -> ParsecT e s m Text
someText ParsecT e s m Text
p = [Text] -> Text
Text.concat ([Text] -> Text) -> ParsecT e s m [Text] -> ParsecT e s m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT e s m Text -> ParsecT e s m [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT e s m Text
p

-- | Match zero or more texts and return the concatenation.
manyText :: (Stream s, Ord e) => ParsecT e s m Text -> ParsecT e s m Text
manyText :: ParsecT e s m Text -> ParsecT e s m Text
manyText ParsecT e s m Text
p = [Text] -> Text
Text.concat ([Text] -> Text) -> ParsecT e s m [Text] -> ParsecT e s m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT e s m Text -> ParsecT e s m [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT e s m Text
p

-- | The longest common prefix of the arguments.
commonPrefix :: Text -> Text -> Text
commonPrefix :: Text -> Text -> Text
commonPrefix Text
a Text
b =
    case Text -> Text -> Maybe (Text, Text, Text)
commonPrefixes Text
a Text
b of
         Maybe (Text, Text, Text)
Nothing             -> Text
empty
         Just (Text
prefix, Text
_, Text
_) -> Text
prefix

-- | The longest common prefix consisting of only whitespace. The longest common
-- prefix of zero texts is infinite, represented as Nothing.
commonIndentation :: [Text] -> Maybe Text
commonIndentation :: [Text] -> Maybe Text
commonIndentation []       = Maybe Text
forall a. Maybe a
Nothing
commonIndentation [Text
x]      = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
Text.takeWhile Char -> Bool
isSpace Text
x
commonIndentation (Text
x:Text
y:[Text]
xs) = [Text] -> Maybe Text
commonIndentation (Text -> Text -> Text
commonPrefix Text
x Text
y Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
xs)

-- | Strip the longest common indentation from a list of lines. Empty lines do
-- not count towards the common indentation.
dropCommonIndentation :: [Text] -> [Text]
dropCommonIndentation :: [Text] -> [Text]
dropCommonIndentation [Text]
unstrippedLines =
    let strippedLines :: [Text]
strippedLines = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
stripEnd [Text]
unstrippedLines
    in case [Text] -> Maybe Text
commonIndentation ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Text
empty) [Text]
strippedLines) of
            Maybe Text
Nothing          -> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
forall a b. a -> b -> a
const Text
empty) [Text]
strippedLines
            Just Text
indentation -> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
empty (Maybe Text -> Text) -> (Text -> Maybe Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Text
stripPrefix Text
indentation) [Text]
strippedLines

isSpaces :: Text -> Bool
isSpaces :: Text -> Bool
isSpaces = (Char -> Bool) -> Text -> Bool
Text.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ')

-- | Apply multiple independent replacements. This function passes over the text
-- once and applies the first replacement it can find at each position. After a
-- replacement is matched, the function continues after the replacement, not
-- inside it.
replaceMultiple :: [(Text, Text)] -> Text -> Text
replaceMultiple :: [(Text, Text)] -> Text -> Text
replaceMultiple [(Text, Text)]
replacements = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe (Text, Text)) -> Text -> [Text]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Text -> Maybe (Text, Text)
replaceAny
  where
    -- | replaceAny assumes input is nonempty
    replaceAny :: Text -> Maybe (Text, Text)
    replaceAny :: Text -> Maybe (Text, Text)
replaceAny Text
t
      | Text -> Bool
Text.null Text
t = Maybe (Text, Text)
forall a. Maybe a
Nothing
      | Bool
otherwise   = [Maybe (Text, Text)] -> Maybe (Text, Text)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (((Text, Text) -> Maybe (Text, Text))
-> [(Text, Text)] -> [Maybe (Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> (Text, Text) -> Maybe (Text, Text)
replaceStart Text
t) [(Text, Text)]
replacements)
                      Maybe (Text, Text) -> Maybe (Text, Text) -> Maybe (Text, Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Int -> Text -> (Text, Text)
Text.splitAt Int
1 Text
t)

    replaceStart :: Text -> (Text, Text) -> Maybe (Text, Text)
    replaceStart :: Text -> (Text, Text) -> Maybe (Text, Text)
replaceStart Text
t (Text
pat, Text
rep) = (Text
rep,) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripPrefix Text
pat Text
t