Refactor code
[darcs-mirror-sem_syn.git] / b18n-combined-cgi.hs
1 {-# LANGUAGE RecordWildCards #-}
2 import Network.CGI
3 import Text.XHtml
4 import Data.Maybe
5 import Data.List
6 import Data.ByteString.Lazy.UTF8 (fromString)
7 import Control.Monad
8 import Control.Applicative ((<$>),(<*>))
9 import Text.PrettyPrint.HughesPJ (render)
10 import System.IO
11
12 import Parser
13 import SemSyn
14 import Type
15 import Shapify
16
17 import JQuery
18
19 data PageInfo = PageInfo
20     { scrollX :: Maybe String
21     , scrollY :: Maybe String
22     , viewFunction :: String
23     , exMode  :: ExecMode
24     , outMode :: OutputMode
25     , showTypes :: Bool
26     , generatedModuleMB :: Maybe String
27     } 
28
29 page (PageInfo {..}) =
30        header << (
31         thetitle << "Combining Syntatic and Semantic Bidirectionalization" +++
32         style ! [ thetype "text/css" ] << cdata cssStyle +++
33         script ! [ thetype "text/javascript", src "?jquery" ] << noHtml +++
34         script ! [ thetype "text/javascript" ] << cdata jsCode 
35        ) +++
36        body ! [ strAttr "onload" "restoreScroll()" ] << (
37         thediv ! [theclass "top"] << (
38                 thespan ! [theclass "title"] << "Combining Syntatic and Semantic Bidirectionalization" +++
39                 thespan ! [theclass "subtitle"] << "Prototype implementation"
40         ) +++
41         maindiv << (
42                 p << ("This tool allows you to experiment with the "+++
43                       "method described in the paper “" +++
44                       hotlink "http://doi.acm.org/10.1145/1291151.1291162"
45                         << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
46                       "” (ICFP'10) by " +++
47                       hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
48                         << "Kazutaka Matsuda" +++
49                       "."
50                 )
51                         
52         ) +++
53         form ! [method "POST",
54                 action "#",
55                 strAttr "onsubmit" "saveScroll()"
56             ] << (
57                 hidden "scrollx" (fromMaybe "0" scrollX) +++
58                 hidden "scrolly" (fromMaybe "0" scrollY) +++
59                 maindiv << (
60                          p << (
61                                 "Please enter the view function. (TODO: Elaborate this text)"
62                         ) +++
63
64                         p << (
65                                 concatHtml (map (\(name,thisCode) -> 
66                                         radio "load" name
67                                         ! (if thisCode == viewFunction then [checked] else [])
68                                         +++ name +++ " "
69                                 ) examples) +++
70                                 mkSubmit True Load +++
71                                 br +++
72                                 textarea ! [name "code", cols "120", rows "7"] << viewFunction
73                         ) 
74                         
75                 ) +++
76                 {- p << astInfo mbAST +++ -}
77                 maindiv ! [ identifier "output" ]<< (
78                         p << (
79                                 "You can calculate a derived put function with various options:" ) +++
80                         p << ( "Execution mode: " +++
81                                concatHtml (map (\mode -> 
82                                   radio "execMode" (show mode) 
83                                         ! (guard (mode == exMode) >> return checked)
84                                         +++ show mode +++ " "
85                                 ) [Normal, Shapify, ShapifyPlus]) +++ br +++
86                                "Output mode: " +++
87                                concatHtml (map (\mode -> 
88                                   radio "outputMode" (show mode) 
89                                         ! (guard (mode == outMode) >> return checked)
90                                         +++ show mode +++ " "
91                                 ) [PseudoCode, HaskellCode, ForwardCode]) +++ br +++
92                                "Show types " +++ checkbox "showTypes" "showTypes"
93                                         ! (guard showTypes >> return checked)
94                                         +++ br +++
95                                mkSubmit True BiDi
96                         ) +++
97                         ( htmlMB generatedModuleMB $ \ generatedModule -> 
98                             {- maybe noHtml outputErrors errors +++ -}
99                             p << ("Result:"+++ br +++
100                                 textarea ! [name "gencode", cols "120"
101                                            , rows (show (1 + length (lines generatedModule)))
102                                            ] << generatedModule
103
104                             )
105                         )
106                 )
107         ) +++
108         maindiv << (
109                 p << (
110                 "The source code of this application and the underlying library can be found " +++
111                 hotlink "TODO" << "here"+++
112                 ".") +++
113                 p << ("© 2010 Joachim Breitner <" +++
114                       hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
115                       ">")
116                 )       
117         )
118        
119
120 cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
121
122 maindiv = thediv ! [theclass "main"]
123         
124 examples =
125         [ ("init", unlines
126                 [ "init (Nil)         = Nil"
127                 , "init (Cons(a,Nil)) = Nil"
128                 , "init (Cons(a,Cons(b,x))) = Cons(a,initWork(b,x))"
129                 , "initWork(a,Nil)       = Nil"
130                 , "initWork(a,Cons(b,x)) = Cons(a,initWork(b,x))"
131                 ])
132         , ("initHalf", unlines
133                 [ "initHalf(Nil)       = Nil"
134                 , "initHalf(Cons(a,x)) = Cons(a,initHalfWork(x,x))"
135                 , ""
136                 , "initHalfWork(xs, Nil)         = Nil"
137                 , "initHalfWork(xs, Cons(x,Nil)) = Nil"
138                 , "initHalfWork(Cons(a,x), Cons(b,Cons(c,y)))"
139                 , "                    = Cons(a,initHalfWork(x,y))"
140                 ])
141         , ("seive", unlines
142                 [ "seive (Nil)               = Nil"
143                 , "seive (Cons(a,Nil))       = Nil"
144                 , "seive (Cons(a,Cons(b,x))) = Cons(b,seive(x))"
145                 ])
146         , ("rev", unlines
147                 [ "reverse(xs) = rev(xs,Nil)"
148                 , "rev(Nil,y)       = y"
149                 , "rev(Cons(a,x),y) = rev(x,Cons(a,y))"
150                 ])
151         ]
152
153 defaultCode = fromJust (lookup "init" examples)
154         
155 outputErrors :: String -> Html
156 outputErrors s = 
157            p << (
158                 strong << "An error occurred:" +++ br +++
159                 pre << s
160                 )
161                 
162 mkSubmit active what = submit (submitId what) (submitLabel what)
163                        ! if active then [] else [disabled]
164
165 data Run = Get | Check | Load | BiDi
166
167
168 submitId Get = "get source"
169 submitId Check = "check"
170 submitId Load = "load"
171 submitId BiDi = "submitBiDi"
172
173 submitCode Get   = Just ("get source")
174 submitCode Check = Nothing
175 submitCode Load  = Nothing
176 submitCode BiDi = Just ("bidirectionalize")
177
178 submitLabel Check = "Re-Parse definition"
179 submitLabel Load  = "Load example"
180 submitLabel x   = fromJust (submitCode x)
181
182 main = runCGI (handleErrors cgiMain)
183
184 -- This function will not work in all casses, but in most.
185 delDefinition name code = unlines squashed
186   where filtered = filter (not . defines name) (lines code)
187         squash [] = []
188         squash ("":_) = [""]
189         squash ("\r":_) = [""]
190         squash ls = ls
191         squashed = concat $ map squash $ group $ filtered
192
193 addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
194   where squashed = lines (delDefinition name code)
195         pad | last squashed == "" || last squashed == "\r" = []
196             | otherwise                                    = [""]
197         new_line = [name ++ " = " ++ def]
198         
199 defines "" (' ':_) = True
200 defines "" ('=':_) = True
201 defines "" "" = False
202 defines "" _   = False
203 defines _  ""  = False
204 defines (i:is) (x:xs) | i == x = defines is xs
205                       | i /= x = False
206
207 cgiMain = do
208     qs <- queryString
209     if qs == "jquery"
210      then jQueryMain
211      else formMain
212
213 jQueryMain = do
214         setHeader "Content-type" "text/javascript"
215         setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100"
216         setHeader "Cache-control" "max-age=36000000" -- 1000 h
217         outputFPS $ jQueryCode
218     
219
220 formMain = do
221         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
222
223         exMode  <- maybe Normal read <$> getInput "execMode"
224         outMode <- maybe PseudoCode read <$> getInput "outputMode"
225         showTypes <- isJust <$> getInput "showTypes"
226         
227         todo <- msum <$> sequence (
228             map (\what -> fmap (const what) <$> getInput (submitId what))
229             [ BiDi, Get, Check, Load ])
230         
231         code <- fromMaybe defaultCode <$> getInput "code"
232         
233         code <- case todo of
234             Just Load -> do loadWhat <- getInput "load"
235                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
236             _ -> return code
237         
238         let mbAST = parseString code
239
240         let conf = defaultConfig { outputMode = outMode, execMode = exMode, isShowType = showTypes }
241         let genCode = case (todo,mbAST) of
242                 (Just Load, _) -> Nothing
243                 (Just _, Right ast) -> Just $ render $ case exMode of 
244                        Normal -> outputCode conf False ast (typeInference ast)
245                        Shapify -> outputCode conf False ast (shapify $ typeInference ast)
246                        ShapifyPlus -> outputCode conf True  ast (introNat $ shapify $ typeInference ast)
247                 _ -> Nothing
248
249         scrollX <- getInput "scrollx"
250         scrollY <- getInput "scrolly"
251
252         outputFPS $ fromString $ showHtml $ page (PageInfo scrollX scrollY code exMode outMode showTypes genCode)
253
254 astInfo (Left err) = maindiv << p << (
255         "Can not parse your definition:" +++ br +++
256         pre << show err +++ br +++
257         mkSubmit True Check)
258
259 astInfo (Right source) = maindiv << (
260         p << ("Definition parsed succesfully"
261 {-              "Your definitions have the following types: " +++
262                 pre << ("get :: " ++ getType ++ "\n"++
263                         "source :: " ++ sourceType) +++
264                 "Therefore, an updater can be derived by " +++
265                 case (canBff, canBffEq, canBffOrd) of
266                         (True, _, _) -> 
267                                 tt << "bff" +++ ", " +++
268                                 tt << "bff_Eq" +++ ", and " +++
269                                 tt << "bff_Ord" +++ "."
270                         (False, True, _) -> 
271                                 tt << "bff_Eq" +++ " and " +++
272                                 tt << "bff_Ord" +++ "."
273                         (False, False, True) -> 
274                                 tt << "bff_Ord" +++ " only."
275                         (False, False, False) -> 
276                                 "none of the " +++ tt << "bff" +++ " functions."
277 -}                                
278         ) +++
279         p << mkSubmit True Check
280         )
281
282 cssStyle = unlines 
283         [ "body { padding:0px; margin: 0px; }"
284         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
285         , "              background-color:#efefef;"
286         , "              border-bottom:1px solid black; }"
287         , "span.title { font-size:xx-large; font-weight:bold; }"
288         , "span.subtitle { padding-left:30px; font-size:large; }"
289         , "div.main { border:1px dotted black;"
290         , "                   padding:10px; margin:10px; }"
291         , "div.submain { padding:10px; margin:11px; }"
292         , "p.subtitle { font-size:large; font-weight:bold; }"
293         , "input.type { font-family:monospace; }"
294         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
295         , "span.mono { font-family:monospace; }"
296         , "pre { margin:10px; margin-left:20px; padding:10px;"
297         , "          border:1px solid black; }"
298         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
299         , "p { text-align:justify; }"
300         ]
301
302 jsCode = unlines 
303     [ "function saveScroll () {"
304     , "    $(\"#scrolly\").val($(\"html\").scrollTop());"
305     , "}"
306     , "function restoreScroll () {"
307     , "    $(\"html\").scrollTop($(\"#scrolly\").val());"
308     , "}"
309     ]
310
311 htmlMB Nothing  f = noHtml
312 htmlMB (Just x) f = f x