Slides 0.1.0.0 → 0.1.0.1

raw patch · 3 files changed

+92/−1 lines, 3 files

Files

• Slides.cabal +3/−1
• src/Slides/Internal.hs +36/−0
• src/Slides/Sequencing.hs +53/−0

@@ -1,5 +1,5 @@ name:                Slides
-version:             0.1.0.0
+version:             0.1.0.1
 synopsis:            Generate slides from Haskell code
 description:         Make presentations in Haskell with diagrams
 license:             MIT
@@ -17,6 +17,8 @@ library
   exposed-modules:     Slides.Presentation
                      , Slides.Common
+  other-modules:       Slides.Sequencing
+                     , Slides.Internal
   build-depends:       base >=4.8 && <4.9
                      , diagrams-svg == 1.3.*
                      , colour == 2.3.*

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}
+module Slides.Internal where
+
+import Diagrams (Diagram)
+import Diagrams.Backend.SVG (SVG(..))
+import qualified Diagrams as Diag
+import qualified Diagrams.Backend.SVG as SVG
+import Slides.Common
+
+html :: String -> String -> String
+html tag content = "<" ++ tag ++ ">" ++ content ++ "</" ++ tag ++ ">"
+
+htmlClass :: String -> String -> String -> String
+htmlClass tag cls content = "<" ++ tag ++ " class=\"" ++ cls ++ "\">" ++ content ++ "</" ++ tag ++ ">"
+
+htmlCustom :: String -> String -> String -> String
+htmlCustom tag att content = "<" ++ tag ++ " " ++ att ++ ">" ++ content ++ "</" ++ tag ++ ">"
+
+dropAllButSvg :: String -> String
+dropAllButSvg ('<' : 's' : 'v' : 'g' : rest) = "<svg" ++ rest
+dropAllButSvg (x : xs) = dropAllButSvg xs
+dropAllButSvg _        = error "No <svg> tag"
+
+svgFromDiagram :: Int -> Diagram SVG -> String
+svgFromDiagram h = dropAllButSvg
+                 . show
+                 . Diag.renderDia SVG (SVG.SVGOptions (Diag.mkHeight $ fromIntegral h) Nothing "")
+
+renderLeafContent :: ContentNode -> String
+renderLeafContent (Header h s) = html ("h" ++ show h) s
+renderLeafContent (Text str)   = str
+renderLeafContent (RawSVG width height str) = htmlCustom "svg" (w ++ " " ++ h) str
+    where w = "width=\"" ++ show width ++ "px\""
+          h = "height=\"" ++ show height ++ "px\""
+renderLeafContent Break        = "<br />"
+renderLeafContent (Diagram h d) = svgFromDiagram h d

@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveFunctor #-}
+module Slides.Sequencing where
+
+import Slides.Common
+import Slides.Internal
+
+data StepF a = Step Eagerness a deriving (Functor, Show)
+type Step = StepF String
+
+(<++>) :: Step -> Step -> Step
+(Step _ str1) <++> (Step e str2) = Step e (str1 ++ str2)
+
+mergeSequences :: [[Step]] -> [Step]
+mergeSequences seqs = case seqs of
+    [] -> []
+    (x : xs) -> lists x xs
+    where endStates = scanl1 (<++>) $ map last seqs
+          prepend p = map (p <++>)
+          lists x xs = x ++ concat (zipWith prepend endStates xs)
+
+setStepEagerness :: Eagerness -> Step -> Step
+setStepEagerness e (Step _ str) = Step e str
+
+setEagerness :: Eagerness -> [Step] -> [Step]
+setEagerness _ [] = []
+setEagerness e (s : ss) = setStepEagerness e s : ss
+
+simplify :: [Step] -> [Step]
+simplify [s] = [setStepEagerness Immediate s]
+simplify ss = ss
+
+sequenceContent :: ContentNode -> [Step]
+sequenceContent (UnfoldList eager nodes) =
+    setEagerness eager $ map (fmap (html "ul")) $ mergeSequences sequences
+    where sequences = map (setEagerness Delay . map (fmap (html "li")) . sequenceContent) nodes
+sequenceContent (Sequence eager nodes) =
+    setEagerness eager $ concatMap (setEagerness Delay . sequenceContent) nodes
+sequenceContent (List nodes) =
+    setEagerness Immediate $ map (fmap (html "ul")) $ mergeSequences sequences
+    where sequences = map (simplify . map (fmap (html "li")) . sequenceContent) nodes
+sequenceContent (ConcatList nodes) =
+    setEagerness Immediate $ mergeSequences sequences
+    where sequences = map (simplify . sequenceContent) nodes
+sequenceContent (UnfoldConcatList eager nodes) =
+    setEagerness eager $ mergeSequences sequences
+    where sequences = map (setEagerness Delay . sequenceContent) nodes
+sequenceContent other = [Step Immediate $ renderLeafContent other]
+
+stepsToStrings :: [Step] -> [String]
+stepsToStrings [] = []
+stepsToStrings (Step _ str : Step Delay str2 : ss) = str : stepsToStrings (Step Delay str2 : ss)
+stepsToStrings [Step _ str] = [str]
+stepsToStrings (Step _ _ : ss) = stepsToStrings ss