1{-# LANGUAGE CPP                        #-}
2{-# LANGUAGE FlexibleContexts           #-}
3{-# LANGUAGE UndecidableInstances       #-}
4{-# LANGUAGE OverloadedStrings          #-}
5{-# LANGUAGE FlexibleInstances          #-}
6{-# LANGUAGE MultiParamTypeClasses      #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE LambdaCase                 #-}
9module Commonmark.SourceMap
10  ( SourceMap(..)
11  , WithSourceMap(..)
12  , runWithSourceMap
13  , addName
14  )
15where
16import           Data.Text            (Text)
17import qualified Data.Text            as T
18import qualified Data.Map.Strict      as M
19import qualified Data.Sequence as Seq
20import Commonmark.Types
21import Control.Monad.Trans.State
22#if !MIN_VERSION_base(4,11,0)
23import           Data.Semigroup       (Semigroup, (<>))
24#endif
25
26-- | A map from source positions to a pair of sequences:
27-- first, elements that start at that position; then, elements
28-- that end at that position.
29newtype SourceMap =
30  SourceMap { unSourceMap :: M.Map SourcePos (Seq.Seq Text, Seq.Seq Text) }
31  deriving (Show)
32
33instance Semigroup SourceMap where
34  (SourceMap m1) <> (SourceMap m2) =
35    SourceMap (M.unionWith combine m1 m2)
36
37instance Monoid SourceMap where
38  mempty = SourceMap mempty
39  mappend = (<>)
40
41instance HasAttributes (WithSourceMap a) where
42  addAttributes _attrs x = x
43
44
45combine :: (Seq.Seq Text, Seq.Seq Text)
46        -> (Seq.Seq Text, Seq.Seq Text)
47        -> (Seq.Seq Text, Seq.Seq Text)
48combine (s1,e1) (s2,e2) = (s1 <> s2, e1 <> e2)
49
50-- | Use this when you want to extract a source map as well
51-- as the parsed content.
52newtype WithSourceMap a =
53        WithSourceMap { unWithSourceMap :: State (Maybe Text, SourceMap) a }
54        deriving (Functor, Applicative, Monad)
55
56instance (Show a, Semigroup a) => Semigroup (WithSourceMap a) where
57  (WithSourceMap x1) <> (WithSourceMap x2) =
58    WithSourceMap ((<>) <$> x1 <*> x2)
59
60instance (Show a, Semigroup a, Monoid a) => Monoid (WithSourceMap a) where
61  mempty = WithSourceMap (return mempty)
62  mappend = (<>)
63
64instance (Show a, Monoid a) => Show (WithSourceMap a) where
65  show (WithSourceMap x) = show $ evalState x mempty
66
67-- | Extract a parsed value and a source map from a
68-- 'WithSourceMap'.
69runWithSourceMap :: (Show a, Monoid a)
70                 => WithSourceMap a -> (a, SourceMap)
71runWithSourceMap (WithSourceMap x) = (v, sm)
72  where (v, (_,sm)) = runState x (mempty, mempty)
73
74addName :: Text -> WithSourceMap ()
75addName name =
76  WithSourceMap $ modify (\(_,sm) -> (Just name,sm))
77
78instance (IsInline a, Semigroup a) => IsInline (WithSourceMap a) where
79  lineBreak = lineBreak <$ addName "lineBreak"
80  softBreak = softBreak <$ addName "softBreak"
81  str t = str t <$ addName "str"
82  entity t = entity t <$ addName "str"
83  escapedChar c = escapedChar c <$ addName "escapedChar"
84  emph x = (emph <$> x) <* addName "emph"
85  strong x = (strong <$> x) <* addName "strong"
86  link dest tit x = (link dest tit <$> x) <* addName "link"
87  image dest tit x = (image dest tit <$> x) <* addName "image"
88  code t = code t <$ addName "code"
89  rawInline f t = rawInline f t <$ addName "rawInline"
90
91instance (IsBlock b a, IsInline b, IsInline (WithSourceMap b), Semigroup a)
92         => IsBlock (WithSourceMap b) (WithSourceMap a) where
93  paragraph x = (paragraph <$> x) <* addName "paragraph"
94  plain x = (plain <$> x) <* addName "plain"
95  thematicBreak = thematicBreak <$ addName "thematicBreak"
96  blockQuote x = (blockQuote <$> x) <* addName "blockQuote"
97  codeBlock i t = codeBlock i t <$ addName "codeBlock"
98  heading lev x = (heading lev <$> x) <*
99                     addName ("heading" <> T.pack (show lev))
100  rawBlock f t = rawBlock f t <$ addName "rawBlock"
101  referenceLinkDefinition k x = referenceLinkDefinition k x <$
102               addName "referenceLinkDefinition"
103  list lt ls items = (list lt ls <$> sequence items) <* addName "list"
104
105instance (Rangeable a, Monoid a, Show a)
106         => Rangeable (WithSourceMap a) where
107  ranged (SourceRange rs) (WithSourceMap x) =
108    WithSourceMap $
109      do res <- x
110         (mbt, SourceMap sm) <- get
111         case mbt of
112           Just t -> do
113             let (starts, ends) = unzip rs
114             let addStart = M.alter (\case
115                                       Nothing    ->
116                                         Just (Seq.singleton t, mempty)
117                                       Just (s,e) ->
118                                         Just (t Seq.<| s, e))
119             let addEnd = M.alter (\case
120                                     Nothing    ->
121                                       Just (mempty, Seq.singleton t)
122                                     Just (s,e) ->
123                                       Just (s, e Seq.|> t))
124             let sm' = foldr addStart sm starts
125             let sm'' = foldr addEnd sm' ends
126             put (mempty, SourceMap sm'')
127             return $! res
128           Nothing -> return $! res
129
130instance ToPlainText a => ToPlainText (WithSourceMap a) where
131  toPlainText (WithSourceMap x) =
132    let v = evalState x (mempty, mempty)
133    in  toPlainText v
134