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