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