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

Use ilist and text-all

Browse Source
This commit is contained in:
Artyom 2016-06-12 22:35:13 +03:00
parent 4b363d035d
commit 57afee3b64
8 changed files with 63 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
guide.cabal
View File

@ -64,6 +64,7 @@ executable guide
, hashable
, http-types
, iproute == 1.7.*
, ilist
, lucid >= 2.9.5 && < 3
, megaparsec == 4.4.*
, microlens-platform >= 0.2.3
@ -77,8 +78,7 @@ executable guide
, shortcut-links >= 0.4.2
, stm-containers == 0.2.10.*
, template-haskell
, text
, text-format
, text-all == 0.3.*
, time >= 1.5
, transformers
, wai

2
src/Config.hs
View File

@ -18,7 +18,7 @@ where
-- General
import BasePrelude
-- Text
import Data.Text (Text)
import Data.Text.All (Text)
-- JSON
import Data.Aeson as Aeson
import Data.Aeson.Encode.Pretty as Aeson hiding (Config)

51
src/JS.hs
View File

@ -17,12 +17,9 @@ module JS where
-- General
import BasePrelude
-- Text
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
-- Formatting and interpolation
import qualified Data.Text.Buildable as Format
import qualified Data.Text.All as T
import Data.Text.All (Text)
-- Interpolation
import NeatInterpolation
-- Local
@ -31,7 +28,7 @@ import Utils
-- | Javascript code.
newtype JS = JS {fromJS :: Text}
deriving (Show, Format.Buildable, Monoid)
deriving (Show, T.Buildable, Monoid)
-- | A concatenation of all Javascript functions defined in this module.
allJSFunctions :: JS
@ -77,9 +74,9 @@ instance ToJS JS where
instance ToJS Text where
toJS = JS . escapeJSString
instance ToJS Integer where
toJS = JS . tshow
toJS = JS . T.show
instance ToJS Int where
toJS = JS . tshow
toJS = JS . T.show
instance ToJS (Uid a) where
toJS = toJS . uidToText
@ -121,20 +118,20 @@ class JSFunction a where
-- This generates function definition
instance JSFunction JS where
makeJSFunction fName fParams fDef =
JS $ format "function {}({}) {\n{}}\n"
(fName, T.intercalate "," fParams, fDef)
JS $ T.format "function {}({}) {\n{}}\n"
(fName, T.intercalate "," fParams, fDef)
-- This generates a function that takes arguments and produces a Javascript
-- function call
instance JSParams a => JSFunction (a -> JS) where
makeJSFunction fName _fParams _fDef = \args ->
JS $ format "{}({});"
(fName, T.intercalate "," (map fromJS (jsParams args)))
JS $ T.format "{}({});"
(fName, T.intercalate "," (map fromJS (jsParams args)))
-- This isn't a standalone function and so it doesn't have to be listed in
-- 'allJSFunctions'.
assign :: ToJS x => JS -> x -> JS
assign v x = JS $ format "{} = {};" (v, toJS x)
assign v x = JS $ T.format "{} = {};" (v, toJS x)
-- TODO: all links here shouldn't be absolute [absolute-links]
@ -670,12 +667,12 @@ deleteItem =
escapeJSString :: Text -> Text
escapeJSString s =
TL.toStrict . B.toLazyText $
B.singleton '"' <> quote s <> B.singleton '"'
T.toStrict $
T.bsingleton '"' <> quote s <> T.bsingleton '"'
where
quote q = case T.uncons t of
Nothing -> B.fromText h
Just (!c, t') -> B.fromText h <> escape c <> quote t'
Nothing -> T.toBuilder h
Just (!c, t') -> T.toBuilder h <> escape c <> quote t'
where
(h, t) = T.break isEscape q
-- 'isEscape' doesn't mention \n, \r and \t because they are handled by
@ -691,26 +688,24 @@ escapeJSString s =
escape '\t' = "\\t"
escape c
| c < '\x20' || c == '\x2028' || c == '\x2029' =
B.fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h
"\\u" <> T.left 4 '0' (T.hex (fromEnum c))
| otherwise =
B.singleton c
where
h = showHex (fromEnum c) ""
T.bsingleton c
newtype JQuerySelector = JQuerySelector Text
deriving (ToJS, Format.Buildable)
deriving (ToJS, T.Buildable)
selectId :: Text -> JQuerySelector
selectId x = JQuerySelector $ format "#{}" [x]
selectId x = JQuerySelector $ T.format "#{}" [x]
selectUid :: Uid Node -> JQuerySelector
selectUid x = JQuerySelector $ format "#{}" [x]
selectUid x = JQuerySelector $ T.format "#{}" [x]
selectClass :: Text -> JQuerySelector
selectClass x = JQuerySelector $ format ".{}" [x]
selectClass x = JQuerySelector $ T.format ".{}" [x]
selectParent :: JQuerySelector -> JQuerySelector
selectParent x = JQuerySelector $ format ":has(> {})" [x]
selectParent x = JQuerySelector $ T.format ":has(> {})" [x]
selectChildren :: JQuerySelector -> JQuerySelector -> JQuerySelector
selectChildren a b = JQuerySelector $ format "{} > {}" (a, b)
selectChildren a b = JQuerySelector $ T.format "{} > {}" (a, b)

11
src/Main.hs
View File

@ -23,10 +23,9 @@ import Lens.Micro.Platform hiding ((&))
-- Containers
import qualified Data.Map as M
-- Text
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import Data.Text.All (Text)
import qualified Data.Text.All as T
import qualified Data.Text.Lazy.All as TL
-- Paths
import System.FilePath ((</>))
-- Network
@ -644,8 +643,8 @@ itemToFeedEntry baseUrl category item =
Atom.entryContent = Just (Atom.HTMLContent (TL.unpack entryContent)) }
where
entryLink = baseUrl </>
T.unpack (format "{}#item-{}"
(categorySlug category, item^.uid))
T.unpack (T.format "{}#item-{}"
(categorySlug category, item^.uid))
entryContent = Lucid.renderText (renderItemForFeed category item)
entryBase = Atom.nullEntry
(T.unpack (uidToText (item^.uid)))

4
src/Markdown.hs
View File

@ -42,8 +42,8 @@ import Lens.Micro.Platform hiding ((&))
import Control.Monad.Writer
import Control.Monad.State
-- Text
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.All as T
import Data.Text.All (Text)
-- ByteString
import qualified Data.ByteString.Lazy as BSL
-- Parsing

16
src/Types.hs
View File

@ -139,9 +139,11 @@ import Lens.Micro.Platform hiding ((&))
-- Containers
import qualified Data.Map as M
import Data.Map (Map)
-- Lists
import Data.List.Index
-- Text
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.All as T
import Data.Text.All (Text)
-- Time
import Data.Time
-- Network
@ -438,7 +440,7 @@ makeFields ''Category
categorySlug :: Category -> Text
categorySlug category =
format "{}-{}" (makeSlug (category^.title), category^.uid)
T.format "{}-{}" (makeSlug (category^.title), category^.uid)
-- Old version, needed for safe migration. It can most likely be already
-- deleted (if a checkpoint has been created), but it's been left here as a
@ -1154,7 +1156,7 @@ restoreCategory catId pos = do
Nothing -> return (Left "category not found in deleted categories")
Just category -> do
categoriesDeleted %= deleteFirst (hasUid catId)
categories %= insertAt pos category
categories %= insertAtGuaranteed pos category
return (Right ())
restoreItem :: Uid Item -> Int -> Acid.Update GlobalState (Either String ())
@ -1167,7 +1169,7 @@ restoreItem itemId pos = do
let item = fromJust (find (hasUid itemId) (category^.itemsDeleted))
let category' = category
& itemsDeleted %~ deleteFirst (hasUid itemId)
& items %~ insertAt pos item
& items %~ insertAtGuaranteed pos item
categories . each . filtered ourCategory .= category'
categoriesDeleted . each . filtered ourCategory .= category'
return (Right ())
@ -1187,7 +1189,7 @@ restoreTrait itemId traitId pos = do
(Just trait, _) -> do
let item' = item
& prosDeleted %~ deleteFirst (hasUid traitId)
& pros %~ insertAt pos trait
& pros %~ insertAtGuaranteed pos trait
let category' = category
& items . each . filtered (hasUid itemId) .~ item'
& itemsDeleted . each . filtered (hasUid itemId) .~ item'
@ -1197,7 +1199,7 @@ restoreTrait itemId traitId pos = do
(_, Just trait) -> do
let item' = item
& consDeleted %~ deleteFirst (hasUid traitId)
& cons %~ insertAt pos trait
& cons %~ insertAtGuaranteed pos trait
let category' = category
& items . each . filtered (hasUid itemId) .~ item'
& itemsDeleted . each . filtered (hasUid itemId) .~ item'

42
src/Utils.hs
View File

@ -15,16 +15,11 @@ NoImplicitPrelude
module Utils
(
-- * Text
format,
tshow,
-- * Lists
moveUp,
moveDown,
deleteFirst,
deleteAt,
insertAt,
insertAtGuaranteed,
ordNub,
-- * 'Eq'
@ -77,15 +72,8 @@ import qualified Data.Set as S
-- Hashable (needed for Uid)
import Data.Hashable
-- Text
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
-- Formatting
import Data.Text.Format hiding (format)
import qualified Data.Text.Format as Format
import qualified Data.Text.Format.Params as Format
import qualified Data.Text.Buildable as Format
import Data.Text.All (Text)
import qualified Data.Text.All as T
-- Network
import qualified Network.Socket as Network
import Data.IP
@ -104,15 +92,6 @@ import Data.SafeCopy
import Language.Haskell.TH
-- | Format a string (a bit like 'Text.Printf.printf' but with different
-- syntax). The version in "Data.Text.Format" returns lazy text, but we
-- use strict text everywhere.
format :: Format.Params ps => Format -> ps -> Text
format f ps = TL.toStrict (Format.format f ps)
tshow :: Show a => a -> Text
tshow = T.pack . show
-- | Move the -1st element that satisfies the predicate- up.
moveUp :: (a -> Bool) -> [a] -> [a]
moveUp p (x:y:xs) = if p y then (y:x:xs) else x : moveUp p (y:xs)
@ -127,15 +106,10 @@ deleteFirst :: (a -> Bool) -> [a] -> [a]
deleteFirst _ [] = []
deleteFirst f (x:xs) = if f x then xs else x : deleteFirst f xs
deleteAt :: Int -> [a] -> [a]
deleteAt _ [] = []
deleteAt 0 (_:xs) = xs
deleteAt i (x:xs) = x : deleteAt (i-1) xs
insertAt :: Int -> a -> [a] -> [a]
insertAt _ a [] = [a]
insertAt 0 a xs = a:xs
insertAt n a (x:xs) = x : insertAt (n-1) a xs
insertAtGuaranteed :: Int -> a -> [a] -> [a]
insertAtGuaranteed _ a [] = [a]
insertAtGuaranteed 0 a xs = a:xs
insertAtGuaranteed n a (x:xs) = x : insertAtGuaranteed (n-1) a xs
ordNub :: Ord a => [a] -> [a]
ordNub = go mempty
@ -176,7 +150,7 @@ sockAddrToIP _ = Nothing
-- | Unique id, used for many things – categories, items, and anchor ids.
newtype Uid a = Uid {uidToText :: Text}
deriving (Eq, Ord, Show, PathPiece, Format.Buildable, Hashable)
deriving (Eq, Ord, Show, PathPiece, T.Buildable, Hashable)
-- See Note [acid-state]
deriveSafeCopySimple 2 'extension ''Uid

27
src/View.hs
View File

@ -61,9 +61,8 @@ import Control.Monad.Random
import qualified Data.Map as M
import Data.Tree
-- Text
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text (Text)
import qualified Data.Text.All as T
import Data.Text.All (Text)
import NeatInterpolation
-- Web
import Lucid hiding (for_)
@ -296,7 +295,7 @@ renderEdits globalState edits = do
let editBlocks = groupBy (equating getIP) edits
let ipNum = length $ groupWith getIP edits
h1_ $ toHtml $
format "Pending edits (IPs: {}, blocks: {})" (ipNum, length editBlocks)
T.format "Pending edits (IPs: {}, blocks: {})" (ipNum, length editBlocks)
for_ editBlocks $ \editBlock -> div_ $ do
blockNode <- thisNode
h2_ $ do
@ -1075,8 +1074,8 @@ renderItemNotes category item = cached (CacheItemNotes (item^.uid)) $ do
this = JS.selectId thisId
editingSectionUid <- randomLongUid
div_ [id_ thisId, class_ "item-notes"] $ do
let notesLink = format "/haskell/{}#{}"
(categorySlug category, thisId)
let notesLink = T.format "/haskell/{}#{}"
(categorySlug category, thisId)
a_ [href_ notesLink] $
strong_ "Notes"
@ -1091,8 +1090,8 @@ renderItemNotes category item = cached (CacheItemNotes (item^.uid)) $ do
-- list of items). Well, actually it doesn't happen
-- yet (at the moment of writing), but it might start
-- happening and then it's better to be prepared.
fullLink = format "/haskell/{}#{}"
(categorySlug category, id')
fullLink = T.format "/haskell/{}#{}"
(categorySlug category, id')
a_ [href_ fullLink, onclick_ handler] $
renderInlines def is
renderTree children
@ -1166,7 +1165,7 @@ renderItemForFeed category item = do
-- Utils
onPageLoad :: Monad m => JS -> HtmlT m ()
onPageLoad js = script_ $ format "$(document).ready(function(){{}});" [js]
onPageLoad js = script_ $ T.format "$(document).ready(function(){{}});" [js]
emptySpan :: Monad m => Text -> HtmlT m ()
emptySpan w = span_ [style_ ("margin-left:" <> w)] mempty
@ -1174,7 +1173,7 @@ emptySpan w = span_ [style_ ("margin-left:" <> w)] mempty
-- Use inputValue to get the value (works with input_ and textarea_)
onEnter :: JS -> Attribute
onEnter handler = onkeydown_ $
format "if (event.keyCode == 13) {{} return false;}" [handler]
T.format "if (event.keyCode == 13) {{} return false;}" [handler]
textInput :: Monad m => [Attribute] -> HtmlT m ()
textInput attrs = input_ (type_ "text" : attrs)
@ -1186,7 +1185,7 @@ clearInput :: JS
clearInput = JS "this.value = '';"
onFormSubmit :: (JS -> JS) -> Attribute
onFormSubmit f = onsubmit_ $ format "{} return false;" [f (JS "this")]
onFormSubmit f = onsubmit_ $ T.format "{} return false;" [f (JS "this")]
button :: Monad m => Text -> [Attribute] -> JS -> HtmlT m ()
button value attrs handler =
@ -1239,7 +1238,7 @@ markdownEditor attr (view mdText -> s) submit cancel = do
textarea_ ([uid_ textareaUid, autocomplete_ "off", class_ "big fullwidth"]
++ attr) $
toHtml s
let val = JS $ format "document.getElementById(\"{}\").value" [textareaUid]
let val = JS $ T.format "document.getElementById(\"{}\").value" [textareaUid]
button "Save" [] $
submit val
emptySpan "6px"
@ -1258,7 +1257,7 @@ smallMarkdownEditor
-> HtmlT m ()
smallMarkdownEditor attr (view mdText -> s) submit mbCancel = do
textareaId <- randomLongUid
let val = JS $ format "document.getElementById(\"{}\").value" [textareaId]
let val = JS $ T.format "document.getElementById(\"{}\").value" [textareaId]
textarea_ ([class_ "fullwidth", uid_ textareaId, autocomplete_ "off",
onEnter (submit val)] ++ attr) $
toHtml s
@ -1290,7 +1289,7 @@ categoryNodeId category = "category-" <> uidToText (category^.uid)
itemLink :: Category -> Item -> Text
itemLink category item =
format "/haskell/{}#{}" (categorySlug category, itemNodeId item)
T.format "/haskell/{}#{}" (categorySlug category, itemNodeId item)
-- See Note [show-hide]; wheh changing these, also look at 'JS.switchSection'.
shown, noScriptShown :: Attribute