packages feed

takahashi (empty) → 0.2.0.0

raw patch · 12 files changed

+1123/−0 lines, 12 filesdep +basedep +free-operationaldep +mtlsetup-changed

Dependencies added: base, free-operational, mtl, reasonable-lens

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2014 Tokiwo Ousaka++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ html/Temp.html view
@@ -0,0 +1,56 @@+<html>+<head>+  <title></title>+  <script type="text/javascript">+    var SlideList = []+    var SlideIndex = 0;+    var Title = "Title";++    function init(){+      SlideList = document.getElementsByName("pages");+      changeSlide(0);+    }++    function changeSlide(index){+      if(0 > index || index >= SlideList.length) return;+      for(i = 0; i < SlideList.length ;i++) {+        if(i == index) {+          SlideList[i].style.display = "table-cell";+          document.title = Title + " - " + (i + 1) + "/" + SlideList.length;+        } else {+          SlideList[i].style.display = "none";+        }+      }+      SlideIndex = index;+    }++    document.onkeydown = function(e){+      if(e.keyCode == 39) changeSlide(SlideIndex + 1);+      if(e.keyCode == 37) changeSlide(SlideIndex - 1);+    }+  </script>+  <style>+    html, body {+      height: 98%;+      width: 99%; +      overflow:hidden;+    }+    h1, h2, h3, ul {+      margin:0px; +    }+    .slide {+      font-size:45pt;+      display:inline-table; +      width:100%; +      height:100%; +    }+  </style>+<head>+<body onload="init()" style="height:100%">+  <div class="slide">++##Presentation++  </div>+</body>+</html>
+ src/Control/Monad/Takahashi.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE GADTs, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Control.Monad.Takahashi +  ( module Control.Monad.Takahashi.Monad+  , takaCont+  , parCont+  , listCont+  , horizonCont+  , verticalCont+  , annotationCont+  , imgCont+  , codeCont+  , titleCont+  ----+  , title+  , taka+  , par+  , list+  , horizon+  , vertical+  , annotation+  , img+  , code+  ----+  , makePage+  ------+  -- from Control.Monad.Takahashi.Slide+  , BlockOption+  , fontColor, bgColor, frameColor, frameStyle+  , SlideOption+  , slideTitle, slideFontSize, titleOption, codeOption+  , contentsOption, annotationOption, blockFontSize+  , defaultSlideOption+  ----+  , Taka(..) +  , buildTakahashi+  , writeSlide+  ----+  , runTakahashi+  , showTakahashi+  , makeSlide +  ----+  , contents+  , central+  ----+  , Contents+  , bindPage+  ------+  -- from Control.Monad.Takahashi.HtmlBuilder+  , DrawType(..)+  ------+  -- from Control.Monad.Takahashi.Util+  , stateSandbox+  ) where+import Control.Lens+import Control.Monad.State++import Control.Monad.Takahashi.Slide+import Control.Monad.Takahashi.Monad+import Control.Monad.Takahashi.HtmlBuilder+import Control.Monad.Takahashi.Util++----+-- Contents++emptyCont :: Contents+emptyCont = Contents $ \_ -> return ()++takaCont :: String -> Contents+takaCont s = Contents $ +  \option -> central (makeContentsStyle option) $ writeHeader1 s++listCont :: [String] -> Contents+listCont xs = Contents $ +  \option -> contents (basicContents option) $ writeList xs++parCont :: String -> Contents+parCont s = Contents $ +  \option -> contents (basicContents option) $ writeParagraph s++imgCont :: DrawType -> String -> Contents+imgCont dt fp = Contents $+  \option -> central (return ()) $ drawPicture dt fp++codeCont :: String -> Contents+codeCont s = Contents $+  \option -> contents (codeContents option) $ writeParagraph s++----++horizonCont :: [Contents] -> Contents+horizonCont cs = Contents $ +  \option -> horizonDiv . map (contents2DivInfo option) $ cs++verticalCont :: [Contents] -> Contents+verticalCont cs = Contents $+  \option -> verticalDiv . map (contents2DivInfo option) $ cs+    +annotationCont :: Contents -> String -> Contents+annotationCont p s = Contents $ \option -> do+    verticalDiv+      [ divInfo+          { divRatio = 11+          , divData = do+              display .= Just Table+              extructHBuilder p option+          }+      , divInfo+          { divData = do+              writeParagraph s+          , divMakeStyle = do+              display .= Just Table+              makeAnnotationStyle option+          }+      ]++twinTopCont :: Contents -> Contents -> Contents+twinTopCont c1 c2 = makeTwinCont verticalDiv 2 1 c1 c2++twinBottomCont :: Contents -> Contents -> Contents+twinBottomCont c1 c2 = makeTwinCont verticalDiv 1 2 c1 c2++twinLeftCont :: Contents -> Contents -> Contents+twinLeftCont c1 c2 = makeTwinCont horizonDiv 2 1 c1 c2++twinRightCont :: Contents -> Contents -> Contents+twinRightCont c1 c2 = makeTwinCont horizonDiv 2 1 c1 c2++titleCont :: String -> String -> Contents+titleCont t s = Contents $ +  \option -> central (makeTitleStyle option) $ do+    writeHeader1 t+    writeParagraph s+  ++----++subTitlePage :: String -> Contents -> Contents+subTitlePage s p = Contents $ \option -> do+  verticalDiv+    [ divInfo+      { divRatio = 10 +      , divData = do+          central (return ()) $ writeHeader2 s+      , divMakeStyle = do+          display .= Just Table+          makeTitleStyle option+      }+    , divInfo+      { divRatio = 45 +      , divData = extructHBuilder p option+      , divMakeStyle = display .= Just Table+      }+    ]++----+-- slides++title :: String -> String -> Taka ()+title t s = get >>= slide . extructHBuilder (titleCont t s)++taka :: String -> Taka ()+taka s = makePage $ takaCont s++list :: [String] -> Taka ()+list xs = makePage $ listCont xs++par :: String -> Taka ()+par s = makePage $ parCont s++horizon :: [Contents] -> Taka ()+horizon ps = makePage $ horizonCont ps++vertical :: [Contents] -> Taka ()+vertical ps = makePage $ verticalCont ps++annotation :: Contents -> String -> Taka ()+annotation p s = makePage $ annotationCont p s++img :: DrawType -> String -> Taka ()+img dt s = makePage $ imgCont dt s++code :: String -> String -> Taka ()+code s c = twinBottom (parCont s) (codeCont c)++twinTop :: Contents -> Contents -> Taka ()+twinTop c1 c2 = makePage $ twinTopCont c1 c2++twinBottom :: Contents -> Contents -> Taka ()+twinBottom c1 c2 = makePage $ twinBottomCont c1 c2++twinLeft :: Contents -> Contents -> Taka ()+twinLeft c1 c2 = makePage $ twinLeftCont c1 c2++twinRight :: Contents -> Contents -> Taka ()+twinRight c1 c2 = makePage $ twinRightCont c1 c2++----+-- helper++makePage :: Contents -> Taka ()+makePage p = do+  s <- use slideTitle+  case s of+    "" -> bindPage p+    _  -> bindPage (subTitlePage s p)++----++contents2DivInfo :: SlideOption -> Contents -> DivInfo Style+contents2DivInfo o f = divInfo { divData = extructHBuilder f o }++basicContents :: SlideOption -> MakeStyle ()+basicContents o = do+  makeContentsStyle o+  setPadding++codeContents :: SlideOption -> MakeStyle ()+codeContents o = do+  makeCodeStyle o+  setPadding++setPadding :: MakeStyle ()+setPadding = do+  margin.paddingTop .= Just (Per 3)+  margin.paddingLeft .= Just (Per 8)++makeTwinCont :: ([DivInfo Style] -> HBuilder ()) +  -> Int -> Int -> Contents -> Contents -> Contents+makeTwinCont builder i1 i2 c1 c2 = Contents $ \option -> do+    builder+      [ divInfo+          { divRatio = i1+          , divData = do+              display .= Just Table+              extructHBuilder c1 option+          }+      , divInfo+          { divRatio = i2+          , divData = do+              display .= Just Table+              extructHBuilder c2 option+          }+      ]
+ src/Control/Monad/Takahashi/HtmlBuilder.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE GADTs, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Control.Monad.Takahashi.HtmlBuilder +  ( HBuilder+  , HBuilderRWS+  , DivDirection+  , buildHtml+  , makeDivs+  , runBuildHtml+  , normalizeDivInfo+  , module Control.Monad.Takahashi.HtmlBuilder.Style+  , module Control.Monad.Takahashi.HtmlBuilder.Monad+  , module Control.Monad.Takahashi.HtmlBuilder.Html+  ) where+import Control.Lens+import Control.Monad.Takahashi.HtmlBuilder.Style+import Control.Monad.Takahashi.HtmlBuilder.Monad+import Control.Monad.Takahashi.HtmlBuilder.Html+import Control.Monad.Takahashi.Util++import Data.List+import Data.Monoid+import Control.Monad.Operational.Simple+import Control.Monad.RWS++----+--to html++type HBuilder a = HtmlBuilder Style a+type HBuilderRWS a = RWS () Html Style a+data DivDirection = DivVertical | DivHorizon deriving (Show, Read, Eq, Ord)++buildHtml :: HBuilder a -> HBuilderRWS a+buildHtml t = interpret advent t+  where+    advent :: HtmlBuilderBase Style x -> HBuilderRWS x+    advent GetHtmlOption = get+    advent (PutHtmlOption o) = put o+    advent (WriteHeader1 str) = tell $ H1 str Emp+    advent (WriteHeader2 str) = tell $ H2 str Emp+    advent (WriteHeader3 str) = tell $ H3 str Emp+    advent (WriteParagraph s) = tell $ P s Emp+    advent (WriteList xs) = tell $ Li xs Emp+    advent (DrawPicture dt fp) = tell $ Img fp (drawType2Style dt) Emp+    advent (VerticalDiv xs) = makeDivs DivVertical $ normalizeDivInfo xs+    advent (HorizonDiv xs) = do+      makeDivs DivHorizon $ normalizeDivInfo xs+      stateSandbox $ do+        float .= Just ClearBoth+        writeStyle <- get+        tell $ Div Nothing Nothing (Just writeStyle) Emp Emp+    advent (WriteHtml h) = tell h++makeDivs :: DivDirection -> [DivInfo Style] -> HBuilderRWS ()+makeDivs dir xs = mapM_ tellMakeDiv xs+  where+    tellMakeDiv :: DivInfo Style -> HBuilderRWS ()+    tellMakeDiv (DivInfo raito makeStyle dat) = do+      stateSandbox $ do+        setStyle raito+        writeStyle <- get+        tell $ Div (Just "block") Nothing (Just . flip execMakeStyle makeStyle $ writeStyle) (runBuildHtml dat) $ Emp++    setStyle :: Int -> HBuilderRWS ()+    setStyle raito = do+      case dir of+        DivVertical -> do+          size .= Size { _height = Just $ Per raito, _width = Just $ Per 100 }+        DivHorizon -> do+          size .= Size { _height = Just $ Per 100, _width = Just $ Per raito }+          float .= Just FloatLeft++runBuildHtml :: HBuilder a -> Html+runBuildHtml t = snd $ execRWS (buildHtml t) () defaultStyle++----+--helper++normalizeDivInfo :: [DivInfo o] -> [DivInfo o]+normalizeDivInfo = map tuple2DivInfo . separatePercentage . map divInfo2Tuple ++separatePercentage :: [(Int, b)] -> [(Int, b)]+separatePercentage xs = let +  fstlst = map (fromIntegral . fst) xs +  sumlst = repeat $ sum fstlst+  perlst = zipWith (/) fstlst sumlst +  in zip (map (floor . (*100)) perlst) $ map snd xs++drawType2Style :: DrawType -> Style+drawType2Style dt = execMakeStyle defaultStyle (drawType2MakeStyle dt) +  where+    drawType2MakeStyle :: DrawType -> MakeStyle ()+    drawType2MakeStyle SimpleDraw = return ()+    drawType2MakeStyle HStretch = size.height .= Just (Per 90)+    drawType2MakeStyle WStretch = size.width .= Just (Per 90)+    drawType2MakeStyle Stretch = do+      size.height .= Just (Per 90)+      size.width .= Just (Per 90)
+ src/Control/Monad/Takahashi/HtmlBuilder/Html.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell #-}+module Control.Monad.Takahashi.HtmlBuilder.Html +  ( Html(..)+  , showHtml+  , showDiv+  ) where+import Control.Monad.Takahashi.HtmlBuilder.Style++import Data.Monoid+import Data.List (intercalate, lines)++data Html +  = H1 String Html+  | H2 String Html+  | H3 String Html+  | Li [String] Html+  | P String Html+  | TT String Html+  | Img String Style Html+  | Div +      (Maybe String) -- Class+      (Maybe String) -- Name+      (Maybe Style)  -- Style+      Html           -- Contents+      Html+  | Emp+  deriving (Show, Read, Eq, Ord)++instance Monoid Html where+  mempty = Emp+  (H1 s h) `mappend` i = H1 s (h `mappend` i)+  (H2 s h) `mappend` i = H2 s (h `mappend` i)+  (H3 s h) `mappend` i = H3 s (h `mappend` i)+  (Li xs h) `mappend` i = Li xs (h `mappend` i)+  (P s h) `mappend` i = P s (h `mappend` i)+  (TT s h) `mappend` i = TT s (h `mappend` i)+  (Img fp s h) `mappend` i = Img fp s (h `mappend` i)+  (Div cls name style con h) `mappend` i = Div cls name style con (h `mappend` i)+  Emp `mappend` i = i++----+-- show++showHtml :: Html -> String+showHtml = intercalate "<br />". lines . showHtml'+  where+    showHtml' :: Html -> String+    showHtml' (H1 s h) = concat ["<h1>", s, "</h1>", showHtml h]+    showHtml' (H2 s h) = concat ["<h2>", s, "</h2>", showHtml h]+    showHtml' (H3 s h) = concat ["<h3>", s, "</h3>", showHtml h]+    showHtml' (Li xs h) = concat ["<ul>", concatMap (\s -> "<li>" ++ s ++ "</li>") xs, "</ul>", showHtml h]+    showHtml' (P s h) = concat ["<p>", s, "</p>", showHtml h]+    showHtml' (TT s h) = concat ["<tt>", s, "</tt>", showHtml h]+    showHtml' img@(Img _ _ h) = concat ["<img ", showImg img ,"/>", showHtml h]+    showHtml' div@(Div _ _ _ s h) = concat ["<div ", showDiv div,">", showHtml s, "</div>", showHtml h]+    showHtml' Emp = ""++showDiv :: Html -> String+showDiv (Div cls name style _ _) = intercalate " " $ filter (/="") [classStr, nameStr, styleStr]+  where+    classStr = maybe "" (\x -> "class=\"" ++ x ++ "\"") cls+    nameStr = maybe "" (\x -> "name=\"" ++ x ++ "\"") name+    styleStr = showStyleStr style+showDiv _ = ""++showImg :: Html -> String+showImg (Img fp style _) = intercalate " " $ filter (/="") ["src=\"" ++ fp ++ "\"", styleStr]+  where+    styleStr = showStyleStr $ Just style++showStyleStr :: Maybe Style -> String+showStyleStr style = maybe "" (\x -> "style=\"" ++ showStyle x ++ "\"") style+
+ src/Control/Monad/Takahashi/HtmlBuilder/Monad.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GADTs, DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+module Control.Monad.Takahashi.HtmlBuilder.Monad where+import Control.Monad.Operational.Simple+import Control.Monad.State.Class(MonadState(..))+import Control.Monad.Takahashi.HtmlBuilder.Style+import Control.Monad.Writer++import Control.Monad.Takahashi.HtmlBuilder.Html++data DrawType = SimpleDraw | HStretch | WStretch | Stretch deriving (Show, Read, Eq, Ord)++data DivInfo o = DivInfo +  { divRatio :: Int+  , divMakeStyle :: MakeStyle ()+  , divData :: HtmlBuilder o ()+  }++divInfo :: DivInfo o+divInfo = DivInfo+  { divRatio = 1+  , divMakeStyle = return ()+  , divData = return ()+  }++data HtmlBuilderBase o a where+  GetHtmlOption :: HtmlBuilderBase o o+  PutHtmlOption :: o -> HtmlBuilderBase o ()+  WriteHeader1 :: String -> HtmlBuilderBase o ()+  WriteHeader2 :: String -> HtmlBuilderBase o ()+  WriteHeader3 :: String -> HtmlBuilderBase o ()+  WriteParagraph :: String -> HtmlBuilderBase o ()+  WriteList :: [String] -> HtmlBuilderBase o ()+  DrawPicture :: DrawType -> String -> HtmlBuilderBase o ()+  VerticalDiv :: [DivInfo o] -> HtmlBuilderBase o ()+  HorizonDiv :: [DivInfo o] -> HtmlBuilderBase o ()+  WriteHtml :: Html -> HtmlBuilderBase o ()++type HtmlBuilder o = Program (HtmlBuilderBase o)++instance MonadState x (HtmlBuilder x) where+  put = putHtmlOption+  get = getHtmlOption++----++divInfo2Tuple :: DivInfo o -> (Int, (MakeStyle (), HtmlBuilder o ()))+divInfo2Tuple di = (divRatio di, (divMakeStyle di, divData di))++tuple2DivInfo :: (Int, (MakeStyle (), HtmlBuilder o ())) -> DivInfo o+tuple2DivInfo (x, (y, z)) = DivInfo { divRatio = x, divMakeStyle = y, divData = z }++----++getHtmlOption :: HtmlBuilder o o+getHtmlOption = singleton GetHtmlOption++putHtmlOption :: o -> HtmlBuilder o ()+putHtmlOption v = singleton $ PutHtmlOption v++writeHeader1 :: String -> HtmlBuilder o ()+writeHeader1 s = singleton $ WriteHeader1 s++writeHeader2 :: String -> HtmlBuilder o ()+writeHeader2 s = singleton $ WriteHeader2 s++writeHeader3 :: String -> HtmlBuilder o ()+writeHeader3 s = singleton $ WriteHeader3 s++writeParagraph :: String -> HtmlBuilder o ()+writeParagraph ss = singleton $ WriteParagraph ss++writeList :: [String] -> HtmlBuilder o ()+writeList ss = singleton $ WriteList ss++drawPicture :: DrawType -> String -> HtmlBuilder o ()+drawPicture t fp = singleton $ DrawPicture t fp++verticalDiv :: [DivInfo o] -> HtmlBuilder o ()+verticalDiv xs = singleton $ VerticalDiv xs++horizonDiv :: [DivInfo o] -> HtmlBuilder o ()+horizonDiv xs = singleton $ HorizonDiv xs++writeHtml :: Html -> HtmlBuilder o ()+writeHtml h = singleton $ WriteHtml h
+ src/Control/Monad/Takahashi/HtmlBuilder/Style.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE TemplateHaskell, RankNTypes #-}+module Control.Monad.Takahashi.HtmlBuilder.Style +  ( FloatOption(..)+  , TextAlign(..)+  , VerticalAlign(..)+  , Display(..)+  , Len(..)+  , Color(..)+  , BorderStyle(..)+  , BoxSizing(..)+  , FontFamily(..)+  , WhiteSpace(..)+  -----+  , Style(..)+  , size, float, display, font, backGround, align, border+  , Size(..)+  , height, width+  , Align(..)+  , textAlign, verticalAlign+  , Font(..)+  , foreColor, fontSize, fontFamily, whiteSpace+  , Margin(..)+  , margin, paddingTop, paddingLeft, paddingRight, paddingBottom+  , marginTop, marginLeft, marginRight, marginBottom+  , Border(..)+  , borderColor, borderWidth, borderStyle, boxSizing +  -----+  , defaultStyle+  , MakeStyle+  , runMakeStyle+  , execMakeStyle+  , showStyle+  , makeStyle+  -----+  , normalizeColor+  , showColor+  ) where+import Control.Lens+import Control.Monad.State+import Numeric+import Data.List(intercalate)++data FloatOption = FloatLeft | ClearBoth deriving (Show, Read, Eq, Ord)+data TextAlign = AlignLeft | AlignCenter | AlignRight deriving (Show, Read, Eq, Ord)+data VerticalAlign = AlignTop | AlignMiddle | AlignBottom deriving (Show, Read, Eq, Ord)+data Display = Table | TableCell | Block | None | InlineTable | InlineBlock deriving (Show, Read, Eq, Ord)+data Len = Per Int | Px Int deriving (Show, Read, Eq, Ord)+data Color = Color Integer Integer Integer deriving (Show, Read, Eq, Ord)+data BorderStyle = BorderNone | BorderSolid | BorderDouble deriving (Show, Read, Eq, Ord)+data BoxSizing = ContentsBox | BorderBox  deriving (Show, Read, Eq, Ord)+data FontFamily = FontName String | Monospace | Selif | SensSelif deriving (Show, Read, Eq, Ord)+data WhiteSpace = Normal | Pre deriving (Show, Read, Eq, Ord)++data Margin = Margin +  { _paddingTop :: Maybe Len+  , _paddingLeft :: Maybe Len+  , _paddingBottom :: Maybe Len+  , _paddingRight :: Maybe Len+  , _marginTop :: Maybe Len+  , _marginLeft :: Maybe Len+  , _marginBottom :: Maybe Len+  , _marginRight :: Maybe Len+  } deriving (Show, Read, Eq, Ord)++data Size = Size +  { _height :: Maybe Len+  , _width :: Maybe Len+  } deriving (Show, Read, Eq, Ord)++data Align = Align+  { _textAlign :: Maybe TextAlign+  , _verticalAlign :: Maybe VerticalAlign+  } deriving (Show, Read, Eq, Ord)++data Font = Font+  { _foreColor :: Maybe Color+  , _fontSize :: Maybe Int+  , _fontFamily :: Maybe [FontFamily]+  , _whiteSpace :: Maybe WhiteSpace+  } deriving (Show, Read, Eq, Ord)++data Border = Border +  { _borderColor :: Maybe Color+  , _borderWidth :: Maybe Int+  , _borderStyle :: Maybe BorderStyle+  , _boxSizing :: Maybe BoxSizing+  } deriving (Show, Read, Eq, Ord)++data Style = Style+  { _size :: Size+  , _float :: Maybe FloatOption+  , _display :: Maybe Display+  , _backGround :: Maybe Color+  , _margin :: Margin+  , _border :: Border+  , _font :: Font+  , _align :: Align+  } deriving (Show, Read, Eq, Ord)++makeLenses ''Margin+makeLenses ''Size+makeLenses ''Align+makeLenses ''Font+makeLenses ''Style+makeLenses ''Border++defaultStyle :: Style+defaultStyle = Style+  { _size = Size+    { _height = Nothing+    , _width = Nothing+    }+  , _align = Align+    { _textAlign = Nothing+    , _verticalAlign = Nothing+    }+  , _font = Font+    { _fontSize = Nothing+    , _foreColor = Nothing+    , _fontFamily = Nothing+    , _whiteSpace = Nothing+    }+  , _margin = Margin+    { _paddingTop = Nothing+    , _paddingLeft = Nothing+    , _paddingBottom  = Nothing+    , _paddingRight  = Nothing+    , _marginTop = Nothing+    , _marginLeft = Nothing+    , _marginBottom  = Nothing+    , _marginRight  = Nothing+    }+  , _border = Border+    { _borderColor = Nothing+    , _borderWidth = Nothing+    , _borderStyle = Nothing+    , _boxSizing = Nothing+    }+  , _float = Nothing+  , _display = Nothing+  , _backGround = Nothing+  }++----++showStyle :: Style -> String+showStyle style = intercalate ";" . filter (/="") $+  [ emaybe (\y -> "height:" ++ showLen y) $ style^.size.height+  , emaybe (\y -> "width:" ++ showLen y) $ style^.size.width+  , emaybe (\y -> "text-align:" ++ showTextAlign y) $ style^.align.textAlign+  , emaybe (\y -> "vertical-align:" ++ showVerticalAlign y) $ style^.align.verticalAlign+  , emaybe showFloat $ _float style+  , emaybe (\y -> "display:" ++ showDisplay y) $ _display style+  , emaybe (\y -> "font-size:" ++ show y ++ "px") $ style^.font.fontSize+  , emaybe (\y -> "color:" ++ showColor y) $ style^.font.foreColor+  , emaybe (\y -> "background:" ++ showColor y) $ _backGround style+  , emaybe (\y -> "padding-top:" ++ showLen y) $ style^.margin.paddingTop+  , emaybe (\y -> "padding-left:" ++ showLen y) $ style^.margin.paddingLeft+  , emaybe (\y -> "padding-right:" ++ showLen y) $ style^.margin.paddingRight+  , emaybe (\y -> "padding-bottom:" ++ showLen y) $ style^.margin.paddingBottom+  , emaybe (\y -> "margin-top:" ++ showLen y) $ style^.margin.marginTop+  , emaybe (\y -> "margin-left:" ++ showLen y) $ style^.margin.marginLeft+  , emaybe (\y -> "margin-right:" ++ showLen y) $ style^.margin.marginRight+  , emaybe (\y -> "margin-bottom:" ++ showLen y) $ style^.margin.marginBottom+  , emaybe (\y -> "border-width:" ++ show y) $ style^.border.borderWidth+  , emaybe (\y -> "border-style:" ++ showBorderStyle y) $ style^.border.borderStyle+  , emaybe (\y -> "border-color:" ++ showColor y) $ style^.border.borderColor+  , emaybe (\y -> "box-sizing:" ++ showBoxSizing y) $ style^.border.boxSizing+  , emaybe (\y -> "font-family:" ++ (intercalate "," $ map showFontFamily y)) $ style^.font.fontFamily+  , emaybe (\y -> "white-space:" ++ showWhiteSpace y) $ style^.font.whiteSpace+  ] +    where+      emaybe = maybe ""     ++      showFloat x+        = case x of+          FloatLeft -> "float:left"+          ClearBoth -> "clear:both"++      showDisplay x+        = case x of+          Table -> "table"+          Block -> "block"+          TableCell -> "table-cell"+          None -> "none;"+          InlineTable -> "inline-table"+          InlineBlock -> "inline-block"++      showBorderStyle x+        = case x of+          BorderNone -> "none"+          BorderSolid -> "solid"+          BorderDouble -> "double"++      showBoxSizing x+        = case x of+          ContentsBox -> "contents-box"+          BorderBox -> "border-box"++      showFontFamily x+        = case x of+          FontName s -> "'" ++ s ++ "'"+          Monospace -> "monospace"+          Selif -> "selif"+          SensSelif -> "sens-selif"++      showWhiteSpace x+        = case x of+          Normal -> "normal"+          Pre -> "pre"++showLen :: Len -> String+showLen (Per x) = show x ++ "%"+showLen (Px x) = show x ++ "px"++----++type MakeStyle a = State Style a++runMakeStyle :: Style -> MakeStyle a -> (a, Style)+runMakeStyle s f = runState f s++execMakeStyle :: Style -> MakeStyle a -> Style+execMakeStyle s f = execState f s++makeStyle :: MakeStyle a -> String+makeStyle f = showStyle . execMakeStyle defaultStyle $ f++----++showTextAlign :: TextAlign -> String+showTextAlign AlignLeft = "left"+showTextAlign AlignCenter = "center"+showTextAlign AlignRight = "right"++showVerticalAlign :: VerticalAlign -> String+showVerticalAlign AlignTop = "top"+showVerticalAlign AlignMiddle = "middle"+showVerticalAlign AlignBottom = "bottom"++----++normalizeColor :: Color -> Color+normalizeColor (Color x y z) = Color (normalize x) (normalize y) (normalize z)+  where+    normalize :: Integer -> Integer+    normalize a +      | a   < 0   = 0+      | 255 < a   = 255+      | otherwise = a++showColor :: Color -> String+showColor (Color x y z) = concat ["#", int2Hex x, int2Hex y, int2Hex z]+  where+    int2Hex :: Integer -> String+    int2Hex i = reverse . take 2 . reverse $ "0" ++ showHex i ""+
+ src/Control/Monad/Takahashi/Monad.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Control.Monad.Takahashi.Monad where+import Control.Monad.Operational.Simple+import Control.Monad.State.Class(MonadState(..))++import Control.Monad.Takahashi.HtmlBuilder++data TakahashiBase o a where+  GetSlideOption :: TakahashiBase o o+  PutSlideOption :: o -> TakahashiBase o ()+  Slide :: HtmlBuilder Style () -> TakahashiBase o ()++type Takahashi o = Program (TakahashiBase o)++instance MonadState x (Takahashi x) where+  put = putSlideOption+  get = getSlideOption++----++getSlideOption :: Takahashi o o+getSlideOption = singleton GetSlideOption++putSlideOption :: o -> Takahashi o ()+putSlideOption v = singleton $ PutSlideOption v++slide :: HtmlBuilder Style () -> Takahashi o ()+slide f = singleton $ Slide f+
+ src/Control/Monad/Takahashi/Slide.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+module Control.Monad.Takahashi.Slide +  ( BlockOption+  , fontColor, bgColor, frameColor, frameStyle+  , SlideOption+  , slideTitle, slideFontSize, titleOption, codeOption+  , contentsOption, annotationOption, blockFontSize+  , defaultSlideOption+  ----+  , Taka(..) +  , buildTakahashi+  , writeSlideWithTemplate+  , writeSlide+  ----+  , runTakahashi+  , showTakahashi+  , makeSlideWithTemplate+  , makeSlide +  , makeTitleStyle+  , makeContentsStyle+  , makeAnnotationStyle+  , makeCodeStyle+  ----+  , contents+  , central+  ----+  , Contents(..)+  , bindPage+  ) where+import Control.Lens+import Control.Monad.RWS+import Data.List+import Paths_takahashi++import Control.Monad.Takahashi.Monad+import Control.Monad.Takahashi.HtmlBuilder+import Control.Monad.Takahashi.Util+import Control.Monad.Operational.Simple++data BlockOption = BlockOption+  { _fontColor :: Maybe Color+  , _bgColor :: Maybe Color+  , _frameColor :: Maybe Color+  , _frameStyle :: Maybe BorderStyle+  , _blockFontSize :: Maybe Int+  } deriving (Show, Read, Eq, Ord)++data SlideOption = SlideOption +  { _slideTitle :: String+  , _slideFontSize :: Maybe Int+  , _titleOption :: BlockOption+  , _contentsOption :: BlockOption+  , _annotationOption :: BlockOption+  , _codeOption :: BlockOption+  } deriving (Show, Read, Eq, Ord)++makeLenses ''BlockOption+makeLenses ''SlideOption++defaultSlideOption :: SlideOption+defaultSlideOption = SlideOption+  { _slideTitle = ""+  , _slideFontSize = Nothing+  , _titleOption = BlockOption+    { _fontColor = Just $ Color 0 0 80+    , _bgColor = Just $ Color 100 100 255+    , _frameColor = Just $ Color 0 0 80+    , _frameStyle = Just BorderSolid+    , _blockFontSize = Nothing+    }+  , _contentsOption = BlockOption+    { _fontColor = Just $ Color 0 0 80+    , _bgColor = Just $ Color 200 200 255+    , _frameColor = Just $ Color 255 255 255+    , _frameStyle = Just BorderSolid+    , _blockFontSize = Nothing+    }+  , _annotationOption = BlockOption+    { _fontColor = Just $ Color 255 0 0+    , _bgColor = Nothing+    , _frameColor = Just $ Color 255 255 255+    , _frameStyle = Nothing+    , _blockFontSize = Nothing+    }+  , _codeOption = BlockOption+    { _fontColor = Just $ Color 0 0 80+    , _bgColor = Nothing+    , _frameColor = Just $ Color 0 0 80+    , _frameStyle = Just BorderDouble+    , _blockFontSize = Nothing+    }+  }++type TakahashiRWS a = RWS () Html SlideOption a++----++type Taka a = Takahashi SlideOption a++buildTakahashi :: Taka a -> TakahashiRWS a+buildTakahashi t = interpret advent t+  where+    advent :: TakahashiBase SlideOption a -> TakahashiRWS a+    advent GetSlideOption = get+    advent (PutSlideOption o) = put o+    advent (Slide t) = do+      style <- mkStyle+      tell $ Div Nothing (Just "pages") (Just style) (runBuildHtml t) Emp++    mkStyle :: TakahashiRWS Style+    mkStyle = do+      option <- get+      return . execMakeStyle defaultStyle $ do+        font.fontSize .= option^.slideFontSize++----++runTakahashi :: Taka a -> Html+runTakahashi t = snd $ execRWS (buildTakahashi t) () defaultSlideOption++showTakahashi :: Taka a -> String+showTakahashi = showHtml . runTakahashi++makeSlideWithTemplate :: String -> Taka a -> IO String+makeSlideWithTemplate r t = do+  instr <- readFile r+  return $ sub "##Presentation" (showTakahashi t) instr++makeSlide :: Taka a -> IO String+makeSlide t = getDataFileName "html/Temp.html" >>= flip makeSlideWithTemplate t++writeSlideWithTemplate :: String -> String -> Taka a -> IO ()+writeSlideWithTemplate r w = makeSlideWithTemplate r >=> writeFile w++writeSlide :: String -> Taka a -> IO ()+writeSlide w = makeSlide >=> writeFile w++------+-- helper +makeTitleStyle :: SlideOption -> MakeStyle ()+makeTitleStyle = makeBlockStyle titleOption++makeContentsStyle :: SlideOption -> MakeStyle ()+makeContentsStyle = makeBlockStyle contentsOption++makeAnnotationStyle :: SlideOption -> MakeStyle ()+makeAnnotationStyle = makeBlockStyle annotationOption++makeCodeStyle :: SlideOption -> MakeStyle ()+makeCodeStyle o = do+  makeBlockStyle codeOption o+  font.fontFamily .= Just [SensSelif, Monospace]+  font.whiteSpace .= Just Pre++makeBlockStyle :: Getter SlideOption BlockOption -> SlideOption -> MakeStyle ()+makeBlockStyle getter option = do+  border.borderStyle .= Just BorderSolid+  border.boxSizing .= Just BorderBox+  border.borderWidth .= Just 10++  border.borderColor .= option^.getter.frameColor+  font.foreColor .= option^.getter.fontColor+  font.fontSize .= option^.getter.blockFontSize+  border.borderStyle .= option^.getter.frameStyle+  backGround .= option^.getter.bgColor++----++contents :: MakeStyle () -> HBuilder () -> HBuilder ()+contents mStyle f = let+  innerDiv = do+      verticalDiv+        [ divInfo+          { divMakeStyle = do+              mStyle+              display .= Just TableCell+          , divData = f+          }+        ]+  in do+    verticalDiv+      [ divInfo+        { divMakeStyle = do+            display .= Just Table+        , divData = innerDiv+        }+      ]++central :: MakeStyle () -> HBuilder () -> HBuilder ()+central mStyle f = let+  newStyle = do+    mStyle+    align.textAlign .= Just AlignCenter+    align.verticalAlign .= Just AlignMiddle+  in contents newStyle f++----++newtype Contents = Contents { extructHBuilder :: SlideOption -> HBuilder () }++bindPage :: Contents -> Taka ()+bindPage p = do+  o <- get+  slide . extructHBuilder p $ o+
+ src/Control/Monad/Takahashi/Util.hs view
@@ -0,0 +1,17 @@+module Control.Monad.Takahashi.Util where+import Control.Monad.State+import Data.List(isPrefixOf)++stateSandbox :: MonadState s m => m a -> m a+stateSandbox f = do+  tmp <- get +  res <- f+  put tmp+  return res++sub :: Eq a => [a] -> [a] -> [a] -> [a]+sub _ _ [] = []+sub x y str@(s:ss)+  | isPrefixOf x str = y ++ drop (length x) str+  | otherwise = s:sub x y ss+
+ takahashi.cabal view
@@ -0,0 +1,32 @@+-- Initial takahashi.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                takahashi+version:             0.2.0.0+synopsis:            library for takahashi method.+description:         create slide as takahashi method.+license:             MIT+license-file:        LICENSE+author:              tokiwoousaka+maintainer:          tokiwoousaka+copyright:           (C) 2014 Tokiwo Ousaka+category:            Control+build-type:          Simple+cabal-version:       >=1.8+data-files:          html/Temp.html++library+  exposed-modules:     Control.Monad.Takahashi, +                       Control.Monad.Takahashi.HtmlBuilder.Html, +                       Control.Monad.Takahashi.HtmlBuilder.Monad, +                       Control.Monad.Takahashi.HtmlBuilder.Style, +                       Control.Monad.Takahashi.HtmlBuilder, +                       Control.Monad.Takahashi.Monad,+                       Control.Monad.Takahashi.Slide,+                       Control.Monad.Takahashi.Util+  other-modules:       Paths_takahashi   +  build-depends:       base >=4.6 && <5, +                       free-operational >=0.5, +                       mtl >=2.1,+                       reasonable-lens >=0.2.1+  hs-source-dirs:      src