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