lucid-extras 0.1.0.1 → 0.2

raw patch · 4 files changed

+185/−47 lines, 4 filesdep ~aesondep ~basedep ~blaze-buildernew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, base, blaze-builder, bytestring, lucid, text

API changes (from Hackage documentation)

Files

• lib/Lucid/Rdash.hs +2/−1
• lib/Lucid/Tables.hs +92/−0
• lib/Lucid/VegaLite.hs +41/−0
• lucid-extras.cabal +50/−46

@@ -27,6 +27,7 @@   , SidebarItem(..)   ) where +import Control.Applicative ((<$>)) import qualified Data.Text as T import Data.List @@ -34,7 +35,7 @@  import Lucid hiding (toHtml) import qualified Lucid (toHtml)-import Data.Monoid ((<>))+import Data.Monoid ((<>), mempty)  toHtml :: Monad m => T.Text -> HtmlT m () toHtml = Lucid.toHtml

@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules,FlexibleInstances #-}
+{-# LANGUAGE DefaultSignatures,FlexibleContexts,TypeApplications,TypeOperators #-}
+{-# LANGUAGE InstanceSigs, TypeSynonymInstances,ScopedTypeVariables, DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveGeneric, DefaultSignatures,
+             PolyKinds, TypeOperators, ScopedTypeVariables, FlexibleContexts,
+             FlexibleInstances, UndecidableInstances,
+             OverloadedStrings, TypeApplications, StandaloneDeriving #-}
+
+module Lucid.Tables where
+
+import Lucid
+import Data.Proxy
+import qualified Data.Text as T
+import GHC.Generics
+import Data.Monoid
+
+class ToHtmlTable a where
+  headers:: Proxy a->[T.Text]
+  
+  default headers:: (Generic a,TableSelectors (Rep a)) => Proxy a -> [T.Text]
+  headers  = map (T.pack) . tableSelectors 
+  
+  toHtmlRow:: Monad m => a ->[HtmlT m ()]
+  default toHtmlRow:: (Monad m, Generic a, GToTable (Rep a)) => a -> [HtmlT m ()]
+  toHtmlRow a = gtoHtmlRow (from a)
+
+
+class GToTable f where
+  gtoHtmlRow:: Monad m => f a ->[HtmlT m ()]
+  
+instance GToTable U1 where
+  gtoHtmlRow U1 = []
+
+instance GToTable a => GToTable  (M1 C c a) where
+
+  gtoHtmlRow =gtoHtmlRow . unM1
+
+
+instance GToTable a => GToTable (M1 D c a) where
+
+  gtoHtmlRow =gtoHtmlRow . unM1
+
+instance (GToTable a, GToTable b) => GToTable (a :*: b) where
+  gtoHtmlRow (a :*: b) =  (gtoHtmlRow a) <> (gtoHtmlRow b)
+  
+instance (Selector d, ToHtml a) => GToTable (M1 S d (K1 R a)) where
+
+  gtoHtmlRow (M1 (K1 x)) =[toHtml x ]
+  
+-- https://hackage.haskell.org/package/hpack-0.15.0/src/src/Hpack/GenericsUtil.hs
+-- Copyright (c) 2014-2016 Simon Hengel <sol@typeful.net>
+
+tableSelectors :: (TableSelectors (Rep a)) => Proxy a -> [String]
+tableSelectors = f
+  where
+    f :: forall a. (TableSelectors (Rep a)) => Proxy a -> [String]
+    f _ = selNames (Proxy :: Proxy (Rep a))
+  
+class TableSelectors a where
+  selNames :: Proxy a -> [String]
+
+instance TableSelectors f => TableSelectors (M1 D x f) where
+  selNames _ = selNames (Proxy :: Proxy f)
+
+instance TableSelectors f => TableSelectors (M1 C x f) where
+  selNames _ = selNames (Proxy :: Proxy f)
+
+instance Selector s => TableSelectors (M1 S s (K1 R t)) where
+  selNames _ = [selName (undefined :: M1 S s (K1 R t) ())]
+
+instance (TableSelectors a, TableSelectors b) => TableSelectors (a :*: b) where
+  selNames _ = selNames (Proxy :: Proxy a) ++ selNames (Proxy :: Proxy b)
+
+instance TableSelectors U1 where
+  selNames _ = []
+  
+{-
+data Test = Test{
+  foo :: String,
+  bar ::String} deriving Generic
+  
+instance ToHtmlTable Test
+
+h = headers $ Proxy @Test
+b :: [Html ()]
+
+b = toHtmlRow $ Test "hello" "world"
+g = from $ Test "hello" "world"
+-}
+
+
+

@@ -0,0 +1,41 @@+{-# language OverloadedStrings, ExtendedDefaultRules #-}+module Lucid.VegaLite (vegaEmbedHead, vegaEmbedBodyScript, mkVegaHtml) where++import Lucid+import Lucid.PreEscaped (scriptSrc)++import qualified Data.Aeson as A++-- import qualified Data.Text as T+import qualified Data.Text.Encoding as T (decodeUtf8)++import qualified Data.ByteString.Lazy as LBS++import Data.Monoid++vegaCDN, vegaLiteCDN, vegaEmbedCDN :: Monad m => HtmlT m ()+vegaCDN = scriptSrc "https://cdn.jsdelivr.net/npm/vega@3"+vegaLiteCDN = scriptSrc "https://cdn.jsdelivr.net/npm/vega-lite@2.5.0"+vegaEmbedCDN = scriptSrc "https://cdn.jsdelivr.net/npm/vega-embed@3"++-- | Construct a HTML page that can render a vega-lite plot. The plot will be rendered by the vega-embed library.+--+-- NB: the 'A.Value' parameter must contain a vega-lite JSON payload+mkVegaHtml :: A.Value -> Html ()+mkVegaHtml vl = doctypehtml_ $ html_ $ do+  meta_ [charset_ "UTF-8"]+  head_ vegaEmbedHead+  with div_ [id_ "vis"] ""+  body_ $ vegaEmbedBodyScript vl ++-- | The statements for downloading the vega javascript blobs from the CDN. Must be in the document \<HEAD\>+vegaEmbedHead :: Html ()+vegaEmbedHead = do+    vegaCDN+    vegaLiteCDN+    vegaEmbedCDN++-- | The statement for embedding the vega JSON payload and initializing vega-embed. Must be in the \<BODY\> block and referenced by a \<div id="vis"\>\</div\>+vegaEmbedBodyScript :: A.Value -> Html ()+vegaEmbedBodyScript vl = +    script_ $ T.decodeUtf8 $ LBS.toStrict ("const spec =" <> A.encode vl <> "; vegaEmbed('#vis', spec).then(result => console.log(result)).catch(console.warn);" :: LBS.ByteString)     

@@ -1,51 +1,55 @@-Name:                lucid-extras-Version:             0.1.0.1-Synopsis:            Generate more HTML with Lucid-Description:         Generate more HTML with Lucid - Bootstrap, Rdash and Email.-License:             MIT-License-file:        LICENSE-Author:              Tom Nielsen <tanielsen@gmail.com>-Maintainer:          Tom Nielsen <tanielsen@gmail.com>-build-type:          Simple-Cabal-Version: 	     >= 1.10-homepage:            https://github.com/diffusionkinetics/open/lucid-extras-bug-reports:         https://github.com/diffusionkinetics/open/issues-category:            Web-Tested-With:         GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1+cabal-version: >=1.10+name: lucid-extras+version: 0.2+license: MIT+license-file: LICENSE+maintainer: Tom Nielsen <tanielsen@gmail.com>+author: Tom Nielsen <tanielsen@gmail.com>+tested-with: ghc ==7.10.2 ghc ==7.10.3 ghc ==8.0.1 ghc ==8.0.2+homepage: https://github.com/diffusionkinetics/open/lucid-extras+bug-reports: https://github.com/diffusionkinetics/open/issues+synopsis: Generate more HTML with Lucid+description:+    Generate more HTML with Lucid - Bootstrap, Rdash, Vega-Lite, Email.+category: Web+build-type: Simple extra-source-files:-                   changelog.md+    changelog.md  source-repository head-  type:     git-  location: https://github.com/diffusionkinetics/open--Library-   ghc-options:       -Wall-   hs-source-dirs:    lib-   default-language:  Haskell2010+    type: git+    location: https://github.com/diffusionkinetics/open -   Exposed-modules:-                   Lucid.Bootstrap3-                 , Lucid.PreEscaped-                 , Lucid.DataTables-                 , Lucid.Rdash-                 , Lucid.Leaflet-   Build-depends:-                 base                    >= 4.6 && < 5-               , aeson-               , lucid-               , text-               , blaze-builder-               , bytestring+library+    exposed-modules:+        Lucid.Bootstrap3+        Lucid.PreEscaped+        Lucid.DataTables+        Lucid.Rdash+        Lucid.Leaflet+        Lucid.Tables+        Lucid.VegaLite+    hs-source-dirs: lib+    default-language: Haskell2010+    ghc-options: -Wall+    build-depends:+        base >=4.6 && <5,+        aeson >=1.1.2.0,+        lucid >=2.9.9,+        text >=1.2.2.2,+        blaze-builder >=0.4.0.2,+        bytestring >=0.10.8.1 -Test-suite            site-gen-    type:       exitcode-stdio-1.0-    ghc-options:      -Wall-    hs-source-dirs:   site-gen-    main-is:          Main.hs-    default-language:  Haskell2010-    other-modules:    DevelMain-    Build-Depends:    base                    >= 4.6 && < 5-                    , directory               >= 1.2-                    , lucid-extras-                    , lucid+test-suite site-gen+    type: exitcode-stdio-1.0+    main-is: Main.hs+    hs-source-dirs: site-gen+    other-modules:+        DevelMain+    default-language: Haskell2010+    ghc-options: -Wall+    build-depends:+        base >=4.6 && <5,+        directory >=1.2,+        lucid-extras -any,+        lucid >=2.9.9