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