diff --git a/guide.cabal b/guide.cabal index 83ddcf6..0afd384 100644 --- a/guide.cabal +++ b/guide.cabal @@ -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 diff --git a/src/Config.hs b/src/Config.hs index dba018a..6c87231 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -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) diff --git a/src/JS.hs b/src/JS.hs index 4e134b7..cf9c0b4 100644 --- a/src/JS.hs +++ b/src/JS.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs index 4b69153..e118268 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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))) diff --git a/src/Markdown.hs b/src/Markdown.hs index 9abc9b0..b58b080 100644 --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs index b96faea..158f0c7 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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' diff --git a/src/Utils.hs b/src/Utils.hs index 3663511..4cbfab8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/src/View.hs b/src/View.hs index 49d4e27..460c22a 100644 --- a/src/View.hs +++ b/src/View.hs @@ -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