Do not show playCode if there was an astError
[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                     ( 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         ) +++
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, playErrorM) <-
368             case (todo,getM,genCodeM,pcM) of
369             -- The user successfully generated code to play with, insert default playCode.
370             -- Do not use the user input, as he probably switched to a new example.
371             (Just BiDi, Just get, Just _, _) ->
372                 return (defaultPlayCode conf get, Nothing)
373             -- The user played with the code
374             (Just EvalGet, Just get, Just genCode, Just pc) -> do
375                 view <- liftIO $ evaluateWith genCode pc ("get source")
376                 case view of 
377                     Left err -> return $ (Just pc, Just err)
378                     Right dat -> return $ (\r -> (Just r, Nothing))
379                                         $ addDefiniton "view" dat 
380                                         $ delDefinition "result"
381                                         $ pc
382             (Just EvalGet, Just get, Just genCode, Nothing) -> do
383                 return (defaultPlayCode conf get, Nothing)
384             (Just EvalPut, Just get, Just genCode, Just pc) -> do
385                 view <- liftIO $ evaluateWith genCode pc ("put source view")
386                 case view of 
387                     Left err -> return $ (Just pc, Just err)
388                     Right dat -> return $ (\r -> (Just r, Nothing))
389                                         $ addDefiniton "result" dat 
390                                         $ pc
391             (Just EvalPut, Just get, Just _, Nothing) -> do
392                 return (defaultPlayCode conf get, Nothing)
393             _ -> return (Nothing, Nothing)
394
395         scrollX <- getInput "scrollx"
396         scrollY <- getInput "scrolly"
397
398         outputFPS $ fromString $ showHtml $ page $
399             PageInfo conf
400                      scrollX
401                      scrollY
402                      code
403                      astError
404                      genCodeM
405                      showCode
406                      playCode
407                      playErrorM
408
409 evaluateWith :: String -> String -> String -> IO (Either String String)
410 evaluateWith genCode playCode expr =
411     withinTmpDir $ do
412         BS.writeFile "BUtil.hs" bUtilCode
413         writeFile "Main.hs" $ "module Main where\n" ++ genCode
414         liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr
415   where mods = 
416             [ "BUtil"
417             , "Main"
418             --, "Data.Maybe"
419             ]
420         imports = mods ++
421             [ "Data.Maybe"
422             , "Prelude"
423             ]
424
425 withFullSource genCode playCode = genCode' ++ "\n" ++ playCode
426     where genCode' = unlines . filter (not . isPrefixOf "import") . lines $ genCode
427
428 astInfo (Left err) = maindiv << p << (
429         "Can not parse your definition:" +++ br +++
430         pre << show err +++ br +++
431         mkSubmit True Check)
432
433 astInfo (Right source) = maindiv << (
434         p << ("Definition parsed succesfully") +++
435         p << mkSubmit True Check
436         )
437
438 cssStyle = unlines 
439         [ "body { padding:0px; margin: 0px; }"
440         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
441         , "              background-color:#efefef;"
442         , "              border-bottom:1px solid black; }"
443         , "span.title { font-size:xx-large; font-weight:bold; }"
444         , "span.subtitle { padding-left:30px; font-size:large; }"
445         , "div.main { border:1px dotted black;"
446         , "                   padding:10px; margin:10px; }"
447         , "div.submain { padding:10px; margin:11px; }"
448         , "p.subtitle { font-size:large; font-weight:bold; }"
449         , "input.type { font-family:monospace; }"
450         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
451         , "span.mono { font-family:monospace; }"
452         , "pre { margin:10px; margin-left:20px; padding:10px;"
453         , "          border:1px solid black; }"
454         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
455         , "p { text-align:justify; }"
456         ]
457
458 jsCode = unlines 
459     [ "function saveScroll () {"
460     , "    $('#scrolly').val($('html').scrollTop());"
461     , "}"
462     , "function restoreScroll () {"
463     , "    $('html').scrollTop($('#scrolly').val());"
464     , "}"
465     , "$(document).ready(function () {"
466     , "   $('#hideShow').show();"
467     , "   if ($('#showCode').val() == 'False')"
468     , "     { $('#genCode').hide(); };"
469     , "   $('#hideShow a').click(function () {"
470     , "      $('#showCode').val("
471     , "         $('#genCode').is(':visible') ? 'False' : 'True'"
472     , "      );"
473     , "      $('#genCode').toggle('slow');"
474     , "   })"
475     , "})"
476     ]
477
478 htmlMB Nothing  f = noHtml
479 htmlMB (Just x) f = f x
480
481 readOnly = emptyAttr "readonly"
482
483
484 firstDeclaredName (AST []) = Nothing
485 firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n)
486
487 {-
488  - Temp-Dir functions taken from XMonad/Lock.hs and simplified.
489  - It also changes TMP so that hint’s temporary files are stored within this directory
490  -}
491 withinTmpDir :: IO a -> IO a
492 withinTmpDir job = do
493   absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory
494   formerdir <- getCurrentDirectory
495   formerTMP <- getEnv "TMPDIR"
496   bracket (do dir <- create_directory absolute_name 0
497               setEnv "TMPDIR" dir True  
498               return dir
499           )
500           (\dir -> do setCurrentDirectory formerdir
501                       maybe (unsetEnv "TMPDIR") (\p -> setEnv "TMPDIR" p True) formerTMP
502                       rmRecursive dir)
503           (const job)
504     where newname name 0 = name
505           newname name n = name ++ "-" ++ show n
506           create_directory :: FilePath -> Int -> IO FilePath
507           create_directory name n
508               = do createDirectory $ newname name n
509                    setCurrentDirectory $ newname name n
510                    getCurrentDirectory
511                 `catch` (\e -> if isAlreadyExistsError e
512                                then create_directory name (n+1)
513                                else throwIO e)
514
515 rmRecursive :: FilePath -> IO ()
516 rmRecursive d =
517     do isd <- isDirectory <$> getSymbolicLinkStatus d
518        if not isd
519           then removeFile d
520           else when isd $ do conts <- actual_dir_contents
521                              withCurrentDirectory d $
522                                mapM_ rmRecursive conts
523                              removeDirectory d
524     where actual_dir_contents = -- doesn't include . or ..
525               do c <- getDirectoryContents d
526                  return $ filter (/=".") $ filter (/="..") c
527
528 withCurrentDirectory :: FilePath -> IO r -> IO r
529 withCurrentDirectory name m =
530     bracket
531         (do cwd <- getCurrentDirectory
532             when (name /= "") (setCurrentDirectory name)
533             return cwd)
534         (\oldwd -> setCurrentDirectory oldwd)
535         (const m)
536