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