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