module Utils
  ( module Utils
  , List.nub, List.nubBy
  ) where

import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket)

-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import qualified Data.Foldable as Fold
import Data.Foldable as Utils (foldlM, foldrM)
import Data.Monoid (First, Sum(..))
import Data.Proxy

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import qualified Data.ByteString as BS
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

-- import Utils.DB as Utils
import Utils.TH as Utils
import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Utils.Route as Utils
import Utils.Icon as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Utils.Parameters as Utils
import Utils.Cookies as Utils
import Utils.Cookies.Registered as Utils
import Utils.Session as Utils
import Utils.Csv as Utils
import Utils.I18n as Utils
import Utils.NTop as Utils

import Text.Blaze (Markup, ToMarkup)

import Data.Char (isDigit, isSpace, isAscii)
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)

import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Vector as V

import qualified Data.Conduit.List as C (mapMaybe)
import qualified Data.Conduit.Combinators as C

import Control.Lens hiding (uncons)
import Control.Lens as Utils (none)
import Control.Lens.Extras (is)
import Data.Set.Lens

import Control.Monad (zipWithM)
import Control.Arrow as Utils ((>>>))
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
import Control.Monad.Trans.Writer.Strict (execWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch
import Control.Monad.Morph (hoist)
import Control.Monad.Fail

import Language.Haskell.TH
import Language.Haskell.TH.Instances ()
import Instances.TH.Lift ()
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))

import Text.Shakespeare.Text (st)

import Data.Aeson (FromJSONKey)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Yaml as Yaml

import Data.Universe

import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
import qualified Data.ByteString.Base64.URL as Base64
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Crypto.Saltine.Class as Saltine
import qualified Crypto.Data.PKCS7 as PKCS7
import Crypto.MAC.KMAC (KMAC, HashSHAKE)
import qualified Crypto.MAC.KMAC as KMAC
import qualified Crypto.Hash as Crypto
import Crypto.Hash (HashAlgorithm, Digest)
import Crypto.Hash.Instances ()

import Data.ByteArray (ByteArrayAccess)

import Data.Fixed
-- import Data.Ratio ((%))

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import Network.Wai (requestMethod)

import Data.Time.Clock

import Data.List.NonEmpty (NonEmpty, nonEmpty)

import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice)

import Data.Constraint (Dict(..))

import Control.Monad.Random.Class (MonadSplit(getSplit), MonadRandom, MonadInterleave(interleave), uniform)
import Control.Monad.Random (RandomGen)
import qualified System.Random.Shuffle as Rand (shuffleM)
import qualified Control.Monad.Random.Lazy as LazyRand

import Data.Data (Data)
import qualified Data.Text.Lazy.Builder as Builder

import Data.Coerce

import System.FilePath as Utils (addExtension, isExtensionOf)
import System.FilePath (dropDrive)

import Yesod.Core.Types
import Yesod.Core.Types.Instances.Catch ()
import Control.Monad.Trans.Resource
import Control.Monad.Reader.Class (MonadReader(local))

{-# ANN module ("HLint: ignore Use asum" :: String) #-}


iconShortcuts -- declares constants for all known icons

-----------
-- Yesod --
-----------

newtype MsgRendererS site = MsgRenderer { render :: forall msg. RenderMessage site msg => msg -> Text }

getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
getMsgRenderer = do
  mr <- getMessageRender
  return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)


guardAuthResult :: MonadHandler m => AuthResult -> m ()
guardAuthResult AuthenticationRequired = notAuthenticated
guardAuthResult (Unauthorized t) = permissionDenied t
guardAuthResult Authorized = return ()

data UnsupportedAuthPredicate tag route = UnsupportedAuthPredicate tag route
  deriving (Eq, Ord, Typeable, Show)
instance (Show tag, Typeable tag, Show route, Typeable route) => Exception (UnsupportedAuthPredicate tag route)

unsupportedAuthPredicate :: ExpQ
unsupportedAuthPredicate = do
  logFunc <- logErrorS
  [e| \tag route -> do
        tRoute <- toTextUrl route
        $(return logFunc) "AccessControl" $ "!" <> toPathPiece tag <> " used on route that doesn't support it: " <> tRoute
        unauthorizedI (UnsupportedAuthPredicate tag route)
    |]

-- | allows conditional attributes in hamlet via *{..} syntax
maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)]
maybeAttribute _ _ Nothing  = []
maybeAttribute a c (Just v) = [(a,c v)]


newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
  deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
  deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)

instance ToContent PrettyValue where
  toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
instance ToTypedContent PrettyValue where
  toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
instance HasContentType PrettyValue where
  getContentType _ = typeJson

toPrettyJSON :: ToJSON a => a -> PrettyValue
toPrettyJSON = PrettyValue . toJSON


newtype YamlValue = YamlValue { unYamlValue :: Value }
  deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
  deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)

instance ToContent YamlValue where
  toContent = toContent . Yaml.encode
instance ToTypedContent YamlValue where
  toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
instance HasContentType YamlValue where
  getContentType _ = "text/vnd.yaml"

toYAML :: ToJSON a => a -> YamlValue
toYAML = YamlValue . toJSON


delimitInternalState :: forall site a. HandlerFor site a -> HandlerFor site a
-- | Switches the `InternalState` contained within the environment of `HandlerFor` to new one created with `bracket`
--
-- Therefor all `ResourceT`-Resources allocated within the inner `HandlerFor`-Action are collected at the end of it.
delimitInternalState act = bracket createInternalState closeInternalState $ \newInternalState -> local (renewEnviron newInternalState) act
  where
    renewEnviron newInternalState HandlerData{..}
      = HandlerData { handlerResource = newInternalState
                    , ..
                    }
  
  
---------------------
-- Text and String --
---------------------

-- DEPRECATED: use hasTickmark instead;
-- maybe reinstate if needed for @bewertung.txt@ files
-- tickmark :: IsString a => a
-- tickmark = fromString "✔"

-- | remove all Whitespace from Text
stripAll :: Text -> Text
stripAll = Text.filter (not . isSpace)

-- | Convert text as it is to Html, may prevent ambiguous types
-- This function definition is mainly for documentation purposes
text2Html :: Text -> Html
text2Html = toHtml

-- | Convert text as it is to Message, may prevent ambiguous types
-- This function definition is mainly for documentation purposes
text2message :: Text -> SomeMessage site
text2message = SomeMessage

toWgt :: ToMarkup a
      => a -> WidgetFor site ()
toWgt = toWidget . toHtml

-- Convenience Functions to avoid type signatures:
text2widget :: Text -> WidgetFor site ()
text2widget t = [whamlet|#{t}|]

citext2widget :: CI Text -> WidgetFor site ()
citext2widget t = [whamlet|#{CI.original t}|]

str2widget :: String -> WidgetFor site ()
str2widget s = [whamlet|#{s}|]

withFragment :: Monad m => MForm m (a, WidgetFor site ()) -> Markup -> MForm m (a, WidgetFor site ())
withFragment form html = flip fmap form $ over _2 (toWidget html >>)

-- | Convert `part` and `whole` into percentage including symbol
--   showing trailing zeroes and to decimal digits
textPercent :: Real a => a -> a -> Text
textPercent = textPercent' False 2

-- | Convert `part` and `whole` into percentage including symbol
--   `trailZero` shows trailing Zeros, `precision` is number of decimal digits
textPercent' :: Real a => Bool -> Int -> a -> a -> Text
textPercent' trailZero precision part whole
    | precision == 0 = showPercent (frac :: Uni)
    | precision == 1 = showPercent (frac :: Deci)
    | precision == 2 = showPercent (frac :: Centi)
    | precision == 3 = showPercent (frac :: Milli)
    | precision == 4 = showPercent (frac :: Micro)
    | otherwise      = showPercent (frac :: Pico)
  where
    frac :: forall a. HasResolution a => Fixed a
    frac = rationalToFixed $ (100*) $ toRational part / toRational whole

    showPercent :: HasResolution a => Fixed a -> Text
    showPercent f = pack $ showFixed trailZero f <> "%"


-- | Convert number of bytes to human readable format
textBytes :: forall a. Integral a => a -> Text
textBytes x
  | v < kb    = rshow  v     <>   "B"
  | v < mb    = rshow (v/kb) <> "KiB"
  | v < gb    = rshow (v/mb) <> "MiB"
  | otherwise = rshow (v/gb) <> "GiB"
 where
  v  = fromIntegral x
  kb :: Double
  kb = 1024
  mb = 1024 * kb
  gb = 1024 * mb
  rshow :: Double -> Text
  rshow = tshow . floorToDigits 1

textDuration :: forall a. Integral a => a -> Text
textDuration n' = view _2 $ foldr acc (toInteger n', "") units
  where units = sortOn (view _1)
          [ (86400, "d")
          , (3600,  "h")
          , (60,    "m")
          , (1,     "s")
          ]
        acc (mult, unit) (n, t)
          | unitCount > 0 = (unitRem, t <> tshow unitCount <> unit)
          | otherwise     = (n, t)
          where (unitCount, unitRem) = n `divMod` mult


stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounterCI = CI.map stepTextCounter

stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounter text
    | (Just i) <- readMay number =
        let iplus1 = tshow (succ i :: Int)
            zeroip = justifyRight (length number) '0' iplus1
        in  prefix <> zeroip <> suffix
    | otherwise = text
  where -- no splitWhile nor findEnd in Data.Text
    suffix =                        takeWhileEnd (not . isDigit) text
    number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
    prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text

-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo  Ue3bung00322 34 (H)"
-- ["12",".ProMo  Ue","3","bung","00322"," ","34"," (H)"]

fromText :: (IsString a, Textual t) => t -> a
fromText = fromString . unpack


-----------
-- Fixed --
-----------

rationalToFixed :: forall a. HasResolution a => Rational -> Fixed a
rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy @a)))

rationalToFixed3 :: Rational -> Fixed E3
rationalToFixed3 = rationalToFixed

rationalToFixed2 :: Rational -> Fixed E2
rationalToFixed2 = rationalToFixed

realToFixed :: forall a n. (Real n, HasResolution a) => n -> Fixed a
realToFixed = rationalToFixed . toRational

----------
-- Bool --
----------

-- | Logical implication, readable synonym for (<=) which appears the wrong way around
implies :: Bool -> Bool -> Bool
implies True x = x
implies _    _ = True



-------------
-- Numeric --
-------------

-- | round n to nearest multiple of m
roundToNearestMultiple :: Int -> Int -> Int
roundToNearestMultiple m n = (n `div` m + 1) * m

roundToDigits :: (RealFrac a, Integral b) => b -> a -> a
roundToDigits d x = fromInteger (round $ x * prec) / prec
  where prec = 10^d

floorToDigits :: (RealFrac a, Integral b) => b -> a -> a
floorToDigits d x = fromInteger (floor $ x * prec) / prec
  where prec = 10^d

-- | Integral division, but rounded upwards.
ceilingDiv :: Integral a => a -> a -> a
ceilingDiv d n = (d+n-1) `div` n

-- | Integral division, rounded to custom digit; convenience function for hamlets
roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c
roundDiv digits numerator denominator
  = roundToDigits digits $ fromIntegral numerator / fromIntegral denominator

-- | @cutOffCoPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@; 0 meaning very and 1 meaning not at all
--
--  @offset@ specifies minimum result value, unless the @full@ is equal to @achieved@
-- 
--  Useful for heat maps, with offset giving a visual step between completed and not yet completed
cutOffCoPercent :: Rational -> Rational -> Rational -> Rational
cutOffCoPercent (abs -> offset) (abs -> full) (abs -> achieved)
  | 0 <= achieved, achieved < full
  , full /= 0
  = offset + (1-offset) * (1 - percent)
  | full <= achieved = 0
  | otherwise = 1
  where
    percent = achieved / full

-- | @cutOffPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@@; 1 meaning very and 0 meaning not at all
--
--  @offset@ specifies minimum result value, unless @achieved@ is zero
-- 
--  Useful for heat maps, with offset giving a visual step between zero and nonzero
cutOffPercent :: Rational -> Rational -> Rational -> Rational
cutOffPercent (abs -> offset) (abs -> full) (abs -> achieved)
  | 0 < achieved, achieved <= full
  , full /= 0
  = offset + (1-offset) * percent
  | achieved <= 0 = 0
  | otherwise = 1
  where
    percent = achieved / full

_Integer :: (RealFrac a, Integral b) => Prism' a b
_Integer = prism' fromIntegral $ fmap (view _1) . assertM' (has $ _2 . only 0) . properFraction

------------
-- Monoid --
------------

-- | Ignore warnings for unused variables
notUsed :: Monoid m => a -> m
notUsed = const mempty

guardMonoid :: Monoid m => Bool -> m -> m
guardMonoid False _ = mempty
guardMonoid True  x = x

------------
-- Tuples --
------------

fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
snd3 :: (a,b,c) -> b
snd3 (_,y,_) = y
trd3 :: (a,b,c) -> c
trd3 (_,_,z) = z

-- Further projections are available via TemplateHaskell, defined in Utils.Common:
-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
-- snd3 = $(projNI 3 2)



-----------
-- Lists --
-----------

-- notNull = not . null

lastMaybe :: [a] -> Maybe a
lastMaybe []    = Nothing
lastMaybe [h]   = Just h
lastMaybe (_:t) = lastMaybe t

lastMaybe' :: [a] -> Maybe a
lastMaybe' l = fmap snd $ l ^? _Snoc


-- | Merge/Add any attribute-value pair to an existing list of such pairs.
--   If the attribute exists, the new valu will be prepended, separated by a single empty space
--   Also see `Utils.mergeAttrs`
insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
insertAttr attr valu = aux
  where
    aux :: [(Text,Text)] -> [(Text,Text)]
    aux [] = [(attr,valu)]
    aux (p@(a,v) : t)
      | attr==a   = (a, Text.append valu $ Text.cons ' ' v) : t
      | otherwise = p : aux t


-- | Copied form Util from package ghc
partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
-- ^ Uses a function to determine which of two output lists an input element should join
partitionWith _ [] = ([],[])
partitionWith f (x:xs) = case f x of
                         Left  b -> (b:bs, cs)
                         Right c -> (bs, c:cs)
    where (bs,cs) = partitionWith f xs

nonEmpty' :: Alternative f => [a] -> f (NonEmpty a)
nonEmpty' = maybe empty pure . nonEmpty

nubOn :: Eq b => (a -> b) -> [a] -> [a]
nubOn = List.nubBy . ((==) `on`)

dropWhileM :: (IsSequence seq, Monad m) => (Element seq -> m Bool) -> seq -> m seq
dropWhileM p xs'
  | Just (x, xs) <- uncons xs'
  = bool (return xs') (dropWhileM p xs) =<< p x
  | otherwise = return xs'


isSubsequenceOfBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
isSubsequenceOfBy _   []       _     = True
isSubsequenceOfBy _   _        []    = False
isSubsequenceOfBy cmp a@(x:a') (y:b)
  | x `cmp` y = isSubsequenceOfBy cmp a' b
  | otherwise = isSubsequenceOfBy cmp a  b

withoutSubsequenceBy :: (a -> b -> Bool) -> [a] -> [b] -> Maybe [b]
withoutSubsequenceBy cmp = go []
  where go acc []       b     = Just $ reverse acc ++ b
        go _   _        []    = Nothing
        go acc a@(x:a') (y:b)
          | x `cmp` y = go acc a' b
          | otherwise = go (y:acc) a b
        

----------
-- Sets --
----------

-- | Intersection of multiple sets. Returns empty set for empty input list
setIntersections :: Ord a => [Set a] -> Set a
setIntersections []    = Set.empty
setIntersections (h:t) = foldl' Set.intersection h t

setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList

-- | Symmetric difference of two sets.
setSymmDiff :: Ord a => Set a -> Set a -> Set a
setSymmDiff x y = (x `Set.difference` y) `Set.union` (y `Set.difference` x)

setProduct :: Set a -> Set b -> Set (a, b)
-- ^ Depends on the valid internal structure of the given sets
setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs

setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)

setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
setFromFunc = Set.fromList . flip filter universeF

----------
-- Maps --
----------

infixl 5 !!!


(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
(!!!) m k = fromMaybe mempty $ Map.lookup k m

groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]

partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
partMap = Map.fromListWith mappend

invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
invertMap = groupMap . map swap . Map.toList

-- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons)
countMapElems :: (Ord v) => Map k v -> Map v Int
countMapElems = Map.fromListWith (+) . map (\(_k,v)->(v,1)) . Map.toList

mapSymmDiff :: (Ord k, Ord v) => Map k v -> Map k v -> Map k (Set v)
mapSymmDiff a b = Map.fromListWith Set.union . map (over _2 Set.singleton) . Set.toList $ (setSymmDiff `on` assocsSet) a b

assocsSet :: Ord (k, v) => Map k v -> Set (k, v)
assocsSet = setOf folded . imap (,)

mapF :: (Ord k, Finite k) => (k -> v) -> Map k v
mapF = flip Map.fromSet $ Set.fromList universeF

partitionKeysEither :: Map (Either k1 k2) v -> (Map k1 v, Map k2 v)
partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) . over _1 (Map.mapKeysMonotonic . view $ singular _Left) . Map.partitionWithKey (\k _ -> is _Left k)

mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v)
mapFromSetM = (sequenceA .) . Map.fromSet

---------------
-- Functions --
---------------

-- curryN, uncurryN see Utils.TH

-- | Just @flip (.)@ for convenient formatting in some cases,
--   Deprecated in favor of Control.Arrow.(>>>)
compose :: (a -> b) -> (b -> c) -> (a -> c)
compose = flip (.)


-----------
-- Maybe --
-----------

toMaybe :: Bool -> a -> Maybe a
toMaybe True  = Just
toMaybe False = const Nothing

toNothing :: a -> Maybe b
toNothing = const Nothing

toNothingS :: String -> Maybe b
toNothingS = const Nothing

-- | Swap 'Nothing' for 'Just' and vice versa
-- This belongs into Module 'Utils' but we have a weird cyclic
-- dependency
flipMaybe :: b -> Maybe a -> Maybe b
flipMaybe x Nothing  = Just x
flipMaybe _ (Just _) = Nothing

-- | Deep alternative to avoid any occurrence of Nothing at all costs, left-biased
deepAlt :: Maybe (Maybe a) -> Maybe (Maybe a) -> Maybe (Maybe a)
deepAlt Nothing        altSnd  = altSnd
deepAlt altFst         Nothing = altFst
deepAlt (Just Nothing) altSnd  = altSnd
deepAlt altFst         _       = altFst

maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap

whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x
whenIsJust Nothing  _ = return ()

ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
ifMaybeM Nothing dft _  = return dft
ifMaybeM (Just x) _ act = act x

maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if
maybePositive a | a > 0     = Just a
                | otherwise = Nothing

positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
positiveSum = maybePositive . getSum

maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act

maybeT :: Monad m => m a -> MaybeT m a -> m a
maybeT x m = runMaybeT m >>= maybe x return

maybeT_ :: Monad m => MaybeT m () -> m ()
maybeT_ = void . runMaybeT

hoistMaybe :: MonadPlus m => Maybe a -> m a
-- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@
hoistMaybe = maybe mzero return

hoistMaybeM :: MonadPlus m => m (Maybe a) -> m a
hoistMaybeM = (=<<) hoistMaybe

catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
catchIfMaybeT p act = catchIf p (lift act) (const mzero)

catchMaybeT :: forall p m e a. (MonadCatch m, Exception e) => p e -> m a -> MaybeT m a
catchMaybeT _ act = catch (lift act) (const mzero :: e -> MaybeT m a)

catchMPlus :: forall p m e a. (MonadPlus m, MonadCatch m, Exception e) => p e -> m a -> m a
catchMPlus _ = handle (const mzero :: e -> m a)

catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> Bool) -> m a -> m a
catchIfMPlus p act = catchIf p act (const mzero)

fromMaybeT :: MaybeT Identity a -> Maybe a
fromMaybeT = runIdentity . runMaybeT

mcons :: Maybe a -> [a] -> [a]
mcons Nothing  xs = xs
mcons (Just x) xs = x:xs

-- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap
ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
ignoreNothing _ Nothing y = y
ignoreNothing _ x Nothing = x
ignoreNothing f (Just x) (Just y) = Just $ f x y

-- `NTop` moved to `Utils.NTop`

exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT

formResultToMaybe :: Alternative m => FormResult a -> m a
formResultToMaybe (FormSuccess x) = pure x
formResultToMaybe  _              = empty

maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a
maybeThrow exc = maybe (throwM exc) return

maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a
maybeThrowM excM = maybe (throwM =<< excM) return

mapMaybeM :: ( Monad m
             , MonoFoldable (f a)
             , MonoPointed (f b)
             , Monoid (f b)
             ) => (Element (f a) -> MaybeT m (Element (f b))) -> f a -> m (f b)
mapMaybeM f = execWriterT . mapM_ (void . runMaybeT . (lift . tell . opoint <=< hoist lift . f))

forMaybeM :: ( Monad m
             , MonoFoldable (f a)
             , MonoPointed (f b)
             , Monoid (f b)
             ) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b)
forMaybeM = flip mapMaybeM

------------
-- Either --
------------

maybeLeft  :: Either a b -> Maybe a
maybeLeft  (Left a) = Just a
maybeLeft  _ = Nothing

maybeRight :: Either a b -> Maybe b
maybeRight (Right b) = Just b
maybeRight _ = Nothing

whenIsLeft  :: Monad m => Either a b -> (a -> m ()) -> m ()
whenIsLeft (Left   x) f = f x
whenIsLeft (Right  _) _ = return ()

whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
whenIsRight (Right x) f = f x
whenIsRight (Left  _) _ = return ()


---------------
-- Exception --
---------------

maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return

maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return

maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
maybeTExceptT err act = maybeExceptT err $ runMaybeT act

maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act

whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
whenExceptT b err = when b $ throwE err

whenMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
whenMExceptT b err = when b $ lift err >>= throwE

guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
guardExceptT b err = unless b $ throwE err

guardMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
guardMExceptT b err = unless b $ lift err >>= throwE

exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT f g = either f g <=< runExceptT

catchIfExceptT :: (MonadCatch m, Exception e) => (e -> e') -> (e -> Bool) -> m a -> ExceptT e' m a
catchIfExceptT err p act = catchIf p (lift act) (throwE . err)

catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)

throwExceptT :: ( Exception e, MonadThrow m )
             => ExceptT e m a -> m a
throwExceptT = exceptT throwM return

generalFinally :: MonadMask m => m a -> (ExitCase a -> m b) -> m a
generalFinally action finalizer = view _1 <$> generalBracket (return ()) (const finalizer) (const action)

------------
-- Monads --
------------

shortCircuitM :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a
shortCircuitM sc binOp mx my = do
  x <- mx
  if
    | sc x      -> return x
    | otherwise -> binOp x <$> my


guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f

assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f

assertMM :: MonadPlus m => (a -> m Bool) -> m a -> m a
assertMM f x = do
  x' <- x
  guardM $ f x'
  return x'

assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
assertM_ f x = guard . f =<< x

assertM' :: Alternative m => (a -> Bool) -> a -> m a
assertM' f x = x <$ guard (f x)

assertMM' :: MonadPlus m => (a -> m Bool) -> a -> m a
assertMM' f x = x <$ guardM (f x)

guardOn :: forall m a. Alternative m => Bool -> a -> m a
guardOn b x = x <$ guard b

guardOnM :: Alternative m => Bool -> m a -> m a
guardOnM b x = guard b *> x

guardMOn :: MonadPlus m => m Bool -> a -> m a
guardMOn b x = x <$ guardM b

guardMOnM :: MonadPlus m => m Bool -> m a -> m a
guardMOnM b x = guardM b *> x

-- Some Utility Functions from Agda.Utils.Monad
-- | Monadic if-then-else.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM c m m' =
    do  b <- c
        if b then m else m'

-- | @ifNotM mc = ifM (not <$> mc)@  from Agda.Utils.Monad
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM c = flip $ ifM c

-- | Short-circuiting monadic boolean function, copied from Andreas Abel's utility function
and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
and2M ma mb = ifM ma mb (return False)
or2M ma = ifM ma (return True)

andM, orM :: (MonoFoldable mono, Element mono ~ m Bool, Monad m) => mono -> m Bool
andM = ofoldl' and2M (return True)
orM = ofoldl' or2M (return False)

-- | Short-circuiting monady any
allM, anyM :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m Bool) -> m Bool
allM xs f = andM . fmap f $ otoList xs
anyM xs f = orM . fmap f $ otoList xs

ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono)
ofoldr1M f (otoList -> x:xs) = foldrM f x xs
ofoldr1M _ _ = error "otoList of NonNull is empty"
ofoldl1M f (otoList -> x:xs) = foldlM f x xs
ofoldl1M _ _ = error "otoList of NonNull is empty"

foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty

ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b
ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty

partitionM :: forall mono m .
  ( MonoFoldable mono
  , Monoid mono
  , MonoPointed mono
  , Monad m)
    => (Element mono -> m Bool) -> mono -> m (mono, mono)
partitionM crit = ofoldlM dist mempty
  where
    dist :: (mono,mono) -> Element mono -> m (mono,mono)
    dist acc x = do
      okay <- crit x
      return $ if
        | okay ->      acc `mappend` (opoint x, mempty)
        | otherwise -> acc `mappend` (mempty, opoint x)

mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList

mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
mconcatForM = flip mconcatMapM

findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero


yesodTimeout :: ( MonadHandler m
                , MonadUnliftIO m
                )
             => (HandlerSite m -> NominalDiffTime) -- ^ Calculate timeout
             -> a -- ^ Default value
             -> m a -- ^ Computation
             -> m a -- ^ Result of computation or default value, if timeout is reached
yesodTimeout getTimeout timeoutRes act = do
  timeoutLength <- getsYesod getTimeout
  diffTimeout timeoutLength timeoutRes act

diffTimeout :: MonadUnliftIO m
            => NominalDiffTime -> a -> m a -> m a
diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout timeoutMicro act
  where
    timeoutMicro
      = let (MkFixed micro :: Micro) = realToFrac timeoutLength
         in fromInteger micro

------------
-- Writer --
------------

tellM :: (MonadTrans t, MonadWriter x (t m), Monad m) => m x -> t m ()
tellM = tell <=< lift

tellPoint :: (MonadWriter mono m, MonoPointed mono) => Element mono -> m ()
tellPoint = tell . opoint
  
tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m ()
tellMPoint = tellM . fmap opoint

-------------
-- Conduit --
-------------

peekN :: forall a o m n. (Integral n, Monad m) => n -> ConduitT a o m [a]
peekN n = do
  peeked <- catMaybes <$> replicateM (fromIntegral n) await
  mapM_ leftover peeked
  return peeked

peekWhile :: forall a o m. Monad m => (a -> Bool) -> ConduitT a o m [a]
peekWhile p = do
  let go acc = do
        next <- await
        case next of
          Nothing -> return (reverse acc, Nothing)
          Just x
            | p x       -> go $ x : acc
            | otherwise -> return (reverse acc, Just x)
  (peeked, failed) <- go []
  mapM_ leftover $ peeked ++ hoistMaybe failed
  return peeked

anyMC, allMC :: forall a o m. Monad m => (a -> m Bool) -> ConduitT a o m Bool
anyMC f = C.mapM f .| orC
allMC f = C.mapM f .| andC

yieldMMany :: forall mono m a. (Monad m, MonoFoldable mono) => m mono -> ConduitT a (Element mono) m ()
yieldMMany = C.yieldMany <=< lift

eitherC :: Monad m => ConduitT l o m () -> ConduitT r o m () -> ConduitT (Either l r) o m ()
eitherC lC rC = void $ sequenceConduits [C.mapMaybe (preview _Left) .| lC, C.mapMaybe (preview _Right) .| rC]

takeWhileMC :: forall a m. Monad m => (a -> m Bool) -> ConduitT a a m ()
takeWhileMC f = loop
  where loop = do
          x <- await
          whenIsJust x $ \x' ->
            whenM (lift $ f x') $ yield x' *> loop

takeWhileTime :: forall a m. MonadIO m => NominalDiffTime -> ConduitT a a m ()
takeWhileTime maxT = do
  sTime <- liftIO getCurrentTime
  takeWhileMC . const $ do
    now <- liftIO getCurrentTime
    let tDelta = now `diffUTCTime` sTime
    return $ tDelta < maxT

runPeekN :: forall o m n. (Integral n, Monad m) => n -> ConduitT () o m () -> m (ConduitT () o m (), [o])
runPeekN n src = over (mapped . _1) unsealConduitT $ src $$+ peekN n

runPeekWhile :: forall o m. Monad m => (o -> Bool) -> ConduitT () o m () -> m (ConduitT () o m (), [o])
runPeekWhile f src = over (mapped . _1) unsealConduitT $ src $$+ peekWhile f

-----------------
-- Alternative --
-----------------

choice :: forall f mono a. (Alternative f, MonoFoldable mono, Element mono ~ f a) => mono -> f a
choice = foldr (<|>) empty

--------------
-- Sessions --
--------------

-- Moved to Utils.Session

-------------
-- Cookies --
-------------

-- Moved to Utils.Cookies.Registered

--------------------
-- GET Parameters --
--------------------

-- Moved to Utils.Parameters

---------------------------------
-- Custom HTTP Headers --
---------------------------------

data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit | HeaderMassInputShortcircuit | HeaderAlerts | HeaderDBTableCanonicalURL | HeaderDryRun
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

instance Universe CustomHeader
instance Finite CustomHeader
nullaryPathPiece ''CustomHeader (intercalate "-" . drop 1 . splitCamel)

lookupCustomHeader :: (MonadHandler m, PathPiece result) => CustomHeader -> m (Maybe result)
lookupCustomHeader ident = (=<<) (fromPathPiece <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident)

hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool
hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident)

addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload) => CustomHeader -> payload -> m ()
addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload)
replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload)

------------------
-- HTTP Headers --
------------------

data ContentDisposition = ContentInline | ContentAttachment
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ContentDisposition
instance Finite ContentDisposition
nullaryPathPiece ''ContentDisposition $ camelToPathPiece' 1

setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath -> m ()
-- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader`
--
-- Takes care of correct formatting and encoding of non-ascii filenames
setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal
  where
    headerVal
      | Just fName <- mFName
      , Text.all isAscii fName
      , Text.all (not . flip elem ['"', '\\']) fName
      = [st|#{toPathPiece cd}; filename="#{fName}"|]
      | Just fName <- mFName
      = let encoded = decodeUtf8 . urlEncode True $ encodeUtf8 fName
         in [st|#{toPathPiece cd}; filename*=UTF-8''#{encoded}|]
      | otherwise
      = toPathPiece cd

------------------
-- Cryptography --
------------------

data SecretBoxEncoding = SecretBoxShort | SecretBoxPretty
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe SecretBoxEncoding
instance Finite SecretBoxEncoding
instance Default SecretBoxEncoding where
  def = SecretBoxShort

encodedSecretBoxBlocksize :: Word8
-- | `encodedSecretBox'` tries to hide plaintext length by ensuring the message
--   length (before addition of HMAC and nonce) is always a multiple of
--   `encodedSecretBlocksize`.
--   Bigger blocksizes hide exact message length better but lead to longer messages
encodedSecretBoxBlocksize = maxBound


encodedSecretBox' :: ( ToJSON a, MonadIO m )
                  => SecretBox.Key
                  -> SecretBoxEncoding
                  -> a -> m Text
encodedSecretBox' sKey pretty val = liftIO $ do
  nonce <- SecretBox.newNonce
  let
    encrypt = SecretBox.secretbox sKey nonce
    base64 = decodeUtf8 . Base64.encode
    pad = PKCS7.padBytesN (fromIntegral encodedSecretBoxBlocksize)
    attachNonce = mappend $ Saltine.encode nonce
    chunk
      | SecretBoxPretty <- pretty = Text.intercalate "\n" . Text.chunksOf 76
      | otherwise                 = id

  return . chunk . base64 . attachNonce . encrypt . pad . toStrict $ Aeson.encode val

data EncodedSecretBoxException
  = EncodedSecretBoxInvalidBase64 !String
  | EncodedSecretBoxInvalidPadding
  | EncodedSecretBoxCiphertextTooShort
  | EncodedSecretBoxCouldNotDecodeNonce
  | EncodedSecretBoxCouldNotOpenSecretBox
  | EncodedSecretBoxCouldNotDecodePlaintext !String
  deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Exception EncodedSecretBoxException

encodedSecretBoxOpen' :: (FromJSON a, MonadError EncodedSecretBoxException m)
                      => SecretBox.Key
                      -> Text -> m a
encodedSecretBoxOpen' sKey chunked = do
  let unchunked = stripAll chunked
  decoded <- either (throwError . EncodedSecretBoxInvalidBase64) return . Base64.decode $ encodeUtf8 unchunked

  unless (BS.length decoded >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
    throwError EncodedSecretBoxCiphertextTooShort
  let (nonceBS, encrypted) = BS.splitAt Saltine.secretBoxNonce decoded
  nonce <- maybe (throwError EncodedSecretBoxCouldNotDecodeNonce) return $ Saltine.decode nonceBS
  padded <- maybe (throwError EncodedSecretBoxCouldNotOpenSecretBox) return $ SecretBox.secretboxOpen sKey nonce encrypted

  unpadded <- maybe (throwError EncodedSecretBoxInvalidPadding) return $ PKCS7.unpadBytesN (fromIntegral encodedSecretBoxBlocksize) padded

  either (throwError . EncodedSecretBoxCouldNotDecodePlaintext) return $ Aeson.eitherDecodeStrict' unpadded

class Monad m => MonadSecretBox m where
  secretBoxKey :: m SecretBox.Key

instance MonadSecretBox ((->) SecretBox.Key) where
  secretBoxKey = id

instance Monad m => MonadSecretBox (ReaderT SecretBox.Key m) where
  secretBoxKey = ask

encodedSecretBox :: ( ToJSON a, MonadSecretBox m, MonadIO m )
                 => SecretBoxEncoding
                 -> a -> m Text
encodedSecretBox pretty val = do
  sKey <- secretBoxKey
  encodedSecretBox' sKey pretty val

encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, MonadSecretBox m )
                     => Text -> m a
encodedSecretBoxOpen ciphertext = do
  sKey <- secretBoxKey
  encodedSecretBoxOpen' sKey ciphertext


kmaclazy :: forall a string key ba chunk.
            ( HashSHAKE a
            , ByteArrayAccess string
            , ByteArrayAccess key
            , ByteArrayAccess chunk
            , LazySequence ba chunk
            )
         => string
         -> key
         -> ba
         -> KMAC a
kmaclazy str k = KMAC.finalize . KMAC.updates (KMAC.initialize @a str k) . toChunks

emptyHash :: forall a. HashAlgorithm a => Q (TExp (Digest a))
-- ^ Hash of `mempty`
--
-- Computationally preferrable to computing the hash at runtime
emptyHash = TH.liftTyped $ Crypto.hashFinalize Crypto.hashInit

-------------
-- Caching --
-------------

cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b
cachedByBinary k = cachedBy (toStrict $ Binary.encode k)

cacheIdentHere :: Q Exp
cacheIdentHere = TH.lift =<< location

cachedHere :: Q Exp
cachedHere = do
  loc <- location
  [e| cachedByBinary loc |]

cachedHereBinary :: Q Exp
cachedHereBinary = do
  loc <- location
  [e| \k -> cachedByBinary (loc, k) |]

hashToText :: Hashable a => a -> Text
hashToText = Text.dropWhileEnd (== '=') . decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash

setEtagHashable, setWeakEtagHashable :: (MonadHandler m, Hashable a) => a -> m ()
setEtagHashable = setEtag . hashToText
setWeakEtagHashable = setWeakEtag . hashToText

setLastModified :: MonadHandler m => UTCTime -> m ()
setLastModified lastModified = do
  rMethod <- requestMethod <$> waiRequest

  when (rMethod `elem` safeMethods) $ do
    ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader "If-Modified-Since"
    $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince)
    when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince)
      notModified

  addHeader "Last-Modified" $ formatRFC1123 lastModified
  where
    precision :: NominalDiffTime
    precision = 1

    safeMethods = [ methodGet, methodHead, methodOptions ]

-- | Adapter for memoization of five-argument function
for5 :: (((k1, k2, k3, k4, k5) -> mv) -> (k1, k2, k3, k4, k5) -> mv) -> (k1 -> k2 -> k3 -> k4 -> k5 -> mv) -> k1 -> k2 -> k3 -> k4 -> k5 -> mv
for5 m f a b c d e = m (\(a',b',c',d',e') -> f a' b' c' d' e') (a,b,c,d,e)

--------------
-- Lattices --
--------------

foldJoin :: (MonoFoldable mono, BoundedJoinSemiLattice (Element mono)) => mono -> Element mono
foldJoin = foldr (\/) bottom

foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono
foldMeet = foldr (/\) top

-----------------
-- Constraints --
-----------------

type DictMaybe constr a = Maybe (Dict constr, a)

pattern DictJust :: constr => a -> DictMaybe constr a
pattern DictJust a = Just (Dict, a)

-------------
-- Ord --
-------------

clamp :: Ord a
      => a -- ^ Minimum
      -> a -- ^ Maximum
      -> a -- ^ Value
      -> a -- ^ Clamped Value
clamp minVal maxVal = clampMin minVal . clampMax maxVal

clampMin, clampMax :: Ord a
                   => a -- ^ Boundary
                   -> a -- ^ Value
                   -> a -- ^ Clamped Value
clampMin = max
clampMax = min

------------
-- Random --
------------

unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a]
unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp

unstableSortOn :: (MonadRandom m, Ord b) => (a -> b) -> [a] -> m [a]
unstableSortOn = unstableSortBy . comparing

unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a]
unstableSort = unstableSortBy compare

uniforms :: (RandomGen g, MonadSplit g m, Foldable t) => t a -> m [a]
uniforms xs = LazyRand.evalRand go <$> getSplit
  where go = (:) <$> interleave (uniform xs) <*> go

----------
-- Lens --
----------

mpreview :: (MonadPlus m, MonadReader s m) => Getting (First a) s a -> m a
mpreview = hoistMaybe <=< preview

mpreviews :: (MonadPlus m, MonadReader s m) => Getting (First b) s a -> (a -> b) -> m b
mpreviews a f = hoistMaybe =<< previews a f

-------------
-- HashMap --
-------------

newtype MergeHashMap k v = MergeHashMap { unMergeHashMap :: HashMap k v }
  deriving (Show, Generic, Typeable, Data)
  deriving newtype ( Eq, Ord, Hashable
                   , Functor, Foldable, NFData
                   , ToJSON
                   )

makePrisms ''MergeHashMap
makeWrapped ''MergeHashMap

type instance Element (MergeHashMap k v) = v
  
instance MonoFoldable (MergeHashMap k v)
instance MonoFunctor (MergeHashMap k v)
instance MonoTraversable (MergeHashMap k v)

instance Traversable (MergeHashMap k) where
  traverse = _MergeHashMap . traverse

instance FunctorWithIndex k (MergeHashMap k)
instance TraversableWithIndex k (MergeHashMap k) where
  itraverse = _MergeHashMap .> itraverse
instance FoldableWithIndex k (MergeHashMap k)

instance (Eq k, Hashable k, Semigroup v) => Semigroup (MergeHashMap k v) where
  (MergeHashMap a) <> (MergeHashMap b) = MergeHashMap $ HashMap.unionWith (<>) a b
instance (Eq k, Hashable k, Semigroup v) => Monoid (MergeHashMap k v) where
  mempty = MergeHashMap HashMap.empty
instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeHashMap k v) where
  parseJSON = case Aeson.fromJSONKey of
      Aeson.FromJSONKeyCoerce -> Aeson.withObject "HashMap ~Text" $
          coerce @(Aeson.Parser (HashMap k v)) @(Aeson.Parser (MergeHashMap k v)) . fmap HashMap.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.<?> Aeson.Key k) . HashMap.toList
      Aeson.FromJSONKeyText f -> Aeson.withObject "HashMap" $
          fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
      Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
          fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
      Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
          fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
    where
      parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
      parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
        where
          p = Aeson.withArray "(k, v)" $ \ab ->
              let n = V.length ab
              in if n == 2
                   then (,) <$> parseJSONElemAtIndex keyParser 0 ab
                            <*> parseJSONElemAtIndex valParser 1 ab
                   else fail $ "cannot unpack array of length " ++
                               show n ++ " into a pair"

      parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
      parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx


newtype MergeMap k v = MergeMap { unMergeMap :: Map k v }
  deriving (Show, Generic, Typeable, Data)
  deriving newtype ( Eq, Ord
                   , Functor, Foldable, NFData
                   , ToJSON
                   )

makePrisms ''MergeMap
makeWrapped ''MergeMap

type instance Element (MergeMap k v) = v
  
instance MonoFoldable (MergeMap k v)
instance MonoFunctor (MergeMap k v)
instance MonoTraversable (MergeMap k v)

instance Traversable (MergeMap k) where
  traverse = _MergeMap . traverse

instance FunctorWithIndex k (MergeMap k)
instance TraversableWithIndex k (MergeMap k) where
  itraverse = _MergeMap .> itraverse
instance FoldableWithIndex k (MergeMap k)

instance (Ord k, Semigroup v) => Semigroup (MergeMap k v) where
  (MergeMap a) <> (MergeMap b) = MergeMap $ Map.unionWith (<>) a b
instance (Ord k, Semigroup v) => Monoid (MergeMap k v) where
  mempty = MergeMap Map.empty
instance (Ord k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeMap k v) where
  parseJSON = case Aeson.fromJSONKey of
      Aeson.FromJSONKeyCoerce -> Aeson.withObject "Map ~Text" $
          coerce @(Aeson.Parser (Map k v)) @(Aeson.Parser (MergeMap k v)) . fmap Map.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.<?> Aeson.Key k) . HashMap.toList
      Aeson.FromJSONKeyText f -> Aeson.withObject "Map" $
          fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList
      Aeson.FromJSONKeyTextParser f -> Aeson.withObject "Map" $
          fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList
      Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
          fmap (MergeMap . Map.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
    where
      parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
      parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
        where
          p = Aeson.withArray "(k, v)" $ \ab ->
              let n = V.length ab
              in if n == 2
                   then (,) <$> parseJSONElemAtIndex keyParser 0 ab
                            <*> parseJSONElemAtIndex valParser 1 ab
                   else fail $ "cannot unpack array of length " ++
                               show n ++ " into a pair"

      parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
      parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx

  
--------------
-- FilePath --
--------------

ensureExtension :: String -> FilePath -> FilePath
ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName

infixr 4 <//>

(<//>) :: FilePath -> FilePath -> FilePath
dir <//> file = dir </> dropDrive file


----------------
-- TH Dungeon --
----------------

makePrisms ''ExitCase