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     , parseError :: 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 parseError $ \err ->
 111                      maindiv << p << (
 112                         "Can not parse your definition:" +++ br +++
 113                         pre << show 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, NoB18n]) +++ 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 "8" ] << 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{..}) get =
 280         Just $ unlines
 281             [ "get s = Main." ++ get ++ " s"
 282             , "put s v = " ++ put
 283             , ""
 284             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
 285             ]
 286     where put | b18nMode == SyntacticB18n =
 287                     get ++ "_140_B s v"
 288               | b18nMode == SemanticB18n =
 289                     get ++ "_B s v"
 290               | b18nMode == CombinedB18n =
 291                     "fromMaybe (error \"Could not handle shape change.\") $ " ++
 292                     get ++ "_Bbd rear 42 s v"
 293
 294 formMain = do
 295         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
 296
 297         conf <- do
 298             b18nMode' <- maybe CombinedB18n read <$> getInput "b18nMode"
 299             return $ defaultConfig
 300                 { isHaskellify = True
 301                 , b18nMode = b18nMode'
 302                 , execMode = ShapifyPlus
 303                 }
 304
 305         todo <- msum <$> sequence (
 306             map (\what -> fmap (const what) <$> getInput (submitId what))
 307             [ BiDi, Get, Check, Load, EvalPut, EvalGet])
 308
 309         code <- filter (/= '\r') <$> fromMaybe defaultCode <$> getInput "code"
 310
 311         code <- case todo of
 312             Just Load -> do loadWhat <- getInput "loadCode"
 313                             return $ fromMaybe code $ loadWhat >>= flip lookup examples
 314             _ -> return code
 315
 316         let eAST = parseString code
 317
 318
 319         let parseError = either (Just . show) (const Nothing) eAST
 320
 321         let (genCodeM,getM) = case (todo,eAST) of
 322                 (Just Load, _) -> (Nothing, Nothing)
 323                 (Just _, Right ast) ->
 324                     (  Just $ render $
 325                        outputCode conf True  ast (introNat $ shapify $ typeInference ast)
 326                     ,  firstDeclaredName ast
 327                     )
 328                 _ -> (Nothing, Nothing)
 329
 330         showCode <- maybe False read <$> getInput "showCode"
 331
 332         pcM <- getInput "playCode"
 333         -- Playcode can only by used when the output is exMode
 334         (playCode, playErrorM) <- -- if outMode /= HaskellCode then return (Nothing, Nothing) else
 335             case (todo,getM,genCodeM,pcM) of
 336             -- The user successfully generated code to play with, insert default playCode.
 337             -- Do not use the user input, as he probably switched to a new example.
 338             (Just BiDi, Just get, Just _, _) ->
 339                 return (defaultPlayCode conf get, Nothing)
 340             -- The user played with the code
 341             (Just EvalGet, Just get, Just genCode, Just pc) -> do
 342                 view <- liftIO $ evaluateWith genCode pc ("get source")
 343                 case view of
 344                     Left err -> return $ (Just pc, Just err)
 345                     Right dat -> return $ (\r -> (Just r, Nothing))
 346                                         $ addDefiniton "view" dat
 347                                         $ delDefinition "result"
 348                                         $ pc
 349             (Just EvalGet, Just get, Just genCode, Nothing) -> do
 350                 return (defaultPlayCode conf get, Nothing)
 351             (Just EvalPut, Just get, Just genCode, Just pc) -> do
 352                 view <- liftIO $ evaluateWith genCode pc ("put source view")
 353                 case view of
 354                     Left err -> return $ (Just pc, Just err)
 355                     Right dat -> return $ (\r -> (Just r, Nothing))
 356                                         $ addDefiniton "result" dat
 357                                         $ pc
 358             (Just EvalPut, Just get, Just _, Nothing) -> do
 359                 return (defaultPlayCode conf get, Nothing)
 360             _ -> return (Nothing, Nothing)
 361
 362         scrollX <- getInput "scrollx"
 363         scrollY <- getInput "scrolly"
 364
 365         outputFPS $ fromString $ showHtml $ page $
 366             PageInfo conf
 367                      scrollX
 368                      scrollY
 369                      code
 370                      parseError
 371                      genCodeM
 372                      showCode
 373                      playCode
 374                      playErrorM
 375
 376 evaluateWith :: String -> String -> String -> IO (Either String String)
 377 evaluateWith genCode playCode expr =
 378     withinTmpDir $ do
 379         BS.writeFile "BUtil.hs" bUtilCode
 380         writeFile "Main.hs" $ "module Main where\n" ++ genCode
 381         liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr
 382   where mods =
 383             [ "BUtil"
 384             , "Main"
 385             --, "Data.Maybe"
 386             ]
 387         imports = mods ++
 388             [ "Data.Maybe"
 389             , "Prelude"
 390             ]
 391
 392 withFullSource genCode playCode = genCode' ++ "\n" ++ playCode
 393     where genCode' = unlines . filter (not . isPrefixOf "import") . lines $ genCode
 394
 395 astInfo (Left err) = maindiv << p << (
 396         "Can not parse your definition:" +++ br +++
 397         pre << show err +++ br +++
 398         mkSubmit True Check)
 399
 400 astInfo (Right source) = maindiv << (
 401         p << ("Definition parsed succesfully") +++
 402         p << mkSubmit True Check
 403         )
 404
 405 cssStyle = unlines
 406         [ "body { padding:0px; margin: 0px; }"
 407         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
 408         , "              background-color:#efefef;"
 409         , "              border-bottom:1px solid black; }"
 410         , "span.title { font-size:xx-large; font-weight:bold; }"
 411         , "span.subtitle { padding-left:30px; font-size:large; }"
 412         , "div.main { border:1px dotted black;"
 413         , "                   padding:10px; margin:10px; }"
 414         , "div.submain { padding:10px; margin:11px; }"
 415         , "p.subtitle { font-size:large; font-weight:bold; }"
 416         , "input.type { font-family:monospace; }"
 417         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
 418         , "span.mono { font-family:monospace; }"
 419         , "pre { margin:10px; margin-left:20px; padding:10px;"
 420         , "          border:1px solid black; }"
 421         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
 422         , "p { text-align:justify; }"
 423         ]
 424
 425 jsCode = unlines
 426     [ "function saveScroll () {"
 427     , "    $('#scrolly').val($('html').scrollTop());"
 428     , "}"
 429     , "function restoreScroll () {"
 430     , "    $('html').scrollTop($('#scrolly').val());"
 431     , "}"
 432     , "$(document).ready(function () {"
 433     , "   $('#hideShow').show();"
 434     , "   if ($('#showCode').val() == 'False')"
 435     , "     { $('#genCode').hide(); };"
 436     , "   $('#hideShow a').click(function () {"
 437     , "      $('#showCode').val("
 438     , "         $('#genCode').is(':visible') ? 'False' : 'True'"
 439     , "      );"
 440     , "      $('#genCode').toggle('slow');"
 441     , "   })"
 442     , "})"
 443     ]
 444
 445 htmlMB Nothing  f = noHtml
 446 htmlMB (Just x) f = f x
 447
 448 readOnly = emptyAttr "readonly"
 449
 450
 451 firstDeclaredName (AST []) = Nothing
 452 firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n)
 453
 454 {-
 455  - Temp-Dir functions taken from XMonad/Lock.hs and simplified.
 456  - It also changes TMP so that hint’s temporary files are stored within this directory
 457  -}
 458 withinTmpDir :: IO a -> IO a
 459 withinTmpDir job = do
 460   absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory
 461   formerdir <- getCurrentDirectory
 462   formerTMP <- getEnv "TMPDIR"
 463   bracket (do dir <- create_directory absolute_name 0
 464               setEnv "TMPDIR" dir True
 465               return dir
 466           )
 467           (\dir -> do setCurrentDirectory formerdir
 468                       maybe (unsetEnv "TMPDIR") (\p -> setEnv "TMPDIR" p True) formerTMP
 469                       rmRecursive dir)
 470           (const job)
 471     where newname name 0 = name
 472           newname name n = name ++ "-" ++ show n
 473           create_directory :: FilePath -> Int -> IO FilePath
 474           create_directory name n
 475               = do createDirectory $ newname name n
 476                    setCurrentDirectory $ newname name n
 477                    getCurrentDirectory
 478                 `catch` (\e -> if isAlreadyExistsError e
 479                                then create_directory name (n+1)
 480                                else throwIO e)
 481
 482 rmRecursive :: FilePath -> IO ()
 483 rmRecursive d =
 484     do isd <- isDirectory <$> getSymbolicLinkStatus d
 485        if not isd
 486           then removeFile d
 487           else when isd $ do conts <- actual_dir_contents
 488                              withCurrentDirectory d $
 489                                mapM_ rmRecursive conts
 490                              removeDirectory d
 491     where actual_dir_contents = -- doesn't include . or ..
 492               do c <- getDirectoryContents d
 493                  return $ filter (/=".") $ filter (/="..") c
 494
 495 withCurrentDirectory :: FilePath -> IO r -> IO r
 496 withCurrentDirectory name m =
 497     bracket
 498         (do cwd <- getCurrentDirectory
 499             when (name /= "") (setCurrentDirectory name)
 500             return cwd)
 501         (\oldwd -> setCurrentDirectory oldwd)
 502         (const m)
 503