module Data.GI.CodeGen.Util
  ( prime
  , parenthesize

  , padTo
  , withComment

  , ucFirst
  , lcFirst

  , modifyQualified

  , tshow
  , terror

  , utf8ReadFile
  , utf8WriteFile

  , splitOn

  , printWarning
  ) where

import GHC.Stack (HasCallStack)

#if !MIN_VERSION_base(4,13,0)
import Data.Monoid ((<>))
#endif
import Data.Char (toLower, toUpper)

import qualified Data.ByteString as B
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO

import qualified System.Console.ANSI as A
import System.IO (stderr, hFlush)

padTo :: Int -> Text -> Text
padTo :: Int -> Text -> Text
padTo Int
n Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
s) Text
" "

withComment :: Text -> Text -> Text
withComment :: Text -> Text -> Text
withComment Text
a Text
b = Int -> Text -> Text
padTo Int
40 Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b

prime :: Text -> Text
prime :: Text -> Text
prime = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'")

parenthesize :: Text -> Text
parenthesize :: Text -> Text
parenthesize Text
s = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Construct the `Text` representation of a showable.
tshow :: Show a => a -> Text
tshow :: forall a. Show a => a -> Text
tshow = FilePath -> Text
T.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show

-- | Capitalize the first character of the given string.
ucFirst :: Text -> Text
ucFirst :: Text -> Text
ucFirst Text
"" = Text
""
ucFirst Text
t = Char -> Text -> Text
T.cons (Char -> Char
toUpper (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Char
Text -> Char
T.head Text
t) (HasCallStack => Text -> Text
Text -> Text
T.tail Text
t)

-- | Make the first character of the given string lowercase.
lcFirst :: Text -> Text
lcFirst :: Text -> Text
lcFirst Text
"" = Text
""
lcFirst Text
t = Char -> Text -> Text
T.cons (Char -> Char
toLower (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Char
Text -> Char
T.head Text
t) (HasCallStack => Text -> Text
Text -> Text
T.tail Text
t)

-- | Apply the given modification function to the given symbol. If the
-- symbol is qualified the modification will only apply to the last
-- component.
modifyQualified :: (Text -> Text) -> Text -> Text
modifyQualified :: (Text -> Text) -> Text -> Text
modifyQualified Text -> Text
f = Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
modify ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"."
    where modify :: [Text] -> [Text]
          modify :: [Text] -> [Text]
modify [] = []
          modify (Text
a:[]) = Text -> Text
f Text
a Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: []
          modify (Text
a:[Text]
as) = Text
a Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
modify [Text]
as

-- | Split a list into sublists delimited by the given element.
splitOn :: Eq a => a -> [a] -> [[a]]
splitOn :: forall a. Eq a => a -> [a] -> [[a]]
splitOn a
x [a]
xs = [a] -> [a] -> [[a]]
go [a]
xs []
    where go :: [a] -> [a] -> [[a]]
go [] [a]
acc = [[a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc]
          go (a
y : [a]
ys) [a]
acc = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
                            then [a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [[a]]
go [a]
ys []
                            else [a] -> [a] -> [[a]]
go [a]
ys (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)

-- | Read a file assuming it is UTF-8 encoded. If decoding fails this
-- calls `error`.
utf8ReadFile :: FilePath -> IO T.Text
utf8ReadFile :: FilePath -> IO Text
utf8ReadFile FilePath
fname = do
  ByteString
bytes <- FilePath -> IO ByteString
B.readFile FilePath
fname
  case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bytes of
    Right Text
text -> Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
text
    Left UnicodeException
error -> Text -> IO Text
forall a. HasCallStack => Text -> a
terror (Text
"Input file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. Show a => a -> Text
tshow FilePath
fname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                          Text
" seems not to be valid UTF-8. Error was:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                          UnicodeException -> Text
forall a. Show a => a -> Text
tshow UnicodeException
error)

-- | Write the given `Text` into an UTF-8 encoded file.
utf8WriteFile :: FilePath -> T.Text -> IO ()
utf8WriteFile :: FilePath -> Text -> IO ()
utf8WriteFile FilePath
fname Text
text = FilePath -> ByteString -> IO ()
B.writeFile FilePath
fname (Text -> ByteString
TE.encodeUtf8 Text
text)

-- | Print a (colored) warning message to stderr
printWarning :: Text -> IO ()
printWarning :: Text -> IO ()
printWarning Text
warning = do
  Bool
inColour <- Handle -> IO Bool
A.hSupportsANSIColor Handle
stderr
  if Bool -> Bool
not Bool
inColour
    then Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr Text
warning
    else do
      Handle -> [SGR] -> IO ()
A.hSetSGR Handle
stderr [ConsoleIntensity -> SGR
A.SetConsoleIntensity ConsoleIntensity
A.BoldIntensity,
                        ConsoleLayer -> ColorIntensity -> Color -> SGR
A.SetColor ConsoleLayer
A.Foreground ColorIntensity
A.Vivid Color
A.Yellow]
      Handle -> Text -> IO ()
TIO.hPutStr Handle
stderr Text
"Warning: "
      Handle -> [SGR] -> IO ()
A.hSetSGR Handle
stderr [ConsoleLayer -> ColorIntensity -> Color -> SGR
A.SetColor ConsoleLayer
A.Foreground ColorIntensity
A.Vivid Color
A.White]
      Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr Text
warning
      Handle -> [SGR] -> IO ()
A.hSetSGR Handle
stderr [SGR
A.Reset]
      Handle -> IO ()
hFlush Handle
stderr

-- | Throw an error with the given `Text`.
terror :: HasCallStack => Text -> a
terror :: forall a. HasCallStack => Text -> a
terror Text
errMsg =
  let fmt :: FilePath
fmt = [SGR] -> FilePath
A.setSGRCode [ConsoleIntensity -> SGR
A.SetConsoleIntensity ConsoleIntensity
A.BoldIntensity,
                          ConsoleLayer -> ColorIntensity -> Color -> SGR
A.SetColor ConsoleLayer
A.Foreground ColorIntensity
A.Vivid Color
A.Red]
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"ERROR: "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [SGR] -> FilePath
A.setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
A.SetColor ConsoleLayer
A.Foreground ColorIntensity
A.Vivid Color
A.White]
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
errMsg
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [SGR] -> FilePath
A.setSGRCode [ConsoleIntensity -> SGR
A.SetConsoleIntensity ConsoleIntensity
A.NormalIntensity,
                             ConsoleLayer -> ColorIntensity -> Color -> SGR
A.SetColor ConsoleLayer
A.Foreground ColorIntensity
A.Vivid Color
A.Blue]
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\nPlease report this at https://github.com/haskell-gi/haskell-gi/issues"
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [SGR] -> FilePath
A.setSGRCode [SGR
A.Reset]
  in FilePath -> a
forall a. HasCallStack => FilePath -> a
error FilePath
fmt