Label b18n radio buttons
[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 qualified Data.ByteString.Lazy as BS
8 import Control.Monad
9 import Control.Applicative ((<$>),(<*>))
10 import Text.PrettyPrint.HughesPJ (render)
11 import System.IO
12 import System.IO.Error hiding ( catch )
13 import Text.ParserCombinators.Parsec (ParseError)
14 import System.Directory
15 import Prelude hiding ( catch )
16 import Control.Exception
17 import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )
18 import System.Posix.Env
19
20
21 import Parser
22 import SemSyn
23 import Type
24 import Shapify
25 import AST
26
27 import MyInterpret
28 import BundledCode
29 import JQuery
30
31 data PageInfo = PageInfo
32     { config :: Config
33     , scrollX :: Maybe String
34     , scrollY :: Maybe String
35     , viewFunction :: String
36     , astError :: Maybe String
37     , generatedModuleMB :: Maybe String
38     , showCode :: Bool
39     , playCodeMB :: Maybe String
40     , playErrorM :: Maybe String
41     } 
42
43 page (PageInfo {..}) =
44        header << (
45         thetitle << "(Combining) Syntatic and Semantic Bidirectionalization" +++
46         style ! [ thetype "text/css" ] << cdata cssStyle +++
47         script ! [ thetype "text/javascript", src "?jquery" ] << noHtml +++
48         script ! [ thetype "text/javascript" ] << cdata jsCode 
49        ) +++
50        body ! [ strAttr "onload" "restoreScroll()" ] << (
51         thediv ! [theclass "top"] << (
52                 thespan ! [theclass "title"] << "(Combining) Syntatic and Semantic Bidirectionalization" +++
53                 thespan ! [theclass "subtitle"] << "Prototype implementation"
54         ) +++
55         maindiv << (
56                 p << "This tool allows you to experiment with the bidirectionalization methods described in the following papers: " +++
57                 ulist << (
58                     li << (
59                       "“" +++
60                       hotlink "http://doi.acm.org/10.1145/1291151.1291162"
61                         << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
62                       "” (ICFP’07) by " +++
63                       hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
64                         << "Kazutaka Matsuda" +++ ", " +++
65                       "Zhenjiang Hu, " +++
66                       "Keisuke Nakano, " +++
67                       "Makoto Hamana and " +++
68                       "Masato Takeichi."
69                     ) +++
70                     li << (
71                       "“" +++
72                       hotlink "http://doi.acm.org/10.1145/1480881.1480904"
73                         << "Bidirectionalization for free! (Pearl)" +++
74                       "” (POPL’09) by " +++
75                       hotlink "http://www.iai.uni-bonn.de/~jv/"
76                         << "Janis Voigtländer"
77                     ) +++
78                     li << (
79                       "“" +++
80                       hotlink "http://www.iai.uni-bonn.de/~jv/icfp10.pdf"
81                         << "Combining Syntactic and Semantic Bidirectionalization" +++
82                       "” (ICFP’10) by " +++
83                       hotlink "http://www.iai.uni-bonn.de/~jv/"
84                         << "Janis Voigtländer" +++ ", " +++
85                       "Zhenjiang Hu, " +++
86                       hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
87                         << "Kazutaka Matsuda" +++ ", " +++
88                       "Meng Wang"
89                     )
90                 )
91         ) +++
92         form ! [method "post",
93                 action "#",
94                 strAttr "onsubmit" "saveScroll()"
95             ] << (
96                 hidden "scrollx" (fromMaybe "0" scrollX) +++
97                 hidden "scrolly" (fromMaybe "0" scrollY) +++
98                 hidden "showCode" (show showCode) +++
99                 maindiv << (
100                          p << (
101                                 "Please enter the view function. (TODO: Elaborate this text)"
102                         ) +++
103
104                         p << (
105                                 concatHtml (map (\(name,thisCode) -> 
106                                         radio "loadCode" name
107                                         ! (if thisCode == viewFunction then [checked] else [])
108                                         +++ name +++ " "
109                                 ) examples) +++
110                                 mkSubmit True Load +++
111                                 br +++
112                                 textarea ! [name "code", cols "120", rows "7"] << viewFunction
113                         ) 
114                         
115                 ) +++
116                 ( htmlMB astError $ \err -> 
117                      maindiv << p << (
118                         "There was an error with the view function:" +++ br +++
119                         pre << err +++ br +++
120                         mkSubmit True Check)
121                 ) +++
122                 -- p << astInfo mbAST +++
123                 maindiv ! [ identifier "output" ]<< (
124                         p << ( "You can try all three bidirectionalization methods." ) +++
125                         p << (  concatHtml (map (\mode -> 
126                                   radio "b18nMode" (show mode) 
127                                         ! (guard (mode == b18nMode config) >> return checked)
128                                         +++ b18nModeName mode +++ " "
129                                 ) [SyntacticB18n, SemanticB18n, CombinedB18n]) +++ " " +++
130                                mkSubmit True BiDi
131                         ) +++
132                         ( htmlMB generatedModuleMB $ \ generatedModule -> 
133                             {- maybe noHtml outputErrors errors +++ -}
134                             p << ("Result Code" +++
135                                 thespan ! [ identifier "hideShow"
136                                           , thestyle "display:none"] << (
137                                     " (" +++ hotlink "javascript:" << "Hide/Show" +++ ")"
138                                 ) +++ ":" +++ br +++
139                                 pre ! [identifier "genCode" ] << generatedModule
140
141                             )
142
143                         )
144                 ) +++
145                 ( htmlMB playCodeMB $ \playCode -> maindiv << ( 
146                     p << (  "You can now play with the code. You can modify the " +++
147                             tt << "source" +++ " and calculate the " +++
148                             tt << "view" +++ ", or modify the " +++
149                             tt << "view" +++ " and calculate an updated "+++
150                             tt << "source" +++ "." +++ br +++
151                             textarea ! [name "playCode", cols "120", rows "12" ] << playCode
152                     ) +++
153                     p << ( "Evaluate " +++
154                            mkSubmit True EvalGet +++ " " +++
155                            mkSubmit True EvalPut
156                     )
157                 )) +++
158                 ( htmlMB playErrorM $ \playError -> maindiv << ( 
159                     p << (
160                         strong << "An error occurred while evaluating your code:" +++ br +++
161                         pre << playError
162                         )
163                 ))
164         ) +++
165         maindiv << (
166             p << (
167                 "The source code of this application and the underlying library can be found " +++
168                 hotlink "TODO" << "here"+++
169                 ". " +++
170                 "The code for the web interface is based on " +++
171                 hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi" << 
172                     "the demo interface from “Bidirectionalization for free!”"
173             ) +++
174             p << ("© 2010 Joachim Breitner <" +++
175                 hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
176               ">")
177             )   
178         )
179        
180
181 cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
182
183 maindiv = thediv ! [theclass "main"]
184         
185 examples =
186         [ ("init", unlines
187                 [ "init []      = []"
188                 , "init [a]     = []"
189                 , "init (a:b:x) = a:initWork b x"
190                 , "initWork a []    = []"
191                 , "initWork a (b:x) = a:initWork b x"
192                 ])
193         , ("sieve", unlines
194                 [ "sieve []      = []"
195                 , "sieve [a]     = []"
196                 , "sieve (a:b:x) = b:sieve x"
197                 ])
198         , ("initHalf", unlines
199                 [ "initHalf []    = []"
200                 , "initHalf (a:x) = a:initHalfWork x x"
201                 , ""
202                 , "initHalfWork xs  []  = []"
203                 , "initHalfWork xs  [x] = []"
204                 , "initHalfWork (a:x) (b:c:y)"
205                 , "                    = a:initHalfWork x y"
206                 ])
207         , ("rev", unlines
208                 [ "reverse xs = rev xs []"
209                 , "rev []    y = y"
210                 , "rev (a:x) y = rev x (a:y)"
211                 ])
212         ]
213
214 defaultCode = fromJust (lookup "init" examples)
215         
216 outputErrors :: String -> Html
217 outputErrors s = 
218            p << (
219                 strong << "An error occurred:" +++ br +++
220                 pre << s
221                 )
222                 
223 mkSubmit active what = submit (submitId what) (submitLabel what)
224                        ! if active then [] else [disabled]
225
226 data Run = Get | Check | Load | BiDi | EvalPut | EvalGet
227
228
229 submitId Get = "get source"
230 submitId Check = "check"
231 submitId Load = "load"
232 submitId BiDi = "submitBiDi"
233 submitId EvalPut = "evalPut"
234 submitId EvalGet = "evalGet"
235
236 submitCode Get   = Just ("get source")
237 submitCode Check = Nothing
238 submitCode Load  = Nothing
239
240 submitLabel Check =   "Re-Parse definition"
241 submitLabel Load  =   "Load example"
242 submitLabel EvalGet = "view = get source"
243 submitLabel EvalPut = "result = put source view"
244 submitLabel BiDi =    "bidirectionalize"
245
246 b18nModeName SemanticB18n = "Semantic bidir. (POPL’09)"
247 b18nModeName SyntacticB18n = "Syntactic bidir. (ICFP’07)"
248 b18nModeName CombinedB18n = "Combined bidir. (ICFP’10)"
249
250 main = runCGI (handleErrors cgiMain)
251
252 -- This function will not work in all casses, but in most.
253 delDefinition name code = unlines squashed
254   where filtered = filter (not . defines name) (lines code)
255         squash [] = []
256         squash ("":_) = [""]
257         squash ("\r":_) = [""]
258         squash ls = ls
259         squashed = concat $ map squash $ group $ filtered
260
261 addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
262   where squashed = lines (delDefinition name code)
263         pad | last squashed == "" || last squashed == "\r" = []
264             | otherwise                                    = [""]
265         new_line = [name ++ " = " ++ def]
266         
267 defines "" (' ':_) = True
268 defines "" ('=':_) = True
269 defines "" "" = False
270 defines "" _   = False
271 defines _  ""  = False
272 defines (i:is) (x:xs) | i == x = defines is xs
273                       | i /= x = False
274
275 cgiMain = do
276     qs <- queryString
277     if qs == "jquery"
278      then jQueryMain
279      else formMain
280
281 jQueryMain = do
282         setHeader "Content-type" "text/javascript"
283         setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100"
284         setHeader "Cache-control" "max-age=36000000" -- 1000 h
285         outputFPS $ jQueryCode
286     
287 defaultPlayCode (Config{ b18nMode = SyntacticB18n}) get =
288         Just $ unlines
289             [ "get s = Main." ++ get ++ " s"
290             , "put s v = " ++ get ++ "_B s v"
291             , ""
292             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
293             ]
294 defaultPlayCode (Config{ b18nMode = SemanticB18n}) get =
295         Just $ unlines
296             [ "get s = Main." ++ get ++ " s"
297             , "put s v = " ++ get ++ "_B s v"
298             , ""
299             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
300             ]
301 defaultPlayCode (Config{ b18nMode = CombinedB18n}) get =
302         Just $ unlines
303             [ "get s = Main." ++ get ++ " s"
304             , "put s v = fromMaybe (error \"Could not handle shape change.\") $ " ++
305                  get ++ "_Bbd bias default_value s v"
306             , "bias = rear"
307             , "default_value = 42"
308             , ""
309             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
310             ]
311
312 formMain = do
313         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
314
315         conf <- do
316             b18nMode' <- maybe CombinedB18n read <$> getInput "b18nMode"
317             return $ adjustConfig $ defaultConfig
318                 { isHaskellify = True
319                 , b18nMode = b18nMode'
320                 }
321         
322         todo <- msum <$> sequence (
323             map (\what -> fmap (const what) <$> getInput (submitId what))
324             [ BiDi, Get, Check, Load, EvalPut, EvalGet])
325         
326         code <- filter (/= '\r') <$> fromMaybe defaultCode <$> getInput "code"
327
328         code <- case todo of
329             Just Load -> do loadWhat <- getInput "loadCode"
330                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
331             _ -> return code
332         
333         let eAST = parseString code
334
335
336         let astError = either (Just . show) checkBidirectionalizability eAST
337
338         let (genCodeM,getM) = case (todo,eAST) of
339                 (Just Load, _) -> (Nothing, Nothing)
340                 (Just _, Right ast) ->
341                     (  Just $ render $ renderCode conf ast
342                     ,  firstDeclaredName ast
343                     )
344                 _ -> (Nothing, Nothing)
345
346         showCode <- maybe False read <$> getInput "showCode"
347
348         pcM <- getInput "playCode" 
349         -- Playcode can only by used when the output is exMode
350         (playCode, playErrorM) <- -- if outMode /= HaskellCode then return (Nothing, Nothing) else
351             case (todo,getM,genCodeM,pcM) of
352             -- The user successfully generated code to play with, insert default playCode.
353             -- Do not use the user input, as he probably switched to a new example.
354             (Just BiDi, Just get, Just _, _) ->
355                 return (defaultPlayCode conf get, Nothing)
356             -- The user played with the code
357             (Just EvalGet, Just get, Just genCode, Just pc) -> do
358                 view <- liftIO $ evaluateWith genCode pc ("get source")
359                 case view of 
360                     Left err -> return $ (Just pc, Just err)
361                     Right dat -> return $ (\r -> (Just r, Nothing))
362                                         $ addDefiniton "view" dat 
363                                         $ delDefinition "result"
364                                         $ pc
365             (Just EvalGet, Just get, Just genCode, Nothing) -> do
366                 return (defaultPlayCode conf get, Nothing)
367             (Just EvalPut, Just get, Just genCode, Just pc) -> do
368                 view <- liftIO $ evaluateWith genCode pc ("put source view")
369                 case view of 
370                     Left err -> return $ (Just pc, Just err)
371                     Right dat -> return $ (\r -> (Just r, Nothing))
372                                         $ addDefiniton "result" dat 
373                                         $ pc
374             (Just EvalPut, Just get, Just _, Nothing) -> do
375                 return (defaultPlayCode conf get, Nothing)
376             _ -> return (Nothing, Nothing)
377
378         scrollX <- getInput "scrollx"
379         scrollY <- getInput "scrolly"
380
381         outputFPS $ fromString $ showHtml $ page $
382             PageInfo conf
383                      scrollX
384                      scrollY
385                      code
386                      astError
387                      genCodeM
388                      showCode
389                      playCode
390                      playErrorM
391
392 evaluateWith :: String -> String -> String -> IO (Either String String)
393 evaluateWith genCode playCode expr =
394     withinTmpDir $ do
395         BS.writeFile "BUtil.hs" bUtilCode
396         writeFile "Main.hs" $ "module Main where\n" ++ genCode
397         liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr
398   where mods = 
399             [ "BUtil"
400             , "Main"
401             --, "Data.Maybe"
402             ]
403         imports = mods ++
404             [ "Data.Maybe"
405             , "Prelude"
406             ]
407
408 withFullSource genCode playCode = genCode' ++ "\n" ++ playCode
409     where genCode' = unlines . filter (not . isPrefixOf "import") . lines $ genCode
410
411 astInfo (Left err) = maindiv << p << (
412         "Can not parse your definition:" +++ br +++
413         pre << show err +++ br +++
414         mkSubmit True Check)
415
416 astInfo (Right source) = maindiv << (
417         p << ("Definition parsed succesfully") +++
418         p << mkSubmit True Check
419         )
420
421 cssStyle = unlines 
422         [ "body { padding:0px; margin: 0px; }"
423         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
424         , "              background-color:#efefef;"
425         , "              border-bottom:1px solid black; }"
426         , "span.title { font-size:xx-large; font-weight:bold; }"
427         , "span.subtitle { padding-left:30px; font-size:large; }"
428         , "div.main { border:1px dotted black;"
429         , "                   padding:10px; margin:10px; }"
430         , "div.submain { padding:10px; margin:11px; }"
431         , "p.subtitle { font-size:large; font-weight:bold; }"
432         , "input.type { font-family:monospace; }"
433         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
434         , "span.mono { font-family:monospace; }"
435         , "pre { margin:10px; margin-left:20px; padding:10px;"
436         , "          border:1px solid black; }"
437         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
438         , "p { text-align:justify; }"
439         ]
440
441 jsCode = unlines 
442     [ "function saveScroll () {"
443     , "    $('#scrolly').val($('html').scrollTop());"
444     , "}"
445     , "function restoreScroll () {"
446     , "    $('html').scrollTop($('#scrolly').val());"
447     , "}"
448     , "$(document).ready(function () {"
449     , "   $('#hideShow').show();"
450     , "   if ($('#showCode').val() == 'False')"
451     , "     { $('#genCode').hide(); };"
452     , "   $('#hideShow a').click(function () {"
453     , "      $('#showCode').val("
454     , "         $('#genCode').is(':visible') ? 'False' : 'True'"
455     , "      );"
456     , "      $('#genCode').toggle('slow');"
457     , "   })"
458     , "})"
459     ]
460
461 htmlMB Nothing  f = noHtml
462 htmlMB (Just x) f = f x
463
464 readOnly = emptyAttr "readonly"
465
466
467 firstDeclaredName (AST []) = Nothing
468 firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n)
469
470 {-
471  - Temp-Dir functions taken from XMonad/Lock.hs and simplified.
472  - It also changes TMP so that hint’s temporary files are stored within this directory
473  -}
474 withinTmpDir :: IO a -> IO a
475 withinTmpDir job = do
476   absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory
477   formerdir <- getCurrentDirectory
478   formerTMP <- getEnv "TMPDIR"
479   bracket (do dir <- create_directory absolute_name 0
480               setEnv "TMPDIR" dir True  
481               return dir
482           )
483           (\dir -> do setCurrentDirectory formerdir
484                       maybe (unsetEnv "TMPDIR") (\p -> setEnv "TMPDIR" p True) formerTMP
485                       rmRecursive dir)
486           (const job)
487     where newname name 0 = name
488           newname name n = name ++ "-" ++ show n
489           create_directory :: FilePath -> Int -> IO FilePath
490           create_directory name n
491               = do createDirectory $ newname name n
492                    setCurrentDirectory $ newname name n
493                    getCurrentDirectory
494                 `catch` (\e -> if isAlreadyExistsError e
495                                then create_directory name (n+1)
496                                else throwIO e)
497
498 rmRecursive :: FilePath -> IO ()
499 rmRecursive d =
500     do isd <- isDirectory <$> getSymbolicLinkStatus d
501        if not isd
502           then removeFile d
503           else when isd $ do conts <- actual_dir_contents
504                              withCurrentDirectory d $
505                                mapM_ rmRecursive conts
506                              removeDirectory d
507     where actual_dir_contents = -- doesn't include . or ..
508               do c <- getDirectoryContents d
509                  return $ filter (/=".") $ filter (/="..") c
510
511 withCurrentDirectory :: FilePath -> IO r -> IO r
512 withCurrentDirectory name m =
513     bracket
514         (do cwd <- getCurrentDirectory
515             when (name /= "") (setCurrentDirectory name)
516             return cwd)
517         (\oldwd -> setCurrentDirectory oldwd)
518         (const m)
519