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