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