Combined-line mode checks bidirectionalizability
[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 ("<![CDATA[\n"++ s ++ "\n]]>")
194
195 maindiv = thediv ! [theclass "main"]
196         
197 examples =
198         [ ("init", unlines
199                 [ "init []      = []"
200                 , "init [a]     = []"
201                 , "init (a:b:x) = a:initWork b x"
202                 , "initWork a []    = []"
203                 , "initWork a (b:x) = a:initWork b x"
204                 ])
205         , ("sieve", unlines
206                 [ "sieve []      = []"
207                 , "sieve [a]     = []"
208                 , "sieve (a:b:x) = b:sieve x"
209                 ])
210         , ("initHalf", unlines
211                 [ "initHalf []    = []"
212                 , "initHalf (a:x) = a:initHalfWork x x"
213                 , ""
214                 , "initHalfWork xs  []  = []"
215                 , "initHalfWork xs  [x] = []"
216                 , "initHalfWork (a:x) (b:c:y)"
217                 , "                    = a:initHalfWork x y"
218                 ])
219         , ("rev", unlines
220                 [ "reverse xs = rev xs []"
221                 , "rev []    y = y"
222                 , "rev (a:x) y = rev x (a:y)"
223                 ])
224         ]
225
226 defaultCode = fromJust (lookup "init" examples)
227         
228 outputErrors :: String -> Html
229 outputErrors s = 
230            p << (
231                 strong << "An error occurred:" +++ br +++
232                 pre << s
233                 )
234                 
235 mkSubmit active what = submit (submitId what) (submitLabel what)
236                        ! if active then [] else [disabled]
237
238 data Run = Get | Check | Load | BiDi | EvalPut | EvalGet
239
240
241 submitId Get = "get source"
242 submitId Check = "check"
243 submitId Load = "load"
244 submitId BiDi = "submitBiDi"
245 submitId EvalPut = "evalPut"
246 submitId EvalGet = "evalGet"
247
248 submitCode Get   = Just ("get source")
249 submitCode Check = Nothing
250 submitCode Load  = Nothing
251
252 submitLabel Check =   "Re-Parse definition"
253 submitLabel Load  =   "Load example"
254 submitLabel EvalGet = "view = get source"
255 submitLabel EvalPut = "result = put source view"
256 submitLabel BiDi =    "bidirectionalize"
257
258 b18nModeName SemanticB18n = "Semantic bidir. (POPL’09)"
259 b18nModeName SyntacticB18n = "Syntactic bidir. (ICFP’07)"
260 b18nModeName CombinedB18n = "Combined bidir. (ICFP’10)"
261
262 main = runCGI (handleErrors cgiMain)
263
264 -- This function will not work in all casses, but in most.
265 delDefinition name code = unlines squashed
266   where filtered = filter (not . defines name) (lines code)
267         squash [] = []
268         squash ("":_) = [""]
269         squash ("\r":_) = [""]
270         squash ls = ls
271         squashed = concat $ map squash $ group $ filtered
272
273 addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
274   where squashed = lines (delDefinition name code)
275         pad | last squashed == "" || last squashed == "\r" = []
276             | otherwise                                    = [""]
277         new_line = [name ++ " = " ++ def]
278         
279 defines "" (' ':_) = True
280 defines "" ('=':_) = True
281 defines "" "" = False
282 defines "" _   = False
283 defines _  ""  = False
284 defines (i:is) (x:xs) | i == x = defines is xs
285                       | i /= x = False
286
287 cgiMain = do
288     qs <- queryString
289     if qs == "jquery"
290      then jQueryMain
291      else formMain
292
293 jQueryMain = do
294         setHeader "Content-type" "text/javascript"
295         setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100"
296         setHeader "Cache-control" "max-age=36000000" -- 1000 h
297         outputFPS $ jQueryCode
298     
299 defaultPlayCode (Config{ b18nMode = SyntacticB18n}) get =
300         Just $ unlines
301             [ "get s = Main." ++ get ++ " s"
302             , "put s v = " ++ get ++ "_B s v"
303             , ""
304             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
305             ]
306 defaultPlayCode (Config{ b18nMode = SemanticB18n}) get =
307         Just $ unlines
308             [ "get s = Main." ++ get ++ " s"
309             , "put s v = " ++ get ++ "_B s v"
310             , ""
311             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
312             ]
313 defaultPlayCode (Config{ b18nMode = CombinedB18n}) get =
314         Just $ unlines
315             [ "get s = Main." ++ get ++ " s"
316             , "put s v = fromMaybe (error \"Could not handle shape change.\") $ " ++
317                  get ++ "_Bbd bias default_value s v"
318             , "bias = rear"
319             , "default_value = 42"
320             , ""
321             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
322             ]
323
324 formMain = do
325         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
326
327         conf <- do
328             b18nMode' <- maybe CombinedB18n read <$> getInput "b18nMode"
329             return $ adjustConfig $ defaultConfig
330                 { isHaskellify = True
331                 , b18nMode = b18nMode'
332                 }
333         
334         todo <- msum <$> sequence (
335             map (\what -> fmap (const what) <$> getInput (submitId what))
336             [ BiDi, Get, Check, Load, EvalPut, EvalGet])
337         
338         code <- filter (/= '\r') <$> fromMaybe defaultCode <$> getInput "code"
339
340         code <- case todo of
341             Just Load -> do loadWhat <- getInput "loadCode"
342                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
343             _ -> return code
344         
345         let eAST = parseString code
346
347
348         let astError = either (Just . show) checkBidirectionalizability eAST
349
350         let (genCodeM,getM) = case (todo,eAST) of
351                 (Just Load, _) -> (Nothing, Nothing)
352                 (Just _, Right ast) ->
353                     (  Just $ render $ renderCode conf ast
354                     ,  firstDeclaredName ast
355                     )
356                 _ -> (Nothing, Nothing)
357
358         showCode <- maybe False read <$> getInput "showCode"
359
360         pcM <- getInput "playCode" 
361         -- Playcode can only by used when the output is exMode
362         (playCode, playErrorM) <- -- if outMode /= HaskellCode then return (Nothing, Nothing) else
363             case (todo,getM,genCodeM,pcM) of
364             -- The user successfully generated code to play with, insert default playCode.
365             -- Do not use the user input, as he probably switched to a new example.
366             (Just BiDi, Just get, Just _, _) ->
367                 return (defaultPlayCode conf get, Nothing)
368             -- The user played with the code
369             (Just EvalGet, Just get, Just genCode, Just pc) -> do
370                 view <- liftIO $ evaluateWith genCode pc ("get source")
371                 case view of 
372                     Left err -> return $ (Just pc, Just err)
373                     Right dat -> return $ (\r -> (Just r, Nothing))
374                                         $ addDefiniton "view" dat 
375                                         $ delDefinition "result"
376                                         $ pc
377             (Just EvalGet, Just get, Just genCode, Nothing) -> do
378                 return (defaultPlayCode conf get, Nothing)
379             (Just EvalPut, Just get, Just genCode, Just pc) -> do
380                 view <- liftIO $ evaluateWith genCode pc ("put source view")
381                 case view of 
382                     Left err -> return $ (Just pc, Just err)
383                     Right dat -> return $ (\r -> (Just r, Nothing))
384                                         $ addDefiniton "result" dat 
385                                         $ pc
386             (Just EvalPut, Just get, Just _, Nothing) -> do
387                 return (defaultPlayCode conf get, Nothing)
388             _ -> return (Nothing, Nothing)
389
390         scrollX <- getInput "scrollx"
391         scrollY <- getInput "scrolly"
392
393         outputFPS $ fromString $ showHtml $ page $
394             PageInfo conf
395                      scrollX
396                      scrollY
397                      code
398                      astError
399                      genCodeM
400                      showCode
401                      playCode
402                      playErrorM
403
404 evaluateWith :: String -> String -> String -> IO (Either String String)
405 evaluateWith genCode playCode expr =
406     withinTmpDir $ do
407         BS.writeFile "BUtil.hs" bUtilCode
408         writeFile "Main.hs" $ "module Main where\n" ++ genCode
409         liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr
410   where mods = 
411             [ "BUtil"
412             , "Main"
413             --, "Data.Maybe"
414             ]
415         imports = mods ++
416             [ "Data.Maybe"
417             , "Prelude"
418             ]
419
420 withFullSource genCode playCode = genCode' ++ "\n" ++ playCode
421     where genCode' = unlines . filter (not . isPrefixOf "import") . lines $ genCode
422
423 astInfo (Left err) = maindiv << p << (
424         "Can not parse your definition:" +++ br +++
425         pre << show err +++ br +++
426         mkSubmit True Check)
427
428 astInfo (Right source) = maindiv << (
429         p << ("Definition parsed succesfully") +++
430         p << mkSubmit True Check
431         )
432
433 cssStyle = unlines 
434         [ "body { padding:0px; margin: 0px; }"
435         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
436         , "              background-color:#efefef;"
437         , "              border-bottom:1px solid black; }"
438         , "span.title { font-size:xx-large; font-weight:bold; }"
439         , "span.subtitle { padding-left:30px; font-size:large; }"
440         , "div.main { border:1px dotted black;"
441         , "                   padding:10px; margin:10px; }"
442         , "div.submain { padding:10px; margin:11px; }"
443         , "p.subtitle { font-size:large; font-weight:bold; }"
444         , "input.type { font-family:monospace; }"
445         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
446         , "span.mono { font-family:monospace; }"
447         , "pre { margin:10px; margin-left:20px; padding:10px;"
448         , "          border:1px solid black; }"
449         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
450         , "p { text-align:justify; }"
451         ]
452
453 jsCode = unlines 
454     [ "function saveScroll () {"
455     , "    $('#scrolly').val($('html').scrollTop());"
456     , "}"
457     , "function restoreScroll () {"
458     , "    $('html').scrollTop($('#scrolly').val());"
459     , "}"
460     , "$(document).ready(function () {"
461     , "   $('#hideShow').show();"
462     , "   if ($('#showCode').val() == 'False')"
463     , "     { $('#genCode').hide(); };"
464     , "   $('#hideShow a').click(function () {"
465     , "      $('#showCode').val("
466     , "         $('#genCode').is(':visible') ? 'False' : 'True'"
467     , "      );"
468     , "      $('#genCode').toggle('slow');"
469     , "   })"
470     , "})"
471     ]
472
473 htmlMB Nothing  f = noHtml
474 htmlMB (Just x) f = f x
475
476 readOnly = emptyAttr "readonly"
477
478
479 firstDeclaredName (AST []) = Nothing
480 firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n)
481
482 {-
483  - Temp-Dir functions taken from XMonad/Lock.hs and simplified.
484  - It also changes TMP so that hint’s temporary files are stored within this directory
485  -}
486 withinTmpDir :: IO a -> IO a
487 withinTmpDir job = do
488   absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory
489   formerdir <- getCurrentDirectory
490   formerTMP <- getEnv "TMPDIR"
491   bracket (do dir <- create_directory absolute_name 0
492               setEnv "TMPDIR" dir True  
493               return dir
494           )
495           (\dir -> do setCurrentDirectory formerdir
496                       maybe (unsetEnv "TMPDIR") (\p -> setEnv "TMPDIR" p True) formerTMP
497                       rmRecursive dir)
498           (const job)
499     where newname name 0 = name
500           newname name n = name ++ "-" ++ show n
501           create_directory :: FilePath -> Int -> IO FilePath
502           create_directory name n
503               = do createDirectory $ newname name n
504                    setCurrentDirectory $ newname name n
505                    getCurrentDirectory
506                 `catch` (\e -> if isAlreadyExistsError e
507                                then create_directory name (n+1)
508                                else throwIO e)
509
510 rmRecursive :: FilePath -> IO ()
511 rmRecursive d =
512     do isd <- isDirectory <$> getSymbolicLinkStatus d
513        if not isd
514           then removeFile d
515           else when isd $ do conts <- actual_dir_contents
516                              withCurrentDirectory d $
517                                mapM_ rmRecursive conts
518                              removeDirectory d
519     where actual_dir_contents = -- doesn't include . or ..
520               do c <- getDirectoryContents d
521                  return $ filter (/=".") $ filter (/="..") c
522
523 withCurrentDirectory :: FilePath -> IO r -> IO r
524 withCurrentDirectory name m =
525     bracket
526         (do cwd <- getCurrentDirectory
527             when (name /= "") (setCurrentDirectory name)
528             return cwd)
529         (\oldwd -> setCurrentDirectory oldwd)
530         (const m)
531