styles updated

styles updated

module RNX.Styles where

import RNX
import RNX.Components
import RNX.Events
import RNX.Props
import RNX.Color
import Prelude

foreign import data StyleSheet :: *
foreign import data StyleProp :: *

type StyleId = Int
data Style = Style String (Array StyleProp)
type StyleSheet' = Array {name:: String, styles:: Array StyleProp}

foreign import _createStyleSheet :: StyleSheet' -> StyleSheet

createStyleSheet :: Array Style -> StyleSheet
createStyleSheet s =
  _createStyleSheet $ map getStyle s
  where
    getStyle (Style name styleProps) = {name: name, styles: styleProps}

-- TODO: make this type safe!
foreign import getStyleId :: StyleSheet -> String -> StyleId

foreign import unsafeMkStyleProp :: forall val. String -> val -> StyleProp

style :: forall action. StyleId -> Prop action
style = unsafeMkProps "style"

styles :: forall action. Array StyleId -> Prop action
styles = unsafeMkProps "style"

--------- Styles ---------------

data Visibility = Visible | Hidden

-- A

data AlignItems
  = AlignItemsFlexStart
  | AlignItemsFlexEnd
  | AlignItemsCenter
  | AlignItemsStretch

alignItems :: AlignItems -> StyleProp
alignItems AlignItemsFlexStart = unsafeMkStyleProp "alignItems" "flex-start"
alignItems AlignItemsFlexEnd   = unsafeMkStyleProp "alignItems" "flex-end"
alignItems AlignItemsCenter    = unsafeMkStyleProp "alignItems" "center"
alignItems AlignItemsStretch   = unsafeMkStyleProp "alignItems" "stretch"

data AlignSelf
  = AlignSelfAuto
  | AlignSelfFlexStart
  | AlignSelfFlexEnd
  | AlignSelfCenter
  | AlignSelfStretch

alignSelf :: AlignSelf -> StyleProp
alignSelf AlignSelfAuto      = unsafeMkStyleProp "alignSelf" "auto"
alignSelf AlignSelfFlexStart = unsafeMkStyleProp "alignSelf" "flex-start"
alignSelf AlignSelfFlexEnd   = unsafeMkStyleProp "alignSelf" "flex-end"
alignSelf AlignSelfCenter    = unsafeMkStyleProp "alignSelf" "center"
alignSelf AlignSelfStretch   = unsafeMkStyleProp "alignSelf" "stretch"

-- B

backfaceVisibility :: Visibility -> StyleProp
backfaceVisibility Visible = unsafeMkStyleProp "backfaceVisibility" "visible"
backfaceVisibility Hidden  = unsafeMkStyleProp "backfaceVisibility" "hidden"

backgroundVisibility :: Visibility -> StyleProp
backgroundVisibility Visible = unsafeMkStyleProp "backgroundVisibility" "visible"
backgroundVisibility Hidden  = unsafeMkStyleProp "backgroundVisibility" "hidden"

borderBottomColor :: Color -> StyleProp
borderBottomColor c = unsafeMkStyleProp "borderBottomColor" (show c)

borderBottomRightRadius :: Int -> StyleProp
borderBottomRightRadius = unsafeMkStyleProp "borderBottomRightRadius"

borderBottomWidth :: Int -> StyleProp
borderBottomWidth = unsafeMkStyleProp "borderBottomWidth"

borderColor :: Color -> StyleProp
borderColor c = unsafeMkStyleProp "borderColor" (show c)

borderLeftColor :: Color -> StyleProp
borderLeftColor c = unsafeMkStyleProp "borderLeftColor" (show c)

borderLeftWidth :: Int -> StyleProp
borderLeftWidth = unsafeMkStyleProp "borderLeftWidth"

borderRadius :: Int -> StyleProp
borderRadius = unsafeMkStyleProp "borderRadius"

borderRightColor :: Color -> StyleProp
borderRightColor c = unsafeMkStyleProp "borderRightColor" (show c)

borderRightWidth :: Int -> StyleProp
borderRightWidth = unsafeMkStyleProp "borderRightWidth"

data BorderStyle
  = BorderSolid
  | BorderDotted
  | BorderDashed

borderStyle :: BorderStyle -> StyleProp
borderStyle BorderSolid  = unsafeMkStyleProp "borderStyle" "solid"
borderStyle BorderDotted = unsafeMkStyleProp "borderStyle" "dotted"
borderStyle BorderDashed = unsafeMkStyleProp "borderStyle" "dashed"

borderTopLeftRadius :: Int -> StyleProp
borderTopLeftRadius = unsafeMkStyleProp "borderTopLeftRadius"

borderTopRightRadius :: Int -> StyleProp
borderTopRightRadius = unsafeMkStyleProp "borderTopRightRadius"

borderTopWidth :: Int -> StyleProp
borderTopWidth = unsafeMkStyleProp "borderTopWidth"

borderWidth :: Int -> StyleProp
borderWidth = unsafeMkStyleProp "borderWidth"

bottom :: Int -> StyleProp
bottom = unsafeMkStyleProp "bottom"

-- E

elevation :: Int -> StyleProp
elevation = unsafeMkStyleProp "elevation"

-- F

flex :: Int -> StyleProp
flex = unsafeMkStyleProp "flex"

flexBasis :: Int -> StyleProp
flexBasis = unsafeMkStyleProp "flexBasis"

data FlexDirection
  = Row
  | Column
  | RowReverse
  | ColumnReverse

flexDirection :: FlexDirection -> StyleProp
flexDirection Row           = unsafeMkStyleProp "flexDirection" "row"
flexDirection Column        = unsafeMkStyleProp "flexDirection" "column"
flexDirection ColumnReverse = unsafeMkStyleProp "flexDirection" "column-reverse"
flexDirection RowReverse    = unsafeMkStyleProp "flexDirection" "row-reverse"

flexGrow :: Int -> StyleProp
flexGrow = unsafeMkStyleProp "flexGrow"

flexShrink :: Int -> StyleProp
flexShrink = unsafeMkStyleProp "flexShrink"

data WrapProp = Wrap | NoWrap

flexWrap :: WrapProp -> StyleProp
flexWrap Wrap   = unsafeMkStyleProp "flexWrap" "wrap"
flexWrap NoWrap = unsafeMkStyleProp "flexWrap" "nowrap"

fontFamily :: String -> StyleProp
fontFamily = unsafeMkStyleProp "fontFamily"

fontSize :: Int -> StyleProp
fontSize = unsafeMkStyleProp "fontSize"

data FontStyle = FontNormal | FontItalic

fontStyle :: FontStyle -> StyleProp
fontStyle FontNormal = unsafeMkStyleProp "fontStyle" "normal"
fontStyle FontItalic = unsafeMkStyleProp "fontStyle" "italic"

data FontVariant
  = SmallCap
  | OldStyleNum
  | LiningNum
  | TabularNum
  | ProportionalNum

fontVariant :: Array FontVariant -> StyleProp
fontVariant ary = unsafeMkStyleProp "fontVariant" (map fontVariantNum ary)

fontVariantNum :: FontVariant -> String
fontVariantNum SmallCap        = "small-caps"
fontVariantNum OldStyleNum     = "oldstyle-nums"
fontVariantNum LiningNum       = "lining-nums"
fontVariantNum TabularNum      = "tabular-nums"
fontVariantNum ProportionalNum = "proportional-nums"

data FontWeight
  = WeightNormal
  | WeightBold
  | Weight100
  | Weight200
  | Weight300
  | Weight400
  | Weight500
  | Weight600
  | Weight700
  | Weight800
  | Weight900

fontWeight :: FontWeight -> StyleProp
fontWeight WeightNormal = unsafeMkStyleProp "fontWeight" "normal"
fontWeight WeightBold   = unsafeMkStyleProp "fontWeight" "bold"
fontWeight Weight100    = unsafeMkStyleProp "fontWeight" "100"
fontWeight Weight200    = unsafeMkStyleProp "fontWeight" "200"
fontWeight Weight300    = unsafeMkStyleProp "fontWeight" "300"
fontWeight Weight400    = unsafeMkStyleProp "fontWeight" "400"
fontWeight Weight500    = unsafeMkStyleProp "fontWeight" "500"
fontWeight Weight600    = unsafeMkStyleProp "fontWeight" "600"
fontWeight Weight700    = unsafeMkStyleProp "fontWeight" "700"
fontWeight Weight800    = unsafeMkStyleProp "fontWeight" "800"
fontWeight Weight900    = unsafeMkStyleProp "fontWeight" "900"

-- H

height :: Int -> StyleProp
height = unsafeMkStyleProp "height"

--J

data JustifyContent
  = JustifyContentFlexStart
  | JustifyContentFlexEnd
  | JustifyContentCenter
  | JustifyContentSpaceBetween
  | JustifyContentSpaceAround

justifyContent :: JustifyContent -> StyleProp
justifyContent JustifyContentFlexStart    = unsafeMkStyleProp "justifyContent" "flex-start"
justifyContent JustifyContentFlexEnd      = unsafeMkStyleProp "justifyContent" "flex-end"
justifyContent JustifyContentCenter       = unsafeMkStyleProp "justifyContent" "center"
justifyContent JustifyContentSpaceBetween = unsafeMkStyleProp "justifyContent" "space-between"
justifyContent JustifyContentSpaceAround  = unsafeMkStyleProp "justifyContent" "space-around"

-- L

left :: Int -> StyleProp
left = unsafeMkStyleProp "left"

letterSpacing :: Int -> StyleProp
letterSpacing = unsafeMkStyleProp "letterSpacing"

lineHeight :: Int -> StyleProp
lineHeight = unsafeMkStyleProp "lineHeight"

-- M

margin :: Int -> StyleProp
margin = unsafeMkStyleProp "margin"

marginBottom :: Int -> StyleProp
marginBottom = unsafeMkStyleProp "marginBottom"

marginHorizontal :: Int -> StyleProp
marginHorizontal = unsafeMkStyleProp "marginHorizontal"

marginLeft :: Int -> StyleProp
marginLeft = unsafeMkStyleProp "marginLeft"

marginRight :: Int -> StyleProp
marginRight = unsafeMkStyleProp "marginRight"

marginTop :: Int -> StyleProp
marginTop = unsafeMkStyleProp "marginTop"

marginVertical :: Int -> StyleProp
marginVertical = unsafeMkStyleProp "marginVertical"

maxHeight :: Int -> StyleProp
maxHeight = unsafeMkStyleProp "maxHeight"

maxWidth :: Int -> StyleProp
maxWidth = unsafeMkStyleProp "maxWidth"

minHeight :: Int -> StyleProp
minHeight = unsafeMkStyleProp "minHeight"

minWidth :: Int -> StyleProp
minWidth = unsafeMkStyleProp "minWidth"

-- O

opacity :: Int -> StyleProp
opacity = unsafeMkStyleProp "opacity"

overflow :: Visibility -> StyleProp
overflow Visible = unsafeMkStyleProp "overflow" "visible"
overflow Hidden  = unsafeMkStyleProp "overflow" "hidden"

overlayColor :: String -> StyleProp
overlayColor = unsafeMkStyleProp "overlayColor"

-- P

padding :: Int -> StyleProp
padding = unsafeMkStyleProp "padding"

paddingBottom :: Int -> StyleProp
paddingBottom = unsafeMkStyleProp "paddingBottom"

paddingHorizontal :: Int -> StyleProp
paddingHorizontal = unsafeMkStyleProp "paddingHorizontal"

paddingLeft :: Int -> StyleProp
paddingLeft = unsafeMkStyleProp "paddingLeft"

paddingRight :: Int -> StyleProp
paddingRight = unsafeMkStyleProp "paddingRight"

paddingTop :: Int -> StyleProp
paddingTop = unsafeMkStyleProp "paddingTop"

paddingVertical :: Int -> StyleProp
paddingVertical = unsafeMkStyleProp "paddingVertical"

data Position = Absolute | Relative

position :: Position -> StyleProp
position Absolute = unsafeMkStyleProp "position" "absolute"
position Relative = unsafeMkStyleProp "position" "relative"

-- R

right :: Int -> StyleProp
right = unsafeMkStyleProp "right"

-- S

shadowColor :: Color -> StyleProp
shadowColor c = unsafeMkStyleProp "shadowColor" (show c)

shadowOffset :: {width :: Int, height :: Int} -> StyleProp
shadowOffset = unsafeMkStyleProp "shadowOffset"

shadowOpacity :: Int -> StyleProp
shadowOpacity = unsafeMkStyleProp "shadowOpacity"

shadowRadius :: Int -> StyleProp
shadowRadius = unsafeMkStyleProp "shadowRadius"

-- T

data TextAlign
  = TextAlignAuto
  | TextAlignLeft
  | TextAlignRight
  | TextAlignCenter
  | TextAlignJustify

textAlign :: TextAlign -> StyleProp
textAlign TextAlignAuto    = unsafeMkStyleProp "textAlign" "auto"
textAlign TextAlignLeft    = unsafeMkStyleProp "textAlign" "left"
textAlign TextAlignRight   = unsafeMkStyleProp "textAlign" "right"
textAlign TextAlignCenter  = unsafeMkStyleProp "textAlign" "center"
textAlign TextAlignJustify = unsafeMkStyleProp "textAlign" "justify"

data TextAlignVertical
  = TextAlignVerticalAuto
  | TextAlignVerticalTop
  | TextAlignVerticalBottom
  | TextAlignVerticalCenter

textAlignVertical :: TextAlignVertical -> StyleProp
textAlignVertical TextAlignVerticalAuto   = unsafeMkStyleProp "textAlignVertical" "auto"
textAlignVertical TextAlignVerticalTop    = unsafeMkStyleProp "textAlignVertical" "top"
textAlignVertical TextAlignVerticalBottom = unsafeMkStyleProp "textAlignVertical" "bottom"
textAlignVertical TextAlignVerticalCenter = unsafeMkStyleProp "textAlignVertical" "center"

textDecorationColor :: Color -> StyleProp
textDecorationColor c = unsafeMkStyleProp "textDecorationColor" (show c)

data TextDecorationLine
  = None
  | Underline
  | LineThrough
  | UnderlineLineThrough

textDecorationLine :: TextDecorationLine -> StyleProp
textDecorationLine None                 = unsafeMkStyleProp "textDecorationLine" "none"
textDecorationLine Underline            = unsafeMkStyleProp "textDecorationLine" "underline"
textDecorationLine LineThrough          = unsafeMkStyleProp "textDecorationLine" "line-through"
textDecorationLine UnderlineLineThrough = unsafeMkStyleProp "textDecorationLine" "underline line-through"

data TextDecorationStyle
  = TextSolid
  | TextDouble
  | TextDotted
  | TextDashed

textDecorationStyle :: TextDecorationStyle -> StyleProp
textDecorationStyle TextSolid  = unsafeMkStyleProp "textDecorationStyle" "solid"
textDecorationStyle TextDouble = unsafeMkStyleProp "textDecorationStyle" "double"
textDecorationStyle TextDotted = unsafeMkStyleProp "textDecorationStyle" "dotted"
textDecorationStyle TextDashed = unsafeMkStyleProp "textDecorationStyle" "dashed"

textShadowColor :: Color -> StyleProp
textShadowColor c = unsafeMkStyleProp "textShadowColor" (show c)

textShadowOffset :: {width :: Int, height :: Int} -> StyleProp
textShadowOffset = unsafeMkStyleProp "textShadowOffset"

textShadowRadius :: Int -> StyleProp
textShadowRadius = unsafeMkStyleProp "textShadowRadius"

top :: Int -> StyleProp
top = unsafeMkStyleProp "top"

-- W

width :: Int -> StyleProp
width = unsafeMkStyleProp "width"

data WritingDirection
  = WritingDirectionAuto
  | WritingDirectionLtr
  | WritingDirectionRtl

writingDirection :: WritingDirection -> StyleProp
writingDirection WritingDirectionAuto = unsafeMkStyleProp "writingDirection" "auto"
writingDirection WritingDirectionLtr  = unsafeMkStyleProp "writingDirection" "ltr"
writingDirection WritingDirectionRtl  = unsafeMkStyleProp "writingDirection" "rtl"

-- Z

zIndex :: Int -> StyleProp
zIndex = unsafeMkStyleProp "zIndex"

-- TODO: Transform Props
-- TODO: resizeMode

module RNX.Styles where

import RNX
import RNX.Components
import RNX.Events
import RNX.Props
import RNX.Color
import Prelude hiding (bottom,top)

foreign import data StyleSheet :: *
foreign import data StyleProp :: *

type StyleId = Int
data Style = Style String (Array StyleProp)
type StyleSheet' = Array {name:: String, styles:: Array StyleProp}

foreign import _createStyleSheet :: StyleSheet' -> StyleSheet

createStyleSheet :: Array Style -> StyleSheet
createStyleSheet s =
  _createStyleSheet $ map getStyle s
  where
    getStyle (Style name styleProps) = {name: name, styles: styleProps}

-- TODO: make this type safe!
foreign import getStyleId :: StyleSheet -> String -> StyleId

foreign import unsafeMkStyleProp :: forall val. String -> val -> StyleProp

style :: forall action. StyleId -> Prop action
style = unsafeMkProps "style"

styles :: forall action. Array StyleId -> Prop action
styles = unsafeMkProps "style"

--------- Styles ---------------

data Visibility = Visible | Hidden

-- A

data AlignItems
  = AlignItemsFlexStart
  | AlignItemsFlexEnd
  | AlignItemsCenter
  | AlignItemsStretch

alignItems :: AlignItems -> StyleProp
alignItems AlignItemsFlexStart = unsafeMkStyleProp "alignItems" "flex-start"
alignItems AlignItemsFlexEnd   = unsafeMkStyleProp "alignItems" "flex-end"
alignItems AlignItemsCenter    = unsafeMkStyleProp "alignItems" "center"
alignItems AlignItemsStretch   = unsafeMkStyleProp "alignItems" "stretch"

data AlignSelf
  = AlignSelfAuto
  | AlignSelfFlexStart
  | AlignSelfFlexEnd
  | AlignSelfCenter
  | AlignSelfStretch

alignSelf :: AlignSelf -> StyleProp
alignSelf AlignSelfAuto      = unsafeMkStyleProp "alignSelf" "auto"
alignSelf AlignSelfFlexStart = unsafeMkStyleProp "alignSelf" "flex-start"
alignSelf AlignSelfFlexEnd   = unsafeMkStyleProp "alignSelf" "flex-end"
alignSelf AlignSelfCenter    = unsafeMkStyleProp "alignSelf" "center"
alignSelf AlignSelfStretch   = unsafeMkStyleProp "alignSelf" "stretch"

-- B

backfaceVisibility :: Visibility -> StyleProp
backfaceVisibility Visible = unsafeMkStyleProp "backfaceVisibility" "visible"
backfaceVisibility Hidden  = unsafeMkStyleProp "backfaceVisibility" "hidden"

backgroundVisibility :: Visibility -> StyleProp
backgroundVisibility Visible = unsafeMkStyleProp "backgroundVisibility" "visible"
backgroundVisibility Hidden  = unsafeMkStyleProp "backgroundVisibility" "hidden"

borderBottomColor :: Color -> StyleProp
borderBottomColor c = unsafeMkStyleProp "borderBottomColor" (show c)

borderBottomRightRadius :: Int -> StyleProp
borderBottomRightRadius = unsafeMkStyleProp "borderBottomRightRadius"

borderBottomWidth :: Int -> StyleProp
borderBottomWidth = unsafeMkStyleProp "borderBottomWidth"

borderColor :: Color -> StyleProp
borderColor c = unsafeMkStyleProp "borderColor" (show c)

borderLeftColor :: Color -> StyleProp
borderLeftColor c = unsafeMkStyleProp "borderLeftColor" (show c)

borderLeftWidth :: Int -> StyleProp
borderLeftWidth = unsafeMkStyleProp "borderLeftWidth"

borderRadius :: Int -> StyleProp
borderRadius = unsafeMkStyleProp "borderRadius"

borderRightColor :: Color -> StyleProp
borderRightColor c = unsafeMkStyleProp "borderRightColor" (show c)

borderRightWidth :: Int -> StyleProp
borderRightWidth = unsafeMkStyleProp "borderRightWidth"

data BorderStyle
  = BorderSolid
  | BorderDotted
  | BorderDashed

borderStyle :: BorderStyle -> StyleProp
borderStyle BorderSolid  = unsafeMkStyleProp "borderStyle" "solid"
borderStyle BorderDotted = unsafeMkStyleProp "borderStyle" "dotted"
borderStyle BorderDashed = unsafeMkStyleProp "borderStyle" "dashed"

borderTopLeftRadius :: Int -> StyleProp
borderTopLeftRadius = unsafeMkStyleProp "borderTopLeftRadius"

borderTopRightRadius :: Int -> StyleProp
borderTopRightRadius = unsafeMkStyleProp "borderTopRightRadius"

borderTopWidth :: Int -> StyleProp
borderTopWidth = unsafeMkStyleProp "borderTopWidth"

borderWidth :: Int -> StyleProp
borderWidth = unsafeMkStyleProp "borderWidth"

bottom :: Int -> StyleProp
bottom = unsafeMkStyleProp "bottom"

-- E

elevation :: Int -> StyleProp
elevation = unsafeMkStyleProp "elevation"

-- F

flex :: Int -> StyleProp
flex = unsafeMkStyleProp "flex"

flexBasis :: Int -> StyleProp
flexBasis = unsafeMkStyleProp "flexBasis"

data FlexDirection
  = Row
  | Column
  | RowReverse
  | ColumnReverse

flexDirection :: FlexDirection -> StyleProp
flexDirection Row           = unsafeMkStyleProp "flexDirection" "row"
flexDirection Column        = unsafeMkStyleProp "flexDirection" "column"
flexDirection ColumnReverse = unsafeMkStyleProp "flexDirection" "column-reverse"
flexDirection RowReverse    = unsafeMkStyleProp "flexDirection" "row-reverse"

flexGrow :: Int -> StyleProp
flexGrow = unsafeMkStyleProp "flexGrow"

flexShrink :: Int -> StyleProp
flexShrink = unsafeMkStyleProp "flexShrink"

data WrapProp = Wrap | NoWrap

flexWrap :: WrapProp -> StyleProp
flexWrap Wrap   = unsafeMkStyleProp "flexWrap" "wrap"
flexWrap NoWrap = unsafeMkStyleProp "flexWrap" "nowrap"

fontFamily :: String -> StyleProp
fontFamily = unsafeMkStyleProp "fontFamily"

fontSize :: Int -> StyleProp
fontSize = unsafeMkStyleProp "fontSize"

data FontStyle = FontNormal | FontItalic

fontStyle :: FontStyle -> StyleProp
fontStyle FontNormal = unsafeMkStyleProp "fontStyle" "normal"
fontStyle FontItalic = unsafeMkStyleProp "fontStyle" "italic"

data FontVariant
  = SmallCap
  | OldStyleNum
  | LiningNum
  | TabularNum
  | ProportionalNum

fontVariant :: Array FontVariant -> StyleProp
fontVariant ary = unsafeMkStyleProp "fontVariant" (map fontVariantNum ary)

fontVariantNum :: FontVariant -> String
fontVariantNum SmallCap        = "small-caps"
fontVariantNum OldStyleNum     = "oldstyle-nums"
fontVariantNum LiningNum       = "lining-nums"
fontVariantNum TabularNum      = "tabular-nums"
fontVariantNum ProportionalNum = "proportional-nums"

data FontWeight
  = WeightNormal
  | WeightBold
  | Weight100
  | Weight200
  | Weight300
  | Weight400
  | Weight500
  | Weight600
  | Weight700
  | Weight800
  | Weight900

fontWeight :: FontWeight -> StyleProp
fontWeight WeightNormal = unsafeMkStyleProp "fontWeight" "normal"
fontWeight WeightBold   = unsafeMkStyleProp "fontWeight" "bold"
fontWeight Weight100    = unsafeMkStyleProp "fontWeight" "100"
fontWeight Weight200    = unsafeMkStyleProp "fontWeight" "200"
fontWeight Weight300    = unsafeMkStyleProp "fontWeight" "300"
fontWeight Weight400    = unsafeMkStyleProp "fontWeight" "400"
fontWeight Weight500    = unsafeMkStyleProp "fontWeight" "500"
fontWeight Weight600    = unsafeMkStyleProp "fontWeight" "600"
fontWeight Weight700    = unsafeMkStyleProp "fontWeight" "700"
fontWeight Weight800    = unsafeMkStyleProp "fontWeight" "800"
fontWeight Weight900    = unsafeMkStyleProp "fontWeight" "900"

-- H

height :: Int -> StyleProp
height = unsafeMkStyleProp "height"

--J

data JustifyContent
  = JustifyContentFlexStart
  | JustifyContentFlexEnd
  | JustifyContentCenter
  | JustifyContentSpaceBetween
  | JustifyContentSpaceAround

justifyContent :: JustifyContent -> StyleProp
justifyContent JustifyContentFlexStart    = unsafeMkStyleProp "justifyContent" "flex-start"
justifyContent JustifyContentFlexEnd      = unsafeMkStyleProp "justifyContent" "flex-end"
justifyContent JustifyContentCenter       = unsafeMkStyleProp "justifyContent" "center"
justifyContent JustifyContentSpaceBetween = unsafeMkStyleProp "justifyContent" "space-between"
justifyContent JustifyContentSpaceAround  = unsafeMkStyleProp "justifyContent" "space-around"

-- L

left :: Int -> StyleProp
left = unsafeMkStyleProp "left"

letterSpacing :: Int -> StyleProp
letterSpacing = unsafeMkStyleProp "letterSpacing"

lineHeight :: Int -> StyleProp
lineHeight = unsafeMkStyleProp "lineHeight"

-- M

margin :: Int -> StyleProp
margin = unsafeMkStyleProp "margin"

marginBottom :: Int -> StyleProp
marginBottom = unsafeMkStyleProp "marginBottom"

marginHorizontal :: Int -> StyleProp
marginHorizontal = unsafeMkStyleProp "marginHorizontal"

marginLeft :: Int -> StyleProp
marginLeft = unsafeMkStyleProp "marginLeft"

marginRight :: Int -> StyleProp
marginRight = unsafeMkStyleProp "marginRight"

marginTop :: Int -> StyleProp
marginTop = unsafeMkStyleProp "marginTop"

marginVertical :: Int -> StyleProp
marginVertical = unsafeMkStyleProp "marginVertical"

maxHeight :: Int -> StyleProp
maxHeight = unsafeMkStyleProp "maxHeight"

maxWidth :: Int -> StyleProp
maxWidth = unsafeMkStyleProp "maxWidth"

minHeight :: Int -> StyleProp
minHeight = unsafeMkStyleProp "minHeight"

minWidth :: Int -> StyleProp
minWidth = unsafeMkStyleProp "minWidth"

-- O

opacity :: Int -> StyleProp
opacity = unsafeMkStyleProp "opacity"

overflow :: Visibility -> StyleProp
overflow Visible = unsafeMkStyleProp "overflow" "visible"
overflow Hidden  = unsafeMkStyleProp "overflow" "hidden"

overlayColor :: String -> StyleProp
overlayColor = unsafeMkStyleProp "overlayColor"

-- P

padding :: Int -> StyleProp
padding = unsafeMkStyleProp "padding"

paddingBottom :: Int -> StyleProp
paddingBottom = unsafeMkStyleProp "paddingBottom"

paddingHorizontal :: Int -> StyleProp
paddingHorizontal = unsafeMkStyleProp "paddingHorizontal"

paddingLeft :: Int -> StyleProp
paddingLeft = unsafeMkStyleProp "paddingLeft"

paddingRight :: Int -> StyleProp
paddingRight = unsafeMkStyleProp "paddingRight"

paddingTop :: Int -> StyleProp
paddingTop = unsafeMkStyleProp "paddingTop"

paddingVertical :: Int -> StyleProp
paddingVertical = unsafeMkStyleProp "paddingVertical"

data Position = Absolute | Relative

position :: Position -> StyleProp
position Absolute = unsafeMkStyleProp "position" "absolute"
position Relative = unsafeMkStyleProp "position" "relative"

-- R

right :: Int -> StyleProp
right = unsafeMkStyleProp "right"

-- S

shadowColor :: Color -> StyleProp
shadowColor c = unsafeMkStyleProp "shadowColor" (show c)

shadowOffset :: {width :: Int, height :: Int} -> StyleProp
shadowOffset = unsafeMkStyleProp "shadowOffset"

shadowOpacity :: Int -> StyleProp
shadowOpacity = unsafeMkStyleProp "shadowOpacity"

shadowRadius :: Int -> StyleProp
shadowRadius = unsafeMkStyleProp "shadowRadius"

-- T

data TextAlign
  = TextAlignAuto
  | TextAlignLeft
  | TextAlignRight
  | TextAlignCenter
  | TextAlignJustify

textAlign :: TextAlign -> StyleProp
textAlign TextAlignAuto    = unsafeMkStyleProp "textAlign" "auto"
textAlign TextAlignLeft    = unsafeMkStyleProp "textAlign" "left"
textAlign TextAlignRight   = unsafeMkStyleProp "textAlign" "right"
textAlign TextAlignCenter  = unsafeMkStyleProp "textAlign" "center"
textAlign TextAlignJustify = unsafeMkStyleProp "textAlign" "justify"

data TextAlignVertical
  = TextAlignVerticalAuto
  | TextAlignVerticalTop
  | TextAlignVerticalBottom
  | TextAlignVerticalCenter

textAlignVertical :: TextAlignVertical -> StyleProp
textAlignVertical TextAlignVerticalAuto   = unsafeMkStyleProp "textAlignVertical" "auto"
textAlignVertical TextAlignVerticalTop    = unsafeMkStyleProp "textAlignVertical" "top"
textAlignVertical TextAlignVerticalBottom = unsafeMkStyleProp "textAlignVertical" "bottom"
textAlignVertical TextAlignVerticalCenter = unsafeMkStyleProp "textAlignVertical" "center"

textDecorationColor :: Color -> StyleProp
textDecorationColor c = unsafeMkStyleProp "textDecorationColor" (show c)

data TextDecorationLine
  = None
  | Underline
  | LineThrough
  | UnderlineLineThrough

textDecorationLine :: TextDecorationLine -> StyleProp
textDecorationLine None                 = unsafeMkStyleProp "textDecorationLine" "none"
textDecorationLine Underline            = unsafeMkStyleProp "textDecorationLine" "underline"
textDecorationLine LineThrough          = unsafeMkStyleProp "textDecorationLine" "line-through"
textDecorationLine UnderlineLineThrough = unsafeMkStyleProp "textDecorationLine" "underline line-through"

data TextDecorationStyle
  = TextSolid
  | TextDouble
  | TextDotted
  | TextDashed

textDecorationStyle :: TextDecorationStyle -> StyleProp
textDecorationStyle TextSolid  = unsafeMkStyleProp "textDecorationStyle" "solid"
textDecorationStyle TextDouble = unsafeMkStyleProp "textDecorationStyle" "double"
textDecorationStyle TextDotted = unsafeMkStyleProp "textDecorationStyle" "dotted"
textDecorationStyle TextDashed = unsafeMkStyleProp "textDecorationStyle" "dashed"

textShadowColor :: Color -> StyleProp
textShadowColor c = unsafeMkStyleProp "textShadowColor" (show c)

textShadowOffset :: {width :: Int, height :: Int} -> StyleProp
textShadowOffset = unsafeMkStyleProp "textShadowOffset"

textShadowRadius :: Int -> StyleProp
textShadowRadius = unsafeMkStyleProp "textShadowRadius"

top :: Int -> StyleProp
top = unsafeMkStyleProp "top"

-- W

width :: Int -> StyleProp
width = unsafeMkStyleProp "width"

data WritingDirection
  = WritingDirectionAuto
  | WritingDirectionLtr
  | WritingDirectionRtl

writingDirection :: WritingDirection -> StyleProp
writingDirection WritingDirectionAuto = unsafeMkStyleProp "writingDirection" "auto"
writingDirection WritingDirectionLtr  = unsafeMkStyleProp "writingDirection" "ltr"
writingDirection WritingDirectionRtl  = unsafeMkStyleProp "writingDirection" "rtl"

-- Z

zIndex :: Int -> StyleProp
zIndex = unsafeMkStyleProp "zIndex"

-- TODO: Transform Props
-- TODO: resizeMode


Use `if _` instead of `case _ of`

Use `if _` instead of `case _ of`

module Halogen.VDom.DOM.Prop
  ( Prop(..)
  , ElemRef(..)
  , PropValue
  , propFromString
  , propFromBoolean
  , propFromInt
  , propFromNumber
  , buildProp
  ) where

import Prelude

import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe(..))
import Data.Nullable (null, toNullable)
import Data.Tuple (Tuple(..), fst, snd)
import Effect (Effect)
import Effect.Ref as Ref
import Effect.Uncurried as EFn
import Foreign (typeOf)
import Foreign.Object as Object
import Halogen.VDom as V
import Halogen.VDom.Machine (Step'(..), mkStep)
import Halogen.VDom.Types (Namespace(..))
import Halogen.VDom.Util as Util
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element) as DOM
import Web.Event.Event (EventType(..), Event) as DOM
import Web.Event.EventTarget (eventListener) as DOM

-- | Attributes, properties, event handlers, and element lifecycles.
-- | Parameterized by the type of handlers outputs.
data Prop a
  = Attribute (Maybe Namespace) String String
  | Property String PropValue
  | Handler DOM.EventType (DOM.Event → Maybe a)
  | Ref (ElemRef DOM.Element → Maybe a)

instance functorProp ∷ Functor Prop where
  map f (Handler ty g) = Handler ty (map f <$> g)
  map f (Ref g) = Ref (map f <$> g)
  map f p = unsafeCoerce p

data ElemRef a
  = Created a
  | Removed a

instance functorElemRef ∷ Functor ElemRef where
  map f (Created a) = Created (f a)
  map f (Removed a) = Removed (f a)

foreign import data PropValue ∷ Type

propFromString ∷ String → PropValue
propFromString = unsafeCoerce

propFromBoolean ∷ Boolean → PropValue
propFromBoolean = unsafeCoerce

propFromInt ∷ Int → PropValue
propFromInt = unsafeCoerce

propFromNumber ∷ Number → PropValue
propFromNumber = unsafeCoerce

-- | A `Machine`` for applying attributes, properties, and event handlers.
-- | An emitter effect must be provided to respond to events. For example,
-- | to allow arbitrary effects in event handlers, one could use `id`.
buildProp
  ∷ ∀ a
  . (a → Effect Unit)
  → DOM.Element
  → V.Machine (Array (Prop a)) Unit
buildProp emit el = renderProp
  where
  renderProp = EFn.mkEffectFn1 \ps1 → do
    events ← Util.newMutMap
    ps1' ← EFn.runEffectFn3 Util.strMapWithIxE ps1 propToStrKey (applyProp events)
    let
      state =
        { events: Util.unsafeFreeze events
        , props: ps1'
        }
    pure $ mkStep $ Step unit state patchProp haltProp

  patchProp = EFn.mkEffectFn2 \state ps2 → do
    events ← Util.newMutMap
    let
      { events: prevEvents, props: ps1 } = state
      onThese = Fn.runFn2 diffProp prevEvents events
      onThis = removeProp prevEvents
      onThat = applyProp events
    props ← EFn.runEffectFn6 Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
    let
      nextState =
        { events: Util.unsafeFreeze events
        , props
        }
    pure $ mkStep $ Step unit nextState patchProp haltProp

  haltProp = EFn.mkEffectFn1 \state → do
    case Object.lookup "ref" state.props of
      Just (Ref f) →
        EFn.runEffectFn1 mbEmit (f (Removed el))
      _ → pure unit

  mbEmit = EFn.mkEffectFn1 case _ of
    Just a → emit a
    _ → pure unit

  applyProp events = EFn.mkEffectFn3 \_ _ v →
    case v of
      Attribute ns attr val → do
        EFn.runEffectFn4 Util.setAttribute (toNullable ns) attr val el
        pure v
      Property prop val → do
        EFn.runEffectFn3 setProperty prop val el
        pure v
      Handler (DOM.EventType ty) f → do
        case Fn.runFn2 Util.unsafeGetAny ty events of
          handler | Fn.runFn2 Util.unsafeHasAny ty events → do
            Ref.write f (snd handler)
            pure v
          _ → do
            ref ← Ref.new f
            listener ← DOM.eventListener \ev → do
              f' ← Ref.read ref
              EFn.runEffectFn1 mbEmit (f' ev)
            EFn.runEffectFn3 Util.pokeMutMap ty (Tuple listener ref) events
            EFn.runEffectFn3 Util.addEventListener ty listener el
            pure v
      Ref f → do
        EFn.runEffectFn1 mbEmit (f (Created el))
        pure v

  diffProp = Fn.mkFn2 \prevEvents events → EFn.mkEffectFn4 \_ _ v1 v2 →
    case v1, v2 of
      Attribute _ _ val1, Attribute ns2 attr2 val2 →
        if val1 == val2
          then pure v2
          else do
            EFn.runEffectFn4 Util.setAttribute (toNullable ns2) attr2 val2 el
            pure v2
      Property _ val1, Property prop2 val2 →
        case Fn.runFn2 Util.refEq val1 val2, prop2 of
          true, _ →
            pure v2
          _, "value" → do
            let elVal = Fn.runFn2 unsafeGetProperty "value" el
            if Fn.runFn2 Util.refEq elVal val2
              then pure v2
              else do
                EFn.runEffectFn3 setProperty prop2 val2 el
                pure v2
          _, _ → do
            EFn.runEffectFn3 setProperty prop2 val2 el
            pure v2
      Handler _ _, Handler (DOM.EventType ty) f → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        Ref.write f (snd handler)
        EFn.runEffectFn3 Util.pokeMutMap ty handler events
        pure v2
      _, _ →
        pure v2

  removeProp prevEvents = EFn.mkEffectFn2 \_ v →
    case v of
      Attribute ns attr _ →
        EFn.runEffectFn3 Util.removeAttribute (toNullable ns) attr el
      Property prop _ →
        EFn.runEffectFn2 removeProperty prop el
      Handler (DOM.EventType ty) _ → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        EFn.runEffectFn3 Util.removeEventListener ty (fst handler) el
      Ref _ →
        pure unit

propToStrKey ∷ ∀ i. Prop i → String
propToStrKey = case _ of
  Attribute (Just (Namespace ns)) attr _ → "attr/" <> ns <> ":" <> attr
  Attribute _ attr _ → "attr/:" <> attr
  Property prop _ → "prop/" <> prop
  Handler (DOM.EventType ty) _ → "handler/" <> ty
  Ref _ → "ref"

setProperty ∷ EFn.EffectFn3 String PropValue DOM.Element Unit
setProperty = Util.unsafeSetAny

unsafeGetProperty ∷ Fn.Fn2 String DOM.Element PropValue
unsafeGetProperty = Util.unsafeGetAny

removeProperty ∷ EFn.EffectFn2 String DOM.Element Unit
removeProperty = EFn.mkEffectFn2 \key el →
  EFn.runEffectFn3 Util.hasAttribute null key el >>= if _
    then EFn.runEffectFn3 Util.removeAttribute null key el
    else case typeOf (Fn.runFn2 Util.unsafeGetAny key el) of
      "string" → EFn.runEffectFn3 Util.unsafeSetAny key "" el
      _        → case key of
        "rowSpan" → EFn.runEffectFn3 Util.unsafeSetAny key 1 el
        "colSpan" → EFn.runEffectFn3 Util.unsafeSetAny key 1 el
        _ → EFn.runEffectFn3 Util.unsafeSetAny key Util.jsUndefined el

module Halogen.VDom.DOM.Prop
  ( Prop(..)
  , ElemRef(..)
  , PropValue
  , propFromString
  , propFromBoolean
  , propFromInt
  , propFromNumber
  , buildProp
  ) where

import Prelude

import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe(..))
import Data.Nullable (null, toNullable)
import Data.Tuple (Tuple(..), fst, snd)
import Effect (Effect)
import Effect.Ref as Ref
import Effect.Uncurried as EFn
import Foreign (typeOf)
import Foreign.Object as Object
import Halogen.VDom as V
import Halogen.VDom.Machine (Step'(..), mkStep)
import Halogen.VDom.Types (Namespace(..))
import Halogen.VDom.Util as Util
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element (Element) as DOM
import Web.Event.Event (EventType(..), Event) as DOM
import Web.Event.EventTarget (eventListener) as DOM

-- | Attributes, properties, event handlers, and element lifecycles.
-- | Parameterized by the type of handlers outputs.
data Prop a
  = Attribute (Maybe Namespace) String String
  | Property String PropValue
  | Handler DOM.EventType (DOM.Event → Maybe a)
  | Ref (ElemRef DOM.Element → Maybe a)

instance functorProp ∷ Functor Prop where
  map f (Handler ty g) = Handler ty (map f <$> g)
  map f (Ref g) = Ref (map f <$> g)
  map f p = unsafeCoerce p

data ElemRef a
  = Created a
  | Removed a

instance functorElemRef ∷ Functor ElemRef where
  map f (Created a) = Created (f a)
  map f (Removed a) = Removed (f a)

foreign import data PropValue ∷ Type

propFromString ∷ String → PropValue
propFromString = unsafeCoerce

propFromBoolean ∷ Boolean → PropValue
propFromBoolean = unsafeCoerce

propFromInt ∷ Int → PropValue
propFromInt = unsafeCoerce

propFromNumber ∷ Number → PropValue
propFromNumber = unsafeCoerce

-- | A `Machine`` for applying attributes, properties, and event handlers.
-- | An emitter effect must be provided to respond to events. For example,
-- | to allow arbitrary effects in event handlers, one could use `id`.
buildProp
  ∷ ∀ a
  . (a → Effect Unit)
  → DOM.Element
  → V.Machine (Array (Prop a)) Unit
buildProp emit el = renderProp
  where
  renderProp = EFn.mkEffectFn1 \ps1 → do
    events ← Util.newMutMap
    ps1' ← EFn.runEffectFn3 Util.strMapWithIxE ps1 propToStrKey (applyProp events)
    let
      state =
        { events: Util.unsafeFreeze events
        , props: ps1'
        }
    pure $ mkStep $ Step unit state patchProp haltProp

  patchProp = EFn.mkEffectFn2 \state ps2 → do
    events ← Util.newMutMap
    let
      { events: prevEvents, props: ps1 } = state
      onThese = Fn.runFn2 diffProp prevEvents events
      onThis = removeProp prevEvents
      onThat = applyProp events
    props ← EFn.runEffectFn6 Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
    let
      nextState =
        { events: Util.unsafeFreeze events
        , props
        }
    pure $ mkStep $ Step unit nextState patchProp haltProp

  haltProp = EFn.mkEffectFn1 \state → do
    case Object.lookup "ref" state.props of
      Just (Ref f) →
        EFn.runEffectFn1 mbEmit (f (Removed el))
      _ → pure unit

  mbEmit = EFn.mkEffectFn1 case _ of
    Just a → emit a
    _ → pure unit

  applyProp events = EFn.mkEffectFn3 \_ _ v →
    case v of
      Attribute ns attr val → do
        EFn.runEffectFn4 Util.setAttribute (toNullable ns) attr val el
        pure v
      Property prop val → do
        EFn.runEffectFn3 setProperty prop val el
        pure v
      Handler (DOM.EventType ty) f → do
        case Fn.runFn2 Util.unsafeGetAny ty events of
          handler | Fn.runFn2 Util.unsafeHasAny ty events → do
            Ref.write f (snd handler)
            pure v
          _ → do
            ref ← Ref.new f
            listener ← DOM.eventListener \ev → do
              f' ← Ref.read ref
              EFn.runEffectFn1 mbEmit (f' ev)
            EFn.runEffectFn3 Util.pokeMutMap ty (Tuple listener ref) events
            EFn.runEffectFn3 Util.addEventListener ty listener el
            pure v
      Ref f → do
        EFn.runEffectFn1 mbEmit (f (Created el))
        pure v

  diffProp = Fn.mkFn2 \prevEvents events → EFn.mkEffectFn4 \_ _ v1 v2 →
    case v1, v2 of
      Attribute _ _ val1, Attribute ns2 attr2 val2 →
        if val1 == val2
          then pure v2
          else do
            EFn.runEffectFn4 Util.setAttribute (toNullable ns2) attr2 val2 el
            pure v2
      Property _ val1, Property prop2 val2 →
        case Fn.runFn2 Util.refEq val1 val2, prop2 of
          true, _ →
            pure v2
          _, "value" → do
            let elVal = Fn.runFn2 unsafeGetProperty "value" el
            if Fn.runFn2 Util.refEq elVal val2
              then pure v2
              else do
                EFn.runEffectFn3 setProperty prop2 val2 el
                pure v2
          _, _ → do
            EFn.runEffectFn3 setProperty prop2 val2 el
            pure v2
      Handler _ _, Handler (DOM.EventType ty) f → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        Ref.write f (snd handler)
        EFn.runEffectFn3 Util.pokeMutMap ty handler events
        pure v2
      _, _ →
        pure v2

  removeProp prevEvents = EFn.mkEffectFn2 \_ v →
    case v of
      Attribute ns attr _ →
        EFn.runEffectFn3 Util.removeAttribute (toNullable ns) attr el
      Property prop _ →
        EFn.runEffectFn2 removeProperty prop el
      Handler (DOM.EventType ty) _ → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        EFn.runEffectFn3 Util.removeEventListener ty (fst handler) el
      Ref _ →
        pure unit

propToStrKey ∷ ∀ i. Prop i → String
propToStrKey = case _ of
  Attribute (Just (Namespace ns)) attr _ → "attr/" <> ns <> ":" <> attr
  Attribute _ attr _ → "attr/:" <> attr
  Property prop _ → "prop/" <> prop
  Handler (DOM.EventType ty) _ → "handler/" <> ty
  Ref _ → "ref"

setProperty ∷ EFn.EffectFn3 String PropValue DOM.Element Unit
setProperty = Util.unsafeSetAny

unsafeGetProperty ∷ Fn.Fn2 String DOM.Element PropValue
unsafeGetProperty = Util.unsafeGetAny

removeProperty ∷ EFn.EffectFn2 String DOM.Element Unit
removeProperty = EFn.mkEffectFn2 \key el →
  EFn.runEffectFn3 Util.hasAttribute null key el >>= case _ of
    true -> EFn.runEffectFn3 Util.removeAttribute null key el
    false -> case typeOf (Fn.runFn2 Util.unsafeGetAny key el) of
      "string" → EFn.runEffectFn3 Util.unsafeSetAny key "" el
      _        → case key of
        "rowSpan" → EFn.runEffectFn3 Util.unsafeSetAny key 1 el
        "colSpan" → EFn.runEffectFn3 Util.unsafeSetAny key 1 el
        _ → EFn.runEffectFn3 Util.unsafeSetAny key Util.jsUndefined el


check if process is undefined

check if process is undefined

module Signal.Time
  ( Time(..)
  , every
  , millisecond
  , now
  , second
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import Signal (constant, Signal(..))

type Time = Number

millisecond :: Time
millisecond = 1

second :: Time
second = 1000

foreign import everyP """
  function everyP(constant, now, t) {
    var out = constant(now());
    setInterval(function() {
      out.set(now());
    }, t);
    return out;
  }""" :: forall c e. Fn3 (c -> Signal c) (Eff (timer :: Timer | e) Time) Time (Signal Time)

every :: Time -> Signal Time
every = runFn3 everyP constant now

-- |Returns the number of milliseconds since an arbitrary, but constant, time in the past.
foreign import now """
  function now() {
    var perf = typeof performance !== 'undefined' ? performance : null,
        process = typeof process !== 'undefined' ? process : null;
    return (
      perf && (perf.now || perf.webkitNow || perf.msNow || perf.oNow || perf.mozNow) ||
      (process && process.hrtime && function() {
        var t = process.hrtime();
        return (t[0] * 1e9 + t[1]) / 1e6;
      }) ||
      Date.now
    ).call(perf);
  }""" :: forall e. Eff (timer :: Timer | e) Time

module Signal.Time
  ( Time(..)
  , every
  , millisecond
  , now
  , second
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import Signal (constant, Signal(..))

type Time = Number

millisecond :: Time
millisecond = 1

second :: Time
second = 1000

foreign import everyP """
  function everyP(constant, now, t) {
    var out = constant(now());
    setInterval(function() {
      out.set(now());
    }, t);
    return out;
  }""" :: forall c e. Fn3 (c -> Signal c) (Eff (timer :: Timer | e) Time) Time (Signal Time)

every :: Time -> Signal Time
every = runFn3 everyP constant now

-- |Returns the number of milliseconds since an arbitrary, but constant, time in the past.
foreign import now """
  function now() {
    var perf = typeof performance !== 'undefined' ? performance : null;
    return (
      perf && (perf.now || perf.webkitNow || perf.msNow || perf.oNow || perf.mozNow) ||
      (process && process.hrtime && function() {
        var t = process.hrtime();
        return (t[0] * 1e9 + t[1]) / 1e6;
      }) ||
      Date.now
    ).call(perf);
  }""" :: forall e. Eff (timer :: Timer | e) Time


add fixme comment

add fixme comment

module LambdaCube.WebGL.Data where

import Prelude
import Control.Monad.Eff.Console as C
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Graphics.WebGLRaw as GL
import Graphics.WebGLTexture as GLTex
import Data.Maybe
import Data.Tuple
import Data.Array
import Data.Foldable
import Data.Traversable

import LambdaCube.IR
import LambdaCube.LinearBase
import LambdaCube.WebGL.Type
import LambdaCube.WebGL.Util

compileBuffer :: Array LCArray -> GFX Buffer
compileBuffer arrs = do
    let offsets = [0] `append` scanl (\s (Array t a) -> s + sizeOfArrayType t * length a) 0 arrs -- BUG:  scanl (+) 0 [1,1] == [1,2] =!= [0,1,2]
        size = case last offsets of
          Just s  -> s
          Nothing -> 0
    b <- newArrayBuffer size
    descs <- for (zip arrs $ take (length arrs) offsets) $ \(Tuple (Array t a) o) -> do
      let len     = length a
          bytes   = len * sizeOfArrayType t
          newView = case t of
            ArrWord8  -> newWord8View
            ArrWord16 -> newWord16View
            ArrInt8   -> newInt8View
            ArrInt16  -> newInt16View
            ArrFloat  -> newFloatView
      view <- newView b o len
      setArrayView view a
      pure {arrType: t, arrLength: len, arrOffset: o, arrSize: bytes, arrView: view}

    bo <- GL.createBuffer_
    GL.bindBuffer_ GL._ARRAY_BUFFER bo
    bufferDataAlloc GL._ARRAY_BUFFER size GL._STATIC_DRAW
    bufferSubDataArrayBuffer GL._ARRAY_BUFFER 0 b
    GL.bindBuffer_ GL._ARRAY_BUFFER nullWebGLBuffer
    pure {arrays: descs, glBuffer: bo, buffer: b}

updateBuffer :: Buffer -> Array (Tuple Int LCArray) -> GFX Unit
updateBuffer b arrs = do
  for_ arrs $ \(Tuple i (Array t a)) -> case b.arrays !! i of
    Nothing -> throwException $ error "wrong index"
    Just d  -> do
      when (arrayTypeToGLType t /= arrayTypeToGLType d.arrType) $ throwException $ error "type mismatch"
      when (length a /= d.arrLength) $ throwException $ error "size mismatch"
      setArrayView d.arrView a
      bufferSubDataArrayView GL._ARRAY_BUFFER d.arrOffset d.arrView

uploadTexture2DToGPU :: String -> (TextureData -> GFX Unit) -> GFX Unit
uploadTexture2DToGPU name action = do
  to <- GL.createTexture_
  loadImage_ name \image -> do
    -- FIXME: basic implementation, the filter should be controlled by the pipeline not by the input
    GLTex.handleLoad2D (GLTex.WebGLTex to) GLTex.LINEAR image
    action $ TextureData to

module LambdaCube.WebGL.Data where

import Prelude
import Control.Monad.Eff.Console as C
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Graphics.WebGLRaw as GL
import Graphics.WebGLTexture as GLTex
import Data.Maybe
import Data.Tuple
import Data.Array
import Data.Foldable
import Data.Traversable

import LambdaCube.IR
import LambdaCube.LinearBase
import LambdaCube.WebGL.Type
import LambdaCube.WebGL.Util

compileBuffer :: Array LCArray -> GFX Buffer
compileBuffer arrs = do
    let offsets = [0] `append` scanl (\s (Array t a) -> s + sizeOfArrayType t * length a) 0 arrs -- BUG:  scanl (+) 0 [1,1] == [1,2] =!= [0,1,2]
        size = case last offsets of
          Just s  -> s
          Nothing -> 0
    b <- newArrayBuffer size
    descs <- for (zip arrs $ take (length arrs) offsets) $ \(Tuple (Array t a) o) -> do
      let len     = length a
          bytes   = len * sizeOfArrayType t
          newView = case t of
            ArrWord8  -> newWord8View
            ArrWord16 -> newWord16View
            ArrInt8   -> newInt8View
            ArrInt16  -> newInt16View
            ArrFloat  -> newFloatView
      view <- newView b o len
      setArrayView view a
      pure {arrType: t, arrLength: len, arrOffset: o, arrSize: bytes, arrView: view}

    bo <- GL.createBuffer_
    GL.bindBuffer_ GL._ARRAY_BUFFER bo
    bufferDataAlloc GL._ARRAY_BUFFER size GL._STATIC_DRAW
    bufferSubDataArrayBuffer GL._ARRAY_BUFFER 0 b
    GL.bindBuffer_ GL._ARRAY_BUFFER nullWebGLBuffer
    pure {arrays: descs, glBuffer: bo, buffer: b}

updateBuffer :: Buffer -> Array (Tuple Int LCArray) -> GFX Unit
updateBuffer b arrs = do
  for_ arrs $ \(Tuple i (Array t a)) -> case b.arrays !! i of
    Nothing -> throwException $ error "wrong index"
    Just d  -> do
      when (arrayTypeToGLType t /= arrayTypeToGLType d.arrType) $ throwException $ error "type mismatch"
      when (length a /= d.arrLength) $ throwException $ error "size mismatch"
      setArrayView d.arrView a
      bufferSubDataArrayView GL._ARRAY_BUFFER d.arrOffset d.arrView

uploadTexture2DToGPU :: String -> (TextureData -> GFX Unit) -> GFX Unit
uploadTexture2DToGPU name action = do
  to <- GL.createTexture_
  loadImage_ name \image -> do
    -- HINT: basic implementation
    GLTex.handleLoad2D (GLTex.WebGLTex to) GLTex.MIPMAP image
    action $ TextureData to


Update MonadSt to have Monad superclass (#45)

module Control.Monad.ST.Class where

import Prelude

import Control.Monad.ST (ST)
import Control.Monad.ST.Global (Global)
import Control.Monad.ST.Global as Global
import Effect (Effect)

class Monad m <= MonadST s m | m -> s where
  liftST :: ST s ~> m

instance monadSTEffect :: MonadST Global Effect where
  liftST = Global.toEffect

instance monadSTST :: MonadST s (ST s) where
  liftST = identity

module Control.Monad.ST.Class where

import Prelude

import Control.Monad.ST (ST)
import Control.Monad.ST.Global (Global)
import Control.Monad.ST.Global as Global
import Effect (Effect)

class MonadST s m | m -> s where
  liftST :: ST s ~> m

instance monadSTEffect :: MonadST Global Effect where
  liftST = Global.toEffect

instance monadSTST :: MonadST s (ST s) where
  liftST = identity


Add `Chr` newtype show instance

Add `Chr` newtype show instance

module Genetics.Browser.Units where

-- TODO: feels like there are better ways of dealing with this (units/dimensions);
-- need to look for libraries

import Prelude
import Data.Foreign.Class (class Decode, class Encode)
import Data.Lens (iso)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Types (Iso')
import Data.Newtype (class Newtype, unwrap)
import Test.QuickCheck (class Arbitrary)

newtype Bp = Bp Number
derive instance newtypeBp :: Newtype Bp _
derive newtype instance eqBp :: Eq Bp
derive newtype instance ordBp :: Ord Bp
derive newtype instance fieldBp :: Field Bp
derive newtype instance semiringBp :: Semiring Bp
derive newtype instance ringBp :: Ring Bp
derive newtype instance arbitraryBp :: Arbitrary Bp
derive newtype instance encodeBp :: Encode Bp
derive newtype instance decodeBp :: Decode Bp

instance showBp :: Show Bp where
  show (Bp n) = show n <> "Bp"

_Bp :: Iso' Bp Number
_Bp = _Newtype

_MBp :: Iso' MBp Number
_MBp = _Newtype

-- probably not actually an isomorphism due to floating point inaccuracies
_BpMBp :: Iso' Bp MBp
_BpMBp = iso mbp bp

newtype MBp = MBp Number
derive instance newtypeMBp :: Newtype MBp _
derive newtype instance eqMBp :: Eq MBp
derive newtype instance ordMBp :: Ord MBp
derive newtype instance fieldMBp :: Field MBp
derive newtype instance semiringMBp :: Semiring MBp
derive newtype instance ringMBp :: Ring MBp
derive newtype instance arbitraryMBp :: Arbitrary MBp
derive newtype instance encodeMBp :: Encode MBp
derive newtype instance decodeMBp :: Decode MBp

instance showMBp :: Show MBp where
  show (MBp n) = show n <> "MBp"

class Field a <= HCoordinate a where
  bp :: a -> Bp
  mbp :: a -> MBp

toScreen :: ∀ c. HCoordinate c => c -> c -> c -> Number
toScreen offset scale x = unwrap ((x' - offset') * scale')
  where offset' = bp offset
        scale' = bp scale
        x' = bp x

instance hCoordBp :: HCoordinate Bp where
  bp = id
  mbp (Bp x) = MBp (x * 0.000001)

instance hCoordMBp :: HCoordinate MBp where
  bp (MBp x) = Bp (x * 1000000.0)
  mbp  = id

newtype Chr = Chr String
derive instance newtypeChr :: Newtype Chr _
derive newtype instance eqChr :: Eq Chr
derive newtype instance encodeChr :: Encode Chr
derive newtype instance decodeChr :: Decode Chr
derive newtype instance showChr :: Show Chr

_Chr :: Iso' Chr String
_Chr = _Newtype

module Genetics.Browser.Units where

-- TODO: feels like there are better ways of dealing with this (units/dimensions);
-- need to look for libraries

import Prelude
import Data.Foreign.Class (class Decode, class Encode)
import Data.Lens (iso)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Types (Iso')
import Data.Newtype (class Newtype, unwrap)
import Test.QuickCheck (class Arbitrary)

newtype Bp = Bp Number
derive instance newtypeBp :: Newtype Bp _
derive newtype instance eqBp :: Eq Bp
derive newtype instance ordBp :: Ord Bp
derive newtype instance fieldBp :: Field Bp
derive newtype instance semiringBp :: Semiring Bp
derive newtype instance ringBp :: Ring Bp
derive newtype instance arbitraryBp :: Arbitrary Bp
derive newtype instance encodeBp :: Encode Bp
derive newtype instance decodeBp :: Decode Bp

instance showBp :: Show Bp where
  show (Bp n) = show n <> "Bp"

_Bp :: Iso' Bp Number
_Bp = _Newtype

_MBp :: Iso' MBp Number
_MBp = _Newtype

-- probably not actually an isomorphism due to floating point inaccuracies
_BpMBp :: Iso' Bp MBp
_BpMBp = iso mbp bp

newtype MBp = MBp Number
derive instance newtypeMBp :: Newtype MBp _
derive newtype instance eqMBp :: Eq MBp
derive newtype instance ordMBp :: Ord MBp
derive newtype instance fieldMBp :: Field MBp
derive newtype instance semiringMBp :: Semiring MBp
derive newtype instance ringMBp :: Ring MBp
derive newtype instance arbitraryMBp :: Arbitrary MBp
derive newtype instance encodeMBp :: Encode MBp
derive newtype instance decodeMBp :: Decode MBp

instance showMBp :: Show MBp where
  show (MBp n) = show n <> "MBp"

class Field a <= HCoordinate a where
  bp :: a -> Bp
  mbp :: a -> MBp

toScreen :: ∀ c. HCoordinate c => c -> c -> c -> Number
toScreen offset scale x = unwrap ((x' - offset') * scale')
  where offset' = bp offset
        scale' = bp scale
        x' = bp x

instance hCoordBp :: HCoordinate Bp where
  bp = id
  mbp (Bp x) = MBp (x * 0.000001)

instance hCoordMBp :: HCoordinate MBp where
  bp (MBp x) = Bp (x * 1000000.0)
  mbp  = id

newtype Chr = Chr String
derive instance newtypeChr :: Newtype Chr _
derive newtype instance eqChr :: Eq Chr
derive newtype instance encodeChr :: Encode Chr
derive newtype instance decodeChr :: Decode Chr

_Chr :: Iso' Chr String
_Chr = _Newtype


Cut from third histories

Cut from third histories

module Cherry.Renderer
  ( Renderer
  , createRenderer
  , runRenderer
  ) where

import Prelude

import Cherry.Store (Store, select)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ref (REF, Ref, modifyRef, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToParentNode)
import DOM.HTML.Window (document, requestAnimationFrame)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import DOM.Node.Types (Node, elementToNode)
import Data.List (List(..), (!!), (:), take)
import Data.Maybe (Maybe(..))
import VOM (VNode, patch)

newtype Renderer e s = Renderer
  { container :: Maybe Node
  , view :: s -> VNode e
  , historyRef :: Ref (List (VNode e))
  , renderFlagRef :: Ref Boolean
  }

createRenderer :: forall e s.
                  String ->
                  (s -> VNode (dom :: DOM, ref :: REF | e)) ->
                  Eff (dom :: DOM, ref :: REF | e) (Renderer (dom :: DOM, ref :: REF | e) s)
createRenderer selector view = do
  doc <- htmlDocumentToParentNode <$> (window >>= document)
  container <- map elementToNode <$> querySelector (QuerySelector selector) doc
  historyRef <- newRef Nil
  renderFlagRef <- newRef false
  pure $ Renderer { container, view, historyRef, renderFlagRef }

runRenderer :: forall e s.
               Store (console :: CONSOLE, dom :: DOM, ref :: REF | e) s ->
               Renderer (console :: CONSOLE, dom :: DOM, ref :: REF | e) s ->
               Eff (console :: CONSOLE, dom :: DOM, ref :: REF | e) Unit
runRenderer store (Renderer r) =
  case r.container of
    Nothing -> log "Container is not found"
    Just t -> do
      renderFlag <- readRef r.renderFlagRef
      if renderFlag
        then pure unit
        else do
          writeRef r.renderFlagRef true
          void $ window >>= requestAnimationFrame do
            writeRef r.renderFlagRef false
            currentState <- select store (\s -> s)
            modifyRef r.historyRef \h -> take 2 $ r.view currentState : h
            history <- readRef r.historyRef
            patch (history !! 1) (history !! 0) t

module Cherry.Renderer
  ( Renderer
  , createRenderer
  , runRenderer
  ) where

import Prelude

import Cherry.Store (Store, select)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ref (REF, Ref, modifyRef, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToParentNode)
import DOM.HTML.Window (document, requestAnimationFrame)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import DOM.Node.Types (Node, elementToNode)
import Data.List (List(..), (!!), (:))
import Data.Maybe (Maybe(..))
import VOM (VNode, patch)

newtype Renderer e s = Renderer
  { container :: Maybe Node
  , view :: s -> VNode e
  , historyRef :: Ref (List (VNode e))
  , renderFlagRef :: Ref Boolean
  }

createRenderer :: forall e s.
                  String ->
                  (s -> VNode (dom :: DOM, ref :: REF | e)) ->
                  Eff (dom :: DOM, ref :: REF | e) (Renderer (dom :: DOM, ref :: REF | e) s)
createRenderer selector view = do
  doc <- htmlDocumentToParentNode <$> (window >>= document)
  container <- map elementToNode <$> querySelector (QuerySelector selector) doc
  historyRef <- newRef Nil
  renderFlagRef <- newRef false
  pure $ Renderer { container, view, historyRef, renderFlagRef }

runRenderer :: forall e s.
               Store (console :: CONSOLE, dom :: DOM, ref :: REF | e) s ->
               Renderer (console :: CONSOLE, dom :: DOM, ref :: REF | e) s ->
               Eff (console :: CONSOLE, dom :: DOM, ref :: REF | e) Unit
runRenderer store (Renderer r) =
  case r.container of
    Nothing -> log "Container is not found"
    Just t -> do
      renderFlag <- readRef r.renderFlagRef
      if renderFlag
        then pure unit
        else do
          writeRef r.renderFlagRef true
          void $ window >>= requestAnimationFrame do
            writeRef r.renderFlagRef false
            currentState <- select store (\s -> s)
            modifyRef r.historyRef (\h -> (r.view currentState) : h)
            history <- readRef r.historyRef
            patch (history !! 1) (history !! 0) t