provenience-0.1.0.2: example/euclidean.hs
{-# LANGUAGE Rank2Types, CPP #-}
{-- The ProvenienceT monad transformer in action
in form of the Euclidean Algorithm --}
import Control.Provenience
import Control.Monad.Trans (lift)
import Control.Monad.State.Strict
import System.IO (readLn)
import Text.Pandoc
import qualified Data.Text.IO as T
import Data.Text (pack)
import Data.Default
main = do
(store,_) <- execProvenienceT workflow 0
putStr "Enter the filename for the html document\n> "
writeDocumentation store =<< getLine
-- finds the greatest common divisor of two numbers
workflow :: ProvenienceT () IO Integer
workflow = do
lift (putStr "Enter the first integer\n> ")
x <- inputM readLn
lift (putStr "Enter the second integer\n> ")
y <- inputM readLn
x `named` "x0" >> y `named` "y0"
x <? varSym 'x' 0
y <? varSym 'y' 0
hoist (euclideanAlgorithm x y)
-- | The actual Euclidean algorithm.
-- The 'State' 'Int' counts the number of steps
euclideanAlgorithm :: Variable Integer -> Variable Integer ->
ProvenienceT () (State Int) Integer
euclideanAlgorithm x y = if value x == value y
then do
why <- desc_result x y
-- make result depend on x and y
result <- func (const (const (value x))) why <%> x <%> y
result `named` "result"
render result
return result
else do
i <- lift get -- which step is this?
lift (put (i+1))
xi <- (func updateX =<< (descX x y)) <%> x <%> y
yi <- (func updateY =<< (descY x y)) <%> x <%> y
xi `named` ("x"++(show i))
yi `named` ("y"++(show i))
xi <? varSym 'x' i
yi <? varSym 'y' i
render xi >> render yi
euclideanAlgorithm xi yi
-- | updates the x-component
updateX :: Integer -> Integer -> Integer
updateX x y = if x > y then x-y else x
-- | updates the y-component
updateY :: Integer -> Integer -> Integer
updateY x y = if y > x then y-x else y
-- | transform the state component of 'euclideanAlgorithm' into something else
hoist :: Monad m => ProvenienceT alt (State Int) a -> ProvenienceT alt m a
hoist (StateT f) = StateT (return . flip evalState 1 . f)
-- * Pandoc helpers
#if MIN_VERSION_pandoc(2,8,0)
-- pandoc-types >= 1.20 has Str Text instead of Str String
str = Str.pack
#else
str = Str
#endif
-- | write the store as html5
writeDocumentation :: VariableStore alt -> FilePath -> IO ()
writeDocumentation store fpath = T.writeFile fpath html where
depgraph = renderStore def store
html = either (error.show) id $
runPure $
writeHtml5String myWriterOpts (makeDocument depgraph)
-- | embed the store rendering into a whole document
makeDocument :: Block -> Pandoc
makeDocument body = Pandoc nullMeta [Header 1 nullAttr [str "The Euclidean algorithm"],body]
myWriterOpts :: WriterOptions
myWriterOpts = def {
writerTemplate = Just provenienceTemplate,
writerVariables = [("title","The Euclidean algorithm"),("copyright","Lackmann Phymetric")]
}
-- | Pandoc Template for Html output
provenienceTemplate :: String
provenienceTemplate = unlines [
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"",
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">",
"<html xmlns=\"http://www.w3.org/1999/xhtml\">",
"<head>",
"<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\"/>",
"<title>$title$</title>",
"<meta name=\"copyright\" content=\"$copyright$\"/>",
"<style type=\"text/css\">",
"table {",
" border-collapse: collapse;",
"}",
"table, th, td {",
" border: 1px solid black;",
"}",
"div.variable{",
" margin-left: 40px;",
" border: 2px solid;",
" padding: 10px 40px;",
" width: 900px;",
" border-radius: 25px;",
"}",
"div.shortname{font-weight:bold; color:OliveDrab;}",
"a.incoming {color:Tomato;}",
"a.outgoing {color:DodgerBlue;}",
"div.valueRendering {background-color:#ebebe0;}",
"p.provenienceHeader {font-weight:bold;}",
"div.provenienceKeyword {font-weight:bold;}",
"</style>",
"</head><body>",
"$body$",
"</body></html>"]
-- * Description generators
-- perform some store lookups and return a 'Block'
type Description = forall m alt. Monad m => StateT (VariableStore alt) m Block
-- | helper function that renders Variable names with subscripts
varSym :: Char -> Int -> Block
varSym x i = Para [str [x],Subscript [str (show i)]]
-- | generates appropriate description of the new x value
descX :: Variable Integer -> Variable Integer -> Description
descX x y = do
link_x <- linkto x
link_y <- linkto y
return $ Para $ if (value x) > (value y)
then [
str "The value of ",
link_x,
str " is larger than the value of ",
link_y,
str " therefore we compute ",
link_x,
str " minus ",
link_y]
else [
str "The value of ",
link_x,
str " is not larger than the value of ",
link_y,
str " therefore the value remains the same."]
-- | generates appropriate description of the new y value
descY :: Variable Integer -> Variable Integer -> Description
descY x y = do
link_x <- linkto x
link_y <- linkto y
return $ Para $ if (value y) > (value x)
then [
str "The value of ",
link_y,
str " is larger than the value of ",
link_x,
str " therefore we compute ",
link_y,
str " minus ",
link_x]
else [
str "The value of ",
link_y,
str " is not larger than the value of ",
link_x,
str " therefore the value remains the same."]
-- | explain that this is the final result
desc_result :: Variable Integer -> Variable Integer -> Description
desc_result x y = do
link_x <- linkto x
link_y <- linkto y
return $ Para [
str "The values of ",
link_x,
str " and ",
link_y,
str " are equal, the algorithm terminates."]