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