diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/html/Temp.html b/html/Temp.html new file mode 100644 --- /dev/null +++ b/html/Temp.html @@ -0,0 +1,56 @@ + + + + + + + +
+ +##Presentation + +
+ + diff --git a/src/Control/Monad/Takahashi.hs b/src/Control/Monad/Takahashi.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Takahashi.hs @@ -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 + } + ] diff --git a/src/Control/Monad/Takahashi/HtmlBuilder.hs b/src/Control/Monad/Takahashi/HtmlBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Takahashi/HtmlBuilder.hs @@ -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) diff --git a/src/Control/Monad/Takahashi/HtmlBuilder/Html.hs b/src/Control/Monad/Takahashi/HtmlBuilder/Html.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Takahashi/HtmlBuilder/Html.hs @@ -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 "
". lines . showHtml' + where + showHtml' :: Html -> String + showHtml' (H1 s h) = concat ["

", s, "

", showHtml h] + showHtml' (H2 s h) = concat ["

", s, "

", showHtml h] + showHtml' (H3 s h) = concat ["

", s, "

", showHtml h] + showHtml' (Li xs h) = concat ["", showHtml h] + showHtml' (P s h) = concat ["

", s, "

", showHtml h] + showHtml' (TT s h) = concat ["", s, "", showHtml h] + showHtml' img@(Img _ _ h) = concat ["", showHtml h] + showHtml' div@(Div _ _ _ s h) = concat ["
", showHtml s, "
", 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 + diff --git a/src/Control/Monad/Takahashi/HtmlBuilder/Monad.hs b/src/Control/Monad/Takahashi/HtmlBuilder/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Takahashi/HtmlBuilder/Monad.hs @@ -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 diff --git a/src/Control/Monad/Takahashi/HtmlBuilder/Style.hs b/src/Control/Monad/Takahashi/HtmlBuilder/Style.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Takahashi/HtmlBuilder/Style.hs @@ -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 "" + diff --git a/src/Control/Monad/Takahashi/Monad.hs b/src/Control/Monad/Takahashi/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Takahashi/Monad.hs @@ -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 + diff --git a/src/Control/Monad/Takahashi/Slide.hs b/src/Control/Monad/Takahashi/Slide.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Takahashi/Slide.hs @@ -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 + diff --git a/src/Control/Monad/Takahashi/Util.hs b/src/Control/Monad/Takahashi/Util.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Takahashi/Util.hs @@ -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 + diff --git a/takahashi.cabal b/takahashi.cabal new file mode 100644 --- /dev/null +++ b/takahashi.cabal @@ -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