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