module Language.Haskell.ER.Interact (interactWithEquation) where
{-
import Control.Concurrent.MVar
import Control.Monad
import Data.Maybe
import Debug.Trace
import Equation.Data.Queue
import Equation.HughesList
import Equation.ImpList
import Equation.Iterator
import Language.Haskell.ER.Base
import Language.Haskell.ER.Equation
import Language.Haskell.ER.QuickCheck
import Language.Haskell.ER.Rewrite
import Language.Haskell.ER.Syntax
import Language.Haskell.ER.Utils
import Language.Haskell.TH hiding (pprint)
import Language.Haskell.TH.Syntax
import MyRewrites
import Program.Data.Queue
import Program.GHC.Base
import Program.HughesList
import Program.ImpList
import Program.Iterator
import Program.Prelude
import Program.PreludeList
import System.Environment
import System.Random
import Test.QuickCheck
import qualified Data.Set as Set
import qualified Language.Haskell.ER.MiscRewrite
import qualified MyRewrites
-}
import Control.Concurrent
import Control.Exception as Exc
import Data.Char
import Data.List
import Data.Tree
import Language.Haskell.ER.BaseRewrite
import Language.Haskell.ER.Dictionary
import Language.Haskell.ER.HaskellRewrite
import Language.Haskell.ER.Ppr
import Language.Haskell.ER.Subst
import Network.TrivialWebServer
import Text.Html
parsePath :: (Read a) => [Char] -> [a]
parsePath [] = []
parsePath xs = case span isDigit xs of
(before,',':after) -> read before : parsePath after
(before,[]) -> [read before]
_ -> error $ "bad path"
{-
b :: Int
b = 1
data EngineAction
= Transform Int -- ^which page# to translate
Path -- ^which path
SubstOrder -- ^which strategy
String -- ^which dictionary entry to apply
| TransResult Int -- ^which page#
| SpeculateWith
Int --
-}
sendCodeToBrowser :: (Language.Haskell.ER.Ppr.Ppr a, Num a1) => a1 -> a
-> [Tree (Path, RewriteInfo)]
-> (Bool -> [Char] -> [Char] -> t)
-> t
sendCodeToBrowser iteration code infos resp = resp False "text/html" txt
where
txt = " " ++
"\n" ++
pprintHtml code ++
"" ++
"
" ++
"Rewrites performed:
\n" ++
show (showInfoInHtml infos) ++
"
" ++
"Debugging info:
" ++
-- "" ++ fullurl ++ "
" ++
-- "" ++ info ++ "
" ++
"" ++
"" ++
"" ++
"\n"
data ReactiveTranslator = ReactiveTranslator
{ sendTranslationRequest :: Int -> SubstOrder -> String -> Response -> IO ()
, sendSpeculationRequest :: Int -> Path -> Response -> IO ()
}
-- , sendOracleEnquiry ::
data ReactionTransAction
= Restart Response -- ^ just display the start state
| TranslationRequest Int SubstOrder String Response
| SpeculationRequest Int Path Response
newReactiveTranslator
:: ( Show exp
, Language.Haskell.ER.Ppr.Ppr exp
, Equationable exp
) => Dictionary
-> [Dec]
-> HaskellRewrite exp -> IO ReactiveTranslator
newReactiveTranslator dictionary decs equation = do
chan <- newChan
let doRewrite eqs = do
action <- readChan chan
case action of
Restart resp -> do
let eq = eqs !! 0
let code = rhs eq
sendCodeToBrowser (0::Int) code [] resp
doRewrite [eq,eq]
-- This includes the back button functionality
TranslationRequest iteration theStrategy dict_path resp -> do
let eq = eqs !! iteration
let code = rhs eq
(code',info) <- runQ $ performRewrite decs
(dictionary,dict_path)
(code,theStrategy)
sendCodeToBrowser iteration code' info resp
let gather (Node (path,RewriteInfo rr) rest)
= Evidence path rr
: concatMap gather rest
gather _ = []
let ex' = concatMap gather info
let eq' = eq { rhs = code'
, evidence = case evidence eq of
Nothing -> Nothing
Just ex -> Just (ex ++ ex')
}
appendFile "workingequations" $
"\n\n" ++ take 78 (repeat '-') ++ "\n\n" ++
(showHaskellRewrite "working" $ eq')
doRewrite (take (iteration + 1) eqs ++ [eq'])
SpeculationRequest i path resp -> do
-- putStrLn "---[code for consideration]---"
-- putStrLn (pprint (rhs (eqs !! i)))
-- putStrLn "---[end code]---"
sub_dict <- runQ $ filterDictionary decs path (rhs (eqs !! i)) dictionary
resp False "text/html" $ renderDictionary sub_dict
doRewrite eqs
let sendTranslationRequest 0 _ _ response =
writeChan chan $ Restart response
sendTranslationRequest i strat dict_path response = do
writeChan chan $ TranslationRequest i strat dict_path response
sendSpeculationRequest i path response =
writeChan chan $ SpeculationRequest i path response
forkIO $ (doRewrite [equation]) `Exc.catch` (\ e -> print e)
return $ ReactiveTranslator sendTranslationRequest
sendSpeculationRequest
-- |
-- This starts a ajax session that lets you take the right hand side of
-- equation, and apply rewrite rules to in interactively.
interactWithEquation :: (Show exp,Language.Haskell.ER.Ppr.Ppr exp,Equationable exp)
=> [ UniHaskellRewrite ]
-> [ Dec ]
-> HaskellRewrite exp
-> IO ()
interactWithEquation rewrites decs equation = do
{- let code = rhs equation
chan <- newChan
let rewrites = concat [ Language.Haskell.ER.HaskellRewrite.dictionary
, Language.Haskell.ER.MiscRewrite.dictionary
, Equation.ImpList.dictionary
, Equation.Iterator.dictionary
, Equation.HughesList.dictionary
, MyRewrites.dictionary
]
let decs = concatMap (\ (Code xs) -> xs)
[ Program.ImpList.defns
, Program.Iterator.defns
, Program.PreludeList.defns
, Program.HughesList.defns
, Program.Prelude.defns
, Program.GHC.Base.defns
]
-}
print decs
let dictionary = generateDictionary rewrites
reactTrans <- newReactiveTranslator dictionary decs equation
server 8 8091 $ \ url args send -> do
let file t = do txt <- readFile ("../ajaxgui/filesystem/" ++ tail url)
send True t $ txt
translateCodeHtml = do
let iteration
= case lookup "n" args of
Nothing -> error "no code number!"
Just n' -> let n = read n' in n
let exp_path = case lookup "p" args of
Nothing -> []
Just [] -> []
Just p -> drop 2 $ parsePath p
let strategyNames = [ ("here", Here)
, ("prefix", Prefix False)
, ("postfix", Postfix)
]
let order =
case lookup "s" args of
Just s -> case lookup s strategyNames of
Just st -> st
Nothing -> error $ "bad strategy: " ++ s
Nothing -> Here
addThePath [] = order
addThePath (x:xs) = Path x $ addThePath xs
theStrategy = addThePath exp_path
-- print $ theStrategy
let dict_path =
case lookup "t" args of
Nothing -> error "no path!"
Just path -> path
sendTranslationRequest reactTrans iteration theStrategy dict_path send
speculateCodeHtml = do
let iteration
= case lookup "n" args of
Nothing -> error "no code number!"
Just n' -> let n = read n' in n
let exp_path = case lookup "p" args of
Nothing -> []
Just [] -> []
Just p -> drop 2 $ parsePath p
sendSpeculationRequest reactTrans iteration exp_path send
let dictHtml = renderDictionary dictionary
print url
case url of
"/code.html" -> translateCodeHtml
"/oracle.html" ->speculateCodeHtml
"/dictionary.html" -> send True "text/html" dictHtml
_ | ".gif" `isSuffixOf` url -> file "image/gif"
_ | ".html" `isSuffixOf` url -> file "text/html"
"/favicon.ico" -> send True "text/html" ""
"/hack.css" -> file "text/css"
"/hack.js" -> file "text/js"
"/dictionary.js" -> file "text/js"
"/photo3.jpg" -> file "image/jpeg"
"/header.js" -> file "text/js"
------------------------------------------------------------------------------
--main = interactWithEquation working_sort4
--main = interactWithEquation working_reverse
--main = interactWithEquation filterExample
------------------------------------------------------------------------------
renderDictionary :: Dictionary -> String
renderDictionary dictionary = dictHtml
where dictHtml = renderHtml ((header << thelink ! [ rel "stylesheet"
, href "/hack.css"
, thetype "text/css"
] << noHtml) +++
(body << (dictToHtml $ dictionary)
+++ tag "script" ! [ thetype "text/javascript"
, src "/dictionary.js"
] << noHtml))
------------------------------------------------------------------------------