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