[server] Handle templates for headers and refs

2 files changed, 62 insertions, 17 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 6ddae49..579ec20 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -65,7 +65,7 @@ import           Options.Applicative            ( Parser
                                                 )
 import           Prelude                 hiding ( takeWhile )
 import           Servall.Types
-import           Servall.WikiParser             ( parseWikiTemplates
+import           Servall.WikiParser             ( infobox
                                                 , wikiFilter
                                                 )
 import           Servant                        ( (:<|>)(..)
@@ -183,14 +183,7 @@ getWpSummaryFull name =
   fmap (TE.decodeUtf8 . BSL.toStrict) (liftIO $ getApiWpSummary name)
 
 getInfobox :: Text -> Handler (HM.HashMap Text Text)
-getInfobox name = do
-  wiki <- getWikiFormat name
-  return $ maybe
-    HM.empty
-    wtFields
-    (find (\(WikiTemplate name _) -> name == "Infobox")
-          (fromRight [] (parseWikiTemplates wiki))
-    )
+getInfobox name = infobox <$> getWikiFormat name
 
 searchYt :: Text -> Handler [Video]
 searchYt query = do
diff --git a/src/Servall/WikiParser.hs b/src/Servall/WikiParser.hs
index a470543..d240c3b 100644
--- a/src/Servall/WikiParser.hs
+++ b/src/Servall/WikiParser.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Servall.WikiParser
-  ( parseWikiTemplates
+  ( infobox
   , wikiFilter
   ) where
 
@@ -26,21 +26,37 @@ import           Data.Attoparsec.Text           ( Parser
 import           Data.Char                      ( isAlpha
                                                 , isAlphaNum
                                                 )
+import           Data.Either                    ( fromRight )
 import qualified Data.HashMap.Lazy             as HM
-import           Data.Maybe                     ( catMaybes )
+import           Data.List                      ( find )
+import           Data.Maybe                     ( catMaybes
+                                                , fromMaybe
+                                                , maybeToList
+                                                )
 import qualified Data.Text                     as T
 import           Data.Text                      ( Text )
 import           GHC.Generics                   ( Generic )
 import           Servall.Types
 import           Text.Pandoc.Definition         ( Block(..)
+                                                , Format(..)
                                                 , Inline(..)
                                                 , Pandoc(..)
+                                                , nullAttr
                                                 )
 import           Text.Pandoc.Generic            ( topDown )
 
 parseWikiTemplates :: Text -> Either String [WikiTemplate]
 parseWikiTemplates = parseOnly wikiP
 
+infobox :: Text -> HM.HashMap Text Text
+infobox wiki = maybe
+  HM.empty
+  wtFields
+  (find isInfobox (fromRight [] (parseWikiTemplates wiki)))
+
+isInfobox :: WikiTemplate -> Bool
+isInfobox (WikiTemplate name _) = name == "Infobox"
+
 wikiP :: Parser [WikiTemplate]
 wikiP = sepBy templateP (commentP <|> skipSpace)
 
@@ -67,7 +83,7 @@ tempFieldP = do
   choice [namedField, tempFieldValueP >> return Nothing]
  where
   namedField = do
-    key <- takeWhile1 (\c -> isAlphaNum c || c == '_')
+    key <- takeWhile1 (\c -> isAlphaNum c || c `elem` ['_', '-'])
     skipSpace
     char '='
     skipSpace
@@ -111,13 +127,49 @@ wikilinkP = do
   return $ beg <> content <> "]]"
 
 wikiFilter :: Text -> Pandoc -> Pandoc
-wikiFilter title = topDown fixUrl . insertHeader title
+wikiFilter title = fixHeaderTemplates . topDown fixInline . insertHeader title
 
 insertHeader :: Text -> Pandoc -> Pandoc
 insertHeader title (Pandoc m bs) =
-  Pandoc m (Header 1 ("", [], []) [Str title] : bs)
+  Pandoc m (Header 1 nullAttr [Str title] : bs)
 
-fixUrl :: Inline -> Inline
-fixUrl (Link attr label (url, "wikilink")) =
+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) =
+    let (raws, rest) = span isTemplateBlock bs
+    in  go
+          (acc ++ [Header level (x, y, attr ++ concatMap infobox' raws) content]
+          )
+          rest
+  go acc (b : bs) = go (acc ++ [b]) bs
+  infobox' :: Block -> [(Text, Text)]
+  infobox' (RawBlock (Format "mediawiki") temp) =
+    fromRight []
+      $   (\wt -> if isInfobox wt then HM.toList (wtFields wt) else [])
+      <$> parseOnly templateP temp
+  infobox' _ = []
+
+isTemplateBlock :: Block -> Bool
+isTemplateBlock (RawBlock (Format "mediawiki") temp) = True
+isTemplateBlock _ = False
+
+fixInline :: Inline -> Inline
+fixInline (Link attr label (url, "wikilink")) =
   Link attr label ("wiki:" <> url, "")
-fixUrl x = x
+fixInline (Note (RawBlock (Format "mediawiki") temp : rest)) =
+  let
+    fields = fromRight HM.empty (wtFields <$> parseOnly templateP temp)
+    url    = HM.lookup "url" fields
+    title  = HM.lookup "title" fields
+    link =
+      (\url' ->
+          Link nullAttr (maybeToList (Str <$> title)) (url', fromMaybe "" title)
+        )
+        <$> url
+  in
+    case link of
+      Just link' -> Note (Plain [link'] : rest)
+      _          -> Note rest
+fixInline x = x