First beginnings of a CGI output
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 28 Jul 2010 16:32:32 +0000 (16:32 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Wed, 28 Jul 2010 16:32:32 +0000 (16:32 +0000)
b18n-combined-cgi.hs [new file with mode: 0644]
b18n-combined.cabal
testcgi.py [new file with mode: 0644]

diff --git a/b18n-combined-cgi.hs b/b18n-combined-cgi.hs
new file mode 100644 (file)
index 0000000..1734b1f
--- /dev/null
@@ -0,0 +1,264 @@
+import Network.CGI
+import Text.XHtml
+import Data.Maybe
+import Data.List
+import Data.ByteString.Lazy.UTF8 (fromString)
+import Control.Monad
+import Control.Applicative ((<$>),(<*>))
+import Text.PrettyPrint.HughesPJ (render)
+
+import Parser
+import SemSyn
+import Type
+import Shapify
+
+page code pageContent =
+       header << (
+       thetitle << "Combining Syntatic and Semantic Bidirectionalization" +++
+       style ! [ thetype "text/css" ] << cdata cssStyle
+       ) +++
+       body << (
+       thediv ! [theclass "top"] << (
+               thespan ! [theclass "title"] << "Combining Syntatic and Semantic Bidirectionalization" +++
+               thespan ! [theclass "subtitle"] << "Prototype implementation"
+       ) +++
+       maindiv << (
+               p << ("This tool allows you to experiment with the "+++
+                      "method described in the paper “" +++
+                     hotlink "http://doi.acm.org/10.1145/1291151.1291162"
+                        << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
+                     "” (ICFP'10) by " +++
+                     hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
+                        << "Kazutaka Matsuda" +++
+                     "."
+               )
+                       
+       ) +++
+        form ! [method "POST", action "#"] << (
+               maindiv << (
+                        p << (
+                               "Please enter the view function. (TODO: Elaborate this text)"
+                       ) +++
+
+                       p << (
+                               concatHtml (map (\(name,thisCode) -> 
+                                       radio "load" name
+                                       ! (if thisCode == code then [checked] else [])
+                                       +++ name +++ " "
+                               ) examples) +++
+                               mkSubmit True Load +++
+                               br +++
+                               textarea ! [name "code", cols "120", rows "7"] << code
+                       ) 
+                       
+               ) +++
+               pageContent
+       ) +++
+        maindiv << (
+               p << (
+               "The source code of this application and the underlying library can be found " +++
+               hotlink "TODO" << "here"+++
+               ".") +++
+               p << ("© 2010 Joachim Breitner <" +++
+                      hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
+                     ">")
+               )       
+       )
+       
+
+cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
+
+maindiv = thediv ! [theclass "main"]
+        
+examples =
+       [ ("init", unlines
+               [ "init (Nil)         = Nil"
+               , "init (Cons(a,Nil)) = Nil"
+               , "init (Cons(a,Cons(b,x))) = Cons(a,initWork(b,x))"
+               , "initWork(a,Nil)       = Nil"
+               , "initWork(a,Cons(b,x)) = Cons(a,initWork(b,x))"
+               ])
+       , ("initHalf", unlines
+               [ "initHalf(Nil)       = Nil"
+               , "initHalf(Cons(a,x)) = Cons(a,initHalfWork(x,x))"
+               , ""
+               , "initHalfWork(xs, Nil)         = Nil"
+               , "initHalfWork(xs, Cons(x,Nil)) = Nil"
+               , "initHalfWork(Cons(a,x), Cons(b,Cons(c,y)))"
+               , "                    = Cons(a,initHalfWork(x,y))"
+               ])
+       , ("seive", unlines
+               [ "seive (Nil)               = Nil"
+               , "seive (Cons(a,Nil))       = Nil"
+               , "seive (Cons(a,Cons(b,x))) = Cons(b,seive(x))"
+               ])
+       , ("rev", unlines
+               [ "reverse(xs) = rev(xs,Nil)"
+               , "rev(Nil,y)       = y"
+               , "rev(Cons(a,x),y) = rev(x,Cons(a,y))"
+               ])
+       ]
+
+defaultCode = fromJust (lookup "halve" examples)
+       
+outputErrors :: String -> Html
+outputErrors s = 
+           p << (
+                strong << "An error occurred:" +++ br +++
+                pre << s
+                )
+                
+mkSubmit active what = submit (submitId what) (submitLabel what)
+                      ! if active then [] else [disabled]
+
+data Run = Get | Check | Load | BiDi
+
+
+submitId Get = "get source"
+submitId Check = "check"
+submitId Load = "load"
+submitId BiDi = "submitBiDi"
+
+submitCode Get   = Just ("get source")
+submitCode Check = Nothing
+submitCode Load  = Nothing
+submitCode BiDi = Just ("bidirectionalize")
+
+submitLabel Check = "Re-Parse definition"
+submitLabel Load  = "Load example"
+submitLabel x   = fromJust (submitCode x)
+
+main = runCGI (handleErrors cgiMain)
+
+-- This function will not work in all casses, but in most.
+delDefinition name code = unlines squashed
+  where filtered = filter (not . defines name) (lines code)
+       squash [] = []
+       squash ("":_) = [""]
+       squash ("\r":_) = [""]
+       squash ls = ls
+       squashed = concat $ map squash $ group $ filtered
+
+addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
+  where        squashed = lines (delDefinition name code)
+       pad | last squashed == "" || last squashed == "\r" = []
+            | otherwise                                    = [""]
+       new_line = [name ++ " = " ++ def]
+       
+defines "" (' ':_) = True
+defines "" ('=':_) = True
+defines "" "" = False
+defines "" _   = False
+defines _  ""  = False
+defines (i:is) (x:xs) | i == x = defines is xs
+                      | i /= x = False
+                  
+
+cgiMain = do
+        setHeader "Content-type" "text/xml; charset=UTF-8"
+
+        exMode  <- maybe Normal read <$> getInput "execMode"
+        outMode <- maybe PseudoCode read <$> getInput "outputMode"
+        showTypes <- isJust <$> getInput "showTypes"
+       
+       todo <- fromMaybe Check . msum <$> sequence (
+            map (\what -> fmap (const what) <$> getInput (submitId what))
+            [ BiDi, Get, Check, Load ])
+        
+       code <- fromMaybe defaultCode <$> getInput "code"
+       
+        let mbAST = parseString code
+
+        code <- case todo of
+            Load -> do loadWhat <- getInput "load"
+                       return $ fromMaybe code $ loadWhat >>= flip lookup examples 
+            _ -> return code
+
+        let conf = defaultConfig { outputMode = outMode, execMode = exMode, isShowType = showTypes }
+        let genCode = case mbAST of
+              Left _ -> ""
+              Right ast -> render $ case exMode of 
+                   Normal -> outputCode conf False ast (typeInference ast)
+                   Shapify -> outputCode conf False ast (shapify $ typeInference ast)
+                   ShapifyPlus -> outputCode conf True  ast (introNat $ shapify $ typeInference ast)
+
+
+        outputFPS $ fromString $ showHtml $ page code $
+               {- p << astInfo mbAST +++ -}
+               maindiv ! [ identifier "output" ]<< (
+                       p << (
+                               "You can calculate a derived put function with various options:" ) +++
+                       p << ( "Execution mode: " +++
+                              concatHtml (map (\mode -> 
+                                 radio "execMode" (show mode) 
+                                       ! (if mode == exMode then [checked] else [])
+                                       +++ show mode +++ " "
+                                ) [Normal, Shapify, ShapifyPlus]) +++ br +++
+                              "Output mode: " +++
+                              concatHtml (map (\mode -> 
+                                 radio "outputMode" (show mode) 
+                                       ! (if mode == outMode then [checked] else [])
+                                       +++ show mode +++ " "
+                                ) [PseudoCode, HaskellCode, ForwardCode]) +++ br +++
+                              "Show types " +++ checkbox "showTypes" "showTypes"
+                                        ! (if showTypes then [checked] else [])
+                                        +++ br +++
+                              mkSubmit True BiDi
+                       ) +++
+                       {- maybe noHtml outputErrors errors +++ -}
+                        p << ("Result:"+++ br +++
+                           textarea ! [name "gencode", cols "120"
+                                       , rows (show (1 + length (lines genCode)))
+                                       ] << genCode
+
+                        )
+               )
+               
+astInfo (Left err) = maindiv << p << (
+       "Can not parse your definition:" +++ br +++
+       pre << show err +++ br +++
+       mkSubmit True Check)
+
+astInfo (Right source) = maindiv << (
+       p << ("Definition parsed succesfully"
+{-             "Your definitions have the following types: " +++
+               pre << ("get :: " ++ getType ++ "\n"++
+                       "source :: " ++ sourceType) +++
+               "Therefore, an updater can be derived by " +++
+               case (canBff, canBffEq, canBffOrd) of
+                       (True, _, _) -> 
+                               tt << "bff" +++ ", " +++
+                               tt << "bff_Eq" +++ ", and " +++
+                               tt << "bff_Ord" +++ "."
+                       (False, True, _) -> 
+                               tt << "bff_Eq" +++ " and " +++
+                               tt << "bff_Ord" +++ "."
+                       (False, False, True) -> 
+                               tt << "bff_Ord" +++ " only."
+                       (False, False, False) -> 
+                               "none of the " +++ tt << "bff" +++ " functions."
+-}                                
+       ) +++
+       p << mkSubmit True Check
+       )
+
+cssStyle = unlines 
+        [ "body { padding:0px; margin: 0px; }"
+        , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
+        , "              background-color:#efefef;"
+        , "              border-bottom:1px solid black; }"
+        , "span.title { font-size:xx-large; font-weight:bold; }"
+        , "span.subtitle { padding-left:30px; font-size:large; }"
+        , "div.main { border:1px dotted black;"
+        , "                   padding:10px; margin:10px; }"
+        , "div.submain { padding:10px; margin:11px; }"
+        , "p.subtitle { font-size:large; font-weight:bold; }"
+        , "input.type { font-family:monospace; }"
+        , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
+        , "span.mono { font-family:monospace; }"
+        , "pre { margin:10px; margin-left:20px; padding:10px;"
+        , "          border:1px solid black; }"
+        , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
+        , "p { text-align:justify; }"
+       ]
+
index 3983694..5e0ba58 100644 (file)
@@ -2,9 +2,9 @@ Name:                b18n-combined
 Version:             0.1
 Synopsis:            Prototype Implementation of Combining Syntatic and Semantic Bidirectionalization (ICFP'10)
 Description:         This is a prototype implementation of the idea presented 
-                    in Combining Syntatic and Semantic Bidirectionalization 
-                    by Janis Voigtlaender, Zhenjiang Hu, Kazutaka Matsuda 
-                    and Meng Wang.
+                     in Combining Syntatic and Semantic Bidirectionalization 
+                     by Janis Voigtlaender, Zhenjiang Hu, Kazutaka Matsuda 
+                     and Meng Wang.
 License:             PublicDomain
 Author:              Kazutaka Matsuda
 Maintainer:          kztk@kb.ecei.tohoku.ac.jp
@@ -19,3 +19,9 @@ Executable b18n-combined
   Main-is: Main.hs            
   Build-depends: base (>=4), mtl, template-haskell, containers, pretty, parsec
   Other-modules: Util, AST, Parser, Type, Shapify, CodeGen
+
+Executable b18n-combined-cgi
+  Main-is: b18n-combined-cgi.hs
+  Build-depends: base (>=4), mtl, template-haskell, containers, pretty, parsec,
+                 xhtml, cgi, utf8-string
+  Other-modules: Util, AST, Parser, Type, Shapify, CodeGen
diff --git a/testcgi.py b/testcgi.py
new file mode 100644 (file)
index 0000000..07e1b00
--- /dev/null
@@ -0,0 +1,22 @@
+#!/usr/bin/python
+
+from BaseHTTPServer import HTTPServer
+from CGIHTTPServer import CGIHTTPRequestHandler
+import sys
+
+class MyRequestHandler(CGIHTTPRequestHandler):
+       def is_cgi(self):
+               self.cgi_info = ("","")
+               return True
+
+       def translate_path(self, path):
+               return sys.argv[1]
+
+
+if len(sys.argv) == 1:
+    print "Usage: %s cgi-script" % sys.argv[0]
+else:    
+    server_address = ('', 8000)
+    http  = HTTPServer(server_address, MyRequestHandler)
+    print "Please connect to http://localhost:%d/" % server_address[1]
+    http.serve_forever()