-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Utils
  ( module Utils
  , module Data.Containers.ListUtils
  ) 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 qualified Data.Traversable as Trav
import Data.Foldable as Utils (foldlM, foldrM)
import Data.Monoid (First, Sum(..), Endo)
import Data.Proxy
import Control.Arrow (Kleisli(..))
import Control.Arrow.Instances ()

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

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CBS
import qualified Data.Char as Char
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 Utils.HttpConditional as Utils
import Utils.Persist as Utils
import Utils.ARC as Utils
import Utils.LRU as Utils
import Utils.Set 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.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 qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch
import Control.Monad.Morph (hoist)
import Control.Monad.Fail
import Control.Monad.Trans.Cont (ContT, evalContT, callCC)
import qualified Control.Monad.State.Class as State

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.SecretBox as Saltine
import qualified Data.ByteString.Base64.URL as Base64
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Crypto.Saltine.Core.Auth as Auth
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 qualified Crypto.Random as Crypto

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 Network.HTTP.Types.Header as Wai

import Web.HttpApiData

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))

import Text.Hamlet (Translate)

import Data.Ratio ((%))

import Data.UUID (UUID)
import qualified Data.UUID as UUID

import Data.Containers.ListUtils

{-# 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)

getTranslate :: forall m site msg. (MonadHandler m, HandlerSite m ~ site, RenderMessage site msg) => m (Translate msg)
getTranslate = (toMarkup .) <$> getMessageRender


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, 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, 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, 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"

instance ToMarkup YamlValue where
  toMarkup = toMarkup . decodeUtf8 . Yaml.encode

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
                    , ..
                    }

selectRep' :: [(ContentType, a)] -> ContentType -> Maybe a
selectRep' cMap _ | null cMap = Nothing
selectRep' cMap' needle = asum
  [ guardOnM (needleMain == "*" && needleSub == "*") $ preview (folded . _2) cMap'
  , guardOnM (needleSub == "*") $ preview (folded . filtered (views _1 $ views _1 (== needleMain) . contentTypeTypes) . _2) cMap'
  , Map.lookup needle cMap
  , Map.lookup (noSpaces needle) cMap
  , Map.lookup (simpleContentType needle) cMap
  ]
  where
    cMap = Map.fromListWith const $ over _1 <$> [id, noSpaces, simpleContentType] <*> cMap'

    (needleMain, needleSub) = contentTypeTypes needle

    noSpaces = CBS.filter (/= ' ')

addAttrsClass :: Text -> [(Text, Text)] -> [(Text, Text)]
addAttrsClass cl attrs = ("class", cl') : noClAttrs
  where
    (clAttrs, noClAttrs) = partition (views _1 $ (== "class") . CI.mk) attrs
    cl' = Text.intercalate " " . nubOrd . filter (not . null) $ cl : (views _2 (Text.splitOn " ") =<< clAttrs)
  
---------------------
-- Text and String --
---------------------

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

nonBreakableDash :: Text -- used directly in several messages
nonBreakableDash = "‑"

-- | Deprecated, replace with Data.Text.elem, once a newer version of Data.Text is available
textElem :: Char -> Text -> Bool
textElem c = Text.any (c ==)

-- | remove all whitespace from Text
-- whereas Text.strip only removes leading and trailing whitespace
stripAll :: Text -> Text
stripAll = Text.filter (not . isSpace)

-- | Strips an optional prefix. Like `Data.Text.stripPrefix` but returns input text if the prefix is not matched, micking the behaviour of `dropPrefix` for `Data.Text`
dropPrefixText :: Text -> Text -> Text
-- dropPrefixText p t = fromMaybe t $ stripPrefix p t 
dropPrefixText p (stripPrefix p -> Just t) = t 
dropPrefixText _ other = other 

-- | take first line, only 
cropText :: Text -> Text
cropText (Text.take 255 -> t) = headDef t $ Text.lines t

tshowCrop :: Show a => a -> Text
tshowCrop = cropText . tshow

-- | strip leading and trailing whitespace and make case insensitive
-- also helps to avoid the need to import just for CI.mk
stripCI :: Text -> CI Text 
stripCI = CI.mk . Text.strip

-- | just to avoid adding an import for this
ciOriginal :: CI Text -> Text 
ciOriginal = CI.original

citext2lower :: CI Text -> Text 
citext2lower = Text.toLower . CI.original

-- avoids unnecessary imports
citext2string :: CI Text -> String 
citext2string = Text.unpack . CI.original

string2citext :: String -> CI Text
string2citext = CI.mk . Text.pack

-- | Convert or remove all non-ascii  characters, e.g. for filenames 
text2asciiAlphaNum :: Text -> Text
text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
  . Text.replace "ä" "ae"
  . Text.replace "Ä" "Ae"
  . Text.replace "Æ" "ae"
  . Text.replace "æ" "ae"
  . Text.replace "Å" "Aa"
  . Text.replace "å" "aa"
  . Text.replace "â" "a"
  . Text.replace "à" "a"
  . Text.replace "á" "a"
  . Text.replace "Ö" "Oe"
  . Text.replace "ö" "oe"
  . Text.replace "œ" "oe"  
  . Text.replace "Ø" "Oe"  
  . Text.replace "ø" "oe"  
  . Text.replace "ò" "o"
  . Text.replace "ò" "o"
  . Text.replace "ò" "o"
  . Text.replace "ó" "o"
  . Text.replace "Ü" "Ue"
  . Text.replace "ü" "ue"
  . Text.replace "ù" "u"
  . Text.replace "ú" "u"
  . Text.replace "û" "u"  
  . Text.replace "ë" "e"
  . Text.replace "ê" "e"
  . Text.replace "è" "e"
  . Text.replace "é" "e"
  . Text.replace "ï" "i"
  . Text.replace "î" "i"
  . Text.replace "ì" "i"
  . Text.replace "í" "i"
  . Text.replace "ß" "ss"  
  . Text.replace "ç" "c"
  . Text.replace "ş" "s"
  . Text.replace "ğ" "g"
  . Text.replace "ñ" "n"

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

citext2Html :: CI Text -> Html
citext2Html = toHtml . CI.original  

char2Text :: Char -> Text
char2Text c 
  | isSpace c = "<Space>"
  | otherwise = Text.singleton c

-- | 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:
text2markup :: Text -> Markup
text2markup t = [shamlet|#{t}|]

text2widget :: Text -> WidgetFor site ()
text2widget t = [whamlet|#{t}|]

show2widget :: Show a => a -> WidgetFor site ()
show2widget t = [whamlet|#{tshow t}|]

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

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

int2widget :: Int64 -> WidgetFor site ()
int2widget i = [whamlet|#{tshow i}|]

word2widget :: Word64 -> WidgetFor site ()
word2widget i = [whamlet|#{tshow i}|]

msg2widget :: RenderMessage site a => a -> WidgetFor site ()
msg2widget msg = [whamlet|_{msg}|]

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

-- | Burst Text into an unordered set of letters
charSet :: Text -> Set Char 
charSet = Text.foldl (flip Set.insert) mempty 
  
-- | Returns Nothing iff both texts are identical,
--   otherwise a differing character is returned, preferable from the first argument
textDiff :: Text -> Text -> Maybe Char
textDiff (Text.uncons -> xs) (Text.uncons -> ys)
  | Just (x,xt) <- xs 
  , Just (y,yt) <- ys 
    = if x == y 
        then textDiff xt yt
        else Just x
  | otherwise
    = fst <$> (xs <|> ys)

-- | 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

{-
-- | Captialize the first character and leave all others as they were 
textToCapital :: Text -> Text 
textToCapital s 
  | Just (h,t) <- Text.uncons s 
    = Text.Cons (Char.toUpper h) t 
  | otherwise = s

snakecase2camelcase :: Text -> Text
snakecase2camelcase t = Text.concat $ map textToCapital words
  where 
    words = Text.splitOn '_' t 
-}

-- also see Utils.Form.cfCommaSeparatedSet
commaSeparatedText :: Text -> Set Text
commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',')


-----------
-- 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

roundToPoints :: forall a. HasResolution a => Rational -> Fixed a
roundToPoints ((* toRational (resolution $ Proxy @a)) -> raw) = MkFixed $
  let (whole, frac) = properFraction raw
   in if | abs frac < abs (1 % 2)
           -> whole
         | otherwise
           -> succ whole

----------
-- 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

assertMonoid :: Monoid m => (m -> Bool) -> m -> m
assertMonoid f x = guardMonoid (f x) x

-- fold would also do, but is more risky if the Folable isn't Maybe
maybeMonoid :: Monoid m => Maybe m -> m
-- ^ Identify `Nothing` with `mempty`
maybeMonoid = fromMaybe mempty

------------
-- 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)

mTuple :: Applicative f => f a -> f b -> f (a, b)
mTuple = liftA2 (,)

-- From Data.Tuple.Extra
mapBoth :: (a -> b) -> (a,a) -> (b,b)
mapBoth f ~(a,b) = (f a, f b)

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

-- avoids some parenthesis within guards
notNull :: MonoFoldable mono => mono -> Bool
notNull = not . null

headDef :: a -> [a] -> a 
headDef _ (h:_) = h
headDef d    _  = d

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

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

minimumMaybe :: (MonoFoldable mono, Ord (Element mono)) => mono -> Maybe (Element mono)
minimumMaybe = fmap minimum . fromNullable

zipMaybes :: [Maybe a] -> [Maybe b] -> [(a,b)]
zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys
zipMaybes      (_:xs)      (_:ys) =         zipMaybes xs ys
zipMaybes        _              _ = []

-- | 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
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
--  Could be implemented using updateAssoc like so, but would add superfluous space at the end:
--  insertAttr attr valu = adjustAssoc (Text.append valu . Text.cons ' ') attr 

-- | Insert key-value pair into association list.
--   If the new value is null/mempty, the first occurrence of the key is removed. (Unlike Data.Map.insert)
--   If the key is already present, then the first associated value is replaced by the new one.
--   Note: Avoid association lists, if possible. See GHC.Data.List.SetOps
--   Some of our libraries use association lists for very few keys.
insertAssoc :: (Eq k, MonoFoldable v) => k -> v -> [(k,v)] -> [(k,v)]
insertAssoc key val = aux 
  where  
    aux [] = mbcons []
    aux (p@(k,_) : t)       
      | key == k  = mbcons t
      | otherwise = p : aux t 
    mbcons t 
      | onull val = t
      | otherwise = (key,val) : t

insertAssoc' :: (Eq k, Eq v, Monoid v) => k -> v -> [(k,v)] -> [(k,v)]
insertAssoc' key val = adjustAssoc (const val) key

-- | Update first matching key/value pair within an association list with a function.
--   If the key is not present, the update function is applied to mempty. (Unlike Data.Map.adjust)
--   If the result is mempty, the first occurrence of the key is removed.
--   Note: Avoid association lists, if possible. See GHC.Data.List.SetOps
adjustAssoc :: (Eq k, Eq v, Monoid v) => (v -> v) -> k -> [(k,v)] -> [(k,v)]
adjustAssoc upd key = aux
  where
    aux []        = mbcons key mempty []
    aux (p@(k,v) : t)
      | key == k  = mbcons k   v      t
      | otherwise = p : aux t
    mbcons k v t
      | v' == mempty =          t
      | otherwise    = (k,v') : t
      where
        v' = upd v

-- | 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

whenNonEmpty :: (Applicative f, Monoid a, MonoFoldable mono) => mono -> (NonEmpty (Element mono) -> f a) -> f a
whenNonEmpty (toList -> h:t) = ($ (h :| t))
whenNonEmpty _ = const $ pure mempty

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

pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a
pattern NonEmpty x xs = x :| xs
{-# COMPLETE NonEmpty #-}
        
checkAsc :: Ord a => [a] -> Bool
checkAsc (x:r@(y:_)) = x<=y && checkAsc r
checkAsc _ = True

----------
-- Sets --
----------
-- all functions that used to be here are now in Utils.Set

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

infixl 5 !!!


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

lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v
-- lookupSome :: Ord k => Map k [v] -> [k] -> [v] 
-- lookupSome m ks = ks >>= (m !!!)
lookupSome = (=<<) . (!!!)

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

maybeMap :: IsMap p => ContainerKey p -> Maybe (MapValue p) -> p
maybeMap k = foldMap (singletonMap k)

maybeMapWith :: IsMap p => (t -> MapValue p) -> ContainerKey p -> Maybe t -> p
maybeMapWith f k = foldMap $ singletonMap k . f 

-- | 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

setToMap :: (Ord k) => (v -> k) -> Set v -> Map k v
setToMap mkKey = Map.fromList . fmap (\x -> (mkKey x, x)) . Set.toList

mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v)
mapFM = sequenceA . mapF

mapFilterM :: (Monad m, Ord k) => (v -> m Bool) -> Map k v -> m (Map k v)
mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . assertMM (lift . f) . hoistMaybe)) (Map.keys m)

_MapUnit :: Iso' (Map k ()) (Set k)
_MapUnit = iso Map.keysSet $ Map.fromSet (const ())

---------------
-- 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

-- | change second of maybe pair to Nothing, if both are Just and equal
eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a)
eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing)
eq2nothing p = p
                
-- replaced by a more general formulation, see canonical
-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
-- null2nothing (Just x) | null x = Nothing
-- null2nothing other = other

-- | Swap 'Nothing' for 'Just' and vice versa
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


-- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a`
filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
filterMaybe c r@(Just x) | c x  = r
filterMaybe _ _                 = Nothing

-- | also referred to as whenJust and forM_
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

maybeVoid :: Monad m => Maybe (m a) -> m ()
maybeVoid = maybe (return ()) void

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)

-- | Monadic version of 'fromMaybe'
fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a
fromMaybeM act = maybeM act pure

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

-- | Monadic version of 'fromMaybe'
maybeThrowM :: (Exception e, MonadThrow m) => e -> m (Maybe a) -> m a
maybeThrowM = fromMaybeM . throwM


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

{-
--   Takes computations returnings @Maybes@; tries each one in order.
--   The first one to return a @Just@ wins. Returns @Nothing@ if all computations
--   return @Nothing@.
--   Copied from GHC.Data.Maybe, which could not be imported somehow.
firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
firstJustsM = foldlM go Nothing 
  where
    go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
    go Nothing          action = action
    go result@(Just _) _action = return result
-}

-- | Run the maybe computation repeatedly until the first Just is returned
--   or the number of maximum retries is exhausted.
--   So like Control.Monad.Loops.untilJust, but with a maximum number of attempts.
untilJustMaxM :: Monad m => Int -> m (Maybe a) -> m (Maybe a)
untilJustMaxM nmax act = go 0 
  where 
    go n | n >= nmax = return Nothing 
         | otherwise = do
            x <- act 
            case x of 
              Nothing      -> go $ succ n 
              res@(Just _) -> return res 

  
------------
-- 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  :: Applicative f => Either a b -> (a -> f ()) -> f ()
whenIsLeft (Left   x) f = f x
whenIsLeft (Right  _) _ = pure ()

whenIsRight :: Applicative f => Either a b -> (b -> f ()) -> f ()
whenIsRight (Right x) f = f x
whenIsRight (Left  _) _ = pure ()

{- Just a reminder for Steffen:
mapLeft :: (a -> c) -> Either a b -> Either c b 
mapLeft = over _Left 
-}

throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a
throwLeft = either throwM return

throwLeftM :: (MonadThrow m, Exception exc) => m (Either exc a) -> m a
throwLeftM = (throwLeft =<<)

actLeft :: Applicative f => Either a b -> (a -> f (Either c b)) -> f (Either c b)
actLeft (Left  x) f = f x
actLeft (Right y) _ = pure $ Right y

-- | like monadic bind for 'Either', but wrapped in another monad
--   ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead
actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c)
actRight (Left  x) _ = pure $ Left x
actRight (Right y) f = f y

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

-- maybeCatchAll :: MonadCatch m => m a -> m (Maybe a)
-- maybeCatchAll act = catch (Just <$> act) ignore
--   where 
--     ignore :: Monad m => SomeException -> m (Maybe a)
--     ignore _ = return Nothing

-- | Ignore all errors by returning Nothing. (Not sure if this function is a good idea)
maybeCatchAll :: MonadCatch m => m (Maybe a) -> m (Maybe a)
maybeCatchAll act = catch act ignore
  where 
    ignore :: Monad m => SomeException -> m (Maybe a)
    ignore _ = return Nothing

maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return
  
maybeExceptT' :: Monad m => e -> Maybe b -> ExceptT e m b
maybeExceptT' err = 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)


-------------
-- Functor --
-------------

infixl 4 <<$>>
(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
(<<$>>) f x = fmap f <$> x


------------
-- 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 x y = c >>= bool y x

-- | @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

allMOf, anyMOf :: Monad m => Getting (Endo [a]) s a -> s -> (a -> m Bool) -> m Bool
allMOf l x = allM $ x ^.. l
anyMOf l x = anyM $ x ^.. l

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)

-- use `foldMapM` instead
-- 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

forever' :: Monad m
         => a
         -> (a -> m a)
         -> m b
forever' start cont = cont start >>= flip forever' cont

foreverBreak :: Monad m
             => ((r -> ContT r m b) -> ContT r m a)
             -> m r
foreverBreak cont = evalContT . callCC $ forever . cont


sortOnM :: (Ord b, Monad m)
        => (a -> m b)
        -> [a]
        -> m [a]
sortOnM f = fmap (map snd . sortBy (comparing fst)) . mapM (\x -> (\y -> y `seq` (y, x)) <$> f x)

-- Stolen from Agda...

mapMM :: (Traversable t, Monad m) => (a -> m b) -> m (t a) -> m (t b)
mapMM f mxs = Trav.mapM f =<< mxs

forMM :: (Traversable t, Monad m) => m (t a) -> (a -> m b) -> m (t b)
forMM = flip mapMM

mapMM_ :: (Foldable t, Monad m) => (a -> m ()) -> m (t a) -> m ()
mapMM_ f mxs = Fold.mapM_ f =<< mxs

forMM_ :: (Foldable t, Monad m) => m (t a) -> (a -> m ()) -> m ()
forMM_ = flip mapMM_

-- | Monadic bind that also returns the intermediate value. This common pattern avoids the duplicated local identifiers required in the equivalent do-notation.
bind2 :: Monad m => m a -> (a -> m b) -> m (a, b)
bind2 ma ma2b = do
  a <- ma
  b <- ma2b a
  return (a,b)

bind3 :: Monad m => m a -> (a -> m b) -> (a -> b -> m c) -> m (a, b, c)
bind3 ma ma2b mab2c = do
  a <- ma
  b <- ma2b  a
  c <- mab2c a b
  return (a,b,c)


--------------
-- Foldable --
--------------

minLength :: ( Integral n
             , MonoFoldable mono
             )
          => n -> mono -> Bool
-- ^ @minLegth n xs = length xs >= n@
minLength l = go l . otoList
  where
    go l' _ | l' <= 0 = True
    go l' xs = case xs of
      _ : xs' -> go (pred l') xs'
      []      -> False

maxLength :: ( Integral n
             , MonoFoldable mono
             )
          => n -> mono -> Bool
-- ^ @maxLegth n xs = length xs <= n@
maxLength l = not . minLength (succ l)

-- anyone :: (Foldable t) => t a -> Maybe a
-- | return any single element from a foldable, if it is not null
anyone :: (Foldable t, Alternative f) => t a -> f a
anyone = Fold.foldr ((<|>).pure) empty


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

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

tellPoint :: forall mono m. (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

class IsWriterT t where
  runWriterT' :: (Monad m, Monoid w) => t w m a -> m (a, w)
  mapWriterT' :: (m (a, w) -> n (b, w')) -> t w m a -> t w' n b 
instance IsWriterT Strict.WriterT where
  runWriterT' = Strict.runWriterT
  mapWriterT' = Strict.mapWriterT
instance IsWriterT Lazy.WriterT where
  runWriterT' = Lazy.runWriterT
  mapWriterT' = Lazy.mapWriterT

evalWriterT :: (IsWriterT t, Monoid w, Monad m) => t w m a -> m a
evalWriterT = fmap fst . runWriterT'

censorM :: (IsWriterT t, Monad m)
        => (w -> m w)
        -> t w m a -> t w m a
censorM f = mapWriterT' (>>= \(x, w) -> (x, ) <$> f w)

-------------
-- 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
  | HeaderUploadToken                  
  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)

waiCustomHeader :: ToHttpApiData payload => CustomHeader -> payload -> Wai.Header
waiCustomHeader ident payload = (CI.mk . encodeUtf8 $ toPathPiece ident, toHeader payload)

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

data ContentDisposition = ContentInline | ContentAttachment
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
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 (decodeUtf8 $ CI.original hContentDisposition) 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

setCSPSandbox :: MonadHandler m => m ()
setCSPSandbox = replaceOrAddHeader "Content-Security-Policy" "sandbox;"

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

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

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)
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.secretbox_noncebytes + Saltine.secretbox_macbytes) $
    throwError EncodedSecretBoxCiphertextTooShort
  let (nonceBS, encrypted) = BS.splitAt Saltine.secretbox_noncebytes 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 :: forall a m.
                        ( FromJSON a, MonadError EncodedSecretBoxException m, MonadSecretBox m )
                     => Text -> m a
encodedSecretBoxOpen ciphertext = do
  sKey <- secretBoxKey
  encodedSecretBoxOpen' sKey ciphertext

encodedAuthSep :: Text
encodedAuthSep = "."

encodedAuth' :: ToJSON a
             => Auth.Key
             -> a -> Text
encodedAuth' aKey val = base64 msg <> encodedAuthSep <> base64 (Saltine.encode auth)
  where msg = toStrict $ Aeson.encode val
        auth = Auth.auth aKey msg
        base64 = decodeUtf8 . Base64.encodeUnpadded

data EncodedAuthException
  = EncodedAuthInvalidSeparation
  | EncodedAuthInvalidBase64 !String
  | EncodedAuthCouldNotDecodeAuthenticator
  | EncodedAuthInvalidAuthenticator
  | EncodedAuthCouldNotDecodePlaintext !String
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (Exception)

encodedAuthVerify' :: (FromJSON a, MonadError EncodedAuthException m)
                   => Auth.Key
                   -> Text -> m a
encodedAuthVerify' aKey bothEncoded = do
  (msgEncoded, authEncoded) <- case Text.splitOn encodedAuthSep bothEncoded of
    [msgEncoded, authEncoded] -> return (msgEncoded, authEncoded)
    _other -> throwError EncodedAuthInvalidSeparation
  authBS <- either (throwError . EncodedAuthInvalidBase64) return . Base64.decode $ encodeUtf8 authEncoded
  auth <- maybe (throwError EncodedAuthCouldNotDecodeAuthenticator) return $ Saltine.decode authBS
  msgDecoded <- either (throwError . EncodedAuthInvalidBase64) return . Base64.decode $ encodeUtf8 msgEncoded
  unless (Auth.verify aKey auth msgDecoded) $
    throwError EncodedAuthInvalidAuthenticator
  either (throwError . EncodedAuthCouldNotDecodePlaintext) return $ Aeson.eitherDecodeStrict' msgDecoded

class Monad m => MonadAuth m where
  authKey :: m Auth.Key

instance MonadAuth ((->) Auth.Key) where
  authKey = id

instance Monad m => MonadAuth (ReaderT Auth.Key m) where
  authKey = ask

encodedAuth :: ( ToJSON a, MonadAuth m )
            => a -> m Text
encodedAuth val = do
  aKey <- authKey
  return $ encodedAuth' aKey val

encodedAuthVerify :: ( FromJSON a, MonadError EncodedAuthException m, MonadAuth m )
                  => Text -> m a
encodedAuthVerify bothEncoded = do
  aKey <- authKey
  encodedAuthVerify' aKey bothEncoded



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) |]

-- TODO: replace with Utils.HttpConditional

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 hIfModifiedSince
    $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince)
    when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince)
      notModified

  addHeader (decodeUtf8 $ CI.original hLastModified) $ 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

minBy,maxBy :: (a -> a -> Ordering) -> a -> a -> a
minBy cmp a b = case a `cmp` b of
  GT -> b
  _  -> a
maxBy cmp a b = case a `cmp` b of
  LT -> b
  _  -> a

minOn,maxOn :: Ord b => (a -> b) -> a -> a -> a
minOn = minBy . comparing
maxOn = maxBy . comparing

inBetween:: Ord a => a -> (a,a) -> Bool
inBetween x (lower,upper) = lower <= x && x <= upper

-- | Given two values and a criterion, returns the unique argument that fulfills the criterion, if it exists
pickBetter :: a -> a -> (a -> Bool) -> Maybe a
pickBetter x y crit
    | cx == cy  = Nothing
    | cx        = Just x
    | otherwise = Just y
  where 
    cx = crit x 
    cy = crit y

reverseOrdering :: Ordering -> Ordering
reverseOrdering EQ = EQ
reverseOrdering GT = LT
reverseOrdering LT = GT

replaceEq :: Ordering -> Ordering -> Ordering
replaceEq r EQ    = r
replaceEq _ other = other

------------
-- 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 (randomInfiniteList $ uniform xs) <$> getSplit

randomInfiniteList :: MonadInterleave m => m a -> m [a]
randomInfiniteList gen = interleave $ (:) <$> gen <*> randomInfiniteList gen

randUUIDC :: MonadIO m
          => (forall m'. Monad m' => m' UUID -> (forall a. m a -> m' a) -> ConduitT i o m' r)
          -> ConduitT i o m r
randUUIDC cont = do
  drg <- liftIO Crypto.drgNew
  let
    mkUUID = do
      uuidBS <- State.state $ Crypto.randomBytesGenerate 16
      return . fromMaybe (error $ "Could not convert bytestring to uuid: " <> show uuidBS) . UUID.fromByteString $ fromStrict uuidBS
  evalStateC drg $ cont mkUUID lift

----------
-- 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, 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, 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


---------------
-- Normalize --
---------------

-- | Bad hack class for datatypes that have multiple inequal representations which ought to be identical, i.e. Just "" ~= Nothing
class Canonical a where 
  canonical :: a -> a


instance {-# OVERLAPPABLE #-} MonoFoldable mono => Canonical (Maybe mono) where
  canonical (Just t) | null t = Nothing
  canonical other = other

{-
instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where
  canonical r@(Just t) = let c = canonical t 
                         in if null c then Nothing else 
                              if t==c then r else Just c
  canonical other = other
-}

-- this instance is more of a convenient abuse of the class (expand to Foldable)
instance (Ord a, Canonical a) => Canonical (Set a) where
  canonical = Set.map canonical

instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome
  canonical Nothing     = Nothing
  canonical r@(Just t)  = let t' = Text.strip t in if
    | Text.null t' -> Nothing
    | t == t'      -> r
    | otherwise    -> Just t'

instance Canonical (Maybe (CI Text)) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome
  canonical Nothing     = Nothing
  canonical r@(Just t)  = let t' = CI.map Text.strip  t in if
    | mempty == t'-> Nothing
    | t == t'     -> r
    | otherwise   -> Just t'