Rakka/Wiki/Interpreter/Base.hs

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