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