1. Gauthier Segay
  2. yesod-widgets

Commits

gauthier  committed 12fb770

/calendarheatmap shows a rendering of calheatmap widget with random values

  • Participants
  • Parent commits fb2b0e6
  • Branches default

Comments (0)

Files changed (4)

File Foundation.hs

View file
 
 module Foundation where
 
-import           Network.HTTP.Conduit     (Manager)
+import           Network.HTTP.Conduit  (Manager)
 import           Prelude
-import           Settings                 (Extra (..), widgetFile)
+import           Settings              (Extra (..), widgetFile)
 import qualified Settings
-import           Settings.Development     (development)
+import           Settings.Development  (development)
 import           Settings.StaticFiles
-import           System.Log.FastLogger    (Logger)
-import           Text.Hamlet              (hamletFile)
-import           Text.Jasmine             (minifym)
+import           System.Log.FastLogger (Logger)
+import           Text.Hamlet           (hamletFile)
+import           Text.Jasmine          (minifym)
 import           Yesod
 import           Yesod.Default.Config
-import           Yesod.Default.Util       (addStaticContentExternal)
+import           Yesod.Default.Util    (addStaticContentExternal)
 import           Yesod.Static
 
-import           Yesod.Widgets.CalHeatMap
-
 -- | The site argument for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have

File Handler/Handlers.hs

View file
 {-# LANGUAGE TypeFamilies          #-}
 
 module Handler.Handlers where
+import           Control.Monad.Random
 import           Data.Aeson
+import           Data.Default             (def)
+import           Data.Time.Calendar       (fromGregorian)
+import           Data.Time.Clock          (UTCTime (..), addUTCTime,
+                                           secondsToDiffTime)
+import           Data.Time.Lens
+import           Import
 import           Yesod.Widgets.CalHeatMap
 
-import           Import
-
 getCalendarHeatMapR :: Handler Html
 getCalendarHeatMapR = do
-    defaultLayout $ do
-        setTitle "Welcome To Yesod!"
-	let chSettings = CalHeatMapJSONSettings (object[])
-        let widget = calHeatMapWidget chSettings
-        [whamlet|^{widget}|]
+  values <- liftIO $ generateRandomData (1::Double,100) 365
+  widgetId <- newIdent
+  let chSettings = (def CalHeatMapWidgetSettings) { chmData = (CalHeatMapRawData $ generateCalHeatMapData values)
+                                                  , chmDomain = Just Week
+                                                  , chmRange = Just (fromInteger $ toInteger $ truncate (365/7))
+                                                  , chmLegend = Just $ take 10  [0, 10..]
+                                                  }
+  let widget = widgetCalHeatMap chSettings widgetId
+  defaultLayout $ do [whamlet|^{widget} |]
+  where
+    getDaysFor d values = map (\(i,_) -> modL hours (+24*i) d) $ zip [1..] values
+    generateCalHeatMapData v = zip (getDaysFor (UTCTime (fromGregorian 2000 01 01) 0) v) v
+
+generateRandomData :: (Random a, MonadRandom m) => (a, a) -> Int -> m [a]
+generateRandomData range count = do
+  values <- getRandomRs range
+  return $ take count values
+
+gR :: (RandomGen g) => g-> ([Integer], g)
+gR = do
+  runRand $ generateRandomData (10::Integer,100) 10
+
+
+

File Yesod/Widgets/CalHeatMap.hs

View file
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Yesod.Widgets.CalHeatMap (CalHeatMapWidgetSettings(..), CalHeatMapData(..),Domain (.. ), SubDomainOrientation(..), SubDomain(..), widgetCalHeatMap) where
 
-module Yesod.Widgets.CalHeatMap where
-import           Data.Aeson            as J
-import           Data.List             (init, map)
-import           Data.Monoid           ((<>))
+import qualified Data.Aeson            as J
+import qualified Data.ByteString       as BS
+import qualified Data.ByteString.Lazy  as LBS
+import           Data.Convertible      (convert)
+import           Data.Default          (Default, def)
+import           Data.List             (minimum)
+import           Data.Maybe            (fromJust, isJust)
 import qualified Data.Text             as T
-import           Data.Time
+import           Data.Text.Encoding    (decodeUtf8)
+import           Data.Time.Calendar    (fromGregorian, toGregorian)
+import           Data.Time.Clock       (UTCTime (..), utctDay)
 import           Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
-import           Prelude
-import           System.Posix.Types    (EpochTime)
-import           Text.Blaze.Internal
-import           Yesod
-import           Yesod.Core
+import           Prelude               (Bool, Double, Int, Maybe (..), Show,
+                                        error, fromEnum, fst, init, map, map,
+                                        min, otherwise, show, toInteger, ($),
+                                        (*), (++))
+import           System.Posix.Types    (EpochTime (..))
+import           Text.Blaze.Html       (Html, preEscapedToHtml)
+import           Yesod                 (julius, whamlet)
+import qualified Yesod                 as Y
 
+utcTimeToEpochTime :: UTCTime -> EpochTime
+utcTimeToEpochTime = convert
 
-data CalHeatMapData = CalHeatMapRawData [(UTCTime, Double)]
-                    | CalHeatMapDataUri T.Text
+data CalHeatMapData = CalHeatMapRawData [(UTCTime, Double)] -- ^ provide raw data
+                    | CalHeatMapURIData T.Text -- ^ provide URI to data (might want to optionally pass a yesod route, not sure how it is done yet)
+                    deriving (Show)
 
-data CalHeatMapSettings = CalHeatMapSettings {
-    chmData        :: CalHeatMapData
-    , chmStartDate :: UTCTime
-    }
-  | CalHeatMapJSONSettings J.Value
+data Domain = Year
+            | Month
+            | Week
+            | Day
+            | Hour
+            deriving (Show)
+data SubDomainOrientation = Horizontal | Vertical
+                          deriving (Show)
+data SubDomain = SubDomain Domain SubDomainOrientation
+               | Minute SubDomainOrientation
+               deriving (Show)
+data CalHeatMapWidgetSettings
+  = CalHeatMapWidgetSettings { chmData              :: CalHeatMapData -- ^ time serie data source for heat map
+                             , chmStartDate         :: Maybe UTCTime -- ^ if Nothing, will be infered from chmData
+                             , chmDomain            :: Maybe Domain
+                             , chmSubDomain         :: Maybe SubDomain
+                             , chmMinDate           :: Maybe UTCTime
+                             , chmMaxDate           :: Maybe UTCTime
+                             , chmWeekStartOnMonday :: Maybe Bool
+                             , chmRange             :: Maybe Int
+                             , chmLegend            :: Maybe [Double]
+                             }
+  | JSON J.Value
+  deriving (Show)
 
-calHeatMapWidget d = do
-  master <- getYesod
-  addScriptRemote "http://kamisama.github.io/cal-heatmap/js/cal-heatmap.min.js"
-  addStylesheetRemote "http://kamisama.github.io/cal-heatmap/css/cal-heatmap.css"
-  divId <- newIdent
+instance Default CalHeatMapWidgetSettings where
+  def = CalHeatMapWidgetSettings { chmData = CalHeatMapRawData []
+                                 , chmStartDate = Nothing
+                                 , chmDomain = Nothing
+                                 , chmSubDomain = Nothing
+                                 , chmMinDate = Nothing
+                                 , chmMaxDate = Nothing
+                                 , chmWeekStartOnMonday = Nothing
+                                 , chmRange = Nothing
+                                 , chmLegend = Nothing
+                                 }
+--widgetCalHeatMap :: CalHeatMapWidgetSettings -> T.Text -> Y.Widget
+widgetCalHeatMap settings widgetId = do
+  Y.addScriptRemote "//d3js.org/d3.v3.min.js"
+  Y.addScriptRemote "http://kamisama.github.io/cal-heatmap/js/cal-heatmap.min.js"
+  Y.addStylesheetRemote "http://kamisama.github.io/cal-heatmap/css/cal-heatmap.css"
+  let divId = T.append widgetId ("_div" :: T.Text)
+  let startDateEpochMs = J.toJSON $ (toInteger (fromEnum  $ (utcTimeToEpochTime startDate))) * 1000
   [whamlet|
 <div##{divId}>
 |]
-  toWidget [julius|
-(function (){
-var cal = new CalHeatMap();
-settings = {
-  itemSelector: '##{toJSON divId}',
-  data : #{toJSON serializedData}
-};
-cal.init(settings);
-})()
+  Y.toWidget [julius|
+    (function (){ console.log(CalHeatMap);
+       var cal = new CalHeatMap();
+       settings = {
+         itemSelector: '#' + #{J.toJSON divId},
+         data : #{serializedData}
+       };
+       settings.start = new Date(#{J.toJSON startDateEpochMs});
+       if(#{isJust $ chmDomain settings}){
+           settings.domain = #{J.toJSON domain};
+       }
+       if(#{isJust $ chmSubDomain settings}){
+           settings.subDomain = #{J.toJSON subdomain};
+       }
+       if(#{isJust $ chmRange settings}){
+           settings.range = #{J.toJSON $ chmRange settings}
+       }
+       if(#{isJust $ chmLegend settings}){
+           settings.legend = #{J.toJSON $ chmLegend settings}
+       }
+       cal.init(settings);
+    })();
 |]
   where
-    serializedData = case chmData d of
+    startDate
+      | isJust $ chmStartDate settings = fromJust $ chmStartDate settings
+      | otherwise =
+          case chmData settings of
+            CalHeatMapRawData [] -> UTCTime (fromGregorian 2000 01 01) 0 -- just get an arbitrary one in this case instead of failing
+            CalHeatMapRawData rd -> minimum $ map fst rd
+            CalHeatMapURIData _ -> error "you have to specify chmStartDate if you are using an URI"
+    serializedData = case chmData settings of
      (CalHeatMapRawData rd) -> serializeRawData rd
-     (CalHeatMapDataUri uri) -> J.String uri
+     (CalHeatMapURIData uri) -> J.String uri
+    domainToString d = case d of
+       Year -> "year" :: T.Text
+       Month -> "month"
+       Week -> "week"
+       Day -> "day"
+       Hour -> "hour"
+    domain
+      | isJust $ chmDomain settings = domainToString $ fromJust $ chmDomain settings
+      | otherwise = domainToString Day
+    subdomainToString sd = case sd of
+       SubDomain d Horizontal -> T.append (domainToString d) "_x" :: T.Text
+       SubDomain d _ -> domainToString d
+       Minute Horizontal -> "min_x"
+       Minute Vertical -> "min"
+    subdomain
+      | isJust $ chmSubDomain settings = subdomainToString $ fromJust $ chmSubDomain settings
+      | otherwise = subdomainToString $ SubDomain Hour Horizontal
 
-serializeRawData :: [(UTCTime, Double)] -> Value
+serializeRawData :: [(UTCTime, Double)] -> J.Value
 serializeRawData items = J.object $ map transformToPair items
   where
-    transformToPair (time, value) = (formattedTime time, toJSON value)
+    transformToPair (time, value) = (formattedTime time, J.toJSON value)
     formattedTime = transformTimeToPOSIXEpochString
     transformTimeToPOSIXEpochString :: UTCTime -> T.Text
     transformTimeToPOSIXEpochString t = T.pack $ init $ show $ utcTimeToPOSIXSeconds t
+
+lazyToStrictBS :: LBS.ByteString -> BS.ByteString
+lazyToStrictBS x = BS.concat $ LBS.toChunks x
+
+toUtf8Text :: J.Value -> T.Text
+toUtf8Text v = decodeUtf8 $ lazyToStrictBS $ J.encode $ v
+
+-- | this is useful to output Aeson's json value in a hamlet template
+toText :: J.Value -> Html
+toText v = preEscapedToHtml $ toUtf8Text $ v

File yesod-widgets.cabal

View file
                      
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
-        ghc-options:   -Wall -O0
+        ghc-options:   -Wall -O0 -auto-all
     else
         ghc-options:   -Wall -O2
 
                  , fast-logger                   >= 0.3
                  , time
                  , blaze-markup
+                 , MonadRandom
+                 , convertible
+                 , time-lens
+                 , blaze-html
+                 , colour
 
 executable         yesod-widgets
     if flag(library-only)
     build-depends:     base
                      , yesod-widgets
                      , yesod
+                     , fast-logger
 
     ghc-options:       -threaded -O2