Rakka/Wiki/Interpreter/Base.hs

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