yeamer 0.1.0.3 → 0.1.0.4
raw patch · 4 files changed
+43/−19 lines, 4 files
Files
- Presentation/Yeamer.hs +42/−13
- demo/Main.hs +0/−3
- test/Main.hs +0/−2
- yeamer.cabal +1/−1
Presentation/Yeamer.hs view
@@ -24,6 +24,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE Rank2Types #-} module Presentation.Yeamer ( Presentation -- * Running a presentation@@ -40,8 +41,10 @@ , verbatim, plaintext, verbatimWithin -- * Structure / composition , addHeading, (======), discardResult+ , module Data.Monoid+ , module Data.Semigroup.Numbered -- * CSS- , divClass, spanClass, (#%), styling+ , divClass, divClasses, spanClass, (#%), styling, Css -- * Server configuration , yeamer' , YeamerServerConfig@@ -140,11 +143,19 @@ instance (Flat a) => Flat (Identity a) #endif +type Sessionable = Flat++data SessionableWitness a where+ SessionableWitness :: Sessionable a => SessionableWitness a+data EncapsulableWitness t where+ EncapsulableWitness :: (∀ r . Sessionable r => SessionableWitness (t r))+ -> EncapsulableWitness t+ data Container t where WithHeading :: Html -> Container Identity ManualCSSClasses :: Container (WriterT HTMChunkK []) GriddedBlocks :: Container Gridded- CustomEncapsulation :: (t Html -> Html) -> Container t+ CustomEncapsulation :: EncapsulableWitness t -> (t Html -> Html) -> Container t data HTMChunkK = HTMDiv {_hchunkCSSClass::Text} | HTMSpan {_hchunkCSSClass::Text} deriving (Generic, Eq, Ord)@@ -153,8 +164,6 @@ instance Flat HTMChunkK makeLenses ''HTMChunkK -type Sessionable = Flat- data IPresentation m r where StaticContent :: Html -> IPresentation m () Resultless :: IPresentation m r -> IPresentation m ()@@ -202,8 +211,8 @@ preprocPres (Styling s p) = Styling s $ preprocPres p preprocPres (Encaps (WithHeading h) p) = Encaps (WithHeading h) $ preprocPres<$>p preprocPres (Encaps ManualCSSClasses p) = Encaps ManualCSSClasses $ preprocPres<$>p-preprocPres (Encaps (CustomEncapsulation f) p)- = Encaps (CustomEncapsulation f) $ preprocPres<$>p+preprocPres (Encaps (CustomEncapsulation (EncapsulableWitness w) f) p)+ = Encaps (CustomEncapsulation (EncapsulableWitness w) f) $ preprocPres<$>p preprocPres (Encaps GriddedBlocks p) = Styling grids . divClass gridClass@@ -388,12 +397,13 @@ go lvl (Encaps (WithHeading h) conts) = let lvl' = min 6 $ lvl + 1 hh = [HTM.h1, HTM.h2, HTM.h3, HTM.h4, HTM.h5, HTM.h6]!!lvl- in go lvl' $ Encaps (CustomEncapsulation $ \(Identity contsr)+ in go lvl' $ Encaps (CustomEncapsulation (EncapsulableWitness SessionableWitness)+ $ \(Identity contsr) -> HTM.div HTM.! HTM.class_ "headed-container" $ hh h <> contsr ) conts go lvl (Encaps ManualCSSClasses conts)- = go lvl $ Encaps (CustomEncapsulation $ \(WriterT contsrs)+ = go lvl $ Encaps (CustomEncapsulation (EncapsulableWitness SessionableWitness) $ \(WriterT contsrs) -> foldMap (\(q,i) -> case i of HTMDiv c -> [hamlet| <div class=#{withSupclass c}> #{q} |]() HTMSpan c -> [hamlet| <span class=#{withSupclass c}> #{q} |]())@@ -403,7 +413,7 @@ | Just _ <- Txt.stripPrefix "autogrid_" c = "autogrid "<>c | otherwise = c- go lvl (Encaps (CustomEncapsulation f) conts) = f $ go lvl <$> conts+ go lvl (Encaps (CustomEncapsulation (EncapsulableWitness _) f) conts) = f $ go lvl <$> conts go _ p = error $ outerConstructorName p <> " cannot be rendered." @@ -468,7 +478,7 @@ outerConstructorName (Resultless _) = "Resultless" outerConstructorName (Styling _ _) = "Styling" outerConstructorName (Encaps (WithHeading _) _) = "Encaps WithHeading"-outerConstructorName (Encaps (CustomEncapsulation _) _) = "Encaps CustomEncapsulation"+outerConstructorName (Encaps (CustomEncapsulation _ _) _) = "Encaps CustomEncapsulation" outerConstructorName (Encaps ManualCSSClasses _) = "Encaps ManualCSSClasses" outerConstructorName (Encaps GriddedBlocks _) = "Encaps GriddedBlocks" outerConstructorName (Pure _) = "Pure"@@ -494,7 +504,7 @@ f <*> Pure x = fmap ($ x) f fs<*>xs = ap fs xs -instance Monad (IPresentation m) where+instance ∀ m . Monad (IPresentation m) where return = pure StaticContent c >>= f = Dependent (StaticContent c) f Resultless p >>= f = Dependent (Resultless p) f@@ -511,6 +521,19 @@ Styling s (Dependent p g) >>= f = Dependent (Styling s p) $ Styling s . g >=> f Encaps (WithHeading h) p >>= f = Dependent (Encaps (WithHeading h) p) f Encaps ManualCSSClasses ps >>= f = Dependent (Encaps ManualCSSClasses ps) f+ Encaps (CustomEncapsulation (EncapsulableWitness w') e') ps' >>= f'+ = bindCustEncaps w' e' ps' f'+ where bindCustEncaps :: ∀ a b t r+ . (Sessionable r, Traversable t, Sessionable (t ()))+ => (∀ r' . Sessionable r' => SessionableWitness (t r'))+ -> (t Html -> Html)+ -> t (IPresentation m r)+ -> (t r -> IPresentation m b)+ -> IPresentation m b+ bindCustEncaps w e ps f+ = case w :: SessionableWitness (t r) of+ SessionableWitness+ -> Dependent (Encaps (CustomEncapsulation (EncapsulableWitness w) e) ps) f Pure x >>= f = f x Deterministic g p >>= f = p >>= f . g Interactive p q >>= f = Dependent (Interactive p q) f@@ -537,6 +560,11 @@ spanClass cn = fmap (fst . head . runWriterT) . Encaps ManualCSSClasses . WriterT . pure . (,HTMSpan cn) +divClasses :: Sessionable r => [(Text, IPresentation m r)] -> IPresentation m r+divClasses cns = fmap (fst . head . runWriterT)+ . Encaps ManualCSSClasses $ WriterT [ (content,HTMDiv cn)+ | (cn,content) <- cns ]+ infix 8 #% -- | Assign this content a CSS class attribute. If the content is inline, this will -- be a @<span>@, else a @<div>@.@@ -554,7 +582,8 @@ tweakContent :: Sessionable r => (Html -> Html) -> IPresentation m r -> IPresentation m r tweakContent f = fmap runIdentity- . Encaps (CustomEncapsulation $ f . runIdentity)+ . Encaps (CustomEncapsulation (EncapsulableWitness SessionableWitness)+ $ f . runIdentity) . Identity infixr 6 $<>@@ -730,7 +759,7 @@ . Just <$> liftIO q go crumbs path (Encaps (WithHeading _) (Identity cont)) = (,True) . fmap Identity . fst <$> go crumbs path cont- go crumbs path (Encaps (CustomEncapsulation _) cont)+ go crumbs path (Encaps (CustomEncapsulation _ _) cont) = (,True) . sequence <$> traverse (\c -> fst <$> go crumbs path c) cont go (crumbh,choiceName,crumbp) [] (Encaps ManualCSSClasses (WriterT conts))
demo/Main.hs view
@@ -6,9 +6,6 @@ import Text.Cassius -import Data.Semigroup-import Data.Semigroup.Numbered- import qualified Diagrams.Prelude as Dia import qualified Diagrams.Backend.Cairo as Dia
test/Main.hs view
@@ -8,8 +8,6 @@ import Text.Hamlet import Data.Foldable-import Data.Semigroup-import Data.Semigroup.Numbered import Data.String (fromString) import Data.Function (fix)
yeamer.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yeamer-version: 0.1.0.3+version: 0.1.0.4 synopsis: Yesod-based server for interactive presentation slides -- description: homepage: https://github.com/leftaroundabout/yeamer