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