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