module Main where
import PTable
import Synthesis
import Analysis
import Matchings
--import TypesMatching
--import Normalizing
import Prelude hiding (span, div, map)
import System.IO
import WASH.CGI.CGI hiding (head, standardQuery, map)
import Data.Map as Map hiding (empty, map)
import Data.List as List
import Data.Maybe
--import Codec.Serialize.SerTH
import Language.Haskell.Pretty
import Language.Pointfree.Pretty
import Language.Pointfree.Syntax
import Examples (freshTable, example)
standardQuery t b = ask $ cssPage t "../style.css" $ makeForm b
{-
serialize :: PTable -> IO ()
serialize ptable = do
h <- openBinaryFile "db.serialized" WriteMode
s <- handleEncoder h
--putStrLn "Creating encoder ok"
let foo = fromPTable ptable
encodeWith s foo
--putStrLn "Encoder ok"
encodeWith s Flush
--putStrLn "Encoder flush ok"
hClose h
unserialize :: IO PTable
unserialize = do
h <- openBinaryFile "db.serialized" ReadMode
d <- handleDecoder h
x <- decodeWith d
hClose h
return (toPTable x)
-}
--main = unserialize >>= run . indexCGI
main = run $ indexCGI $ either error snd example
--main = run (io (serialize (toPTable ([],([],([],[]))))) >> standardQuery "bla" empty)
errorPage _ s F0 = standardQuery "Error page"
<body>
<h1><%= "Error: " ++ s %></h1>
</body>
indexCGI ex = do
standardQuery "The \"Periodic Table\" of algorithms - select operating mode" (index ex)
index ex =
<div>
<% submit F0 (redirect ex) <[ value="Consult the table"]> %>
<% submit F0 (errorPage ex "this function is disabled") <[ value="Add your own function(s) (DISABLED)"]> %>
</div>
redirect ex F0 = selectFunctCGI ex
{-
upload ex F0 = standardQuery "Add your own functions to the table"
<body>
<h2>Type your code below...</h2>
<p>Note: the code you type must be an entire Haskell module</p>
<% codeIF <- makeTextarea "" <[ rows="20" cols="80" ]> %>
<br />
<% submit codeIF (uploadCheckLCGI ex) <[ value="Add"]> %>
<h2>... or upload from a file in your disk</h2>
<% codeFile <- fileInputField empty %>
<br />
<% submit codeFile (uploadCheckRCGI ex) <[ value="Upload"]> %>
</body>
-- Code from textbox
uploadCheckLCGI ex = standardQuery "Hylofactorization" . (uploadCheck ex . value)
uploadCheckRCGI ex iCode = io (f iCode) >>= (standardQuery "Hylofactorization" . (uploadCheck ex))
where f s = readFile $ fileReferenceName $ value s
ppResult (a,(b,(c,d))) = do
<p>Name <%= show a %></p>
<p>Functor: <%= show b%></p>
<p>Algebra:</p>
<pre class="pf"><%= prettyPrint $ pf2hs c %></pre>
<p>Coalgebra:</p>
<pre class="pf"><%= prettyPrint $ pf2hs d %></pre>
uploadCheck ex codeStr = do
let result = str2hylos codeStr
<h2>Input code:</h2>
<pre class="pw"><%= codeStr %></pre>
<h2>Derived hylofactorizations:</h2>
case result of
Nothing -> <p>Could not parse the input file!</p>
Just result ->
<span>
<p><% foldr (\a b -> a >> <hr /> >> b) empty $ fmap ppResult result %></p>
<% submit F0 (addTableCGI ex result 0) <[ value="Add these functions to the table"]> %>
</span>
addTableCGI ex functions n F0 = standardQuery ("Adding function " ++ (show $ succ n)) (addTable ex functions n)
addTable ex functions n = do
let currFun = succ n
totFun = length functions
(funName,(functor,(a,c))) = functions !! n
<#>
<h2>Adding function <%= show currFun %> of <%= show totFun %></h2>
<p>Name you supplied: <%= funName %></p>
<p>Name as you want it in the table: <% funNameFromUser <- textInputField <[ value=<% funName %> ]> %></p>
<p>A comment on this function: <% funCommFromUser <- textInputField empty %></p>
<hr />
<p>Derived functor: <%= show functor%></p>
<p>Name for this functor: <% functNameFromUser <- textInputField empty %></p>
<p>A comment on this functor: <% functCommFromUser <- textInputField <[ value=<% show functor %> ]> %></p>
<hr />
<p>Algebra:</p>
<pre class="pf"><%= prettyPrint $ pf2hs a %></pre>
<p>Name for this gene: <% aNameFromUser <- textInputField empty %></p>
<p>A comment on this gene: <% aCommFromUser <- textInputField empty %></p>
<hr />
<p>Coalgebra:</p>
<pre class="pf"><%= prettyPrint $ pf2hs c %></pre>
<p>Name for this gene: <% cNameFromUser <- textInputField empty %></p>
<p>A comment on this gene: <% cCommFromUser <- textInputField empty %></p>
<% submit (F8 funNameFromUser funCommFromUser functNameFromUser functCommFromUser aNameFromUser aCommFromUser cNameFromUser cCommFromUser) (reallyAddCGI ex functions n) <[ value="Add"]> %>
</#>
reallyAddCGI ex functions n x = standardQuery "Adding function" (reallyAdd ex functions n x)
-- TODO: Add error checking
reallyAdd ex functions n (F8 ifunNameFU ifunCommFU ifunctNameFU ifunctCommFU iaNameFU iaCommFU icNameFU icCommFU) = do
let
(funNameFU:funCommFU:functNameFU:functCommFU:aNameFU:aCommFU:cNameFU:cCommFU:[]) =
fmap value [ifunNameFU, ifunCommFU, ifunctNameFU, ifunctCommFU, iaNameFU, iaCommFU, icNameFU, icCommFU]
currFun = succ n
totFun = length functions
(funName,(functor,(a,c))) = functions !! n
funMatch = [ f | f <- fmap funct (Map.elems (functors ex)), isJust (match (normalize f) (normalize functor)) ]
functName =
case funMatch of
[] -> functNameFU
(h:_) ->
let aux = Map.assocs (functors ex)
aux2 = List.filter (\(a,(Functor b c)) -> c == h) aux
in if (length aux2 /= 1) then (error "4") else (fst $ head aux2)
ex1 =
case funMatch of
[] -> insertFunctor functName (Functor functCommFU functor) ex
(h:_) -> ex
ex2 = insertAlg aNameFU (Gene aCommFU functName "" a) ex1
ex3 = insertCoAlg cNameFU (Gene cCommFU functName "" c) ex2
ex4 = insertFunction funNameFU (Function funCommFU functName aNameFU cNameFU) ex3
<#>
<p>Function <%= funNameFU %> added to the table!</p>
<% if (funMatch == [])
then empty
else <p>The derived functor for your function already existed in the table, so you can find your genes under the functor <%= functName %>!</p> %>
<% submit F0 (pressToAddCGI ex4 functions (succ n)) <[ value="Continue adding"]> %>
</#>
pressToAddCGI ex functions n F0
| n < length functions = io (serialize ex) >> (standardQuery "Adding function" (addTable ex functions n))
| otherwise = io (serialize ex) >> (standardQuery "Finished adding!" (index ex))
-}
selectFunctCGI ex = standardQuery "Select functor..." (selectFunct ex)
selectFunct ex =
let dispFunct idF = show (functors ex ! idF)
in
<div>
<% funct <- selectSingle dispFunct Nothing (keys $ functors ex) empty %>
<% submit funct (tableFunctCGI ex) <[ value="Choose this functor"]> %>
</div> >>
<script type="text/javascript" src="../wz_tooltip.js"></script>
tableFunctCGI ex = standardQuery "Select genes..." . (tableFunct ex Nothing)
tableFunct ex mac iFunct =
let idFunct = value iFunct
algs = Map.filter ((== idFunct) . gfunctor) (algebras ex)
coalgs = Map.filter ((== idFunct) . gfunctor) (coalgebras ex)
f2comment f x = (\s -> "return escape('" ++ s ++ "')") $ if (aux f x == "") then "No user comment for this gene..." else (aux f x)
where aux f x = either error gcomment (f x ex)
colH a = <span onmouseover=<% f2comment getAlg a %> ><%= a %></span>
header = foldr (>>) empty [<th scope="col"><% colH a %></th> | a <- keys algs]
oldSelection o a c = maybe empty (\(a', c') -> if (a == a' && c == c') then o else empty) mac
oldSelectionColor = \_ _ -> <[]> -- oldSelection <[ bgcolor="red"]> -- use for background color of the last selected function
oldSelectionCheck = oldSelection <[ checked="checked"]>
genCell a c rg = do
let
str "" = "return escape('There\\'s no user comment for this function...')"
str c = "return escape('" ++ c ++ "')"
mIdF = lookupByGenes a c ex
radio = radioButton rg (a, c) (oldSelectionCheck a c)
case mIdF of
Left e -> <span onmouseover=<% str "Unnamed function" %> ><% radio %></span>
Right idF -> either (const radio) (\f -> <span onmouseover=<% str (fcomment f) %> > <% radio >> text (show f) %> </span>) (getFunction idF ex)
contents c rg = foldr (>>) empty [ <td <% oldSelectionColor a c %> ><% genCell a c rg %></td> | a <- keys algs]
rowH c = <span onmouseover=<% f2comment getCoAlg c %> ><%= c %></span>
rows rg = foldr (>>) empty [ <tr><th scope="row"><% rowH c %></th><% contents c rg %></tr> | c <- keys coalgs]
functComment idF = if (aux == "") then "no user comment for this functor" else aux
where aux = either error fccomment (getFunctor idF ex)
in
<#>
<div>
<p>Table for the functor <%= idFunct %> (User comment: <%= functComment idFunct %>)</p>
<!-- Outer table for the string headers -->
<table border="1">
<tr><td/><td align="center">Algebras</td></tr>
<tr><td valign="center">Coalgebras</td><td>
<!-- Inner table with the actual data -->
<table border="2">
<% rg <- radioGroup %>
<tr>
<!-- Header row naming the algebras -->
<td/><% header %>
</tr>
<!-- Rows, first with the name of the coalgebra and then the functions' names -->
<% rows rg %>
</table>
</td></tr>
</table>
<% submit rg (synthCGI iFunct ex) <[ value="Show/synthesize this function"]> %>
</div>
<h2>... or select another functor:</h2>
<% selectFunct ex %>
<h2>... or add your own functions</h2>
<% submit F0 (errorPage ex "this function is disabled") <[ value="Add your own function(s) (DISABLED)"]> %>
</#>
synthCGI iFunct ex = standardQuery "The function in this place is..." . (synth iFunct ex)
synth iFunct ex iGenes =
let (a, c) = value iGenes
idF = combine a c "newF" "" ex
wrapCode s = <pre class="pf"><%= prettyPrint s %></pre>
wrapCode2 idF s =
let f = either error id (getFunction idF ex)
in
<#>
<p>User comment: <%= if (fcomment f == "") then "No user comment for this function" else (fcomment f) %></p>
<p>Code:</p>
<pre class="pf"><%= prettyPrint s %></pre>
</#>
in
case idF of
-- There was already a function, show it
Left idF -> either error (wrapCode2 idF) (expandPWById idF ex)
-- Incompatible genes
Right (Left e) -> <p>Incompatible genes!</p>
-- New function generated
Right (Right newFunct) -> either error wrapCode (expandPW newFunct ex)
>>
<#>
<% submit F0 (generateCGI idF ex a c iFunct) <[ value="Get this function in a module"]> %>
<h2>... select another function:</h2>
<% tableFunct ex (Just (a,c)) iFunct %>
</#>
generateCGI a b c d e F0 = standardQuery "Complete Haskell module" (generate a b c d e)
generate idF ex a c iFunct = do
let
addOn = "module Output where\n\nimport Pointless.Functors\nimport Pointless.Combinators\nimport Pointless.Combinators.Uncurried\nimport Pointless.RecursionPatterns\n\nf = "
code =
case idF of
Left e -> "a" -- maybe (error "5") (prettyPrint . pf2hs) (mkhylo a c ex)
Right idF -> "b" -- either error (prettyPrint . pf2hs) (expandPFById idF ex)
<#>
<pre class="pf"><%= addOn ++ code %></pre>
<% tableFunct ex Nothing iFunct %>
</#>
|
