{-# OPTIONS_HADDOCK ignore-exports #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes       #-}
-- | General specific prelude for language-puppet
-- | Customization of the Protolude with extra specific utilities.
module XPrelude.Extra (
      module Exports
    , String
    , Container
    , unwrapError
    , isEmpty
    , dropInitialColons
    , textElem
    , getDirectoryContents
    , takeBaseName
    , strictifyEither
    , scientific2text
    , text2Scientific
    , getFiles
    , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith
    -- * Logger
    , loggerName
    , logDebug
    , logInfo
    , logInfoStr
    , logWarning
    , logError
    , logDebugStr
) 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                     as Exports (fail)
import           Control.Monad.Trans.Except        as Exports (except, throwE, catchE)
import           Control.Monad.Trans.Maybe         as Exports (runMaybeT)
import           Data.Aeson                        as Exports (FromJSON, ToJSON, fromJSON, toJSON)
import           Data.HashMap.Strict               as Exports (HashMap)
import           Data.HashSet                      as Exports (HashSet)
import           Data.Scientific                   as Exports (Scientific)
import           Data.Set                          as Exports (Set)
import           Data.String                       as Exports (IsString (..))
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 Map
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
import           XPrelude.PP

type Container = Map.HashMap Text

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

-- | 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) => HashMap k v -> HS.HashSet k
{-# INLINABLE ikeys #-}
ikeys = HS.fromList . Map.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) -> HashMap k v -> HashMap k v -> HashMap k v
{-# INLINABLE iunionWith #-}
iunionWith = Map.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"

-- | In case of a Left error, print and exit immediately.
unwrapError :: Doc -> Either PrettyError a -> IO a
unwrapError desc = either exit pure
    where
      exit = \err -> putDoc (display err) >> exitFailure
      display err = red desc <> ":" <+> getError err