2004 lines
68 KiB
Haskell
2004 lines
68 KiB
Haskell
-- 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'
|