[server] fixing main / see also etc., and comment parser

1 files changed, 44 insertions, 23 deletions

diff --git a/src/Servall/WikiParser.hs b/src/Servall/WikiParser.hs
index 7053197..56f2d94 100644
--- a/src/Servall/WikiParser.hs
+++ b/src/Servall/WikiParser.hs
@@ -29,10 +29,15 @@ import           Data.Attoparsec.Text           ( Parser
 import           Data.Char                      ( isAlpha
                                                 , isAlphaNum
                                                 )
-import           Data.Either                    ( fromRight )
-import           Data.List                      ( find )
+import           Data.Either                    ( fromRight
+                                                , rights
+                                                )
+import           Data.List                      ( find
+                                                , intersperse
+                                                )
 import           Data.Maybe                     ( catMaybes
                                                 , fromMaybe
+                                                , isNothing
                                                 , mapMaybe
                                                 , maybeToList
                                                 )
@@ -72,7 +77,7 @@ templateP = do
   string "{{"
   name <- tempHeaderP
   skipSpace
-  fields <- many' (choice [tempFieldP, commentP >> return Nothing])
+  fields <- many' tempFieldP
   string "}}"
   return $ WikiTemplate name (catMaybes fields)
 
@@ -122,7 +127,7 @@ tempHeaderP = do
 tempFieldP :: Parser (Maybe (Maybe Text, Text))
 tempFieldP = do
   char '|' >> skipSpace
-  choice [namedField, fmap (Just . (Nothing, )) tempFieldValueP]
+  namedField <|> fmap (Just . (Nothing, )) tempFieldValueP
  where
   namedField = do
     key <- takeWhile1 (\c -> isAlphaNum c || c `elem` ['_', '-'])
@@ -163,13 +168,7 @@ tempFieldValueP = do
 
 commentP :: Parser ()
 commentP = do
-  string "<!--" >> untilCommentEnd ""
- where
-  untilCommentEnd :: Text -> Parser ()
-  untilCommentEnd xs | T.isSuffixOf "--" xs = char '>' >> return ()
-  untilCommentEnd _                         = do
-    xs <- takeWhile1 (/= '>')
-    untilCommentEnd xs
+  string "<!--" >> manyTill anyChar (string "-->") >> return ()
 
 wikilinkP :: Parser Text
 wikilinkP = do
@@ -193,7 +192,7 @@ skipRefP = (ref1 <|> ref2) >> ""
   ref2 = string "<ref " >> manyTill (notChar '>') (string "/>")
 
 wikiFilter :: Text -> Pandoc -> Pandoc
-wikiFilter title = fixHeaderTemplates . topDown fixInline . insertHeader title
+wikiFilter title = topDown fixInline . fixHeaderTemplates . insertHeader title
 
 insertHeader :: Text -> Pandoc -> Pandoc
 insertHeader title (Pandoc m bs) =
@@ -203,21 +202,43 @@ fixHeaderTemplates :: Pandoc -> Pandoc
 fixHeaderTemplates (Pandoc m blocks) = Pandoc m (go [] blocks) where
   go :: [Block] -> [Block] -> [Block]
   go acc [] = acc
-  go acc (Header level (x, y, attr) content : bs) =
+  go acc (b : bs) =
     let (raws, rest) = span isTemplateBlock bs
+    -- assume all parsing returns Right
     in  go
-          (  acc
-          ++ [ Header
-                 level
-                 ( x
-                 , y
-                 , attr ++ infobox (T.concat (map templateFromRawBlock raws))
-                 )
-                 content
-             ]
+          (acc ++ processTemplates
+            [b]
+            (rights (map (parseOnly templateP . templateFromRawBlock) raws))
           )
           rest
-  go acc (b : bs) = go (acc ++ [b]) bs
+  processTemplates :: [Block] -> [WikiTemplate] -> [Block]
+  processTemplates bs [] = bs
+  processTemplates (Header level (x, y, attr) content : bs) (t : ts)
+    | isInfobox t = processTemplates
+      (Header level (x, y, attr ++ filterNameValues (wtArgs t)) content : bs)
+      ts
+  processTemplates bs (t : ts) = processTemplates (bs ++ templateToBlocks t) ts
+
+templateToBlocks :: WikiTemplate -> [Block]
+templateToBlocks (WikiTemplate key pairs)
+  | key `elem` ["Main", "See also", "Further"]
+  = [ Para
+        [ Emph
+            ([Str (showKey key)] ++ intersperse
+              (Str ", ")
+              ( map
+                  (\(_, title) -> Link nullAttr [Str title] (title, "wikilink"))
+              $ filter (\(k, v) -> isNothing k && (not (T.null v))) pairs
+              )
+            )
+        ]
+    ]
+ where
+  showKey "Main"     = "Main article(s): "
+  showKey "See also" = "See also: "
+  showKey "Further"  = "Further information: "
+  showKey _          = error "The impossible happened."
+templateToBlocks _ = []
 
 isTemplateBlock :: Block -> Bool
 isTemplateBlock (RawBlock (Format "mediawiki") temp) = True