Show parseErrors
[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 Text.ParserCombinators.Parsec (ParseError)
12
13
14 import Parser
15 import SemSyn
16 import Type
17 import Shapify
18 import AST
19
20 import JQuery
21
22 data PageInfo = PageInfo
23     { scrollX :: Maybe String
24     , scrollY :: Maybe String
25     , viewFunction :: String
26     , parseError :: Maybe String
27     , exMode  :: ExecMode
28     , outMode :: OutputMode
29     , showTypes :: Bool
30     , generatedModuleMB :: Maybe String
31     } 
32
33 page (PageInfo {..}) =
34        header << (
35         thetitle << "Combining Syntatic and Semantic Bidirectionalization" +++
36         style ! [ thetype "text/css" ] << cdata cssStyle +++
37         script ! [ thetype "text/javascript", src "?jquery" ] << noHtml +++
38         script ! [ thetype "text/javascript" ] << cdata jsCode 
39        ) +++
40        body ! [ strAttr "onload" "restoreScroll()" ] << (
41         thediv ! [theclass "top"] << (
42                 thespan ! [theclass "title"] << "Combining Syntatic and Semantic Bidirectionalization" +++
43                 thespan ! [theclass "subtitle"] << "Prototype implementation"
44         ) +++
45         maindiv << (
46                 p << ("This tool allows you to experiment with the "+++
47                       "method described in the paper “" +++
48                       hotlink "http://doi.acm.org/10.1145/1291151.1291162"
49                         << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
50                       "” (ICFP'10) by " +++
51                       hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
52                         << "Kazutaka Matsuda" +++
53                       "."
54                 )
55                         
56         ) +++
57         form ! [method "POST",
58                 action "#",
59                 strAttr "onsubmit" "saveScroll()"
60             ] << (
61                 hidden "scrollx" (fromMaybe "0" scrollX) +++
62                 hidden "scrolly" (fromMaybe "0" scrollY) +++
63                 maindiv << (
64                          p << (
65                                 "Please enter the view function. (TODO: Elaborate this text)"
66                         ) +++
67
68                         p << (
69                                 concatHtml (map (\(name,thisCode) -> 
70                                         radio "load" name
71                                         ! (if thisCode == viewFunction then [checked] else [])
72                                         +++ name +++ " "
73                                 ) examples) +++
74                                 mkSubmit True Load +++
75                                 br +++
76                                 textarea ! [name "code", cols "120", rows "7"] << viewFunction
77                         ) 
78                         
79                 ) +++
80                 ( htmlMB parseError $ \err -> 
81                      maindiv << p << (
82                         "Can not parse your definition:" +++ br +++
83                         pre << show err +++ br +++
84                         mkSubmit True Check)
85                 ) +++
86                 -- p << astInfo mbAST +++
87                 maindiv ! [ identifier "output" ]<< (
88                         p << (
89                                 "You can calculate a derived put function with various options:" ) +++
90                         p << ( "Execution mode: " +++
91                                concatHtml (map (\mode -> 
92                                   radio "execMode" (show mode) 
93                                         ! (guard (mode == exMode) >> return checked)
94                                         +++ show mode +++ " "
95                                 ) [Normal, Shapify, ShapifyPlus]) +++ br +++
96                                "Output mode: " +++
97                                concatHtml (map (\mode -> 
98                                   radio "outputMode" (show mode) 
99                                         ! (guard (mode == outMode) >> return checked)
100                                         +++ show mode +++ " "
101                                 ) [PseudoCode, HaskellCode, ForwardCode]) +++ br +++
102                                "Show types " +++ checkbox "showTypes" "showTypes"
103                                         ! (guard showTypes >> return checked)
104                                         +++ br +++
105                                mkSubmit True BiDi
106                         ) +++
107                         ( htmlMB generatedModuleMB $ \ generatedModule -> 
108                             {- maybe noHtml outputErrors errors +++ -}
109                             p << ("Result:"+++ br +++
110                                 textarea ! [name "gencode", cols "120"
111                                            , rows (show (1 + length (lines generatedModule)))
112                                            ] << generatedModule
113
114                             )
115                         )
116                 )
117         ) +++
118         maindiv << (
119                 p << (
120                 "The source code of this application and the underlying library can be found " +++
121                 hotlink "TODO" << "here"+++
122                 ".") +++
123                 p << ("© 2010 Joachim Breitner <" +++
124                       hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
125                       ">")
126                 )       
127         )
128        
129
130 cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
131
132 maindiv = thediv ! [theclass "main"]
133         
134 examples =
135         [ ("init", unlines
136                 [ "init (Nil)         = Nil"
137                 , "init (Cons(a,Nil)) = Nil"
138                 , "init (Cons(a,Cons(b,x))) = Cons(a,initWork(b,x))"
139                 , "initWork(a,Nil)       = Nil"
140                 , "initWork(a,Cons(b,x)) = Cons(a,initWork(b,x))"
141                 ])
142         , ("initHalf", unlines
143                 [ "initHalf(Nil)       = Nil"
144                 , "initHalf(Cons(a,x)) = Cons(a,initHalfWork(x,x))"
145                 , ""
146                 , "initHalfWork(xs, Nil)         = Nil"
147                 , "initHalfWork(xs, Cons(x,Nil)) = Nil"
148                 , "initHalfWork(Cons(a,x), Cons(b,Cons(c,y)))"
149                 , "                    = Cons(a,initHalfWork(x,y))"
150                 ])
151         , ("seive", unlines
152                 [ "seive (Nil)               = Nil"
153                 , "seive (Cons(a,Nil))       = Nil"
154                 , "seive (Cons(a,Cons(b,x))) = Cons(b,seive(x))"
155                 ])
156         , ("rev", unlines
157                 [ "reverse(xs) = rev(xs,Nil)"
158                 , "rev(Nil,y)       = y"
159                 , "rev(Cons(a,x),y) = rev(x,Cons(a,y))"
160                 ])
161         ]
162
163 defaultCode = fromJust (lookup "init" examples)
164         
165 outputErrors :: String -> Html
166 outputErrors s = 
167            p << (
168                 strong << "An error occurred:" +++ br +++
169                 pre << s
170                 )
171                 
172 mkSubmit active what = submit (submitId what) (submitLabel what)
173                        ! if active then [] else [disabled]
174
175 data Run = Get | Check | Load | BiDi
176
177
178 submitId Get = "get source"
179 submitId Check = "check"
180 submitId Load = "load"
181 submitId BiDi = "submitBiDi"
182
183 submitCode Get   = Just ("get source")
184 submitCode Check = Nothing
185 submitCode Load  = Nothing
186 submitCode BiDi = Just ("bidirectionalize")
187
188 submitLabel Check = "Re-Parse definition"
189 submitLabel Load  = "Load example"
190 submitLabel x   = fromJust (submitCode x)
191
192 main = runCGI (handleErrors cgiMain)
193
194 -- This function will not work in all casses, but in most.
195 delDefinition name code = unlines squashed
196   where filtered = filter (not . defines name) (lines code)
197         squash [] = []
198         squash ("":_) = [""]
199         squash ("\r":_) = [""]
200         squash ls = ls
201         squashed = concat $ map squash $ group $ filtered
202
203 addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
204   where squashed = lines (delDefinition name code)
205         pad | last squashed == "" || last squashed == "\r" = []
206             | otherwise                                    = [""]
207         new_line = [name ++ " = " ++ def]
208         
209 defines "" (' ':_) = True
210 defines "" ('=':_) = True
211 defines "" "" = False
212 defines "" _   = False
213 defines _  ""  = False
214 defines (i:is) (x:xs) | i == x = defines is xs
215                       | i /= x = False
216
217 cgiMain = do
218     qs <- queryString
219     if qs == "jquery"
220      then jQueryMain
221      else formMain
222
223 jQueryMain = do
224         setHeader "Content-type" "text/javascript"
225         setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100"
226         setHeader "Cache-control" "max-age=36000000" -- 1000 h
227         outputFPS $ jQueryCode
228     
229
230 formMain = do
231         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
232
233         exMode  <- maybe Normal read <$> getInput "execMode"
234         outMode <- maybe PseudoCode read <$> getInput "outputMode"
235         showTypes <- isJust <$> getInput "showTypes"
236         
237         todo <- msum <$> sequence (
238             map (\what -> fmap (const what) <$> getInput (submitId what))
239             [ BiDi, Get, Check, Load ])
240         
241         code <- fromMaybe defaultCode <$> getInput "code"
242         
243         code <- case todo of
244             Just Load -> do loadWhat <- getInput "load"
245                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
246             _ -> return code
247         
248         let mbAST = parseString code
249
250         let conf = defaultConfig { outputMode = outMode, execMode = exMode, isShowType = showTypes }
251         let parseError = either (Just . show) (const Nothing) mbAST
252
253         let genCode = case (todo,mbAST) of
254                 (Just Load, _) -> Nothing
255                 (Just _, Right ast) -> Just $ render $ case exMode of 
256                        Normal -> outputCode conf False ast (typeInference ast)
257                        Shapify -> outputCode conf False ast (shapify $ typeInference ast)
258                        ShapifyPlus -> outputCode conf True  ast (introNat $ shapify $ typeInference ast)
259                 _ -> Nothing
260
261         scrollX <- getInput "scrollx"
262         scrollY <- getInput "scrolly"
263
264         outputFPS $ fromString $ showHtml $ page (PageInfo scrollX scrollY code parseError exMode outMode showTypes genCode)
265
266 astInfo (Left err) = maindiv << p << (
267         "Can not parse your definition:" +++ br +++
268         pre << show err +++ br +++
269         mkSubmit True Check)
270
271 astInfo (Right source) = maindiv << (
272         p << ("Definition parsed succesfully"
273 {-              "Your definitions have the following types: " +++
274                 pre << ("get :: " ++ getType ++ "\n"++
275                         "source :: " ++ sourceType) +++
276                 "Therefore, an updater can be derived by " +++
277                 case (canBff, canBffEq, canBffOrd) of
278                         (True, _, _) -> 
279                                 tt << "bff" +++ ", " +++
280                                 tt << "bff_Eq" +++ ", and " +++
281                                 tt << "bff_Ord" +++ "."
282                         (False, True, _) -> 
283                                 tt << "bff_Eq" +++ " and " +++
284                                 tt << "bff_Ord" +++ "."
285                         (False, False, True) -> 
286                                 tt << "bff_Ord" +++ " only."
287                         (False, False, False) -> 
288                                 "none of the " +++ tt << "bff" +++ " functions."
289 -}                                
290         ) +++
291         p << mkSubmit True Check
292         )
293
294 cssStyle = unlines 
295         [ "body { padding:0px; margin: 0px; }"
296         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
297         , "              background-color:#efefef;"
298         , "              border-bottom:1px solid black; }"
299         , "span.title { font-size:xx-large; font-weight:bold; }"
300         , "span.subtitle { padding-left:30px; font-size:large; }"
301         , "div.main { border:1px dotted black;"
302         , "                   padding:10px; margin:10px; }"
303         , "div.submain { padding:10px; margin:11px; }"
304         , "p.subtitle { font-size:large; font-weight:bold; }"
305         , "input.type { font-family:monospace; }"
306         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
307         , "span.mono { font-family:monospace; }"
308         , "pre { margin:10px; margin-left:20px; padding:10px;"
309         , "          border:1px solid black; }"
310         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
311         , "p { text-align:justify; }"
312         ]
313
314 jsCode = unlines 
315     [ "function saveScroll () {"
316     , "    $(\"#scrolly\").val($(\"html\").scrollTop());"
317     , "}"
318     , "function restoreScroll () {"
319     , "    $(\"html\").scrollTop($(\"#scrolly\").val());"
320     , "}"
321     ]
322
323 htmlMB Nothing  f = noHtml
324 htmlMB (Just x) f = f x