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