{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
-- | General specific prelude for language-puppet
-- | Customization of the Protolude with extra specific utilities
module Puppet.Prelude (
module Exports
, String
, isEmpty
, dropInitialColons
, textElem
, getDirectoryContents
, takeBaseName
, takeDirectory
, strictifyEither
, scientific2text
, text2Scientific
, getFiles
, loggerName
, logDebug
, logInfo
, logInfoStr
, logWarning
, logError
, logDebugStr
, ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith
) where
import Protolude as Exports hiding (Down,
Infix, Prefix,
Selector, State,
StateT, Strict,
break, check,
evalState,
evalStateT,
execState,
execStateT, from,
hash, list,
moduleName,
runState,
runStateT,
sourceColumn,
sourceLine, to,
uncons, unsnoc,
withState, (%),
(<&>), (<.>))
import Control.Exception.Lens as Exports (catching)
import Control.Lens as Exports hiding (Strict,
argument, noneOf,
op)
import Control.Monad.Trans.Except as Exports (throwE)
import Control.Monad.Trans.Maybe as Exports (runMaybeT)
import Data.Aeson as Exports (fromJSON, toJSON)
import Data.Scientific as Exports (Scientific)
import Data.Set as Exports (Set)
import Data.Tuple.Strict as Exports (Pair (..))
import Data.Vector as Exports (Vector)
import Text.Regex.PCRE.ByteString.Utils as Exports (Regex)
import Data.Attoparsec.Text (parseOnly, rational)
import qualified Data.ByteString as BS
import qualified Data.Either.Strict as S
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Scientific as Scientific
import Data.String (String)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified System.Log.Logger as Log
import System.Posix.Directory.ByteString
text2Scientific :: Text -> Maybe Scientific
text2Scientific t =
case parseOnly rational t of
Left _ -> Nothing
Right s -> Just s
scientific2text :: Scientific -> Text
scientific2text n =
Text.pack $ case Scientific.floatingOrInteger n of
Left r -> show (r :: Double)
Right i -> show (i :: Integer)
strictifyEither :: Either a b -> S.Either a b
strictifyEither (Left x) = S.Left x
strictifyEither (Right x) = S.Right x
textElem :: Char -> Text -> Bool
textElem c = Text.any (==c)
-- | See System.FilePath.Posix
takeBaseName :: Text -> Text
takeBaseName fullname =
let afterLastSlash = List.last $ Text.splitOn "/" fullname
splitExtension = List.init $ Text.splitOn "." afterLastSlash
in Text.intercalate "." splitExtension
-- | See System.FilePath.Posix
takeDirectory :: Text -> Text
takeDirectory "" = "."
takeDirectory "/" = "/"
takeDirectory x =
let res = Text.dropWhileEnd (== '/') file
file = dropFileName x
in if Text.null res && not (Text.null file)
then file
else res
-- | Drop the filename.
--
-- > dropFileName x == fst (splitFileName x)
--
-- (See System.FilePath.Posix)
dropFileName :: Text -> Text
dropFileName = fst . splitFileName
-- | Split a filename into directory and file. 'combine' is the inverse.
--
-- > Valid x => uncurry (</>) (splitFileName x) == x || fst (splitFileName x) == "./"
-- > Valid x => isValid (fst (splitFileName x))
-- > splitFileName "file/bob.txt" == ("file/", "bob.txt")
-- > splitFileName "file/" == ("file/", "")
-- > splitFileName "bob" == ("./", "bob")
-- > Posix: splitFileName "/" == ("/","")
-- > Windows: splitFileName "c:" == ("c:","")
--
-- (See System.FilePath.Posix)
splitFileName :: Text -> (Text, Text)
splitFileName x =
(if Text.null dir then "./" else dir, name)
where
(dir, name) = splitFileName_ x
splitFileName_ y =
let (a,b) = Text.break (=='/') $ Text.reverse y
in (Text.reverse b, Text.reverse a)
-- | helper for hashmap, in case we want another kind of map ..
ifromList :: (Monoid m, At m, Foldable f) => f (Index m, IxValue m) -> m
{-# INLINABLE ifromList #-}
ifromList = foldl' (\curm (k,v) -> curm & at k ?~ v) mempty
ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k
{-# INLINABLE ikeys #-}
ikeys = HS.fromList . HM.keys
isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b
{-# INLINABLE isingleton #-}
isingleton k v = mempty & at k ?~ v
ifromListWith :: (Monoid m, At m, Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m
{-# INLINABLE ifromListWith #-}
ifromListWith f = foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty
iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m
{-# INLINABLE iinsertWith #-}
iinsertWith f k v m =
m & at k %~ mightreplace
where
mightreplace Nothing = Just v
mightreplace (Just x) = Just (f v x)
iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v
{-# INLINABLE iunionWith #-}
iunionWith = HM.unionWith
getFiles :: Text -> Text -> Text -> IO [Text]
getFiles moduledir subdir extension =
fmap concat
$ getDirContents moduledir
>>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir))
checkForSubFiles :: Text -> Text -> IO [Text]
checkForSubFiles extension dir =
catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case
Right o -> return ((map (\x -> dir <> "/" <> x) . filter (Text.isSuffixOf extension)) o )
Left _ -> return []
getDirContents :: Text -> IO [Text]
getDirContents x = fmap (filter (not . Text.all (=='.'))) (getDirectoryContents x)
getDirectoryContents :: Text -> IO [Text]
getDirectoryContents fpath = do
h <- openDirStream (Text.encodeUtf8 fpath)
let readHandle = do
fp <- readDirStream h
if BS.null fp
then return []
else fmap (Text.decodeUtf8 fp :) readHandle
out <- readHandle
closeDirStream h
pure out
isEmpty :: (Eq x, Monoid x) => x -> Bool
isEmpty = (== mempty)
-- | remove the '::' token from a text if any
dropInitialColons :: Text -> Text
dropInitialColons t = fromMaybe t (Text.stripPrefix "::" t)
loggerName :: String
loggerName = "language-puppet"
logDebug :: Text -> IO ()
logDebug = Log.debugM "language-puppet" . toS
logInfo :: Text -> IO ()
logInfo = Log.infoM "language-puppet" . toS
logInfoStr :: String -> IO ()
logInfoStr = Log.infoM "language-puppet"
logWarning :: Text -> IO ()
logWarning = Log.warningM "language-puppet" . toS
logError :: Text -> IO ()
logError = Log.errorM "language-puppet" . toS
logDebugStr :: String -> IO ()
logDebugStr = Log.debugM "language-puppet"