]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Wiki/Interpreter/Base.hs
1af5c77e9844f7e5497b8c4ba364f3ac8440d101
[Rakka.git] / 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       }