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