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