[#150] [WIP] Add highlighting for chain changes in snippets

src/Snippets/Parser.hs

@@ -7,6 +7,8 @@ module Snippets.Parser
 )
 where
 
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IM
 import qualified Data.Map as M (fromList)
 import Imports
 
@@ -14,12 +16,17 @@ import Imports
 import qualified Data.Text            as T
 import qualified Data.Text.IO         as TIO
 -- MegaParsec
-import           Text.Megaparsec      (alphaNumChar, anyChar, between, char, letterChar, many, manyTill, notFollowedBy, sepBy, space, string)
+import           Text.Megaparsec      ( alphaNumChar, anyChar
+                                      , between, char
+                                      , letterChar, many
+                                      , manyTill, notFollowedBy
+                                      , sepBy, space, string
+                                      )
 import qualified Text.Megaparsec      as MP
 import           Text.Megaparsec.Text (Parser)
 
--- TODO: take out `Multiple` to separate type and parse once in the beggining of the snippet
-data SnippetNode = Multiple [Text]
+
+data SnippetNode = Multiple (IntMap Text)
                  | Choice (Map Text Text)
                  | CodeText Text
                  | Hackage Text
@@ -75,7 +82,7 @@ parseMultiple :: Parser [SnippetNode]
 parseMultiple = do
   keyword "Multiple"
   multNames <- betweenBrackets labels
-  pure [Multiple multNames]
+  pure [Multiple $ IM.fromList $ zip [1..] multNames]
 
 parseChoice :: Parser SnippetNode
 parseChoice = do

src/Snippets/Renderer.hs

@@ -6,16 +6,17 @@
 module Snippets.Renderer
 where
 
-import Imports
+import           Imports
 
-import qualified Data.Map as M (lookup)
+import qualified Data.IntMap     as IM
+import qualified Data.Map        as M (lookup)
 
 --import Text.Highlighting.Kate
 -- Web
-import Lucid hiding (for_)
+import           Lucid           hiding (for_)
 
-import Guide.Utils
-import Snippets.Parser
+import           Guide.Utils
+import           Snippets.Parser
 
 renderTestSnippets :: (MonadIO m) => IO (HtmlT m ())
 renderTestSnippets = do
@@ -24,8 +25,9 @@ renderTestSnippets = do
     includeJS "/snippetTabs.js"
     includeCSS "/snippets.css"
     title_ "Snippets – Aelve Guide"
-    meta_ [name_ "viewport",
-         content_ "width=device-width, initial-scale=1.0, user-scalable=yes"]
+    meta_ [ name_ "viewport"
+          , content_ "width=device-width, initial-scale=1.0, user-scalable=yes"
+          ]
 
     body_ $ renderSnippet nodes
 
@@ -34,48 +36,69 @@ renderSnippet [] = div_ "Empty Snippet"
 renderSnippet x = do
   let (snpt, rest) = createLabels x
   unless (null snpt) $ createTabButtons snpt
-  for_ snpt $ \lbl -> renderTab lbl rest
+  for_ snpt $ \lbl -> renderTab snpt lbl rest
 
-createLabels :: [[SnippetNode]] -> ([Text], [[SnippetNode]])
-createLabels ([Multiple lbls]:xs) = (lbls, xs)
-createLabels ([]:xs) = createLabels xs
-createLabels x = ([], x)
+createLabels :: [[SnippetNode]] -> ([(Int, Text)], [[SnippetNode]])
+createLabels ([Multiple lbls]:xs) = (IM.assocs lbls, xs)
+createLabels ([]:xs)              = createLabels xs
+createLabels x                    = ([], x)
 
-createTabButtons :: (MonadIO m) => [Text] -> HtmlT m ()
+createTabButtons :: (MonadIO m) => [(Int, Text)] -> HtmlT m ()
 createTabButtons [] = div_ "error"
-createTabButtons (lbl:lbls) =
-  div_ [class_ "tab"] $ do
+createTabButtons lbls =
+  div_ [class_ "tab"] $
+    for_ lbls $ \l -> renderButton l
+ where
+  renderButton :: (MonadIO m) => (Int, Text) -> HtmlT m ()
+  renderButton (1, lbl) =
     button_ [class_ "tablinks", onclick_ ("openCode(event , \"" <> lbl <> "\")"), id_ "defaultOpen"] $ toHtml lbl
-    for_ lbls $ \l ->
-      button_ [class_ "tablinks", onclick_ ("openCode(event , \"" <> l <> "\")")] $ toHtml l
+  renderButton (_, lbl) =
+    button_ [class_ "tablinks", onclick_ ("openCode(event , \"" <> lbl <> "\")")] $ toHtml lbl
 
-renderTab :: (MonadIO m) => Text -> [[SnippetNode]] -> HtmlT m ()
-renderTab lbl x = div_ [class_ "code tabcontent", id_ lbl] $
+renderTab :: (MonadIO m) => [(Int, Text)] -> (Int, Text) -> [[SnippetNode]] -> HtmlT m ()
+renderTab lbls intLbl@(_, lbl) x = div_ [class_ "code tabcontent", id_ lbl] $
   pre_ $
-    for_ x (renderLine lbl)
+    for_ x (renderLine lbls intLbl)
 
-renderLine :: (MonadIO m) => Text -> [SnippetNode] -> HtmlT m ()
-renderLine lbl x =
+renderLine :: (MonadIO m) => [(Int, Text)] -> (Int, Text) -> [SnippetNode] -> HtmlT m ()
+renderLine lbls intLbl x =
   unless (null x) $
     case head x of
-      HltLine -> mark_ [class_ "lineMark"] $ renderNode lbl (tail x)
-      _       -> renderNode lbl x
+      HltLine -> mark_ [class_ "lineMark"] $ renderNode lbls intLbl (tail x)
+      _       -> renderNode lbls intLbl x
 
 
-renderNode :: (MonadIO m) => Text -> [SnippetNode] -> HtmlT m ()
-renderNode _ [] = "\n"
-renderNode lbl (HltBegin:xs) = do
-  mark_ [class_ "inlineMark"] $ renderNode lbl (takeWhile (HltEnd /=) xs)
-  renderNode lbl(tail $ dropWhile (HltEnd /=) xs)
-renderNode lbl (CodeText t : xs) = do
+renderNode :: (MonadIO m) => [(Int, Text)] -> (Int, Text) -> [SnippetNode] -> HtmlT m ()
+renderNode _ _ [] = "\n"
+renderNode lbls intLbl (HltBegin:xs) = do
+  mark_ [class_ "inlineMark"] $ renderNode lbls intLbl (takeWhile (HltEnd /=) xs)
+  renderNode lbls intLbl (tail $ dropWhile (HltEnd /=) xs)
+renderNode lbls intLbl (CodeText t : xs) = do
   toHtml t
-  renderNode lbl xs
-renderNode lbl (Choice x:xs) = do
-  case M.lookup lbl x of
-    Just txt -> toHtml txt
+  renderNode lbls intLbl xs
+renderNode lbls intLbl@(curInt, curLbl) (Choice x:xs) = do
+  case M.lookup curLbl x of
+    Just curTxt ->
+      if curInt == 1
+        then toHtml curTxt
+      else
+        case findLblByInd (pred curInt) lbls of
+             Just prevLbl -> case M.lookup prevLbl x of
+                                  Just prevTxt ->
+                                    if prevTxt /= curTxt
+                                      then span_ [class_ "diff"] $ toHtml curTxt
+                                    else toHtml curTxt
+                                  Nothing -> span_ [class_ "diff"] $ toHtml curTxt
+             Nothing -> toHtml curTxt
     Nothing -> ""
-  renderNode lbl xs
-renderNode lbl (Hackage x:xs) = do
+  renderNode lbls intLbl xs
+renderNode lbls lbl (Hackage x:xs) = do
   a_ [href_ "#"] (toHtml x)
-  renderNode lbl xs
-renderNode lbl (_:xs) = renderNode lbl xs
+  renderNode lbls lbl xs
+renderNode lbls lbl (_:xs) = renderNode lbls lbl xs
+
+findLblByInd :: Int -> [(Int, Text)] -> Maybe Text
+findLblByInd _ [] = Nothing
+findLblByInd n ((i, x):xs)
+  | i == n = Just x
+  | otherwise = findLblByInd n xs

static/snippets.css

@@ -44,4 +44,8 @@ div.tab button.active {
     padding: 6px 12px;
     border: 1px solid #ccc;
     border-top: none;
+}
+
+.diff {
+    background-color: cadetblue;
 }