diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +First release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Aelve + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Aelve nor the names of other contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# shortcut-links + +Package! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/shortcut-links.cabal b/shortcut-links.cabal new file mode 100644 --- /dev/null +++ b/shortcut-links.cabal @@ -0,0 +1,34 @@ +name: shortcut-links +version: 0.1.0.0 +synopsis: Link shortcuts for use in text markup +description: + This package is a database of link shortcuts. A Markdown example: + @[Google](\@w)@ turns into . +homepage: http://github.com/aelve/shortcut-links +bug-reports: http://github.com/aelve/shortcut-links/issues +license: BSD3 +license-file: LICENSE +author: Artyom +maintainer: Artyom +copyright: 2015–∞ Aelve +category: Text, Web +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/aelve/shortcut-links.git + +library + exposed-modules: ShortcutLinks + ShortcutLinks.All + ShortcutLinks.Utils + -- other-modules: + -- other-extensions: + build-depends: base >= 4.5 && < 5 + , text >= 1.1 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/ShortcutLinks.hs b/src/ShortcutLinks.hs new file mode 100644 --- /dev/null +++ b/src/ShortcutLinks.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE +OverloadedStrings + #-} + +module ShortcutLinks +( + Result(..), + allShortcuts, +) +where + + +-- Text +import Data.Text (Text) +import qualified Data.Text as T +-- shortcut-links +import ShortcutLinks.All (allShortcuts, Result(..)) +import ShortcutLinks.Utils (format) + + +-- | Use a shortcut from 'allShortcuts'. +-- +-- This is the main function you should use. It does the lookup and so on. +useShortcut + :: Text -- ^ Shortcut name + -> Maybe Text -- ^ Option + -> Text -- ^ Link text + -> Result Text -- ^ Resulting URL +useShortcut name option link = + let givenShortcut (names,_) = name `elem` names + in case filter givenShortcut allShortcuts of + [] -> fail (format "there's no shortcut named '{}'" name) + [sh] -> (snd sh) option link + _ -> fail (format "there's more than one shortcut named '{}'" name) diff --git a/src/ShortcutLinks/All.hs b/src/ShortcutLinks/All.hs new file mode 100644 --- /dev/null +++ b/src/ShortcutLinks/All.hs @@ -0,0 +1,894 @@ +{-# LANGUAGE +OverloadedStrings, +DeriveFunctor, +ViewPatterns + #-} + + +module ShortcutLinks.All +( + Result(..), + Shortcut, + allShortcuts, + + -- * Encyclopedias + wikipedia, tvtropes, + + -- * Social networks + facebook, vk, googleplus, + + -- * Microblogs + twitter, juick, + + -- * Major search engines + google, duckduckgo, yandex, baidu, + + -- * Programming language libraries + npm, jam, rubygems, pypi, metacpanPod, metacpanRelease, hackage, cargo, + pub, hex, cran, swiprolog, dub, bpkg, pear, + + -- * Code hosting + github, gitlab, bitbucket, + + -- * OS packages + -- ** Mobile + googleplay, + -- ** Windows + chocolatey, + -- ** OS X + braumeister, + -- ** Linux + debian, aur, mint, fedora, gentoo, opensuse, + + -- * Addons + -- ** Text editors + marmalade, melpa, elpa, packagecontrol, atomPackage, atomTheme, jedit, vim, + -- ** Browsers + operaExt, operaTheme, firefox, chrome, + + -- * Manuals + ghcExt, + + -- * Standards and databases + rfc, ecma, cve, +) +where + + +-- General +import Data.Monoid +import Control.Applicative +import Control.Monad +import Data.Maybe +-- Text +import qualified Data.Text as T +import Data.Text (Text) +import Data.Char +-- shortcut-links +import ShortcutLinks.Utils + + +data Result a = Failure String | Warning [String] a | Success a + deriving (Show, Functor) + +instance Applicative Result where + pure = return + (<*>) = ap + +instance Monad Result where + fail = Failure + return = Success + Failure x >>= _ = Failure x + Warning wa a >>= f = case f a of + Success b -> Warning wa b + Warning wb b -> Warning (wa ++ wb) b + Failure x -> Failure x + Success a >>= f = f a + +warn :: String -> Result () +warn s = Warning [s] () + +type Shortcut = Maybe Text -> Text -> Result Text + +-- | A list of all functions included in this module, together with suggested +-- names for them. +allShortcuts :: [([Text], Shortcut)] +allShortcuts = + let (.=) names func = (T.words names, func) + in [ + -- encyclopedias + "w wikipedia" .= wikipedia, + "tvt tvtropes" .= tvtropes, + -- social networks + "fb facebook" .= facebook, + "vk vkontakte" .= vk, + "gp gplus googleplus" .= googleplus, + -- microblogs + "t twitter" .= twitter, + "juick" .= juick, + -- search engines + "google" .= google, + "ddg duckduckgo" .= duckduckgo, + "yandex" .= yandex, + "baidu" .= baidu, + -- programming language libraries + "npm" .= npm, + "jam" .= jam, + "gem" .= rubygems, + "pypi" .= pypi, + "cpan" .= metacpanPod, + "cpan-r" .= metacpanRelease, + "hackage" .= hackage, + "cargo" .= cargo, + "pub" .= pub, + "hex" .= hex, + "cran" .= cran, + "swiprolog" .= swiprolog, + "dub" .= dub, + "bpkg" .= bpkg, + "pear" .= pear, + -- code hosting + "gh github" .= github, + "gitlab" .= gitlab, + "bitbucket" .= bitbucket, + -- OS + "gplay googleplay" .= googleplay, + "chocolatey" .= chocolatey, + "brew" .= braumeister, + -- OS – Linux + "debian" .= debian, + "aur" .= aur, + "mint" .= mint, + "fedora" .= fedora, + "gentoo" .= gentoo, + "opensuse" .= opensuse, + -- text editors + "marmalade" .= marmalade, + "melpa" .= melpa, + "elpa" .= elpa, + "sublime" .= packagecontrol, + "atom" .= atomPackage, + "atom-theme" .= atomTheme, + "jedit" .= jedit, + "vim" .= vim, + -- browsers + "opera" .= operaExt, + "opera-theme" .= operaTheme, + "firefox" .= firefox, + "chrome" .= chrome, + -- manuals + "ghc-ext" .= ghcExt, + -- standards and databases + "rfc" .= rfc, + "ecma" .= ecma, + "cve" .= cve ] + +-- | +-- +-- Link example: +-- @[green](\@fb)@ → +-- +facebook :: Shortcut +facebook _ q = return $ "https://facebook.com/" <> q + +-- | (Вконтакте) +-- +-- Link example (username): +-- @[green](\@vk)@ → +-- +-- +-- Link example (ID): +-- +-- @[1337](\@vk)@ → +-- +vk :: Shortcut +vk _ q = return $ "https://vk.com/" <> q' + where q' = if not (T.null q) && isDigit (T.head q) then "id" <> q else q + +-- | +-- +-- Link example (username): +-- @[SergeyBrin](\@gp)@ → +-- +-- +-- Link example (username with @+@): +-- @[+SergeyBrin](\@gp)@ → +-- +-- +-- Link example (full name – will just be concatenated): +-- @[Sergey Brin](\@gp)@ → +-- +-- +-- Link example (ID): +-- @[Sergey Brin](\@gp:109813896768294978296)@ → +-- +-- +-- Link example (hashtag): +-- @[#Australia](\@gp)@ → +-- +googleplus :: Shortcut +googleplus _ q + | T.null q = return $ url + | T.head q == '#' = return $ format "{}/explore/{}" url (T.tail q) + | T.head q == '+' = return $ format "{}/{}" url q + | T.all isDigit q = return $ format "{}/{}" url q + | otherwise = return $ format "{}/+{}" url (T.concat (T.words q)) + where url = "https://plus.google.com" + +-- | +-- +-- Link example (username): +-- @[kmett](\@t)@ → +-- +-- +-- Link example (username with @\@@): +-- @[\@kmett](\@t)@ → +-- +-- +-- Link example (hashtag): +-- @[#haskell](\@t)@ → +-- +twitter :: Shortcut +twitter _ q + | T.null q = return $ url + | T.head q == '#' = return $ format "{}/hashtag/{}" url (T.tail q) + | T.head q == '@' = return $ format "{}/{}" url (T.tail q) + | otherwise = return $ format "{}/{}" url q + where url = "https://twitter.com" + +-- | +-- +-- Link example (username): +-- @[thefish](\@juick)@ → +-- +-- +-- Link example (username with @\@@): +-- @[\@thefish](\@juick)@ → +-- +-- +-- Link example (tag): +-- @[*Haskell](\@juick)@ → +-- +juick :: Shortcut +juick _ q + | T.null q = return $ url + | T.head q == '*' = return $ format "{}/tag/{}" url (T.tail q) + | T.head q == '@' = return $ format "{}/{}" url (T.tail q) + | otherwise = return $ format "{}/{}" url q + where url = "https://juick.com" + +-- | +-- +-- Link example: +-- @[random query](\@google)@ → +-- +google :: Shortcut +google _ q = return $ + "https://google.com/search?nfpr=1&q=" <> replaceSpaces '+' q + +-- | +-- +-- Link example: +-- @[random query](\@ddg)@ → +-- +duckduckgo :: Shortcut +duckduckgo _ q = return $ "https://duckduckgo.com/?q=" <> replaceSpaces '+' q + +-- | (Russian search engine) +-- +-- Link example: +-- @[random query](\@yandex)@ → +-- +yandex :: Shortcut +yandex _ q = return $ + "http://yandex.ru/search/?noreask=1&text=" <> replaceSpaces '+' q + +-- | (Chinese search engine) +-- +-- Link example: +-- @[random query](\@baidu)@ → +-- +baidu :: Shortcut +baidu _ q = return $ "http://baidu.com/s?nojc=1&wd=" <> replaceSpaces '+' q + +-- | __Node.js__ – +-- +-- Link example: +-- @[markdown](\@npm)@ → +-- +npm :: Shortcut +npm _ q = return $ "https://npmjs.com/package/" <> q + +-- | __Javascript__ – +-- +-- Link example: +-- @[pagedown](\@jam)@ → +-- +jam :: Shortcut +jam _ q = return $ "http://jamjs.org/packages/#/details/" <> q + +-- | __Ruby__ – +-- +-- Link example: +-- @[github-markdown](\@gem)@ → +-- +rubygems :: Shortcut +rubygems _ q = return $ "https://rubygems.org/gems/" <> q + +-- | __Python__ – +-- +-- Link example: +-- @[Markdown](\@pypi)@ → +-- +pypi :: Shortcut +pypi _ q = return $ "https://pypi.python.org/pypi/" <> q + +-- | __Perl__ – (by module) +-- +-- Link example: +-- @[Text::Markdown](\@cpan)@ → +-- +metacpanPod :: Shortcut +metacpanPod _ q = return $ "https://metacpan.org/pod/" <> q + +-- | __Perl__ – (by release) +-- +-- Link example: +-- @[Text-Markdown](\@cpan-r)@ → +-- +metacpanRelease :: Shortcut +metacpanRelease _ q = return $ "https://metacpan.org/release/" <> q + +-- | __Haskell__ – +-- +-- Link example: +-- @[cmark](\@hackage)@ → +-- +hackage :: Shortcut +hackage _ q = return $ "https://hackage.haskell.org/package/" <> q + +-- | __Rust__ – +-- +-- Link example: +-- @[hoedown](\@cargo)@ → +-- +cargo :: Shortcut +cargo _ q = return $ "https://crates.io/crates/" <> q + +-- | __PHP__ – +-- +-- Link example: +-- @[Text_Wiki_Doku](\@pear)@ → +-- +pear :: Shortcut +pear _ q = return $ "http://pear.php.net/package/" <> q + +-- | __Dart__ – +-- +-- Link example: +-- @[md_proc](\@pub)@ → +-- +pub :: Shortcut +pub _ q = return $ "https://pub.dartlang.org/packages/" <> q + +-- | __R__ – +-- +-- Link example: +-- @[markdown](\@cran)@ → +-- +cran :: Shortcut +cran _ q = return $ "http://cran.r-project.org/web/packages/" <> q + +-- | __Erlang__ – +-- +-- Link example: +-- @[earmark](\@hex)@ → +-- +hex :: Shortcut +hex _ q = return $ "https://hex.pm/packages/" <> q + +-- | __SWI-Prolog__ – +-- +-- Link example: +-- @[markdown](\@swiprolog)@ → +-- +swiprolog :: Shortcut +swiprolog _ q = return $ "http://www.swi-prolog.org/pack/list?p=" <> q + +-- | __D__ – +-- +-- Link example: +-- @[dmarkdown](\@dub)@ → +-- +dub :: Shortcut +dub _ q = return $ "http://code.dlang.org/packages/" <> q + +-- | __Bash__ – +-- +-- Link example: +-- @[markdown](\@bpkg)@ → +-- +bpkg :: Shortcut +bpkg _ q = return $ "http://bpkg.io/pkg/" <> q + +-- | +-- +-- Link example: +-- @[aelve/shortcut-links](\@gh)@ → +-- +-- +-- The repository owner can also be given as an option: +-- +-- @[shortcut-links](\@gh(aelve))@ → +-- +github :: Shortcut +github mbOwner q = case mbOwner of + Nothing -> return $ format "https://github.com/{}" q + Just owner -> return $ format "https://github.com/{}/{}" owner q + +-- | +-- +-- Link example: +-- @[bos/text](\@bitbucket)@ → +-- +-- +-- The repository owner can also be given as an option: +-- +-- @[text](\@bitbucket(bos))@ → +-- +bitbucket :: Shortcut +bitbucket mbOwner q = case mbOwner of + Nothing -> return $ format "https://bitbucket.org/{}" q + Just owner -> return $ format "https://bitbucket.org/{}/{}" owner q + +-- | +-- +-- Link example: +-- @[learnyou/lysa](\@gitlab)@ → +-- +-- +-- The repository owner can also be given as an option: +-- +-- @[lysa](\@gitlab(learnyou))@ → +-- +-- +-- Note that links like work but are going to be +-- automatically redirected to either or +-- , depending on whether it's a user or a +-- team. So, it's a case when the “links have to look as authentic as +-- possible” principle is violated (but c'mon, this “u” thing looks ugly +-- anyway). +gitlab :: Shortcut +gitlab mbOwner q = case mbOwner of + Nothing -> return $ format "https://gitlab.com/{}" q + Just owner -> return $ format "https://gitlab.com/{}/{}" owner q + +-- | __Android__ – (formerly Play Market) +-- +-- Link example: +-- @[Opera Mini](\@gplay:com.opera.mini.native)@ → +-- +googleplay :: Shortcut +googleplay _ q = return $ "https://play.google.com/store/apps/details?id=" <> q + +-- | (Homebrew formulas) +-- +-- Link example: +-- @[multimarkdown](\@brew)@ → +-- +braumeister :: Shortcut +braumeister _ q = return $ "http://braumeister.org/formula/" <> q + +-- | +-- +-- Link example: +-- @[Opera](\@chocolatey)@ → +-- +chocolatey :: Shortcut +chocolatey _ q = return $ "https://chocolatey.org/packages/" <> q + +-- | __Debian__ – +-- +-- Link example (stable distribution): +-- @[ghc](\@debian)@ → +-- +-- +-- Link example (experimental distribution, but could be any other): +-- @[ghc](\@debian(experimental))@ → +-- +debian :: Shortcut +debian mbDist q = return $ format "https://packages.debian.org/{}/{}" dist q + where + dist = fromMaybe "stable" mbDist + +-- | __Arch Linux__ – (“user repository”) +-- +-- Link example: +-- @[ghc-git](\@aur)@ → +-- +aur :: Shortcut +aur _ q = return $ "https://aur.archlinux.org/packages/" <> q + +-- | __Gentoo__ – +-- +-- Link example: +-- @[dev-lang/ghc](\@gentoo)@ → +-- +-- +-- Link example (category as an option): +-- @[ghc](\@gentoo(dev-lang))@ → +-- +-- +-- Note that if you don't specify any category, the link would still work – +-- but there are a lot of packages with overlapping names (like “ace”, “csv”, +-- “http”), and such links would lead to search pages listing several +-- packages. So, it's better to include categories. +gentoo :: Shortcut +gentoo mbCat q = return $ "https://packages.gentoo.org/package/" <> pkg + where + pkg = case mbCat of + Nothing -> q + Just cat -> cat <> "/" <> q + +-- | __openSUSE__ – +-- +-- Link example: +-- @[ghc](\@opensuse)@ → +-- +opensuse :: Shortcut +opensuse _ q = return $ "http://software.opensuse.org/package/" <> q + +-- | __Linux Mint__ – +-- +-- Link example: +-- @[ghc](\@mint)@ → +-- +mint :: Shortcut +mint _ q = return $ "http://community.linuxmint.com/software/view/" <> q + +-- | __Fedora__ – +-- +-- Link example: +-- @[ghc](\@fedora)@ → +-- +fedora :: Shortcut +fedora _ q = return $ "https://admin.fedoraproject.org/pkgdb/package/" <> q + +-- | __Emacs__ – +-- +-- Link example: +-- @[markdown-mode](\@marmalade)@ → +-- +marmalade :: Shortcut +marmalade _ q = return $ "https://marmalade-repo.org/packages/" <> q + +-- | __Emacs__ – +-- +-- Link example: +-- @[markdown-mode](\@melpa)@ → +-- +melpa :: Shortcut +melpa _ q = return $ "http://melpa.org/#/" <> q + +-- | __Emacs__ – +-- +-- Link example: +-- @[undo-tree](\@elpa)@ → +-- +elpa :: Shortcut +elpa _ q = return $ format "https://elpa.gnu.org/packages/{}.html" q + +-- | __Sublime Text__ – +-- +-- Link example: +-- @[MarkdownEditing](\@sublime)@ → +-- +packagecontrol :: Shortcut +packagecontrol _ q = return $ "https://packagecontrol.io/packages/" <> q + +-- | __Atom__ – +-- +-- Link example: +-- @[tidy-markdown](\@atom)@ → +-- +atomPackage :: Shortcut +atomPackage _ q = return $ "https://atom.io/packages/" <> q + +-- | __Atom__ – +-- +-- Link example: +-- @[atom-material-ui](\@atom-theme)@ → +-- +atomTheme :: Shortcut +atomTheme _ q = return $ "https://atom.io/themes/" <> q + +-- | __jEdit__ – +-- +-- Link example: +-- @[MarkdownPlugin](\@jedit)@ → +-- +jedit :: Shortcut +jedit _ q = return $ "http://plugins.jedit.org/plugins/?" <> q + +-- | __Vim__ – +-- +-- Link example (ID): +-- @[haskell.vim](\@vim:2062)@ → +-- +vim :: Shortcut +vim _ q = return $ "http://www.vim.org/scripts/script.php?script_id=" <> q + +-- | __Opera__ – +-- +-- Link example: +-- @[Amazon](\@opera:amazon-for-opera)@ → +-- +operaExt :: Shortcut +operaExt _ q = return $ "https://addons.opera.com/extensions/details/" <> q + +-- | __Opera__ – +-- +-- Link example: +-- @[Space theme](\@opera-theme:space-15)@ → +-- +operaTheme :: Shortcut +operaTheme _ q = return $ "https://addons.opera.com/themes/details/" <> q + +-- | __Firefox__ – (extensions, themes) +-- +-- Link example: +-- @[tree-style-tab]@ → +-- +firefox :: Shortcut +firefox _ q = return $ "https://addons.mozilla.org/firefox/addon/" <> q + +-- | __Chrome__ – (extensions, apps, themes) +-- +-- Link example: +-- @[hdokiejnpimakedhajhdlcegeplioahd]@ → +-- +chrome :: Shortcut +chrome _ q = return $ "https://chrome.google.com/webstore/detail/" <> q + +-- | (Glasgow Haskell Compiler) extensions +-- +-- Link example: +-- @[ViewPatterns](\@ghc-ext)@ → +-- +ghcExt :: Shortcut +ghcExt _ ext = case lookup ext ghcExtsList of + Nothing -> fail (format "unknown GHC extension '{}'" ext) + Just link -> return link + +-- | +-- +-- Link example: +-- @[RFC 2026](\@rfc)@ → +-- +-- +-- Precise format of recognised text: optional “rfc” (case-insensitive), then +-- arbitrary amount of spaces and punctuation (or nothing), then the +-- number. Examples: “RFC 2026”, “RFC-2026”, “rfc2026”, “rfc #2026”, “2026”, +-- “#2026”. +rfc :: Shortcut +rfc _ x = do + let n = T.dropWhile (not . isAlphaNum) (tryStripPrefixCI "rfc" x) + -- We don't use 'readMaybe' here because 'readMaybe' isn't available in GHC + -- 7.4, which Pandoc has to be compatible with. + unless (T.all isDigit n) $ + warn "non-digits in RFC number" + when (T.null n) $ + warn "no RFC number" + let n' = T.dropWhile (== '0') n `orElse` "0" + return ("https://tools.ietf.org/html/rfc" <> n') + +-- | +-- +-- Link example (standard): +-- @[ECMA-262](\@ecma)@ → +-- +-- +-- Link example (technical report): +-- @[TR/71](\@ecma)@ → +-- +-- +-- Precise format of recognised text for standards: optional “ECMA” +-- (case-insensitive), then arbitrary amount of spaces and punctuation (or +-- nothing), then the number. Examples: “ECMA-262”, “ECMA 262”, “ecma262”, +-- “ECMA #262”, “262”, “#262”. +-- +-- Format for technical reports is the same, except that “TR” (instead of +-- “ECMA”) is not optional (so, if there's only a number given, it's +-- considered a standard and not a technical report). +ecma :: Shortcut +ecma _ q = do + -- TODO: move dropSeparators to Utils and use it in 'rfc' and 'cve' + let dropSeparators = T.dropWhile (not . isAlphaNum) + let (dropSeparators -> mbNum, isTR) = case stripPrefixCI "tr" q of + Nothing -> (tryStripPrefixCI "ecma" q, False) + Just q' -> (q', True) + -- We don't use 'readMaybe' here because 'readMaybe' isn't available in GHC + -- 7.4, which Pandoc has to be compatible with. + unless (T.all isDigit mbNum) $ + warn "non-digits in ECMA standard number" + when (T.null mbNum) $ + warn "no ECMA standard number" + -- The number has to have at least 3 digits. + let num = T.justifyRight 3 '0' mbNum + url = "http://ecma-international.org/publications" :: Text + return $ if isTR + then format "{}/techreports/E-TR-{}.htm" url num + else format "{}/standards/Ecma-{}.htm" url num + +-- | (Common Vulnerabilities and Exposures) +-- +-- Link example: +-- @[CVE-2014-10001](\@cve)@ → +-- +-- +-- Precise format of recognised text: optional “cve” (case-insensitive), then +-- arbitrary amount of spaces and punctuation (or nothing), then the year, +-- ‘-’, and a number. Examples: “CVE-2014-10001”, “cve 2014-10001”, +-- “2014-10001”. +cve :: Shortcut +cve _ x = do + let n = T.dropWhile (not . isAlphaNum) (tryStripPrefixCI "cve" x) + unless (T.length n >= 9) $ + warn "CVE-ID is too short" + let isValid = and [ + T.length n >= 9, + T.all isDigit (T.take 4 n), + T.index n 4 == '-', + T.all isDigit (T.drop 5 n) ] + unless isValid $ + warn "CVE-ID doesn't follow the - format" + return ("http://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-" <> n) + +-- | +-- +-- Link example (English Wikipedia): +-- @[grey-headed flying fox](\@w)@ → +-- +-- +-- Link example (Russian Wikipedia, but any language code can be used): +-- @[Haskell](\@w(ru))@ → +-- +wikipedia :: Shortcut +wikipedia mbLang q = return $ + format "https://{}.wikipedia.org/wiki/{}" lang q' + where + lang = fromMaybe "en" mbLang + q' = titleFirst (replaceSpaces '_' q) + +-- | +-- +-- Link example (trope): +-- @[so bad, it's good](\@tvtropes)@ → +-- +-- +-- Link example (series): +-- @[Elementary](\@tvtropes(series))@ → +-- +-- +-- You can give anything as a category instead of “series”, it'll be +-- capitalised but nothing else. +tvtropes :: Shortcut +tvtropes mbCat q = return $ + format "http://tvtropes.org/pmwiki/pmwiki.php/{}/{}" cat q' + where + cat = maybe "Main" titleFirst mbCat + isSep c = (isSpace c || isPunctuation c) && c /= '\'' + -- Break into words, transform each word like “it's” → “Its”, and concat. + -- Note that e.g. “man-made” is considered 2 separate words. + q' = T.concat $ map (titleFirst . T.filter isAlphaNum) (T.split isSep q) + +ghcExtsList :: [(Text, Text)] +ghcExtsList = do + let (.=) = (,) + base = "https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/" + prefix x = map (\(a, b) -> (a, x <> b)) + prefix base $ concat [ + prefix "syntax-extns.html" [ + "DisambiguateRecordFields" .= "#disambiguate-fields", + "EmptyCase" .= "#empty-case", + "NoImplicitPrelude" .= "#rebindable-syntax", + "NegativeLiterals" .= "#negative-literals", + "RebindableSyntax" .= "#rebindable-syntax", + "PatternGuards" .= "#pattern-guards", + "ViewPatterns" .= "#view-patterns", + "UnicodeSyntax" .= "#unicode-syntax", + "MagicHash" .= "#magic-hash", + "ParallelListComp" .= "#parallel-list-comprehensions", + "TransformListComp" .= "#generalised-list-comprehensions", + "MonadComprehensions" .= "#monad-comprehensions", + "ExplicitNamespaces" .= "#explicit-namespaces", + "RecursiveDo" .= "#recursive-do-notation", + "RecordWildCards" .= "#record-wildcards", + "NamedFieldPuns" .= "#record-puns", + "PackageImports" .= "#package-imports", + "LambdaCase" .= "#lambda-case", + "MultiWayIf" .= "#multi-way-if", + "NumDecimals" .= "#num-decimals", + "BinaryLiterals" .= "#binary-literals", + "PostfixOperators" .= "#postfix-operators", + "TupleSections" .= "#tuple-sections", + "PatternSynonyms" .= "#pattern-synonyms" ], + + prefix "data-type-extensions.html" [ + "GADTs" .= "#gadt", + "GADTSyntax" .= "#gadt-style", + "ExistentialQuantification" .= "#existential-quantification", + "LiberalTypeSynonyms" .= "#type-synonyms", + "EmptyDataDecls" .= "#nullary-types", + "DatatypeContexts" .= "#datatype-contexts", + "TypeOperators" .= "#type-operators" ], + + prefix "other-type-extensions.html" [ + "AllowAmbiguousTypes" .= "#ambiguity", + "ImplicitParams" .= "#implicit-parameters", + "NoMonomorphismRestriction" .= "#monomorphism", + "RelaxedPolyRec" .= "#typing-binds", + "MonoLocalBinds" .= "#mono-local-binds", + "ScopedTypeVariables" .= "#scoped-type-variables", + "ExplicitForAll" .= "#explicit-foralls", + "PolymorphicComponents" .= "#universal-quantification", + "Rank2Types" .= "#universal-quantification", + "RankNTypes" .= "#universal-quantification", + "ImpredicativeTypes" .= "#impredicative-polymorphism", + "KindSignatures" .= "#kinding", + "FlexibleContexts" .= "#flexible-contexts" ], + + prefix "type-class-extensions.html" [ + "IncoherentInstances" .= "#instance-overlap", + "OverlappingInstances" .= "#instance-overlap", + "OverloadedLists" .= "#overloaded-lists", + "OverloadedStrings" .= "#overloaded-strings", + "UndecidableInstances" .= "#undecidable-instances", + "TypeSynonymInstances" .= "#flexible-instance-head", + "FlexibleInstances" .= "#instance-rules", + "ConstrainedClassMethods" .= "#class-method-types", + "DefaultSignatures" .= "#class-default-signatures", + "MultiParamTypeClasses" .= "#multi-param-type-classes", + "NullaryTypeClasses" .= "#nullary-type-classes", + "InstanceSigs" .= "#instance-sigs", + "FunctionalDependencies" .= "#functional-dependencies" ], + + prefix "deriving.html" [ + "AutoDeriveTypeable" .= "#auto-derive-typeable", + "DeriveDataTypeable" .= "#deriving-typeable", + "DeriveGeneric" .= "#deriving-typeable", + "DeriveFunctor" .= "#deriving-extra", + "DeriveTraversable" .= "#deriving-extra", + "DeriveFoldable" .= "#deriving-extra", + "GeneralizedNewtypeDeriving" .= "#newtype-deriving", + "DeriveAnyClass" .= "#derive-any-class", + "StandaloneDeriving" .= "#stand-alone-deriving" ], + + prefix "template-haskell.html" [ + "TemplateHaskell" .= "", + "QuasiQuotes" .= "#th-quasiquotation" ], + + prefix "ffi.html" [ + "ForeignFunctionInterface" .= "", + "InterruptibleFFI" .= "#ffi-interruptible", + "CApiFFI" .= "#ffi-capi" ], + + prefix "partial-type-signatures.html" [ + "PartialTypeSignatures" .= "", + "NamedWildCards" .= "#named-wildcards" ], + + map (.= "safe-haskell.html") [ + "Safe", + "Trustworthy", + "Unsafe" ], + + [ "Arrows" .= "arrow-notation.html", + "ConstraintKinds" .= "constraint-kind.html", + "DataKinds" .= "promotion.html", + "ExtendedDefaultRules" .= "interactive-evaluation.html#extended-default-rules", + "TypeFamilies" .= "type-families.html", + "PolyKinds" .= "kind-polymorphism.html", + "BangPatterns" .= "bang-patterns.html", + "CPP" .= "options-phases.html#c-pre-processor", + "RoleAnnotations" .= "roles.html#role-annotations", + "UnboxedTuples" .= "primitives.html#unboxed-tuples" ] ] diff --git a/src/ShortcutLinks/Utils.hs b/src/ShortcutLinks/Utils.hs new file mode 100644 --- /dev/null +++ b/src/ShortcutLinks/Utils.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE +OverloadedStrings, +FlexibleInstances + #-} + +{- | +Useful functions when writing your own link rules. +-} +module ShortcutLinks.Utils +( + replaceSpaces, + titleFirst, + tryStripPrefixCI, + stripPrefixCI, + orElse, + format, +) +where + + +-- General +import Data.Monoid +-- Text +import Data.Char +import qualified Data.Text as T +import Data.Text (Text) + + +-- | Replace spaces in text with chosen character (useful when processing queries containing spaces – they are often turned into “+” or “_”). +-- +-- >>> replaceSpaces '_' "hi there" +-- "hi___there" +replaceSpaces :: Char -> Text -> Text +replaceSpaces r = T.map (\c -> if isSpace c then r else c) + +-- | Convert the 1st character of a string to upper case. +-- +-- This function is dumber than it could've been; when the 1st character +-- doesn't have a single-character uppercase form (like “ß”), it is left +-- intact instead of being converted (“Ss” in the case of “ß”). This is good, +-- however; for instance, if the “proper” capitalisation rule was applied to +-- e.g. Wikipedia links, a link to the article on “ß” would've been rendered +-- as “Ss”, which is a redirect to “Schutzstaffel”. +titleFirst :: Text -> Text +titleFirst s = case T.uncons s of + Nothing -> "" + Just (c, rest) -> toUpper c `T.cons` rest + +-- | Strip given prefix from a string, or do nothing if the string doesn't +-- have given prefix. +-- +-- This function is case-insensitive. +-- +-- >>> tryStripPrefixCI "FOO" "FooBAR" +-- "BAR" +-- +-- >>> tryStripPrefixCI "foo" "quux" +-- "quux" +tryStripPrefixCI :: Text -> Text -> Text +tryStripPrefixCI pref str = + let pref' = T.toCaseFold pref + (str_pref, rest) = T.splitAt (T.length pref') str + in if T.toCaseFold str_pref == pref' then rest else str + +-- | Strip given prefix from a string. +-- +-- This function is case-insensitive. +-- +-- >>> stripPrefixCI "FOO" "FooBAR" +-- Just "BAR" +-- +-- >>> stripPrefixCI "foo" "quux" +-- Nothing +stripPrefixCI :: Text -> Text -> Maybe Text +stripPrefixCI pref str = + let pref' = T.toCaseFold pref + (str_pref, rest) = T.splitAt (T.length pref') str + in if T.toCaseFold str_pref == pref' then Just rest else Nothing + +-- | Choose the 2nd value if the 1st is empty (equal to 'mempty'). +orElse :: (Eq a, Monoid a) => a -> a -> a +orElse a b = if a == mempty then b else a + +------------------------------------------------------------------------------ +-- A micro formatting library which supports Text better than printf. +------------------------------------------------------------------------------ + +class FormatArg a where + formatArg :: a -> Text + +instance FormatArg Text where formatArg = id +instance FormatArg String where formatArg = T.pack +instance FormatArg Int where formatArg = T.pack . show +instance FormatArg Integer where formatArg = T.pack . show + +class FormatType r where + format' :: Text -> [Text] -> r + +instance FormatType String where + format' str params = T.unpack $ format' str params + +instance FormatType Text where + format' str params = go fragments (reverse params) + where + fragments = T.splitOn "{}" str + go (f:fs) (y:ys) = f <> y <> go fs ys + go [f] [] = f + go _ _ = error $ format + "ShortcutLinks.Utils.format: {} placeholders, but {} parameters" + (length fragments - 1) + (length params) + +instance (FormatArg a, FormatType r) => FormatType (a -> r) where + format' str params = \a -> format' str (formatArg a : params) + +-- | A 'printf'-like function which fully supports 'Text' as an input and +-- output format and which uses @{}@ instead of @%@ to indicate +-- placeholders. If you use it, don't forget to enable @OverloadedStrings@. +-- +-- This is a lightweight alternative to something like the text-format +-- package, and it's closer to 'printf' and simpler to use. +format :: FormatType r => Text -> r +format str = format' str []