Added DatePicker widget

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets.hs

@@ -2,6 +2,7 @@ module IHaskell.Display.Widgets (module X) where
 
 import           IHaskell.Display.Widgets.Button as X
 import           IHaskell.Display.Widgets.ColorPicker as X
+import           IHaskell.Display.Widgets.DatePicker as X
 
 import           IHaskell.Display.Widgets.Box.Box as X
 import           IHaskell.Display.Widgets.Box.SelectionContainer.Accordion as X
@@ -50,4 +51,4 @@ import           IHaskell.Display.Widgets.String.TextArea as X
 import           IHaskell.Display.Widgets.Common as X
 import           IHaskell.Display.Widgets.Types as X (setField, getField, properties, triggerDisplay,
                                                       triggerChange, triggerClick, triggerSelection,
-                                                      triggerSubmit, ChildWidget(..))
+                                                      triggerSubmit, ChildWidget(..), Date(..))

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Common.hs

@@ -102,6 +102,7 @@ pattern Repeat = S.SRepeat
 pattern Interval = S.SInterval
 pattern ShowRepeat = S.SShowRepeat
 pattern Concise = S.SConcise
+pattern DateValue = S.SDateValue
 
 -- | Close a widget's comm
 closeWidget :: IHaskellWidget w => w -> IO ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/DatePicker.hs

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+
+module IHaskell.Display.Widgets.DatePicker
+  ( -- * The DatePicker Widget
+    DatePicker
+    -- * Create a new DatePicker
+  , mkDatePicker
+  ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (void)
+
+import           Data.Aeson
+import           Data.IORef (newIORef)
+import           Data.Vinyl (Rec(..), (<+>))
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'DatePicker' represents a DatePicker from IPython.html.widgets.
+type DatePicker = IPythonWidget 'DatePickerType
+
+-- | Create a new DatePicker
+mkDatePicker :: IO DatePicker
+mkDatePicker = do
+  -- Default properties, with a random uuid
+  wid <- U.random
+
+  let ddw = defaultDescriptionWidget "DatePickerView" "DatePickerModel"
+      date = (DateValue =:: defaultDate)
+              :& (Disabled =:: False)
+              :& RNil
+      datePickerState = WidgetState (ddw <+> date)
+
+  stateIO <- newIORef datePickerState
+
+  let datePicker = IPythonWidget wid stateIO
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen datePicker $ toJSON datePickerState
+
+  -- Return the DatePicker widget
+  return datePicker
+
+instance IHaskellWidget DatePicker where
+  getCommUUID = uuid
+  comm widget val _ =
+    case nestedObjectLookup val ["state", "value"] of
+      Just o -> case fromJSON o of
+        Success date -> void $ setField' widget DateValue date
+        _ -> pure ()
+      _ -> pure ()
\ No newline at end of file

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Singletons.hs

@@ -108,5 +108,6 @@ singletons
              | Interval
              | ShowRepeat
              | Concise
+             | DateValue
              deriving (Eq, Ord, Show)
   |]

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Types.hs

@@ -63,7 +63,7 @@
 -- specification.
 module IHaskell.Display.Widgets.Types where
 
-import           Control.Monad (unless, join, when, void)
+import           Control.Monad (unless, join, when, void,mzero)
 import           Control.Applicative ((<$>))
 import qualified Control.Exception as Ex
 import           Data.Typeable (Typeable, TypeRep, typeOf)
@@ -247,6 +247,7 @@ type family FieldType (f :: Field) :: * where
         FieldType 'S.Interval = Integer
         FieldType 'S.ShowRepeat = Bool
         FieldType 'S.Concise = Bool
+        FieldType 'S.DateValue = Date
 
 -- | Can be used to put different widgets in a list. Useful for dealing with children widgets.
 data ChildWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => ChildWidget (IPythonWidget w)
@@ -276,6 +277,7 @@ instance CustomBounded Double where
 -- Different types of widgets. Every widget in IPython has a corresponding WidgetType
 data WidgetType = ButtonType
                 | ColorPickerType
+                | DatePickerType
                 | AudioType
                 | ImageType
                 | VideoType
@@ -319,10 +321,12 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields 'ButtonType =
                   DescriptionWidgetClass :++
                     ['S.Disabled, 'S.Icon, 'S.ButtonStyle ,'S.ClickHandler]
-
   WidgetFields 'ColorPickerType =
                   DescriptionWidgetClass :++
                     ['S.StringValue, 'S.Concise, 'S.Disabled]
+  WidgetFields 'DatePickerType =
+                  DescriptionWidgetClass :++
+                    ['S.DateValue, 'S.Disabled]
 
   WidgetFields 'AudioType =
                   MediaClass :++ ['S.AudioFormat, 'S.AutoPlay, 'S.Loop, 'S.Controls]
@@ -651,6 +655,9 @@ instance ToPairs (Attr 'S.ShowRepeat) where
 instance ToPairs (Attr 'S.Concise) where
   toPairs x = ["concise" .= toJSON x]
 
+instance ToPairs (Attr 'S.DateValue) where
+  toPairs x = ["value" .= toJSON x]
+
 -- | Store the value for a field, as an object parametrized by the Field. No verification is done
 -- for these values.
 (=::) :: (SingI f, Typeable (FieldType f)) => Sing f -> FieldType f -> Attr f
@@ -980,9 +987,38 @@ instance IHaskellWidget (IPythonWidget w) => IHaskellDisplay (IPythonWidget w) w
   display b = do
     widgetSendView b -- Keeping compatibility with classic notebook
     return $ Display [ widgetdisplay $ unpack $ decodeUtf8 $ encode $ object [
-      "model_id" .= getCommUUID b, 
+      "model_id" .= getCommUUID b,
       "version_major" .= version_major,
       "version_minor" .= version_minor] ]
     where
       version_major = 2 :: Int
       version_minor = 0 :: Int
+
+-- | The date class from IPython
+data Date
+  -- | No date specified. used by default
+  = NullDate
+  -- | Date year month day
+  | Date Integer Integer Integer deriving (Eq,Ord)
+
+defaultDate :: Date
+defaultDate = NullDate
+
+instance Show Date where
+  show NullDate = "NullDate"
+  show (Date y m d) = printf "%04d-%02d-%02d" y m d
+
+instance ToJSON Date where
+  toJSON NullDate = object []
+  toJSON (Date y m d) = object [ "year" .= toJSON y
+                               , "month" .= toJSON (m-1) -- In the frontend months go from 0 to 11
+                               , "date" .= toJSON d
+                               ]
+
+instance FromJSON Date where
+  parseJSON (Object v) = Date
+    <$> v .: "year"
+    <*> ((+1) <$> v .: "month")
+    <*> v .: "date"
+  parseJSON Null = pure NullDate
+  parseJSON _ = mzero
\ No newline at end of file