Commit 6622b260 authored by Sumit Sahrawat's avatar Sumit Sahrawat

Get rid of S prefix on singletons

parent 3a2228d2
......@@ -85,6 +85,7 @@ library
IHaskell.Display.Widgets.Types
IHaskell.Display.Widgets.Common
IHaskell.Display.Widgets.Singletons
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
......
......@@ -61,5 +61,5 @@ instance IHaskellWidget CheckBox where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Bool value) = HM.lookup key2 dict2
setField' widget SBoolValue value
setField' widget BoolValue value
triggerChange widget
......@@ -36,9 +36,9 @@ mkToggleButton = do
uuid <- U.random
let boolState = defaultBoolWidget "ToggleButtonView"
toggleState = (STooltip =:: "")
:& (SIcon =:: "")
:& (SButtonStyle =:: DefaultButton)
toggleState = (Tooltip =:: "")
:& (Icon =:: "")
:& (ButtonStyle =:: DefaultButton)
:& RNil
widgetState = WidgetState (boolState <+> toggleState)
......@@ -66,5 +66,5 @@ instance IHaskellWidget ToggleButton where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Bool value) = HM.lookup key2 dict2
setField' widget SBoolValue value
setField' widget BoolValue value
triggerChange widget
......@@ -36,10 +36,10 @@ mkFlexBox = do
uuid <- U.random
let boxAttrs = defaultBoxWidget "FlexBoxView"
flxAttrs = (SOrientation =:: HorizontalOrientation)
:& (SFlex =:: 0)
:& (SPack =:: StartLocation)
:& (SAlign =:: StartLocation)
flxAttrs = (Orientation =:: HorizontalOrientation)
:& (Flex =:: 0)
:& (Pack =:: StartLocation)
:& (Align =:: StartLocation)
:& RNil
widgetState = WidgetState $ boxAttrs <+> flxAttrs
......
......@@ -62,5 +62,5 @@ instance IHaskellWidget Accordion where
key2 = "selected_index" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Number num) = HM.lookup key2 dict2
setField' widget SSelectedIndex (Sci.coefficient num)
setField' widget SelectedIndex (Sci.coefficient num)
triggerChange widget
......@@ -61,5 +61,5 @@ instance IHaskellWidget TabWidget where
key2 = "selected_index" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Number num) = HM.lookup key2 dict2
setField' widget SSelectedIndex (Sci.coefficient num)
setField' widget SelectedIndex (Sci.coefficient num)
triggerChange widget
......@@ -36,12 +36,12 @@ mkButton = do
uuid <- U.random
let dom = defaultDOMWidget "ButtonView"
but = (SDescription =:: "")
:& (STooltip =:: "")
:& (SDisabled =:: False)
:& (SIcon =:: "")
:& (SButtonStyle =:: DefaultButton)
:& (SClickHandler =:: return ())
but = (Description =:: "")
:& (Tooltip =:: "")
:& (Disabled =:: False)
:& (Icon =:: "")
:& (ButtonStyle =:: DefaultButton)
:& (ClickHandler =:: return ())
:& RNil
buttonState = WidgetState (dom <+> but)
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module IHaskell.Display.Widgets.Common where
import Data.Aeson
import Data.Aeson.Types (emptyObject)
import Data.Text (pack, Text)
import Data.Singletons.TH
import IHaskell.Display (IHaskellWidget)
import IHaskell.Eval.Widgets (widgetSendClose)
import qualified IHaskell.Display.Widgets.Singletons as S
pattern ViewModule = S.SViewModule
pattern ViewName = S.SViewName
pattern MsgThrottle = S.SMsgThrottle
pattern Version = S.SVersion
pattern DisplayHandler = S.SDisplayHandler
pattern Visible = S.SVisible
pattern CSS = S.SCSS
pattern DOMClasses = S.SDOMClasses
pattern Width = S.SWidth
pattern Height = S.SHeight
pattern Padding = S.SPadding
pattern Margin = S.SMargin
pattern Color = S.SColor
pattern BackgroundColor = S.SBackgroundColor
pattern BorderColor = S.SBorderColor
pattern BorderWidth = S.SBorderWidth
pattern BorderRadius = S.SBorderRadius
pattern BorderStyle = S.SBorderStyle
pattern FontStyle = S.SFontStyle
pattern FontWeight = S.SFontWeight
pattern FontSize = S.SFontSize
pattern FontFamily = S.SFontFamily
pattern Description = S.SDescription
pattern ClickHandler = S.SClickHandler
pattern SubmitHandler = S.SSubmitHandler
pattern Disabled = S.SDisabled
pattern StringValue = S.SStringValue
pattern Placeholder = S.SPlaceholder
pattern Tooltip = S.STooltip
pattern Icon = S.SIcon
pattern ButtonStyle = S.SButtonStyle
pattern B64Value = S.SB64Value
pattern ImageFormat = S.SImageFormat
pattern BoolValue = S.SBoolValue
pattern Options = S.SOptions
pattern SelectedLabel = S.SSelectedLabel
pattern SelectedValue = S.SSelectedValue
pattern SelectionHandler = S.SSelectionHandler
pattern Tooltips = S.STooltips
pattern Icons = S.SIcons
pattern SelectedLabels = S.SSelectedLabels
pattern SelectedValues = S.SSelectedValues
pattern IntValue = S.SIntValue
pattern StepInt = S.SStepInt
pattern MaxInt = S.SMaxInt
pattern MinInt = S.SMinInt
pattern IntPairValue = S.SIntPairValue
pattern LowerInt = S.SLowerInt
pattern UpperInt = S.SUpperInt
pattern FloatValue = S.SFloatValue
pattern StepFloat = S.SStepFloat
pattern MaxFloat = S.SMaxFloat
pattern MinFloat = S.SMinFloat
pattern FloatPairValue = S.SFloatPairValue
pattern LowerFloat = S.SLowerFloat
pattern UpperFloat = S.SUpperFloat
pattern Orientation = S.SOrientation
pattern ShowRange = S.SShowRange
pattern ReadOut = S.SReadOut
pattern SliderColor = S.SSliderColor
pattern BarStyle = S.SBarStyle
pattern ChangeHandler = S.SChangeHandler
pattern Children = S.SChildren
pattern OverflowX = S.SOverflowX
pattern OverflowY = S.SOverflowY
pattern BoxStyle = S.SBoxStyle
pattern Flex = S.SFlex
pattern Pack = S.SPack
pattern Align = S.SAlign
pattern Titles = S.STitles
pattern SelectedIndex = S.SSelectedIndex
-- | Close a widget's comm
closeWidget :: IHaskellWidget w => w -> IO ()
closeWidget w = widgetSendClose w emptyObject
-- Widget properties
singletons [d|
data Field = ViewModule
| ViewName
| MsgThrottle
| Version
| DisplayHandler
| Visible
| CSS
| DOMClasses
| Width
| Height
| Padding
| Margin
| Color
| BackgroundColor
| BorderColor
| BorderWidth
| BorderRadius
| BorderStyle
| FontStyle
| FontWeight
| FontSize
| FontFamily
| Description
| ClickHandler
| SubmitHandler
| Disabled
| StringValue
| Placeholder
| Tooltip
| Icon
| ButtonStyle
| B64Value
| ImageFormat
| BoolValue
| Options
| SelectedLabel
| SelectedValue
| SelectionHandler
| Tooltips
| Icons
| SelectedLabels
| SelectedValues
| IntValue
| StepInt
| MaxInt
| MinInt
| IntPairValue
| LowerInt
| UpperInt
| FloatValue
| StepFloat
| MaxFloat
| MinFloat
| FloatPairValue
| LowerFloat
| UpperFloat
| Orientation
| ShowRange
| ReadOut
| SliderColor
| BarStyle
| ChangeHandler
| Children
| OverflowX
| OverflowY
| BoxStyle
| Flex
| Pack
| Align
| Titles
| SelectedIndex
deriving (Eq, Ord, Show)
|]
newtype StrInt = StrInt Integer deriving (Num, Ord, Eq, Enum)
instance ToJSON StrInt where
......
......@@ -65,5 +65,5 @@ instance IHaskellWidget BoundedFloatText where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Number value) = HM.lookup key2 dict2
setField' widget SFloatValue (Sci.toRealFloat value)
setField' widget FloatValue (Sci.toRealFloat value)
triggerChange widget
......@@ -38,7 +38,7 @@ mkFloatProgress = do
uuid <- U.random
let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView"
progressAttrs = (SBarStyle =:: DefaultBar) :& RNil
progressAttrs = (BarStyle =:: DefaultBar) :& RNil
widgetState = WidgetState $ boundedFloatAttrs <+> progressAttrs
stateIO <- newIORef widgetState
......
......@@ -37,10 +37,10 @@ mkFloatSlider = do
uuid <- U.random
let boundedFloatAttrs = defaultBoundedFloatWidget "FloatSliderView"
sliderAttrs = (SOrientation =:: HorizontalOrientation)
:& (SShowRange =:: False)
:& (SReadOut =:: True)
:& (SSliderColor =:: "")
sliderAttrs = (Orientation =:: HorizontalOrientation)
:& (ShowRange =:: False)
:& (ReadOut =:: True)
:& (SliderColor =:: "")
:& RNil
widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs
......@@ -68,5 +68,5 @@ instance IHaskellWidget FloatSlider where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Number value) = HM.lookup key2 dict2
setField' widget SFloatValue (Sci.toRealFloat value)
setField' widget FloatValue (Sci.toRealFloat value)
triggerChange widget
......@@ -40,10 +40,10 @@ mkFloatRangeSlider = do
uuid <- U.random
let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatSliderView"
sliderAttrs = (SOrientation =:: HorizontalOrientation)
:& (SShowRange =:: True)
:& (SReadOut =:: True)
:& (SSliderColor =:: "")
sliderAttrs = (Orientation =:: HorizontalOrientation)
:& (ShowRange =:: True)
:& (ReadOut =:: True)
:& (SliderColor =:: "")
:& RNil
widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs
......@@ -74,5 +74,5 @@ instance IHaskellWidget FloatRangeSlider where
Just (Object dict2) = HM.lookup key1 dict1
Just (Array values) = HM.lookup key2 dict2
[x, y] = map (\(Number x) -> Sci.toRealFloat x) $ V.toList values
setField' widget SFloatPairValue (x, y)
setField' widget FloatPairValue (x, y)
triggerChange widget
......@@ -62,5 +62,5 @@ instance IHaskellWidget FloatText where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Number value) = HM.lookup key2 dict2
setField' widget SFloatValue (Sci.toRealFloat value)
setField' widget FloatValue (Sci.toRealFloat value)
triggerChange widget
......@@ -37,8 +37,8 @@ mkImageWidget = do
uuid <- U.random
let dom = defaultDOMWidget "ImageView"
img = (SImageFormat =:: PNG)
:& (SB64Value =:: mempty)
img = (ImageFormat =:: PNG)
:& (B64Value =:: mempty)
:& RNil
widgetState = WidgetState (dom <+> img)
......
......@@ -64,5 +64,5 @@ instance IHaskellWidget BoundedIntText where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Number value) = HM.lookup key2 dict2
setField' widget SIntValue (Sci.coefficient value)
setField' widget IntValue (Sci.coefficient value)
triggerChange widget
......@@ -38,7 +38,7 @@ mkIntProgress = do
uuid <- U.random
let boundedIntAttrs = defaultBoundedIntWidget "ProgressView"
progressAttrs = (SBarStyle =:: DefaultBar) :& RNil
progressAttrs = (BarStyle =:: DefaultBar) :& RNil
widgetState = WidgetState $ boundedIntAttrs <+> progressAttrs
stateIO <- newIORef widgetState
......
......@@ -37,10 +37,10 @@ mkIntSlider = do
uuid <- U.random
let boundedIntAttrs = defaultBoundedIntWidget "IntSliderView"
sliderAttrs = (SOrientation =:: HorizontalOrientation)
:& (SShowRange =:: False)
:& (SReadOut =:: True)
:& (SSliderColor =:: "")
sliderAttrs = (Orientation =:: HorizontalOrientation)
:& (ShowRange =:: False)
:& (ReadOut =:: True)
:& (SliderColor =:: "")
:& RNil
widgetState = WidgetState $ boundedIntAttrs <+> sliderAttrs
......@@ -68,5 +68,5 @@ instance IHaskellWidget IntSlider where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Number value) = HM.lookup key2 dict2
setField' widget SIntValue (Sci.coefficient value)
setField' widget IntValue (Sci.coefficient value)
triggerChange widget
......@@ -38,10 +38,10 @@ mkIntRangeSlider = do
uuid <- U.random
let boundedIntAttrs = defaultBoundedIntRangeWidget "IntSliderView"
sliderAttrs = (SOrientation =:: HorizontalOrientation)
:& (SShowRange =:: True)
:& (SReadOut =:: True)
:& (SSliderColor =:: "")
sliderAttrs = (Orientation =:: HorizontalOrientation)
:& (ShowRange =:: True)
:& (ReadOut =:: True)
:& (SliderColor =:: "")
:& RNil
widgetState = WidgetState $ boundedIntAttrs <+> sliderAttrs
......@@ -72,5 +72,5 @@ instance IHaskellWidget IntRangeSlider where
Just (Object dict2) = HM.lookup key1 dict1
Just (Array values) = HM.lookup key2 dict2
[x, y] = map (\(Number x) -> Sci.coefficient x) $ V.toList values
setField' widget SIntPairValue (x, y)
setField' widget IntPairValue (x, y)
triggerChange widget
......@@ -61,5 +61,5 @@ instance IHaskellWidget IntText where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Number value) = HM.lookup key2 dict2
setField' widget SIntValue (Sci.coefficient value)
setField' widget IntValue (Sci.coefficient value)
triggerChange widget
......@@ -35,7 +35,7 @@ mkDropdown = do
-- Default properties, with a random uuid
uuid <- U.random
let selectionAttrs = defaultSelectionWidget "DropdownView"
dropdownAttrs = (SButtonStyle =:: DefaultButton) :& RNil
dropdownAttrs = (ButtonStyle =:: DefaultButton) :& RNil
widgetState = WidgetState $ selectionAttrs <+> dropdownAttrs
stateIO <- newIORef widgetState
......@@ -62,15 +62,15 @@ instance IHaskellWidget Dropdown where
key2 = "selected_label" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
opts <- getField widget Options
case opts of
OptionLabels _ -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
setField' widget SelectedLabel label
setField' widget SelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
setField' widget SelectedLabel label
setField' widget SelectedValue value
triggerSelection widget
......@@ -60,15 +60,15 @@ instance IHaskellWidget RadioButtons where
key2 = "selected_label" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
opts <- getField widget Options
case opts of
OptionLabels _ -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
setField' widget SelectedLabel label
setField' widget SelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
setField' widget SelectedLabel label
setField' widget SelectedValue value
triggerSelection widget
......@@ -59,15 +59,15 @@ instance IHaskellWidget Select where
key2 = "selected_label" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
opts <- getField widget Options
case opts of
OptionLabels _ -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
setField' widget SelectedLabel label
setField' widget SelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
setField' widget SelectedLabel label
setField' widget SelectedValue value
triggerSelection widget
......@@ -64,15 +64,15 @@ instance IHaskellWidget SelectMultiple where
Just (Object dict2) = HM.lookup key1 dict1
Just (Array labels) = HM.lookup key2 dict2
labelList = map (\(String x) -> x) $ V.toList labels
opts <- getField widget SOptions
opts <- getField widget Options
case opts of
OptionLabels _ -> void $ do
setField' widget SSelectedLabels labelList
setField' widget SSelectedValues labelList
setField' widget SelectedLabels labelList
setField' widget SelectedValues labelList
OptionDict ps ->
case sequence $ map (`lookup` ps) labelList of
Nothing -> return ()
Just valueList -> void $ do
setField' widget SSelectedLabels labelList
setField' widget SSelectedValues valueList
setField' widget SelectedLabels labelList
setField' widget SelectedValues valueList
triggerSelection widget
......@@ -35,9 +35,9 @@ mkToggleButtons = do
-- Default properties, with a random uuid
uuid <- U.random
let selectionAttrs = defaultSelectionWidget "ToggleButtonsView"
toggleButtonsAttrs = (STooltips =:: [])
:& (SIcons =:: [])
:& (SButtonStyle =:: DefaultButton)
toggleButtonsAttrs = (Tooltips =:: [])
:& (Icons =:: [])
:& (ButtonStyle =:: DefaultButton)
:& RNil
widgetState = WidgetState $ selectionAttrs <+> toggleButtonsAttrs
......@@ -67,15 +67,15 @@ instance IHaskellWidget ToggleButtons where
key2 = "selected_label" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
opts <- getField widget Options
case opts of
OptionLabels _ -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
setField' widget SelectedLabel label
setField' widget SelectedValue label
OptionDict ps ->
case lookup label ps of
Nothing -> return ()
Just value -> void $ do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
setField' widget SelectedLabel label
setField' widget SelectedValue value
triggerSelection widget
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module IHaskell.Display.Widgets.Singletons where
import Data.Singletons.TH
-- Widget properties
singletons [d|
data Field = ViewModule
| ViewName
| MsgThrottle
| Version
| DisplayHandler
| Visible
| CSS
| DOMClasses
| Width
| Height
| Padding
| Margin
| Color
| BackgroundColor
| BorderColor
| BorderWidth
| BorderRadius
| BorderStyle
| FontStyle
| FontWeight
| FontSize
| FontFamily
| Description
| ClickHandler
| SubmitHandler
| Disabled
| StringValue
| Placeholder
| Tooltip
| Icon
| ButtonStyle
| B64Value
| ImageFormat
| BoolValue
| Options
| SelectedLabel
| SelectedValue
| SelectionHandler
| Tooltips
| Icons
| SelectedLabels
| SelectedValues
| IntValue
| StepInt
| MaxInt
| MinInt
| IntPairValue
| LowerInt
| UpperInt
| FloatValue
| StepFloat
| MaxFloat
| MinFloat
| FloatPairValue
| LowerFloat
| UpperFloat
| Orientation
| ShowRange
| ReadOut
| SliderColor
| BarStyle
| ChangeHandler
| Children
| OverflowX
| OverflowY
| BoxStyle
| Flex
| Pack
| Align
| Titles
| SelectedIndex
deriving (Eq, Ord, Show)
|]
......@@ -35,7 +35,7 @@ mkTextWidget = do
-- Default properties, with a random uuid
uuid <- U.random
let strWidget = defaultStringWidget "TextView"
txtWidget = (SSubmitHandler =:: return ()) :& (SChangeHandler =:: return ()) :& RNil
txtWidget = (SubmitHandler =:: return ()) :& (ChangeHandler =:: return ()) :& RNil
widgetState = WidgetState $ strWidget <+> txtWidget
stateIO <- newIORef widgetState
......@@ -61,7 +61,7 @@ instance IHaskellWidget TextWidget where
case Map.lookup "sync_data" dict1 of
Just (Object dict2) ->
case Map.lookup "value" dict2 of
Just (String val) -> setField' tw SStringValue val >> triggerChange tw
Just (String val) -> setField' tw StringValue val >> triggerChange tw
Nothing -> return ()
Nothing ->
case Map.lookup "content" dict1 of
......
......@@ -35,7 +35,7 @@ mkTextArea = do
-- Default properties, with a random uuid
uuid <- U.random
let strAttrs = defaultStringWidget "TextareaView"
wgtAttrs = (SChangeHandler =:: return ()) :& RNil
wgtAttrs = (ChangeHandler =:: return ()) :& RNil
widgetState = WidgetState $ strAttrs <+> wgtAttrs
stateIO <- newIORef widgetState
......@@ -62,5 +62,5 @@ instance IHaskellWidget TextArea where
key2 = "value" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (String value) = HM.lookup key2 dict2
setField' widget SStringValue value
setField' widget StringValue value
triggerChange widget
......@@ -54,7 +54,7 @@ for source_dir in ["src", "ipython-kernel", "ihaskell-display"]:
if "ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets" in root:
# Ignore Types.hs and Common.hs from ihaskell-widgets
# They cause issues with hindent, due to promoted types
ignored_files = ["Types.hs", "Common.hs"]
ignored_files = ["Types.hs", "Common.hs", "Singletons.hs"]
else:
# Take Haskell files, but ignore the Cabal Setup.hs
# Also ignore IHaskellPrelude.hs, it uses CPP in weird places
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment