aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-11-30 01:23:04 +03:00
Code Issues Projects Releases Wiki Activity

Add section separators to Guide.Utils

Browse Source
This commit is contained in:
Artyom 2017-01-30 03:31:48 +03:00
parent 08090b5075
commit eb5e896e33
No known key found for this signature in database
GPG Key ID: B8E35A33FF522710
1 changed files with 40 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
src/Guide/Utils.hs
View File

@ -103,6 +103,10 @@ import Language.Haskell.Meta (parseExp)
import Data.Generics.Uniplate.Data (transform) import Data.Generics.Uniplate.Data (transform)
----------------------------------------------------------------------------
-- Lists
----------------------------------------------------------------------------
-- | Move the -1st element that satisfies the predicate- up. -- | Move the -1st element that satisfies the predicate- up.
moveUp :: (a -> Bool) -> [a] -> [a] moveUp :: (a -> Bool) -> [a] -> [a]
moveUp p (x:y:xs) = if p y then y : x : xs else x : moveUp p (y:xs) moveUp p (x:y:xs) = if p y then y : x : xs else x : moveUp p (y:xs)
@ -129,9 +133,17 @@ ordNub = go mempty
go s (x:xs) | x `S.member` s = go s xs go s (x:xs) | x `S.member` s = go s xs
| otherwise = x : go (S.insert x s) xs | otherwise = x : go (S.insert x s) xs
----------------------------------------------------------------------------
-- Eq
----------------------------------------------------------------------------
equating :: Eq b => (a -> b) -> (a -> a -> Bool) equating :: Eq b => (a -> b) -> (a -> a -> Bool)
equating f = (==) `on` f equating f = (==) `on` f
----------------------------------------------------------------------------
-- Urls
----------------------------------------------------------------------------
type Url = Text type Url = Text
sanitiseUrl :: Url -> Maybe Url sanitiseUrl :: Url -> Maybe Url
@ -150,6 +162,10 @@ makeSlug =
T.toLower . T.toLower .
T.map (\x -> if x == '_' || x == '/' then '-' else x) T.map (\x -> if x == '_' || x == '/' then '-' else x)
----------------------------------------------------------------------------
-- IP
----------------------------------------------------------------------------
deriveSafeCopySimple 0 'base ''IPv4 deriveSafeCopySimple 0 'base ''IPv4
deriveSafeCopySimple 0 'base ''IPv6 deriveSafeCopySimple 0 'base ''IPv6
deriveSafeCopySimple 0 'base ''IP deriveSafeCopySimple 0 'base ''IP
@ -159,6 +175,10 @@ sockAddrToIP (Network.SockAddrInet _ x) = Just (IPv4 (fromHostAddress x))
sockAddrToIP (Network.SockAddrInet6 _ _ x _) = Just (IPv6 (fromHostAddress6 x)) sockAddrToIP (Network.SockAddrInet6 _ _ x _) = Just (IPv6 (fromHostAddress6 x))
sockAddrToIP _ = Nothing sockAddrToIP _ = Nothing
----------------------------------------------------------------------------
-- Uid
----------------------------------------------------------------------------
-- | Unique id, used for many things – categories, items, and anchor ids. -- | Unique id, used for many things – categories, items, and anchor ids.
newtype Uid a = Uid {uidToText :: Text} newtype Uid a = Uid {uidToText :: Text}
deriving (Eq, Ord, Show, PathPiece, T.Buildable, Hashable, A.ToJSON) deriving (Eq, Ord, Show, PathPiece, T.Buildable, Hashable, A.ToJSON)
@ -206,17 +226,29 @@ data Node
uid_ :: Uid Node -> Attribute uid_ :: Uid Node -> Attribute
uid_ = id_ . uidToText uid_ = id_ . uidToText
----------------------------------------------------------------------------
-- Lucid
----------------------------------------------------------------------------
includeJS :: Monad m => Url -> HtmlT m () includeJS :: Monad m => Url -> HtmlT m ()
includeJS url = with (script_ "") [src_ url] includeJS url = with (script_ "") [src_ url]
includeCSS :: Monad m => Url -> HtmlT m () includeCSS :: Monad m => Url -> HtmlT m ()
includeCSS url = link_ [rel_ "stylesheet", type_ "text/css", href_ url] includeCSS url = link_ [rel_ "stylesheet", type_ "text/css", href_ url]
----------------------------------------------------------------------------
-- Spock
----------------------------------------------------------------------------
atomFeed :: MonadIO m => Atom.Feed -> ActionCtxT ctx m () atomFeed :: MonadIO m => Atom.Feed -> ActionCtxT ctx m ()
atomFeed feed = do atomFeed feed = do
setHeader "Content-Type" "application/atom+xml; charset=utf-8" setHeader "Content-Type" "application/atom+xml; charset=utf-8"
bytes $ T.encodeUtf8 (T.pack (XML.ppElement (Atom.xmlFeed feed))) bytes $ T.encodeUtf8 (T.pack (XML.ppElement (Atom.xmlFeed feed)))
----------------------------------------------------------------------------
-- Template Haskell
----------------------------------------------------------------------------
hs :: QuasiQuoter hs :: QuasiQuoter
hs = QuasiQuoter { hs = QuasiQuoter {
quoteExp = either fail TH.lift . parseExp, quoteExp = either fail TH.lift . parseExp,
@ -235,6 +267,10 @@ dumpSplices x = do
bangNotStrict :: Q Bang bangNotStrict :: Q Bang
bangNotStrict = bang noSourceUnpackedness noSourceStrictness bangNotStrict = bang noSourceUnpackedness noSourceStrictness
----------------------------------------------------------------------------
-- SafeCopy
----------------------------------------------------------------------------
{- | {- |
A change from one version of a record (one constructor, several fields) to A change from one version of a record (one constructor, several fields) to
another version. We only record the latest version, so we have to be able to another version. We only record the latest version, so we have to be able to
@ -544,5 +580,9 @@ migrateVer tyName ver constructors = do
lam1E (varP arg) (caseE (varE arg) (map return branches')) lam1E (varP arg) (caseE (varE arg) (map return branches'))
----------------------------------------------------------------------------
-- Orphan instances
----------------------------------------------------------------------------
instance MonadThrow m => MonadThrow (HtmlT m) where instance MonadThrow m => MonadThrow (HtmlT m) where
throwM e = lift $ throwM e throwM e = lift $ throwM e