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