-- This file is part of Hoppy.
--
-- Copyright 2015-2021 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP #-}

-- | General routines.
--
-- Unlike "Foreign.Hoppy.Generator.Util", these are private to the package.
module Foreign.Hoppy.Generator.Common (
  filterMaybe,
  fromMaybeM,
  fromEitherM,
  maybeFail,
  whileJust_,
  for,
  butLast,
  listSubst,
  listSubst',
  doubleQuote,
  strInterpolate,
  zipWithM,
  -- * String utilities
  capitalize,
  lowerFirst,
  upperFirst,
  pluralize,
  -- * File utilities
  writeFileIfDifferent,
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Exception (evaluate)
import Control.Monad (when)
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Data.Char (toLower, toUpper)
import qualified Data.List as L
import qualified Data.Map as M
import Data.Map (Map)
import System.Directory (doesFileExist)
import System.IO (IOMode (ReadMode), hGetContents, withFile)

-- | @filterMaybe bad@ converts a @Just bad@ into a @Nothing@, returning all
-- other @Maybe@ values as is.
filterMaybe :: Eq a => a -> Maybe a -> Maybe a
filterMaybe :: a -> Maybe a -> Maybe a
filterMaybe a
bad (Just a
value) | a
value a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
bad = Maybe a
forall a. Maybe a
Nothing
filterMaybe a
_ Maybe a
mayb = Maybe a
mayb

-- | @fromMaybeM m x = maybe m return x@
fromMaybeM :: Monad m => m a -> Maybe a -> m a
fromMaybeM :: m a -> Maybe a -> m a
fromMaybeM = (m a -> (a -> m a) -> Maybe a -> m a)
-> (a -> m a) -> m a -> Maybe a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | @fromEitherM f x = either f return x@
fromEitherM :: Monad m => (e -> m a) -> Either e a -> m a
fromEitherM :: (e -> m a) -> Either e a -> m a
fromEitherM = ((e -> m a) -> (a -> m a) -> Either e a -> m a)
-> (a -> m a) -> (e -> m a) -> Either e a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | @maybeFail s x = maybe (fail s) x@
maybeFail :: MonadFail m => String -> Maybe a -> m a
maybeFail :: String -> Maybe a -> m a
maybeFail = m a -> Maybe a -> m a
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (m a -> Maybe a -> m a)
-> (String -> m a) -> String -> Maybe a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

-- | @whileJust_ gen act@ runs @act@ on values generated from @gen@ until @gen@
-- returns a @Nothing@.
whileJust_ :: Monad m => m (Maybe a) -> (a -> m b) -> m ()
whileJust_ :: m (Maybe a) -> (a -> m b) -> m ()
whileJust_ m (Maybe a)
gen a -> m b
act = m (Maybe a)
gen m (Maybe a) -> (Maybe a -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just a
x -> a -> m b
act a
x m b -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (Maybe a) -> (a -> m b) -> m ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whileJust_ m (Maybe a)
gen a -> m b
act
  Maybe a
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | @for = flip map@
for :: [a] -> (a -> b) -> [b]
for :: [a] -> (a -> b) -> [b]
for = ((a -> b) -> [a] -> [b]) -> [a] -> (a -> b) -> [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map

-- | Drops the last item from the list, if non-empty.
butLast :: [a] -> [a]
butLast :: [a] -> [a]
butLast [] = []
butLast [a]
xs = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs

-- | @listSubst a b xs@ replaces all @x@ in @xs@ such that @x == a@ with @b@.
listSubst :: Eq a => a -> a -> [a] -> [a]
listSubst :: a -> a -> [a] -> [a]
listSubst a
x a
x' = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> [a] -> [a]) -> (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ \a
y -> if a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x then a
x' else a
y

-- | @listSubst' a bs xs@ replaces all @x@ in @xs@ such that @x == a@ with the
-- sequence of items @bs@.
listSubst' :: Eq a => a -> [a] -> [a] -> [a]
listSubst' :: a -> [a] -> [a] -> [a]
listSubst' a
x [a]
xs' = (a -> [a]) -> [a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((a -> [a]) -> [a] -> [a]) -> (a -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ \a
y -> if a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x then [a]
xs' else [a
y]

-- | Renders a double-quoted string, enclosing the given characters in double
-- quotes and escaping double quotes and backslashes with backslashes.
doubleQuote :: String -> String
doubleQuote :: String -> String
doubleQuote String
str = Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
  where escape :: String -> String
escape String
s =
          if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') String
s
          then Char -> String -> String -> String
forall a. Eq a => a -> [a] -> [a] -> [a]
listSubst' Char
'"' String
"\\\"" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
               Char -> String -> String -> String
forall a. Eq a => a -> [a] -> [a] -> [a]
listSubst' Char
'\\' String
"\\\\" String
s
          else String
s

-- | Takes a map of strings and a target string, and replaces references to keys
-- enclosed in braces in the target string with their values.  Returns a @Right@
-- with the replaced string on success, and when an unknown key is encountered
-- then a @Left@ with the unknown key.
strInterpolate :: Map String String -> String -> Either String String
strInterpolate :: Map String String -> String -> Either String String
strInterpolate Map String String
values String
str = case (Char -> Bool) -> String -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (Char
'{' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
str of
  Maybe Int
Nothing -> String -> Either String String
forall a b. b -> Either a b
Right String
str
  Just Int
openBraceIndex ->
    let (String
prefix, String
termAndSuffix) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
openBraceIndex String
str
    in case (Char -> Bool) -> String -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (Char
'}' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
termAndSuffix of
         Maybe Int
Nothing -> String -> Either String String
forall a b. b -> Either a b
Right String
str
         Just Int
closeBraceIndex ->
           let termLength :: Int
termLength = Int
closeBraceIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
               term :: String
term = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
termLength (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
termAndSuffix
               suffix :: String
suffix = Int -> String -> String
forall a. Int -> [a] -> [a]
drop (Int
closeBraceIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
termAndSuffix
           in case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
term Map String String
values of
                Maybe String
Nothing -> String -> Either String String
forall a b. a -> Either a b
Left String
term
                Just String
value -> Map String String -> String -> Either String String
strInterpolate Map String String
values (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix

-- | Zips two lists using a monadic function.
zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM :: (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM a -> b -> m c
f [a]
xs [b]
ys = [m c] -> m [c]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([m c] -> m [c]) -> [m c] -> m [c]
forall a b. (a -> b) -> a -> b
$ (a -> b -> m c) -> [a] -> [b] -> [m c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> m c
f [a]
xs [b]
ys

-- | Upper cases the first character of a string, and lower cases the rest of
-- it.  Does nothing to an empty string.
capitalize :: String -> String
capitalize :: String -> String
capitalize String
"" = String
""
capitalize (Char
c:String
cs) = Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cs

-- | Lower cases the first character of a string, if nonempty.
lowerFirst :: String -> String
lowerFirst :: String -> String
lowerFirst String
"" = String
""
lowerFirst (Char
c:String
cs) = Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs

-- | Upper cases the first character of a string, if nonempty.
upperFirst :: String -> String
upperFirst :: String -> String
upperFirst String
"" = String
""
upperFirst (Char
c:String
cs) = Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs

-- | Adds a noun onto a number in either singular or plural form, depending on
-- the number.
pluralize :: Int -> String -> String -> String
pluralize :: Int -> String -> String -> String
pluralize Int
num String
singular String
plural =
  if Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  then String
"1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
singular
  else Int -> String
forall a. Show a => a -> String
show Int
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
plural

-- | If the file specified does not exist or its contents does not match the
-- given string, then this writes the string to the file.
writeFileIfDifferent :: FilePath -> String -> IO ()
writeFileIfDifferent :: String -> String -> IO ()
writeFileIfDifferent String
path String
newContents = do
  Bool
exists <- String -> IO Bool
doesFileExist String
path
  -- We need to read the file strictly, otherwise lazy IO might try to write the
  -- file while it's still open and locked for reading.
  Bool
doWrite <- if Bool
exists
             then (String
newContents String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=) (String -> Bool) -> IO String -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
readStrictly
             else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doWrite (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
path String
newContents
  where readStrictly :: IO String
readStrictly = String -> IOMode -> (Handle -> IO String) -> IO String
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode ((Handle -> IO String) -> IO String)
-> (Handle -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
            String
contents <- Handle -> IO String
hGetContents Handle
handle
            Int
_ <- Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
contents
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
contents