Document custom functions
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 15 Oct 2008 15:14:21 +0000 (15:14 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Wed, 15 Oct 2008 15:14:21 +0000 (15:14 +0000)
polyfix-cgi.hs

index 932da23..e27c4d4 100644 (file)
@@ -25,61 +25,6 @@ import System.Random (randomRIO)
 import Data.Maybe
 import Text.PrettyPrint.HughesPJ (render)
 
-main = runCGI (handleErrors cgiMain)
-
-cgiMain = do
-       setHeader "Content-type" "text/xml; charset=UTF-8"
-       
-       mTypeStr <- getInput "type"
-
-       
-       let content = case mTypeStr of 
-               Nothing      -> askTypeForm
-                Just typeStr -> case parseType' typeStr of
-                       Left err  -> typeError typeStr err
-                       Right typ -> generateResult typeStr typ
-       
-       outputFPS $ fromString $ showHtml $
-              header (
-               thetitle << "PolyFix" +++
-               style ! [ thetype "text/css" ] << cdata cssStyle
-              ) +++
-              body ( form ! [method "POST", action "#"] << (
-               thediv ! [theclass "top"] << (
-                       thespan ! [theclass "title"] << "PolyFix" +++
-                       thespan ! [theclass "subtitle"] << "Counter Examples for Free Theorems"
-               ) +++
-               content +++
-               maindiv ( p << ("© 2008 Daniel Seidel und Joachim Breitner <" +++
-                             hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
-                             ">")
-                       )       
-               ))
-
-maindiv = thediv ! [theclass "main"]
-
-cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
-
-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; }"
-        ]
-
 askDiv v e =  maindiv << (
        p << ( "Please enter a function type, prepended with a list of type variables, " +++
               "whose relations should be allowed to be nonstrict, and a single dot.") +++            p << ( input ! [name "type", value v] +++ " " +++
@@ -138,3 +83,76 @@ generateResult typeStr typ = askDiv typeStr noHtml +++
        ft_simple = freeTheorem typ
         counter_example = getComplete' typ
        
+main = runCGI (handleErrors cgiMain)
+
+cgiMain = do
+       setHeader "Content-type" "text/xml; charset=UTF-8"
+       
+       mTypeStr <- getInput "type"
+
+       
+       let content = case mTypeStr of 
+               Nothing      -> askTypeForm
+                Just typeStr -> case parseType' typeStr of
+                       Left err  -> typeError typeStr err
+                       Right typ -> generateResult typeStr typ
+       
+       outputFPS $ fromString $ showHtml $
+              header (
+               thetitle << "PolyFix" +++
+               style ! [ thetype "text/css" ] << cdata cssStyle
+              ) +++
+              body ( form ! [method "POST", action "#"] << (
+               thediv ! [theclass "top"] << (
+                       thespan ! [theclass "title"] << "PolyFix" +++
+                       thespan ! [theclass "subtitle"] << "Counter Examples for Free Theorems"
+               ) +++
+               content +++
+               maindiv ( p << ("In the simplified theorems, the following custom haskell functions might appear:") +++
+                         pre << addDefs ) +++
+               maindiv ( p << ("© 2008 Daniel Seidel und Joachim Breitner <" +++
+                             hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
+                             ">")
+                       )       
+               ))
+
+maindiv = thediv ! [theclass "main"]
+
+cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
+
+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; }"
+        ]
+
+addDefs = unlines 
+       [ "allZipWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool"
+       , "allZipWith p [] [] = True"
+       , "allZipWith p [] _  = False"
+       , "allZipWith p _  [] = False"
+       , "allZipWith p (x:xs) (y:ys) = p x y && allZipWith p xs ys"
+       , ""
+       , "eitherMap :: (a -> b) -> (c -> d) -> Either a c -> Either b d"
+       , "eitherMap f1 f2 (Left v)  = Left (f1 v)"
+       , "eitherMap f1 f2 (Right v) = Right (f2 v)"
+       , ""
+       , "andEither :: (a -> b -> Bool) -> (c -> d -> Bool) -> Either a c -> Bool"
+       , "andEither p1 p2 (Left v1)  (Left v2)  = p1 v1 v2"
+       , "andEither p1 p2 (Right v1) (Right v2) = p2 v1 v2"
+       , "andEither _  _  _          _          = False"
+       ]