Rakka/Wiki/Interpreter/Base.hs

   1 module Rakka.Wiki.Interpreter.Base
   2     ( interpreters
   3     )
   4     where
   5
   6 import           Control.Arrow
   7 import           Control.Arrow.ListArrow
   8 import           Data.Map (Map)
   9 import qualified Data.Map as M
  10 import           Data.Maybe
  11 import           Rakka.Page
  12 import           Rakka.SystemConfig
  13 import           Rakka.Wiki
  14 import           Rakka.Wiki.Interpreter
  15 import           Text.XML.HXT.Arrow.XmlArrow
  16 import           Text.XML.HXT.Arrow.XmlNodeSet
  17
  18
  19 interpreters :: [Interpreter]
  20 interpreters = [ lineBreakInterp
  21                , spanInterp
  22                , divInterp
  23                , pageNameInterp
  24                , otherLangsInterp
  25                , newPageInterp
  26                , editPageInterp
  27                , loginInterp
  28                ]
  29
  30
  31 lineBreakInterp :: Interpreter
  32 lineBreakInterp = InlineCommandInterpreter {
  33                     iciName = "br"
  34                   , iciInterpret
  35                       = \ _ (InlineCommand _ attrs _) -> return $ LineBreak attrs
  36                   }
  37
  38
  39 spanInterp :: Interpreter
  40 spanInterp = InlineCommandInterpreter {
  41                iciName = "span"
  42              , iciInterpret
  43                  = \ _ (InlineCommand _ attrs contents) -> return $ Span attrs contents
  44              }
  45
  46
  47 divInterp :: Interpreter
  48 divInterp = BlockCommandInterpreter {
  49               bciName = "div"
  50             , bciInterpret
  51                 = \ _ (BlockCommand _ attrs contents)
  52                 -> return $ Div attrs (map Block contents)
  53             }
  54
  55
  56 pageNameInterp :: Interpreter
  57 pageNameInterp = InlineCommandInterpreter {
  58                    iciName = "pageName"
  59                  , iciInterpret
  60                      = \ ctx _ -> return $ Text (fromMaybe "" $ ctxPageName ctx)
  61                  }
  62
  63
  64 otherLangsInterp :: Interpreter
  65 otherLangsInterp
  66     = BlockCommandInterpreter {
  67         bciName = "inOtherLanguages"
  68       , bciInterpret
  69           = \ ctx _ ->
  70             let linkTable = case ctxMainPage ctx of
  71                               Just page -> runLA ( getXPathTreesInDoc "/page/otherLang/link"
  72                                                    >>>
  73                                                    ( getAttrValue0 "lang"
  74                                                      &&&
  75                                                      getAttrValue0 "page"
  76                                                    )
  77                                                  ) page
  78                               Nothing   -> []
  79             in
  80               case linkTable of
  81                 [] -> return EmptyBlock
  82                 _  -> do Languages langTable <- getSysConf (ctxSysConf ctx)
  83                          let merged = mergeTables langTable linkTable
  84                          return $ mkLangList merged
  85       }
  86     where
  87       mergeTables :: Map LanguageTag LanguageName
  88                   -> [(LanguageTag, PageName)]
  89                   -> [(LanguageName, PageName)]
  90       mergeTables _ []     = []
  91       mergeTables m (x:xs) = let (langTag, name) = x
  92                                  langName        = fromMaybe langTag (M.lookup langTag m)
  93                              in
  94                                (langName, name) : mergeTables m xs
  95
  96       mkLangList :: [(LanguageName, PageName)] -> BlockElement
  97       mkLangList xs = List Bullet (map mkLangLink xs)
  98
  99       mkLangLink :: (LanguageName, PageName) -> ListItem
 100       mkLangLink (langName, name)
 101           = [Inline (PageLink (Just name) Nothing (Just langName))]
 102
 103
 104 -- <input type="button"
 105 --        value="Create new page"
 106 --        onclick="Rakka.newPage()"
 107 --        class="newButton" />
 108 newPageInterp :: Interpreter
 109 newPageInterp
 110     = InlineCommandInterpreter {
 111         iciName = "newPage"
 112       , iciInterpret
 113           = \ _ (InlineCommand _ args _) ->
 114             let label = fromMaybe "Create new page" (lookup "label" args)
 115                 attrs = [ ("type"   , "button")
 116                         , ("value"  , label)
 117                         , ("onclick", "Rakka.newPage()")
 118                         , ("class"  , "newButton")
 119                         ]
 120             in
 121               return (Input attrs)
 122       }
 123
 124
 125 -- <input type="button"
 126 --        value="Edit"
 127 --        onclick="Rakka.editPage(\"Foo\")"
 128 --        class="editButton" />
 129 editPageInterp :: Interpreter
 130 editPageInterp
 131     = InlineCommandInterpreter {
 132         iciName = "editPage"
 133       , iciInterpret
 134           = \ ctx (InlineCommand _ args _) ->
 135             let name  = fromMaybe (fromMaybe "" $ ctxPageName ctx) (lookup "page" args)
 136                 label = fromMaybe "Edit this page" (lookup "label" args)
 137                 attrs = [ ("type"   , "button")
 138                         , ("value"  , label)
 139                         , ("onclick", "Rakka.editPage(\"" ++ name ++ "\")")
 140                         , ("class"  , "editButton")
 141                         ]
 142             in
 143               return (Input attrs)
 144       }
 145
 146
 147 -- <input type="button"
 148 --        value="Login"
 149 --        class="loginButton" />
 150 loginInterp :: Interpreter
 151 loginInterp
 152     = InlineCommandInterpreter {
 153         iciName = "login"
 154       , iciInterpret
 155           = \ _ _ ->
 156             let attrs = [ ("type"   , "button")
 157                         , ("value"  , "Login")
 158                         , ("class"  , "loginButton")
 159                         ]
 160             in
 161               return (Input attrs)
 162       }