{-# LANGUAGE CPP #-}
module Foreign.Hoppy.Generator.Common (
filterMaybe,
fromMaybeM,
fromEitherM,
maybeFail,
whileJust_,
for,
butLast,
listSubst,
listSubst',
doubleQuote,
strInterpolate,
zipWithM,
capitalize,
lowerFirst,
upperFirst,
pluralize,
writeFileIfDifferent,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Exception (evaluate)
import Control.Monad (when)
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 :: Eq a => a -> Maybe a -> Maybe a
filterMaybe bad (Just value) | value == bad = Nothing
filterMaybe _ mayb = mayb
fromMaybeM :: Monad m => m a -> Maybe a -> m a
fromMaybeM = flip maybe return
fromEitherM :: Monad m => (e -> m a) -> Either e a -> m a
fromEitherM = flip either return
maybeFail :: Monad m => String -> Maybe a -> m a
maybeFail = fromMaybeM . fail
whileJust_ :: Monad m => m (Maybe a) -> (a -> m b) -> m ()
whileJust_ gen act = gen >>= \case
Just x -> act x >> whileJust_ gen act
Nothing -> return ()
for :: [a] -> (a -> b) -> [b]
for = flip map
butLast :: [a] -> [a]
butLast [] = []
butLast xs = take (length xs - 1) xs
listSubst :: Eq a => a -> a -> [a] -> [a]
listSubst x x' = map $ \y -> if y == x then x' else y
listSubst' :: Eq a => a -> [a] -> [a] -> [a]
listSubst' x xs' = concatMap $ \y -> if y == x then xs' else [y]
doubleQuote :: String -> String
doubleQuote str = '"' : escape str ++ "\""
where escape s =
if any (\c -> c == '"' || c == '\\') s
then listSubst' '"' "\\\"" $
listSubst' '\\' "\\\\" s
else s
strInterpolate :: Map String String -> String -> Either String String
strInterpolate values str = case L.findIndex ('{' ==) str of
Nothing -> Right str
Just openBraceIndex ->
let (prefix, termAndSuffix) = splitAt openBraceIndex str
in case L.findIndex ('}' ==) termAndSuffix of
Nothing -> Right str
Just closeBraceIndex ->
let termLength = closeBraceIndex - 1
term = take termLength $ tail termAndSuffix
suffix = drop (closeBraceIndex + 1) termAndSuffix
in case M.lookup term values of
Nothing -> Left term
Just value -> strInterpolate values $ prefix ++ value ++ suffix
zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM f xs ys = sequence $ zipWith f xs ys
capitalize :: String -> String
capitalize "" = ""
capitalize (c:cs) = toUpper c : map toLower cs
lowerFirst :: String -> String
lowerFirst "" = ""
lowerFirst (c:cs) = toLower c : cs
upperFirst :: String -> String
upperFirst "" = ""
upperFirst (c:cs) = toUpper c : cs
pluralize :: Int -> String -> String -> String
pluralize num singular plural =
if num == 1
then "1 " ++ singular
else show num ++ " " ++ plural
writeFileIfDifferent :: FilePath -> String -> IO ()
writeFileIfDifferent path newContents = do
exists <- doesFileExist path
doWrite <- if exists
then (newContents /=) <$> readStrictly
else return True
when doWrite $ writeFile path newContents
where readStrictly = withFile path ReadMode $ \handle -> do
contents <- hGetContents handle
_ <- evaluate $ length contents
return contents