{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Commonmark.Extensions.RebaseRelativePaths
( rebaseRelativePathsSpec )
where
import Commonmark.Types
import Commonmark.Syntax
import Commonmark.Inlines
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
import Text.Parsec (getPosition)
import Text.Parsec.Pos (sourceName)
import System.FilePath
import qualified System.FilePath.Windows as Windows
import qualified System.FilePath.Posix as Posix
import Network.URI (URI (uriScheme), parseURI)
import qualified Data.Set as Set
rebaseRelativePathsSpec
:: forall m bl il . (Monad m , IsInline il , IsBlock il bl)
=> SyntaxSpec m il bl
rebaseRelativePathsSpec :: forall (m :: * -> *) bl il.
(Monad m, IsInline il, IsBlock il bl) =>
SyntaxSpec m il bl
rebaseRelativePathsSpec =
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
defaultSyntaxSpec {
syntaxBracketedSpecs :: [BracketedSpec il]
syntaxBracketedSpecs = [BracketedSpec il
rebasedImageSpec, BracketedSpec il
rebasedLinkSpec] }
where
rebasedImageSpec :: BracketedSpec il
rebasedImageSpec :: BracketedSpec il
rebasedImageSpec =BracketedSpec
{ bracketedName :: Text
bracketedName = Text
"Image"
, bracketedNests :: Bool
bracketedNests = Bool
True
, bracketedPrefix :: Maybe Char
bracketedPrefix = forall a. a -> Maybe a
Just Char
'!'
, bracketedSuffixEnd :: Maybe Char
bracketedSuffixEnd = forall a. a -> Maybe a
Just Char
')'
, bracketedSuffix :: ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
bracketedSuffix = forall {c} {u}.
IsInline c =>
ReferenceMap -> Text -> ParsecT [Tok] u Identity (c -> c)
newImageSuffix
}
rebasedLinkSpec :: BracketedSpec il
rebasedLinkSpec :: BracketedSpec il
rebasedLinkSpec = BracketedSpec
{ bracketedName :: Text
bracketedName = Text
"Link"
, bracketedNests :: Bool
bracketedNests = Bool
False
, bracketedPrefix :: Maybe Char
bracketedPrefix = forall a. Maybe a
Nothing
, bracketedSuffixEnd :: Maybe Char
bracketedSuffixEnd = forall a. a -> Maybe a
Just Char
')'
, bracketedSuffix :: ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
bracketedSuffix = forall {c} {u}.
IsInline c =>
ReferenceMap -> Text -> ParsecT [Tok] u Identity (c -> c)
newLinkSuffix
}
newImageSuffix :: ReferenceMap -> Text -> ParsecT [Tok] u Identity (c -> c)
newImageSuffix ReferenceMap
rm Text
key = do
SourcePos
pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
LinkInfo Text
target Text
title Attributes
attrs Maybe SourcePos
mbpos <- forall s. ReferenceMap -> Text -> Parsec [Tok] s LinkInfo
pLink ReferenceMap
rm Text
key
let pos' :: SourcePos
pos' = forall a. a -> Maybe a -> a
fromMaybe SourcePos
pos Maybe SourcePos
mbpos
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. HasAttributes a => Attributes -> a -> a
addAttributes Attributes
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsInline a => Text -> Text -> a -> a
image (SourcePos -> Text -> Text
rebasePath SourcePos
pos' Text
target) Text
title
newLinkSuffix :: ReferenceMap -> Text -> ParsecT [Tok] u Identity (c -> c)
newLinkSuffix ReferenceMap
rm Text
key = do
SourcePos
pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
LinkInfo Text
target Text
title Attributes
attrs Maybe SourcePos
mbpos <- forall s. ReferenceMap -> Text -> Parsec [Tok] s LinkInfo
pLink ReferenceMap
rm Text
key
let pos' :: SourcePos
pos' = forall a. a -> Maybe a -> a
fromMaybe SourcePos
pos Maybe SourcePos
mbpos
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. HasAttributes a => Attributes -> a -> a
addAttributes Attributes
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsInline a => Text -> Text -> a -> a
link (SourcePos -> Text -> Text
rebasePath SourcePos
pos' Text
target) Text
title
rebasePath :: SourcePos -> Text -> Text
rebasePath :: SourcePos -> Text -> Text
rebasePath SourcePos
pos Text
path = do
let fp :: FilePath
fp = SourcePos -> FilePath
sourceName SourcePos
pos
isFragment :: Bool
isFragment = Int -> Text -> Text
T.take Int
1 Text
path forall a. Eq a => a -> a -> Bool
== Text
"#"
path' :: FilePath
path' = Text -> FilePath
T.unpack Text
path
isAbsolutePath :: Bool
isAbsolutePath = FilePath -> Bool
Posix.isAbsolute FilePath
path' Bool -> Bool -> Bool
|| FilePath -> Bool
Windows.isAbsolute FilePath
path'
in if Text -> Bool
T.null Text
path Bool -> Bool -> Bool
|| Bool
isFragment Bool -> Bool -> Bool
|| Bool
isAbsolutePath Bool -> Bool -> Bool
|| Text -> Bool
isURI Text
path
then Text
path
else
case FilePath -> FilePath
takeDirectory FilePath
fp of
FilePath
"" -> Text
path
FilePath
"." -> Text
path
FilePath
d -> FilePath -> Text
T.pack FilePath
d forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
path
schemes :: Set.Set T.Text
schemes :: Set Text
schemes = forall a. Ord a => [a] -> Set a
Set.fromList
[ Text
"aaa", Text
"aaas", Text
"about", Text
"acap", Text
"acct", Text
"acr", Text
"adiumxtra", Text
"afp", Text
"afs"
, Text
"aim", Text
"appdata", Text
"apt", Text
"attachment", Text
"aw", Text
"barion", Text
"beshare", Text
"bitcoin"
, Text
"blob", Text
"bolo", Text
"browserext", Text
"callto", Text
"cap", Text
"chrome", Text
"chrome-extension"
, Text
"cid", Text
"coap", Text
"coaps", Text
"com-eventbrite-attendee", Text
"content", Text
"crid", Text
"cvs"
, Text
"data", Text
"dav", Text
"dict", Text
"dis", Text
"dlna-playcontainer", Text
"dlna-playsingle"
, Text
"dns", Text
"dntp", Text
"dtn", Text
"dvb", Text
"ed2k", Text
"example", Text
"facetime", Text
"fax", Text
"feed"
, Text
"feedready", Text
"file", Text
"filesystem", Text
"finger", Text
"fish", Text
"ftp", Text
"geo", Text
"gg"
, Text
"git", Text
"gizmoproject", Text
"go", Text
"gopher", Text
"graph", Text
"gtalk", Text
"h323", Text
"ham"
, Text
"hcp", Text
"http", Text
"https", Text
"hxxp", Text
"hxxps", Text
"hydrazone", Text
"iax", Text
"icap", Text
"icon"
, Text
"im", Text
"imap", Text
"info", Text
"iotdisco", Text
"ipn", Text
"ipp", Text
"ipps", Text
"irc", Text
"irc6"
, Text
"ircs", Text
"iris", Text
"iris.beep", Text
"iris.lwz", Text
"iris.xpc", Text
"iris.xpcs"
, Text
"isostore", Text
"itms", Text
"jabber", Text
"jar", Text
"jms", Text
"keyparc", Text
"lastfm", Text
"ldap"
, Text
"ldaps", Text
"lvlt", Text
"magnet", Text
"mailserver", Text
"mailto", Text
"maps", Text
"market"
, Text
"message", Text
"mid", Text
"mms", Text
"modem", Text
"mongodb", Text
"moz", Text
"ms-access"
, Text
"ms-browser-extension", Text
"ms-drive-to", Text
"ms-enrollment", Text
"ms-excel"
, Text
"ms-gamebarservices", Text
"ms-getoffice", Text
"ms-help", Text
"ms-infopath"
, Text
"ms-media-stream-id", Text
"ms-officeapp", Text
"ms-project", Text
"ms-powerpoint"
, Text
"ms-publisher", Text
"ms-search-repair", Text
"ms-secondary-screen-controller"
, Text
"ms-secondary-screen-setup", Text
"ms-settings", Text
"ms-settings-airplanemode"
, Text
"ms-settings-bluetooth", Text
"ms-settings-camera", Text
"ms-settings-cellular"
, Text
"ms-settings-cloudstorage", Text
"ms-settings-connectabledevices"
, Text
"ms-settings-displays-topology", Text
"ms-settings-emailandaccounts"
, Text
"ms-settings-language", Text
"ms-settings-location", Text
"ms-settings-lock"
, Text
"ms-settings-nfctransactions", Text
"ms-settings-notifications"
, Text
"ms-settings-power", Text
"ms-settings-privacy", Text
"ms-settings-proximity"
, Text
"ms-settings-screenrotation", Text
"ms-settings-wifi", Text
"ms-settings-workplace"
, Text
"ms-spd", Text
"ms-sttoverlay", Text
"ms-transit-to", Text
"ms-virtualtouchpad"
, Text
"ms-visio", Text
"ms-walk-to", Text
"ms-whiteboard", Text
"ms-whiteboard-cmd", Text
"ms-word"
, Text
"msnim", Text
"msrp", Text
"msrps", Text
"mtqp", Text
"mumble", Text
"mupdate", Text
"mvn", Text
"news", Text
"nfs"
, Text
"ni", Text
"nih", Text
"nntp", Text
"notes", Text
"ocf", Text
"oid", Text
"onenote", Text
"onenote-cmd"
, Text
"opaquelocktoken", Text
"pack", Text
"palm", Text
"paparazzi", Text
"pkcs11", Text
"platform", Text
"pop"
, Text
"pres", Text
"prospero", Text
"proxy", Text
"pwid", Text
"psyc", Text
"qb", Text
"query", Text
"redis"
, Text
"rediss", Text
"reload", Text
"res", Text
"resource", Text
"rmi", Text
"rsync", Text
"rtmfp", Text
"rtmp"
, Text
"rtsp", Text
"rtsps", Text
"rtspu", Text
"secondlife", Text
"service", Text
"session", Text
"sftp", Text
"sgn"
, Text
"shttp", Text
"sieve", Text
"sip", Text
"sips", Text
"skype", Text
"smb", Text
"sms", Text
"smtp", Text
"snews"
, Text
"snmp", Text
"soap.beep", Text
"soap.beeps", Text
"soldat", Text
"spotify", Text
"ssh", Text
"steam"
, Text
"stun", Text
"stuns", Text
"submit", Text
"svn", Text
"tag", Text
"teamspeak", Text
"tel", Text
"teliaeid"
, Text
"telnet", Text
"tftp", Text
"things", Text
"thismessage", Text
"tip", Text
"tn3270", Text
"tool", Text
"turn"
, Text
"turns", Text
"tv", Text
"udp", Text
"unreal", Text
"urn", Text
"ut2004", Text
"v-event", Text
"vemmi"
, Text
"ventrilo", Text
"videotex", Text
"vnc", Text
"view-source", Text
"wais", Text
"webcal", Text
"wpid"
, Text
"ws", Text
"wss", Text
"wtai", Text
"wyciwyg", Text
"xcon", Text
"xcon-userid", Text
"xfire"
, Text
"xmlrpc.beep", Text
"xmlrpc.beeps", Text
"xmpp", Text
"xri", Text
"ymsgr", Text
"z39.50", Text
"z39.50r"
, Text
"z39.50s"
, Text
"doi", Text
"isbn", Text
"javascript", Text
"pmid"
]
isURI :: T.Text -> Bool
isURI :: Text -> Bool
isURI = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False URI -> Bool
hasKnownScheme forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe URI
parseURI forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack
where
hasKnownScheme :: URI -> Bool
hasKnownScheme = (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
':') forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> FilePath
uriScheme