{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Commonmark.Extensions.AutoIdentifiers
  ( autoIdentifiersSpec
  , autoIdentifiersAsciiSpec
  )
where
import Commonmark.Types
import Commonmark.Syntax
import Commonmark.Blocks
import Data.Char (isSpace, isAlphaNum, isAscii, isMark,
                  generalCategory, GeneralCategory(ConnectorPunctuation))
import Data.Dynamic
import qualified Data.Map as M
import qualified Data.Text as T
import Text.Parsec
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif

autoIdentifiersSpec :: (Monad m, IsBlock il bl, IsInline il, ToPlainText il)
                    => SyntaxSpec m il bl
autoIdentifiersSpec :: SyntaxSpec m il bl
autoIdentifiersSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxFinalParsers :: [BlockParser m il bl bl]
syntaxFinalParsers = [Bool -> BlockParser m il bl bl
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, ToPlainText il) =>
Bool -> BlockParser m il bl bl
addAutoIdentifiers Bool
False]
  }

autoIdentifiersAsciiSpec
                    :: (Monad m, IsBlock il bl, IsInline il, ToPlainText il)
                    => SyntaxSpec m il bl
autoIdentifiersAsciiSpec :: SyntaxSpec m il bl
autoIdentifiersAsciiSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxFinalParsers :: [BlockParser m il bl bl]
syntaxFinalParsers = [Bool -> BlockParser m il bl bl
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, ToPlainText il) =>
Bool -> BlockParser m il bl bl
addAutoIdentifiers Bool
True]
  }

-- Go through the node stack and add identifiers where they
-- are missing.
addAutoIdentifiers :: (Monad m, IsBlock il bl, IsInline il, ToPlainText il)
                   => Bool -> BlockParser m il bl bl
addAutoIdentifiers :: Bool -> BlockParser m il bl bl
addAutoIdentifiers ascii :: Bool
ascii = do
  [BlockNode m il bl]
nodes <- BPState m il bl -> [BlockNode m il bl]
forall (m :: * -> *) il bl. BPState m il bl -> [BlockNode m il bl]
nodeStack (BPState m il bl -> [BlockNode m il bl])
-> ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m [BlockNode m il bl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
  [BlockNode m il bl]
nodes' <- (BlockNode m il bl
 -> ParsecT [Tok] (BPState m il bl) m (BlockNode m il bl))
-> [BlockNode m il bl]
-> ParsecT [Tok] (BPState m il bl) m [BlockNode m il bl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((BlockData m il bl
 -> ParsecT [Tok] (BPState m il bl) m (BlockData m il bl))
-> BlockNode m il bl
-> ParsecT [Tok] (BPState m il bl) m (BlockNode m il bl)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((BlockData m il bl
  -> ParsecT [Tok] (BPState m il bl) m (BlockData m il bl))
 -> BlockNode m il bl
 -> ParsecT [Tok] (BPState m il bl) m (BlockNode m il bl))
-> (BlockData m il bl
    -> ParsecT [Tok] (BPState m il bl) m (BlockData m il bl))
-> BlockNode m il bl
-> ParsecT [Tok] (BPState m il bl) m (BlockNode m il bl)
forall a b. (a -> b) -> a -> b
$ Bool
-> BlockData m il bl
-> ParsecT [Tok] (BPState m il bl) m (BlockData m il bl)
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, ToPlainText il) =>
Bool
-> BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
addId Bool
ascii) [BlockNode m il bl]
nodes
  (BPState m il bl -> BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((BPState m il bl -> BPState m il bl)
 -> ParsecT [Tok] (BPState m il bl) m ())
-> (BPState m il bl -> BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b. (a -> b) -> a -> b
$ \st :: BPState m il bl
st -> BPState m il bl
st{ nodeStack :: [BlockNode m il bl]
nodeStack = [BlockNode m il bl]
nodes' }
  bl -> BlockParser m il bl bl
forall (m :: * -> *) a. Monad m => a -> m a
return (bl -> BlockParser m il bl bl) -> bl -> BlockParser m il bl bl
forall a b. (a -> b) -> a -> b
$! bl
forall a. Monoid a => a
mempty

addId :: (Monad m, IsBlock il bl, IsInline il, ToPlainText il)
       => Bool -> BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
addId :: Bool
-> BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
addId ascii :: Bool
ascii bd :: BlockData m il bl
bd
  | BlockSpec m il bl -> Text
forall (m :: * -> *) il bl. BlockSpec m il bl -> Text
blockType (BlockData m il bl -> BlockSpec m il bl
forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec BlockData m il bl
bd) Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["ATXHeading", "SetextHeading"] =
    case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "id" (BlockData m il bl -> [(Text, Text)]
forall (m :: * -> *) il bl. BlockData m il bl -> [(Text, Text)]
blockAttributes BlockData m il bl
bd) of
      Nothing  -> do
        il
contents <- [Tok] -> BlockParser m il bl il
forall (m :: * -> *) il bl.
Monad m =>
[Tok] -> BlockParser m il bl il
runInlineParser
                    ([Tok] -> [Tok]
removeIndent ([Tok] -> [Tok])
-> (BlockData m il bl -> [Tok]) -> BlockData m il bl -> [Tok]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Tok]] -> [Tok]
forall a. Monoid a => [a] -> a
mconcat ([[Tok]] -> [Tok])
-> (BlockData m il bl -> [[Tok]]) -> BlockData m il bl -> [Tok]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Tok]] -> [[Tok]]
forall a. [a] -> [a]
reverse ([[Tok]] -> [[Tok]])
-> (BlockData m il bl -> [[Tok]]) -> BlockData m il bl -> [[Tok]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockData m il bl -> [[Tok]]
forall (m :: * -> *) il bl. BlockData m il bl -> [[Tok]]
blockLines (BlockData m il bl -> [Tok]) -> BlockData m il bl -> [Tok]
forall a b. (a -> b) -> a -> b
$ BlockData m il bl
bd)
        let ident :: Text
ident = Bool -> Text -> Text
makeIdentifier Bool
ascii (il -> Text
forall a. ToPlainText a => a -> Text
toPlainText il
contents)
        Map Text Dynamic
counterMap <- BPState m il bl -> Map Text Dynamic
forall (m :: * -> *) il bl. BPState m il bl -> Map Text Dynamic
counters (BPState m il bl -> Map Text Dynamic)
-> ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m (Map Text Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
        let key :: Text
key = "identifier:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident
        Int
cnt <- case Text -> Map Text Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Map Text Dynamic
counterMap of
                    Nothing -> Int -> ParsecT [Tok] (BPState m il bl) m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 0
                    Just x :: Dynamic
x  -> Int -> ParsecT [Tok] (BPState m il bl) m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ParsecT [Tok] (BPState m il bl) m Int)
-> Int -> ParsecT [Tok] (BPState m il bl) m Int
forall a b. (a -> b) -> a -> b
$! (Dynamic -> Int -> Int
forall a. Typeable a => Dynamic -> a -> a
fromDyn Dynamic
x (0 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
        let ident' :: Text
ident' = if Int
cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
                        then Text
ident
                        else Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
cnt)
        (BPState m il bl -> BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((BPState m il bl -> BPState m il bl)
 -> ParsecT [Tok] (BPState m il bl) m ())
-> (BPState m il bl -> BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b. (a -> b) -> a -> b
$ \st :: BPState m il bl
st ->
          BPState m il bl
st{ counters :: Map Text Dynamic
counters = Text -> Dynamic -> Map Text Dynamic -> Map Text Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
key (Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
cnt) Map Text Dynamic
counterMap }
        BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockData m il bl -> BlockParser m il bl (BlockData m il bl))
-> BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
forall a b. (a -> b) -> a -> b
$! BlockData m il bl
bd{ blockAttributes :: [(Text, Text)]
blockAttributes = ("id",Text
ident') (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: BlockData m il bl -> [(Text, Text)]
forall (m :: * -> *) il bl. BlockData m il bl -> [(Text, Text)]
blockAttributes BlockData m il bl
bd }
      Just _ -> BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockData m il bl -> BlockParser m il bl (BlockData m il bl))
-> BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
forall a b. (a -> b) -> a -> b
$! BlockData m il bl
bd
  | Bool
otherwise = BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockData m il bl -> BlockParser m il bl (BlockData m il bl))
-> BlockData m il bl -> BlockParser m il bl (BlockData m il bl)
forall a b. (a -> b) -> a -> b
$! BlockData m il bl
bd

makeIdentifier :: Bool -> T.Text -> T.Text
makeIdentifier :: Bool -> Text -> Text
makeIdentifier ascii :: Bool
ascii = Text -> Text
toIdent (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower
  where
    toIdent :: Text -> Text
toIdent = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
f
    f :: Char -> Text
f '-' = "-"
    f '_' = "_"
    f c :: Char
c | Char -> Bool
isSpace Char
c = "-"
    f c :: Char
c | Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> Bool
isMark Char
c Bool -> Bool -> Bool
||
          Char -> GeneralCategory
generalCategory Char
c GeneralCategory -> GeneralCategory -> Bool
forall a. Eq a => a -> a -> Bool
== GeneralCategory
ConnectorPunctuation
                    = Char -> Text
fromchar Char
c
        | Bool
otherwise = Text
forall a. Monoid a => a
mempty
    fromchar :: Char -> Text
fromchar c :: Char
c
      | Bool
ascii
      , Bool -> Bool
not (Char -> Bool
isAscii Char
c) = Text -> (Char -> Text) -> Maybe Char -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty Char -> Text
T.singleton (Maybe Char -> Text) -> Maybe Char -> Text
forall a b. (a -> b) -> a -> b
$ Char -> Map Char Char -> Maybe Char
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Char
c Map Char Char
asciiMap
      | Bool
otherwise       = Char -> Text
T.singleton Char
c

asciiMap :: M.Map Char Char
asciiMap :: Map Char Char
asciiMap = [(Char, Char)] -> Map Char Char
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [('\192','A')
  ,('\193','A')
  ,('\194','A')
  ,('\195','A')
  ,('\196','A')
  ,('\197','A')
  ,('\199','C')
  ,('\200','E')
  ,('\201','E')
  ,('\202','E')
  ,('\203','E')
  ,('\204','I')
  ,('\205','I')
  ,('\206','I')
  ,('\207','I')
  ,('\209','N')
  ,('\210','O')
  ,('\211','O')
  ,('\212','O')
  ,('\213','O')
  ,('\214','O')
  ,('\217','U')
  ,('\218','U')
  ,('\219','U')
  ,('\220','U')
  ,('\221','Y')
  ,('\224','a')
  ,('\225','a')
  ,('\226','a')
  ,('\227','a')
  ,('\228','a')
  ,('\229','a')
  ,('\231','c')
  ,('\232','e')
  ,('\233','e')
  ,('\234','e')
  ,('\235','e')
  ,('\236','i')
  ,('\237','i')
  ,('\238','i')
  ,('\239','i')
  ,('\241','n')
  ,('\242','o')
  ,('\243','o')
  ,('\244','o')
  ,('\245','o')
  ,('\246','o')
  ,('\249','u')
  ,('\250','u')
  ,('\251','u')
  ,('\252','u')
  ,('\253','y')
  ,('\255','y')
  ,('\256','A')
  ,('\257','a')
  ,('\258','A')
  ,('\259','a')
  ,('\260','A')
  ,('\261','a')
  ,('\262','C')
  ,('\263','c')
  ,('\264','C')
  ,('\265','c')
  ,('\266','C')
  ,('\267','c')
  ,('\268','C')
  ,('\269','c')
  ,('\270','D')
  ,('\271','d')
  ,('\274','E')
  ,('\275','e')
  ,('\276','E')
  ,('\277','e')
  ,('\278','E')
  ,('\279','e')
  ,('\280','E')
  ,('\281','e')
  ,('\282','E')
  ,('\283','e')
  ,('\284','G')
  ,('\285','g')
  ,('\286','G')
  ,('\287','g')
  ,('\288','G')
  ,('\289','g')
  ,('\290','G')
  ,('\291','g')
  ,('\292','H')
  ,('\293','h')
  ,('\296','I')
  ,('\297','i')
  ,('\298','I')
  ,('\299','i')
  ,('\300','I')
  ,('\301','i')
  ,('\302','I')
  ,('\303','i')
  ,('\304','I')
  ,('\305','i')
  ,('\308','J')
  ,('\309','j')
  ,('\310','K')
  ,('\311','k')
  ,('\313','L')
  ,('\314','l')
  ,('\315','L')
  ,('\316','l')
  ,('\317','L')
  ,('\318','l')
  ,('\323','N')
  ,('\324','n')
  ,('\325','N')
  ,('\326','n')
  ,('\327','N')
  ,('\328','n')
  ,('\332','O')
  ,('\333','o')
  ,('\334','O')
  ,('\335','o')
  ,('\336','O')
  ,('\337','o')
  ,('\340','R')
  ,('\341','r')
  ,('\342','R')
  ,('\343','r')
  ,('\344','R')
  ,('\345','r')
  ,('\346','S')
  ,('\347','s')
  ,('\348','S')
  ,('\349','s')
  ,('\350','S')
  ,('\351','s')
  ,('\352','S')
  ,('\353','s')
  ,('\354','T')
  ,('\355','t')
  ,('\356','T')
  ,('\357','t')
  ,('\360','U')
  ,('\361','u')
  ,('\362','U')
  ,('\363','u')
  ,('\364','U')
  ,('\365','u')
  ,('\366','U')
  ,('\367','u')
  ,('\368','U')
  ,('\369','u')
  ,('\370','U')
  ,('\371','u')
  ,('\372','W')
  ,('\373','w')
  ,('\374','Y')
  ,('\375','y')
  ,('\376','Y')
  ,('\377','Z')
  ,('\378','z')
  ,('\379','Z')
  ,('\380','z')
  ,('\381','Z')
  ,('\382','z')
  ,('\416','O')
  ,('\417','o')
  ,('\431','U')
  ,('\432','u')
  ,('\461','A')
  ,('\462','a')
  ,('\463','I')
  ,('\464','i')
  ,('\465','O')
  ,('\466','o')
  ,('\467','U')
  ,('\468','u')
  ,('\486','G')
  ,('\487','g')
  ,('\488','K')
  ,('\489','k')
  ,('\490','O')
  ,('\491','o')
  ,('\496','j')
  ,('\500','G')
  ,('\501','g')
  ,('\504','N')
  ,('\505','n')
  ,('\512','A')
  ,('\513','a')
  ,('\514','A')
  ,('\515','a')
  ,('\516','E')
  ,('\517','e')
  ,('\518','E')
  ,('\519','e')
  ,('\520','I')
  ,('\521','i')
  ,('\522','I')
  ,('\523','i')
  ,('\524','O')
  ,('\525','o')
  ,('\526','O')
  ,('\527','o')
  ,('\528','R')
  ,('\529','r')
  ,('\530','R')
  ,('\531','r')
  ,('\532','U')
  ,('\533','u')
  ,('\534','U')
  ,('\535','u')
  ,('\536','S')
  ,('\537','s')
  ,('\538','T')
  ,('\539','t')
  ,('\542','H')
  ,('\543','h')
  ,('\550','A')
  ,('\551','a')
  ,('\552','E')
  ,('\553','e')
  ,('\558','O')
  ,('\559','o')
  ,('\562','Y')
  ,('\563','y')
  ,('\894',';')
  ,('\7680','A')
  ,('\7681','a')
  ,('\7682','B')
  ,('\7683','b')
  ,('\7684','B')
  ,('\7685','b')
  ,('\7686','B')
  ,('\7687','b')
  ,('\7690','D')
  ,('\7691','d')
  ,('\7692','D')
  ,('\7693','d')
  ,('\7694','D')
  ,('\7695','d')
  ,('\7696','D')
  ,('\7697','d')
  ,('\7698','D')
  ,('\7699','d')
  ,('\7704','E')
  ,('\7705','e')
  ,('\7706','E')
  ,('\7707','e')
  ,('\7710','F')
  ,('\7711','f')
  ,('\7712','G')
  ,('\7713','g')
  ,('\7714','H')
  ,('\7715','h')
  ,('\7716','H')
  ,('\7717','h')
  ,('\7718','H')
  ,('\7719','h')
  ,('\7720','H')
  ,('\7721','h')
  ,('\7722','H')
  ,('\7723','h')
  ,('\7724','I')
  ,('\7725','i')
  ,('\7728','K')
  ,('\7729','k')
  ,('\7730','K')
  ,('\7731','k')
  ,('\7732','K')
  ,('\7733','k')
  ,('\7734','L')
  ,('\7735','l')
  ,('\7738','L')
  ,('\7739','l')
  ,('\7740','L')
  ,('\7741','l')
  ,('\7742','M')
  ,('\7743','m')
  ,('\7744','M')
  ,('\7745','m')
  ,('\7746','M')
  ,('\7747','m')
  ,('\7748','N')
  ,('\7749','n')
  ,('\7750','N')
  ,('\7751','n')
  ,('\7752','N')
  ,('\7753','n')
  ,('\7754','N')
  ,('\7755','n')
  ,('\7764','P')
  ,('\7765','p')
  ,('\7766','P')
  ,('\7767','p')
  ,('\7768','R')
  ,('\7769','r')
  ,('\7770','R')
  ,('\7771','r')
  ,('\7774','R')
  ,('\7775','r')
  ,('\7776','S')
  ,('\7777','s')
  ,('\7778','S')
  ,('\7779','s')
  ,('\7786','T')
  ,('\7787','t')
  ,('\7788','T')
  ,('\7789','t')
  ,('\7790','T')
  ,('\7791','t')
  ,('\7792','T')
  ,('\7793','t')
  ,('\7794','U')
  ,('\7795','u')
  ,('\7796','U')
  ,('\7797','u')
  ,('\7798','U')
  ,('\7799','u')
  ,('\7804','V')
  ,('\7805','v')
  ,('\7806','V')
  ,('\7807','v')
  ,('\7808','W')
  ,('\7809','w')
  ,('\7810','W')
  ,('\7811','w')
  ,('\7812','W')
  ,('\7813','w')
  ,('\7814','W')
  ,('\7815','w')
  ,('\7816','W')
  ,('\7817','w')
  ,('\7818','X')
  ,('\7819','x')
  ,('\7820','X')
  ,('\7821','x')
  ,('\7822','Y')
  ,('\7823','y')
  ,('\7824','Z')
  ,('\7825','z')
  ,('\7826','Z')
  ,('\7827','z')
  ,('\7828','Z')
  ,('\7829','z')
  ,('\7830','h')
  ,('\7831','t')
  ,('\7832','w')
  ,('\7833','y')
  ,('\7840','A')
  ,('\7841','a')
  ,('\7842','A')
  ,('\7843','a')
  ,('\7864','E')
  ,('\7865','e')
  ,('\7866','E')
  ,('\7867','e')
  ,('\7868','E')
  ,('\7869','e')
  ,('\7880','I')
  ,('\7881','i')
  ,('\7882','I')
  ,('\7883','i')
  ,('\7884','O')
  ,('\7885','o')
  ,('\7886','O')
  ,('\7887','o')
  ,('\7908','U')
  ,('\7909','u')
  ,('\7910','U')
  ,('\7911','u')
  ,('\7922','Y')
  ,('\7923','y')
  ,('\7924','Y')
  ,('\7925','y')
  ,('\7926','Y')
  ,('\7927','y')
  ,('\7928','Y')
  ,('\7929','y')
  ,('\8175','`')
  ,('\8490','K')
  ,('\8800','=')
  ,('\8814','<')
  ,('\8815','>')
  ]