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