Add more of the D3 force API

Add more of the D3 force API

module Graphics.D3.Layout.Force
  ( ForceLayout(..)
  , forceLayout
  , size
  , linkDistance
  , linkStrength
  , friction
  , charge
  , chargeDistance
  , theta
  , gravity
  , nodes
  , links
  , start
  , alpha
  , resume
  , stop
  , tick
  , drag
  , onDragStart
  , onTick
  , createDrag
  ) where

import Control.Monad.Eff
import Data.Foreign
import Data.Foreign.EasyFFI

import Graphics.D3.Base
import Graphics.D3.Selection
import Graphics.D3.Util

ffi = unsafeForeignFunction

foreign import data ForceLayout :: *

foreign import forceLayout "var forceLayout = d3.layout.force" :: D3Eff ForceLayout

size :: forall d. { width :: Number, height :: Number | d } -> ForceLayout -> D3Eff ForceLayout
size dimensions = f dimensions.width dimensions.height
  where f = ffi ["width", "height", "force", ""] "force.size([width, height])"

linkDistance :: Number -> ForceLayout -> D3Eff ForceLayout
linkDistance = ffi ["distance", "force", ""] "force.linkDistance(distance)"

linkStrength :: Number -> ForceLayout -> D3Eff ForceLayout
linkStrength = ffi ["strength", "force", ""] "force.linkStrength(strength)"

friction :: Number -> ForceLayout -> D3Eff ForceLayout
friction = ffi ["friction", "force", ""] "force.friction(friction)"

charge :: Number -> ForceLayout -> D3Eff ForceLayout
charge = ffi ["charge", "force", ""] "force.charge(charge)"

chargeDistance :: Number -> ForceLayout -> D3Eff ForceLayout
chargeDistance = ffi ["distance", "force", ""] "force.chargeDistance(distance)"

theta :: Number -> ForceLayout -> D3Eff ForceLayout
theta = ffi ["theta", "force", ""] "force.theta(theta)"

gravity :: Number -> ForceLayout -> D3Eff ForceLayout
gravity = ffi ["gravity", "force", ""] "force.gravity(gravity)"

nodes :: forall a. [a] -> ForceLayout -> D3Eff ForceLayout
nodes = ffi ["nodes", "force", ""] "force.nodes(nodes)"

links :: forall a. [a] -> ForceLayout -> D3Eff ForceLayout
links = ffi ["links", "force", ""] "force.links(links)"

start :: ForceLayout -> D3Eff ForceLayout
start = ffi ["force", ""] "force.start()"

alpha :: Number -> ForceLayout -> D3Eff ForceLayout
alpha = ffi ["alpha", "force", ""] "force.alpha(alpha)"

resume :: ForceLayout -> D3Eff ForceLayout
resume = ffi ["force", ""] "force.resume()"

stop :: ForceLayout -> D3Eff ForceLayout
stop = ffi ["force", ""] "force.stop()"

tick :: ForceLayout -> D3Eff ForceLayout
tick = ffi ["force", ""] "force.tick()"

onTick :: forall e r. (Foreign -> Eff e r) -> ForceLayout -> D3Eff ForceLayout
onTick = ffi
  ["callback", "force", ""]
  "force.on('tick', function (d) { return callback(d)(); })"

onDragStart :: forall e r. (Foreign -> Eff e r) -> ForceLayout -> D3Eff ForceLayout
onDragStart = ffi ["callback", "force", ""] "force.on('dragstart', callback)"

drag :: ForceLayout -> D3Eff ForceLayout
drag = ffi ["force", ""] "force.drag()"

createDrag :: forall s. ForceLayout -> Selection s -> D3Eff (Selection s)
createDrag = ffi ["obj", "callable", ""] "callable.call(obj);"

module Graphics.D3.Layout.Force
  ( ForceLayout(..)
  , forceLayout
  , size
  , charge
  , linkDistance
  , nodes
  , links
  , drag
  , onDragStart
  , start
  , onTick
  , createDrag
  ) where

import Control.Monad.Eff
import Data.Foreign
import Data.Foreign.EasyFFI

import Graphics.D3.Base
import Graphics.D3.Selection
import Graphics.D3.Util

ffi = unsafeForeignFunction

foreign import data ForceLayout :: *

foreign import forceLayout "var forceLayout = d3.layout.force" :: D3Eff ForceLayout

size :: forall d. { width :: Number, height :: Number | d } -> ForceLayout -> D3Eff ForceLayout
size dimensions = f dimensions.width dimensions.height
  where f = ffi ["width", "height", "layout", ""] "layout.size([width, height])"

nodes :: forall a. [a] -> ForceLayout -> D3Eff ForceLayout
nodes = ffi ["nodes", "graph", ""] "graph.nodes(nodes)"

links :: forall a. [a] -> ForceLayout -> D3Eff ForceLayout
links = ffi ["links", "graph", ""] "graph.links(links)"

charge :: Number -> ForceLayout -> D3Eff ForceLayout
charge = ffi ["charge", "forced", ""] "forced.charge(charge)"

linkDistance :: Number -> ForceLayout -> D3Eff ForceLayout
linkDistance = ffi ["distance", "forced", ""] "forced.linkDistance(distance)"

onTick :: forall eff r. (Foreign -> Eff eff r) -> ForceLayout -> D3Eff ForceLayout
onTick = ffi
  ["callback", "ticking", ""]
  "ticking.on('tick', function (d) { return callback(d)(); })"

drag :: ForceLayout -> D3Eff ForceLayout
drag = ffi ["draggable", ""] "draggable.drag()"

onDragStart :: forall eff r. (Foreign -> Eff eff r) -> ForceLayout -> D3Eff ForceLayout
onDragStart = ffi ["callback", "draggable", ""] "draggable.on(\"dragstart\", callback)"

start :: ForceLayout -> D3Eff ForceLayout
start = ffi ["draggable", ""] "draggable.start()"

createDrag :: forall s. ForceLayout -> Selection s -> D3Eff (Selection s)
createDrag = ffi ["obj", "callable", ""] "callable.call(obj);"


Drop problematic newtype instances and provide helpers instead

module Database.PostgreSQL.Value where

import Prelude

import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT, except, runExcept, runExceptT)
import Data.Array (foldl)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.ByteString (ByteString)
import Data.Date (Date, canonicalDate, day, month, year)
import Data.DateTime.Instant (Instant, instant)
import Data.Decimal (Decimal)
import Data.Decimal as Decimal
import Data.Either (Either(..), note)
import Data.Enum (fromEnum, toEnum)
import Data.Identity (Identity)
import Data.Int (fromString)
import Data.JSDate (JSDate)
import Data.List (List)
import Data.List as List
import Data.List.NonEmpty (singleton)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.String (Pattern(..), split)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence, traverse)
import Foreign (Foreign, ForeignError(..), MultipleErrors, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, renderForeignError, unsafeFromForeign, unsafeToForeign)
import Foreign.Internal (readObject)
import Foreign.Object (Object)

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Either String a

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = lmap show <<< runExcept <<< readBoolean

else instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = lmap show <<< runExcept <<< readChar

else instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = lmap show <<< runExcept <<< readInt

else instance fromSQLValueNumber :: FromSQLValue Number where
    fromSQLValue = lmap show <<< runExcept <<< readNumber

else instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = lmap show <<< runExcept <<< readString

else instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = pure $ unsafeFromForeign x
        | otherwise = throwError "FromSQLValue ByteString: not a buffer"

else instance fromSQLValueInstant :: FromSQLValue Instant where
    fromSQLValue v = do
      t <- instantFromString Left Right v
      note ("Instant construction failed for given timestamp: " <> show t) $ instant (Milliseconds t)

else instance fromSQLValueDate :: FromSQLValue Date where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        let
            msg = "Date parsing failed for value: " <> s
        case split (Pattern "-") s of
            [y, m, d] -> do
                let
                  result = canonicalDate
                    <$> (toEnum =<< fromString y)
                    <*> (toEnum =<< fromString m)
                    <*> (toEnum =<< fromString d)
                note msg result
            _ -> Left msg

else instance fromSQLValueJSDate :: FromSQLValue JSDate where
    fromSQLValue = Right <<< unsafeFromForeign

else instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = pure Nothing
                   | otherwise = Just <$> fromSQLValue x

else instance fromSQLValueForeign :: FromSQLValue Foreign where
    fromSQLValue = pure

else instance fromSQLValueObject ∷ FromSQLValue a ⇒ FromSQLValue (Object a) where
  fromSQLValue sql = lmap showErr $ unwrap $ runExceptT main
    where
    showErr ∷ MultipleErrors → String
    showErr e = foldl (\a x → a <> renderForeignError x <> " ") "" e
    main ∷ ExceptT MultipleErrors Identity (Object a)
    main = do
      objF ∷ Object Foreign <- readObject sql
      let eso = sequence $ map fromSQLValue objF
      let emo = lmap (singleton <<< ForeignError) eso
      except emo
else instance fromSQLValueDecimal :: FromSQLValue Decimal where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        note ("Decimal literal parsing failed: " <> s) (Decimal.fromString s)

newtypeFromSQLValue ∷ ∀ a b. Newtype a b ⇒ FromSQLValue b ⇒ Foreign → Either String a
newtypeFromSQLValue = map wrap <<< fromSQLValue

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = unsafeToForeign

else instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = unsafeToForeign

else instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = unsafeToForeign

else instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = unsafeToForeign

else instance toSQLValueString :: ToSQLValue String where
    toSQLValue = unsafeToForeign

else instance toSQLValueArray :: (ToSQLValue a) => ToSQLValue (Array a) where
    toSQLValue = unsafeToForeign <<< map toSQLValue

else instance toSQLValueList :: (ToSQLValue a) => ToSQLValue (List a) where
    toSQLValue = unsafeToForeign <<< Array.fromFoldable <<< map toSQLValue

else instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = unsafeToForeign

else instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

else instance toSQLValueDate :: ToSQLValue Date where
    toSQLValue date =
        let
            y = fromEnum $ year date
            m = fromEnum $ month date
            d = fromEnum $ day date
        in
            unsafeToForeign $ show y <> "-" <> show m <> "-" <> show d

else instance toSQLValueJSDate :: ToSQLValue JSDate where
    toSQLValue = unsafeToForeign

else instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = null
    toSQLValue (Just x) = toSQLValue x

else instance toSQLValueForeign :: ToSQLValue Foreign where
    toSQLValue = identity

else instance toSQLValueObject ∷ ToSQLValue a ⇒ ToSQLValue (Object a) where
  toSQLValue = unsafeToForeign

else instance toSQLValueDecimal :: ToSQLValue Decimal where
    toSQLValue = Decimal.toString >>> unsafeToForeign

newtypeToSQLValue ∷ ∀ a b. Newtype a b ⇒ ToSQLValue b ⇒ a → Foreign
newtypeToSQLValue = unwrap >>> toSQLValue

foreign import null :: Foreign
foreign import instantToString :: Instant -> Foreign
foreign import instantFromString :: (String -> Either String Number) -> (Number -> Either String Number) -> Foreign -> Either String Number
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean

module Database.PostgreSQL.Value where

import Prelude

import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT, except, runExcept, runExceptT)
import Data.Array (foldl)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.ByteString (ByteString)
import Data.Date (Date, canonicalDate, day, month, year)
import Data.DateTime.Instant (Instant, instant)
import Data.Decimal (Decimal)
import Data.Decimal as Decimal
import Data.Either (Either(..), note)
import Data.Enum (fromEnum, toEnum)
import Data.Identity (Identity)
import Data.Int (fromString)
import Data.JSDate (JSDate)
import Data.List (List)
import Data.List as List
import Data.List.NonEmpty (singleton)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.String (Pattern(..), split)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence, traverse)
import Foreign (Foreign, ForeignError(..), MultipleErrors, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, renderForeignError, unsafeFromForeign, unsafeToForeign)
import Foreign.Internal (readObject)
import Foreign.Object (Object)

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Either String a

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = lmap show <<< runExcept <<< readBoolean

else instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = lmap show <<< runExcept <<< readChar

else instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = lmap show <<< runExcept <<< readInt

else instance fromSQLValueNumber :: FromSQLValue Number where
    fromSQLValue = lmap show <<< runExcept <<< readNumber

else instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = lmap show <<< runExcept <<< readString

else instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = pure $ unsafeFromForeign x
        | otherwise = throwError "FromSQLValue ByteString: not a buffer"

else instance fromSQLValueInstant :: FromSQLValue Instant where
    fromSQLValue v = do
      t <- instantFromString Left Right v
      note ("Instant construction failed for given timestamp: " <> show t) $ instant (Milliseconds t)

else instance fromSQLValueDate :: FromSQLValue Date where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        let
            msg = "Date parsing failed for value: " <> s
        case split (Pattern "-") s of
            [y, m, d] -> do
                let
                  result = canonicalDate
                    <$> (toEnum =<< fromString y)
                    <*> (toEnum =<< fromString m)
                    <*> (toEnum =<< fromString d)
                note msg result
            _ -> Left msg

else instance fromSQLValueJSDate :: FromSQLValue JSDate where
    fromSQLValue = Right <<< unsafeFromForeign

else instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = pure Nothing
                   | otherwise = Just <$> fromSQLValue x

else instance fromSQLValueForeign :: FromSQLValue Foreign where
    fromSQLValue = pure

else instance fromSQLValueObject ∷ FromSQLValue a ⇒ FromSQLValue (Object a) where
  fromSQLValue sql = lmap showErr $ unwrap $ runExceptT main
    where
    showErr ∷ MultipleErrors → String
    showErr e = foldl (\a x → a <> renderForeignError x <> " ") "" e
    main ∷ ExceptT MultipleErrors Identity (Object a)
    main = do
      objF ∷ Object Foreign <- readObject sql
      let eso = sequence $ map fromSQLValue objF
      let emo = lmap (singleton <<< ForeignError) eso
      except emo
else instance fromSQLValueDecimal :: FromSQLValue Decimal where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        note ("Decimal literal parsing failed: " <> s) (Decimal.fromString s)

else instance fromSQLValueNewtype ∷ (Newtype a b, FromSQLValue b) ⇒ FromSQLValue a where
    fromSQLValue = map wrap <<< fromSQLValue

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = unsafeToForeign

else instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = unsafeToForeign

else instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = unsafeToForeign

else instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = unsafeToForeign

else instance toSQLValueString :: ToSQLValue String where
    toSQLValue = unsafeToForeign

else instance toSQLValueArray :: (ToSQLValue a) => ToSQLValue (Array a) where
    toSQLValue = unsafeToForeign <<< map toSQLValue

else instance toSQLValueList :: (ToSQLValue a) => ToSQLValue (List a) where
    toSQLValue = unsafeToForeign <<< Array.fromFoldable <<< map toSQLValue

else instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = unsafeToForeign

else instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

else instance toSQLValueDate :: ToSQLValue Date where
    toSQLValue date =
        let
            y = fromEnum $ year date
            m = fromEnum $ month date
            d = fromEnum $ day date
        in
            unsafeToForeign $ show y <> "-" <> show m <> "-" <> show d

else instance toSQLValueJSDate :: ToSQLValue JSDate where
    toSQLValue = unsafeToForeign

else instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = null
    toSQLValue (Just x) = toSQLValue x

else instance toSQLValueForeign :: ToSQLValue Foreign where
    toSQLValue = identity

else instance toSQLValueObject ∷ ToSQLValue a ⇒ ToSQLValue (Object a) where
  toSQLValue = unsafeToForeign

else instance toSQLValueDecimal :: ToSQLValue Decimal where
    toSQLValue = Decimal.toString >>> unsafeToForeign

else instance toSQLValueNewtype ∷ (Newtype a b, ToSQLValue b) ⇒ ToSQLValue a where
    toSQLValue = unwrap >>> toSQLValue

foreign import null :: Foreign
foreign import instantToString :: Instant -> Foreign
foreign import instantFromString :: (String -> Either String Number) -> (Number -> Either String Number) -> Foreign -> Either String Number
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean


no need for second function

no need for second function

module Data.DOM.Simple.Ajax where

import Control.Monad.Eff
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events

foreign import data XMLHttpRequest :: *

foreign import makeXMLHttpRequest
  "function makeXMLHttpRequest() {  \
  \  return new XMLHttpRequest();   \
  \}" :: forall eff. (Eff (dom :: DOM | eff) XMLHttpRequest)

foreign import open
  "function open(method) {                \
  \  return function(url) {               \
  \    return function (obj) {            \
  \      return function () {             \
  \         obj.open(method, url);        \
  \      };                               \
  \    };                                 \
  \  };                                   \
  \}" :: forall eff. String -> String -> XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

foreign import send
  "function send(obj) {     \
  \  return function () {   \
  \    obj.send();          \
  \  };                     \
  \}" :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

foreign import setRequestHeader
  "function setRequestHeader(key) {           \
  \   return function (value) {               \
  \     return function (obj) {               \
  \       return function () {                \
  \         obj.setRequestHeader(key, value); \
  \       }                                   \
  \     }                                     \
  \   }                                       \
  \}" :: forall eff. String -> String -> XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

module Data.DOM.Simple.Ajax where

import Control.Monad.Eff
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events

foreign import data XMLHttpRequest :: *

foreign import makeXMLHttpRequest
  "function makeXMLHttpRequest() {  \
  \  return function() {            \
  \    return new XMLHttpRequest(); \
  \  }                              \
  \}" :: forall eff. (Eff (dom :: DOM | eff) XMLHttpRequest)

foreign import open
  "function open(method) {                \
  \  return function(url) {               \
  \    return function (obj) {            \
  \      return function () {             \
  \         obj.open(method, url);        \
  \      };                               \
  \    };                                 \
  \  };                                   \
  \}" :: forall eff. String -> String -> XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

foreign import send
  "function send(obj) {     \
  \  return function () {   \
  \    obj.send();          \
  \  };                     \
  \}" :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

foreign import setRequestHeader
  "function setRequestHeader(key) {           \
  \   return function (value) {               \
  \     return function (obj) {               \
  \       return function () {                \
  \         obj.setRequestHeader(key, value); \
  \       }                                   \
  \     }                                     \
  \   }                                       \
  \}" :: forall eff. String -> String -> XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)


forgot to commit this prev commit

forgot to commit this prev commit


Export parOneOfMap (#19)

Export parOneOfMap (#19)

module Control.Parallel
  ( parTraverse
  , parTraverse_
  , parSequence
  , parSequence_
  , parOneOf
  , parOneOfMap
  , module Control.Parallel.Class
  ) where

import Prelude

import Control.Alternative (class Alternative)
import Control.Parallel.Class (class Parallel, parallel, sequential, ParCont(..))

import Data.Foldable (class Foldable, traverse_, oneOfMap)
import Data.Traversable (class Traversable, traverse)

-- | Traverse a collection in parallel.
parTraverse
  :: forall f m t a b
   . Parallel f m
  => Traversable t
  => (a -> m b)
  -> t a
  -> m (t b)
parTraverse f = sequential <<< traverse (parallel <<< f)

-- | Traverse a collection in parallel, discarding any results.
parTraverse_
  :: forall f m t a b
   . Parallel f m
  => Foldable t
  => (a -> m b)
  -> t a
  -> m Unit
parTraverse_ f = sequential <<< traverse_ (parallel <<< f)

parSequence
  :: forall a t m f
   . Parallel f m
  => Traversable t
  => t (m a)
  -> m (t a)
parSequence = parTraverse id

parSequence_
  :: forall a t m f
   . Parallel f m
  => Foldable t
  => t (m a)
  -> m Unit
parSequence_ = parTraverse_ id

-- | Race a collection in parallel.
parOneOf
  :: forall a t m f
   . Parallel f m
  => Alternative f
  => Foldable t
  => Functor t
  => t (m a)
  -> m a
parOneOf = sequential <<< oneOfMap parallel

-- | Race a collection in parallel while mapping to some effect.
parOneOfMap
  :: forall a b t m f
   . Parallel f m
  => Alternative f
  => Foldable t
  => Functor t
  => (a -> m b)
  -> t a
  -> m b
parOneOfMap f = sequential <<< oneOfMap (parallel <<< f)

module Control.Parallel
  ( parTraverse
  , parTraverse_
  , parSequence
  , parSequence_
  , parOneOf
  , module Control.Parallel.Class
  ) where

import Prelude

import Control.Alternative (class Alternative)
import Control.Parallel.Class (class Parallel, parallel, sequential, ParCont(..))

import Data.Foldable (class Foldable, traverse_, oneOfMap)
import Data.Traversable (class Traversable, traverse)

-- | Traverse a collection in parallel.
parTraverse
  :: forall f m t a b
   . Parallel f m
  => Traversable t
  => (a -> m b)
  -> t a
  -> m (t b)
parTraverse f = sequential <<< traverse (parallel <<< f)

-- | Traverse a collection in parallel, discarding any results.
parTraverse_
  :: forall f m t a b
   . Parallel f m
  => Foldable t
  => (a -> m b)
  -> t a
  -> m Unit
parTraverse_ f = sequential <<< traverse_ (parallel <<< f)

parSequence
  :: forall a t m f
   . Parallel f m
  => Traversable t
  => t (m a)
  -> m (t a)
parSequence = parTraverse id

parSequence_
  :: forall a t m f
   . Parallel f m
  => Foldable t
  => t (m a)
  -> m Unit
parSequence_ = parTraverse_ id

-- | Race a collection in parallel.
parOneOf
  :: forall a t m f
   . Parallel f m
  => Alternative f
  => Foldable t
  => Functor t
  => t (m a)
  -> m a
parOneOf = sequential <<< oneOfMap parallel

-- | Race a collection in parallel while mapping to some effect.
parOneOfMap
  :: forall a b t m f
   . Parallel f m
  => Alternative f
  => Foldable t
  => Functor t
  => (a -> m b)
  -> t a
  -> m b
parOneOfMap f = sequential <<< oneOfMap (parallel <<< f)


Improve QTL feature source

Improve QTL feature source

module Genetics.Browser.Source.QTL
       where

import Prelude

import Text.Parsing.CSV (defaultParsers)
import Text.Parsing.Parser (parseErrorMessage, runParser)
import Data.Map as Map
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff)
import Data.Array (fromFoldable, mapMaybe)
import Data.Either (Either(..))
import Data.Foreign (Foreign)
import Data.Foreign.Null (writeNull)
import Data.Function.Uncurried (Fn4, runFn4)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Genetics.Browser.Feature (Feature(..))
import Global (readFloat)
import Network.HTTP.Affjax (AJAX, get)
import Unsafe.Coerce (unsafeCoerce)

type QTLFeature = Feature (score :: Number)

                  -- the first Foreign should be Nullable Feature or similar
type FetchCallback = ∀ r. Fn4 String Foreign Number Foreign (Aff (ajax :: AJAX | r) Unit)

-- Feature should be in this, and 'r' should be the row in Feature r
type Source r =  String -> Number -> Number
              -> Number -> Foreign -> Foreign
              -> FetchCallback -> Aff (ajax :: AJAX | r) Unit

fetch :: Source ()
fetch chr pmin pmax scale types pool f = do
  res <- get "http://test-gn2.genenetwork.org/api_pre1/qtl/lod2.csv"
  let parsed = runParser res.response defaultParsers.fileHeaded
      results = (map lineToFeature) <$> parsed
  case fromFoldable <$> results of
    Left  er -> unsafeCoerce $
                runFn4 f (parseErrorMessage er) writeNull 0.0 writeNull
    Right fs -> unsafeCoerce $ let fs' = mapMaybe id fs -- filtering away Nothings
                in runFn4 f "features" (unsafeCoerce fs') 0.0 writeNull

-- not very safe or stable (case sensitive, numbers as strings...)
lineToFeature :: Map String String -> Maybe QTLFeature
lineToFeature m = do
  chr <- Map.lookup "Chr" m
  min <- readFloat <$> Map.lookup "Mb" m
  score <- readFloat <$> (Map.lookup "LRS" m <|> Map.lookup "LOD" m)
  pure $ Feature { chr: chr, min: min, max: min, score: score }

module Genetics.Browser.Source.QTL
       where

import Prelude
import Text.Parsing.CSV
import Text.Parsing.Parser
import Data.Map as Map
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Data.Array (fromFoldable)
import Data.Foreign (Foreign)
import Data.HTTP.Method (Method(..))
import Data.Map (Map)
import Data.Maybe (Maybe)
import Debug.Trace (traceAny)
import Genetics.Browser.Feature (Feature(..))
import Global (readFloat)
import Network.HTTP.Affjax (affjax, defaultRequest, get)

type QTLFeature = Feature (score :: Number)

-- this needs to be safer...
-- what a mess.
-- fetch :: ∀ a b. String -> Number -> Number -> Number -> Foreign -> Foreign -> (a -> b) -> Aff _ Unit
fetch chr pmin pmax scale types pool f = do
  liftEff $ log "getting in purescript"
  res <- get "http://test-gn2.genenetwork.org/api_pre1/qtl/lod2.csv"
  let parsed = runParser res.response defaultParsers.fileHeaded
      results = (map lineToFeature) <$> parsed
  liftEff $ log $ "GET: " <> res.response
  traceAny ((fromFoldable <$> results) :: _) (\_ -> pure unit)
  f res

-- also not very safe or stable (case sensitive, numbers as strings...)
lineToFeature :: Map String String -> Maybe QTLFeature
lineToFeature m = do
  chr <- Map.lookup "Chr" m
  min <- readFloat <$> Map.lookup "Mb" m
  score <- readFloat <$> (Map.lookup "LRS" m <|> Map.lookup "LOD" m)
  pure $ Feature { chr: chr, min: min, max: min, score: score }


Change signature of foldC

Change signature of foldC

module Control.Monad.Cont.Extras where

import Data.Array ()
import Data.Maybe
import Data.Either

import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Trans
import Control.Monad.Cont.Trans

type WithRef eff = Eff (ref :: Ref | eff)

type ContRef eff = ContT Unit (WithRef eff)

foldC :: forall eff a b r. (b -> a -> Either b r) -> b -> ContRef eff a -> ContRef eff r
foldC f r0 c = do
  current <- lift $ newRef r0
  callCC $ \k -> quietly $ do
    a <- c
    b <- lift $ readRef current
    case f b a of
      Left next -> lift $ writeRef current next
      Right r -> k r

  where
  quietly :: forall m a. (Monad m) => ContT Unit m Unit -> ContT Unit m a
  quietly = withContT (\_ _ -> return unit)

collect :: forall eff a. ContRef eff (Maybe a) -> ContRef eff [a]
collect = foldC f []
  where
  f xs Nothing = Right xs
  f xs (Just x) = Left (xs ++ [x])

module Control.Monad.Cont.Extras where

import Data.Array ()
import Data.Maybe
import Data.Tuple

import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Trans
import Control.Monad.Cont.Trans

type WithRef eff = Eff (ref :: Ref | eff)

type ContRef eff = ContT Unit (WithRef eff)

foldC :: forall eff a r. (r -> a -> Tuple Boolean r) -> r -> ContRef eff a -> ContRef eff r
foldC f r0 c = do
  current <- lift $ newRef r0
  callCC $ \k -> quietly $ do
    a <- c
    r <- lift $ readRef current
    case f r a of
      Tuple emit next -> do
        when emit $ k next
        lift $ writeRef current next

  where
  quietly :: forall m a. (Monad m) => ContT Unit m Unit -> ContT Unit m a
  quietly = withContT (\_ _ -> return unit)

collect :: forall eff a. ContRef eff (Maybe a) -> ContRef eff [a]
collect = foldC f []
  where
  f xs Nothing = Tuple true xs
  f xs (Just x) = Tuple false (xs ++ [x])


In progress refactoring

In progress refactoring

module SearchEngine where

import Data.Maybe.Unsafe (fromJust)
import Data.Map (Map(), fromList, lookup, insert, empty)
import Control.Apply
import Data.Tuple
import Data.String (trim, split, toCharArray, fromCharArray, toLower)
import Data.Char
import Data.Array (range, length, filter, null, sort, sortBy, groupBy, drop, concatMap, concat)
import Data.Foldable (foldl)
import Data.Maybe
import Data.Function (on)
import Data.Array.Unsafe (head)

type Doc = [Line]
type Line = String
type Word = String
type LineNumber = Number
type Pos = Number
type Index = Map Word [Tuple Pos LineNumber]

data PartialTermIndex = D (Map Char (Tuple [[Char]] PartialTermIndex))

both :: forall a. (a -> Boolean) -> (a -> Boolean) -> a -> Boolean
both = lift2 (&&)

lines :: String -> [Line]
lines s = trim <$> (split "\n" s)

words :: String -> [Word]
words s = trim <$> (split " " s)

numLines :: Doc -> [Tuple Line LineNumber]
numLines doc = flip zip ns doc
    where ns = range 0 (length doc)

numWords :: Line -> [Tuple Word Pos]
numWords line = flip zip ns ws
    where ns = range 0 (length ws)
          ws = cleanWords (words line)

isUpperCaseLetter :: Char -> Boolean
isUpperCaseLetter ch = toCharCode ch >= 65 && toCharCode ch <= 90

isLowerCaseLetter :: Char -> Boolean
isLowerCaseLetter ch = toCharCode ch >= 97 && toCharCode ch <= 122

isLetter :: Char -> Boolean
isLetter ch = isUpperCaseLetter ch || isLowerCaseLetter ch

isAscii :: Char -> Boolean
isAscii ch = toCharCode ch >= 0 && toCharCode ch <= 127

cleanWords :: [Word] -> [Word]
cleanWords = (<$>) toLower <<<
             (<$>) fromCharArray <<<
             filter (not <<< null) <<<
             (<$>) (filter (both isLetter isAscii)) <<<
             (<$>) toCharArray

allNumWords :: [Tuple Line LineNumber] -> [Tuple Word (Tuple Pos LineNumber)]
allNumWords = (>>= (\(Tuple l i) -> (<$>) (\(Tuple w p) -> Tuple w (Tuple p i)) $ numWords l))

makeLists :: [Tuple Word (Tuple Pos LineNumber)] -> [Tuple Word [Tuple Pos LineNumber]]
makeLists = (<$>) (\(Tuple w (Tuple p i)) -> Tuple w [Tuple p i])

accumulate :: [Tuple Word [Tuple Pos LineNumber]] -> [Tuple Word [Tuple Pos LineNumber]]
accumulate = foldl f []
           where f [] x = [x]
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w == w2 = (Tuple w (l:ls)):xs
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w /= w2 = (Tuple w2 [l]):((Tuple w ls):xs)

createTermIndex :: Doc -> Index
createTermIndex =  fromList <<< accumulate <<< makeLists <<< sort <<< allNumWords <<< numLines

createPartialTermIndex :: [String] -> PartialTermIndex
createPartialTermIndex = createPartialTermIndex' <<< (<$>) toCharArray
  where
    createPartialTermIndex' []  = D empty
    createPartialTermIndex' ws  =
        foldl (\(D m) (Tuple k ws') -> D $ insert k (Tuple ws' (createPartialTermIndex' ((<$>) (drop 1) ws'))) m) (D empty) <<<
        (<$>) (\ws' -> Tuple (head (head ws')) ws') <<<
        groupBy ((==) `on` head) <<<
        sortBy (compare `on` head) <<<
        filter (not <<< null) $ ws

module SearchEngine where

import Data.Maybe.Unsafe (fromJust)
import Data.Map (Map(), fromList, lookup, insert, empty)
import Control.Apply
import Data.Tuple
import Data.String (trim, split, toCharArray, fromCharArray, toLower)
import Data.Char
import Data.Array (range, length, filter, null, sort, sortBy, groupBy, drop, concatMap, concat)
import Data.Foldable (foldl)
import Data.Maybe
import Data.Function (on)
import Data.Array.Unsafe (head)

type Doc = [Line]
type Line = String
type Word = String
type LineNumber = Number
type Pos = Number
type Index = Map Word [Tuple Pos LineNumber]

data PartialTermIndex = D (Map Char (Tuple [[Char]] PartialTermIndex))

both :: forall a. (a -> Boolean) -> (a -> Boolean) -> a -> Boolean
both = lift2 (&&)

lines :: String -> [Line]
lines s = trim <$> (split "\n" s)

words :: String -> [Word]
words s = trim <$> (split " " s)

numLines :: Doc -> [Tuple Line LineNumber]
numLines doc = flip zip ns doc
    where ns = range 0 (length doc)

numWords :: Line -> [Tuple Word Pos]
numWords line = flip zip ns ws
    where ns = range 0 (length ws)
          ws = cleanWords (words line)

isUpperCaseLetter :: Char -> Boolean
isUpperCaseLetter ch = toCharCode ch >= 65 && toCharCode ch <= 90

isLowerCaseLetter :: Char -> Boolean
isLowerCaseLetter ch = toCharCode ch >= 97 && toCharCode ch <= 122

isLetter :: Char -> Boolean
isLetter ch = isUpperCaseLetter ch || isLowerCaseLetter ch

isAscii :: Char -> Boolean
isAscii ch = toCharCode ch >= 0 && toCharCode ch <= 127

cleanWords :: [Word] -> [Word]
cleanWords = (<$>) toLower <<<
             (<$>) fromCharArray <<<
             filter (not <<< null) <<<
             (<$>) (filter (both isLetter isAscii)) <<<
             (<$>) toCharArray

allNumWords :: [Tuple Line LineNumber] -> [Tuple Word (Tuple Pos LineNumber)]
allNumWords = (>>= (\(Tuple l i) -> (<$>) (\(Tuple w p) -> Tuple w (Tuple p i)) $ numWords l))

makeLists :: [Tuple Word (Tuple Pos LineNumber)] -> [Tuple Word [Tuple Pos LineNumber]]
makeLists = (<$>) (\(Tuple w (Tuple p i)) -> Tuple w [Tuple p i])

accumulate :: [Tuple Word [Tuple Pos LineNumber]] -> [Tuple Word [Tuple Pos LineNumber]]
accumulate = foldl f []
           where f [] x = [x]
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w == w2 = (Tuple w (l:ls)):xs
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w /= w2 = (Tuple w2 [l]):((Tuple w ls):xs)

createTermIndex :: Doc -> Index
createTermIndex =  fromList <<< accumulate <<< makeLists <<< sort <<< allNumWords <<< numLines

createPartialTermIndex :: [[Char]] -> PartialTermIndex
createPartialTermIndex []  = D empty
createPartialTermIndex ws  =
    foldl (\(D m) (Tuple k ws') -> D $ insert k (Tuple ws' (createPartialTermIndex ((<$>) (drop 1) ws'))) m) (D empty) <<<
    (<$>) (\ws' -> Tuple (head (head ws')) ws') <<<
    groupBy ((==) `on` head) <<<
    sortBy (compare `on` head) <<<
    filter (not <<< null) $ ws


Unified view

Unified view

module Flag.Core (fetch, shuffle, view, foldp, init) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (decodeJson, Json)
import Data.Array (length, replicate, sortBy, zip, head, take, uncons)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), snd)
import Flag.Types (Countries, Country(..), Event(..), State)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (h1, button, ul, li, div, img)
import Text.Smolder.HTML.Attributes (className, src, alt)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

init ∷ State
init = { countries: Nothing, correct: 0, incorrect: 0 }

shuffle ∷ ∀ e a. Array a → Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

decode ∷ ∀ r. { response ∷ Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch ∷ ∀ e. Aff (random ∷ RANDOM, ajax ∷ AJAX | e) (Maybe Countries)
fetch = do
  get "/countries.json" >>= \xs → case decode xs of
    Left _          → pure $ Nothing
    Right countries → pure $ Just countries

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM, ajax ∷ AJAX)
foldp (Request)           state = onlyEffects state [Just <<< Receive <$> fetch]
foldp (Receive Nothing)   state = noEffects $ state { countries = Nothing }
foldp (Receive (Just xs)) state = noEffects $ state { countries = Just xs }
foldp (Respond name)      state = noEffects $ case join $ uncons <$> state.countries of
  Nothing                              → state { countries = Nothing }
  Just { head: (Country x), tail: xs } → case name == x.name of
    true  → state { countries = Just xs, correct = state.correct + 1 }
    false → state { countries = Just xs, incorrect = state.incorrect + 1 }

view ∷ State → HTML Event
view state = div ! className "flagship" $ do
  ul ! className "header" $ do
    li $ h1 $ text "Flagship"
    li $ button #! onClick (const Request) $ text "Start"
    li ! className "score correct" $ text $ show state.correct
    li ! className "score incorrect" $ text $ show state.incorrect
    li ! className "score" $ text $ show $ state.correct + state.incorrect
  <> do div ! className "prompt" $ case state.countries of
          Nothing        → button #! onClick (const Request) $ text "Start"
          Just countries → case head countries of
            Nothing              → div $ text "All done!"
            Just (Country current) → do
              img ! src ("images/flags/" <> current.flag) ! alt "Flag"
              ul ! className "countries" $ for_ (take 4 countries) $ \(Country answer) →
                li $ button #! onClick (const $ Respond answer.name) $ text answer.name

module Flag.Core (view, foldp, init) where

import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (decodeJson, Json)
import Data.Array (length, replicate, sortBy, zip)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), snd)
import Flag.Types (Countries, Country(..), State, Event(..))
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (h1, button, ul, li, div)
import Text.Smolder.HTML.Attributes (className)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

init ∷ State
init = { countries: Nothing, correct: 0, incorrect: 0 }

shuffle ∷ ∀ e a. Array a → Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

decode ∷ ∀ r. { response ∷ Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch ∷ ∀ e. Aff (ajax ∷ AJAX | e) (Maybe Event)
fetch = do
  response <- attempt $ get "/countries.json"
  let countries = either (Left <<< show) decode response
  pure $ Just $ Receive $ case shuffle <$> countries of
    Left _   → Nothing
    Right xs → Just xs

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM, ajax ∷ AJAX)
foldp (Respond name)      state = noEffects $ state { countries = Nothing, correct = state.correct + 1 }
foldp (Receive Nothing)   state = noEffects $ state { countries = Nothing }
foldp (Receive (Just xs)) state = noEffects $ state { countries = Just xs }
foldp (Request)           state = { state, effects: [fetch] }

view ∷ State → HTML Event
view state = div ! className "flagship" $ case state.countries of
  Nothing → toolbar state
  Just _  → toolbar state <> country state

toolbar ∷ State → HTML Event
toolbar state = ul ! className "header" $ do
  li $ h1 $ text "Flagship"
  li $ button #! onClick (const Request) $ text "Start"
  li ! className "score correct" $ text $ show state.correct
  li ! className "score incorrect" $ text $ show state.incorrect
  li ! className "score" $ text $ show $ state.correct + state.incorrect
    -- where isDisabled = state.countries >>= \xs → pure $ if (length xs == 0) then "" else "disabled"

country ∷ State → HTML Event
country state = div ! className "prompt" $ do
  case state.countries of
    Nothing        → button #! onClick (const Request) $ text "Start"
    Just _         → button $ text "Test"
    -- Just countries → liftEff $ countries >>= \countries -> case head countries of
    --   Nothing              → pure $ div $ text "All done!"
    --   Just (Country model) → pure $ do
    --     img ! src ("images/flags/" <> model.flag) ! alt "Flag"
    --     ul ! className "countries" $ for_ (take 4 countries) $ answer

answer ∷ Country → HTML Event
answer (Country model) =
  li $ button #! onClick (const $ Respond model.name) $ text model.name


Fix type signature

Fix type signature

module ShortId where

import Control.Monad.Eff (Eff)

foreign import data SHORTID :: !

foreign import generate :: forall e. Eff (shortid :: SHORTID | e) String

module ShortId where

import Control.Monad.Eff (Eff)

foreign import data SHORTID :: !

foreign import generate :: forall e. Eff (random :: SHORTID | e) String


add itemized duration

add itemized duration

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Newtype (unwrap)
import Data.Time.Duration (class Duration, Days(..), Hours(..), Milliseconds(..), Minutes(..), Seconds(..), convertDuration)
import Data.Tuple (Tuple(..))

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
        timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
        millisFormatter = Formatter { comma: false, before: 3, after: 0, abbreviations: false, sign: false }
        diffMillis :: ItemizedDuration
        diffMillis = diff startDatetime now
    in if startDatetime < now
       then Nothing
       else Just let d :: Days
                     d  = convertDuration diffMillis
                     d' = floor $ unwrap d
                     dd = show d'
                     h :: Hours
                     h  = convertDuration $ d - (Days $ toNumber d')
                     h' = toNumber $ floor $ unwrap h
                     hh = format timeFormatter h'
                     m :: Minutes
                     m  = convertDuration $ h - (Hours h')
                     m' = toNumber $ floor $ unwrap m
                     mm = format timeFormatter m'
                     s :: Seconds
                     s  = convertDuration $ m - (Minutes m')
                     s' = toNumber $ floor $ unwrap s
                     ss = format timeFormatter s'
                 in (if d' > 0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss

msInSecond :: Number
msInSecond = 1000.0
msInMinute :: Number
msInMinute = 60.0 * msInSecond
msInHour :: Number
msInHour = 60.0 * msInMinute
msInDay :: Number
msInDay = 24.0 * msInHour

data ItemizedDuration = Itemized Days Hours Minutes Seconds Milliseconds

instance durationItemized :: Duration ItemizedDuration where
  fromDuration (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) =
    Milliseconds (d * msInDay + h * msInHour + m * msInMinute + s * msInSecond + ms)
  toDuration (Milliseconds ms') = Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)
    where divMod x y = Tuple (div x y) (mod x y)
          (Tuple s' ms) = divMod ms' 1000.0
          (Tuple m' s)  = divMod s' 60.0
          (Tuple h' m)  = divMod m' 60.0
          (Tuple d  h)  = divMod h' 24.0

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Newtype (unwrap)
import Data.Time.Duration (Days(..), Hours(..), Milliseconds, Minutes(..), Seconds, convertDuration)

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
        timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
        millisFormatter = Formatter { comma: false, before: 3, after: 0, abbreviations: false, sign: false }
        diffMillis :: Milliseconds
        diffMillis = diff startDatetime now
    in if startDatetime < now
       then Nothing
       else Just let d :: Days
                     d  = convertDuration diffMillis
                     d' = floor $ unwrap d
                     dd = show d'
                     h :: Hours
                     h  = convertDuration $ d - (Days $ toNumber d')
                     h' = toNumber $ floor $ unwrap h
                     hh = format timeFormatter h'
                     m :: Minutes
                     m  = convertDuration $ h - (Hours h')
                     m' = toNumber $ floor $ unwrap m
                     mm = format timeFormatter m'
                     s :: Seconds
                     s  = convertDuration $ m - (Minutes m')
                     s' = toNumber $ floor $ unwrap s
                     ss = format timeFormatter s'
                 in (if d' > 0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss


Remove TCO test

Remove TCO test

module Main where

newtype Id = Id forall a. a -> a

runId = \id a -> case id of
  Id f -> f a

newtype Nat = Nat forall r. r -> (r -> r) -> r

runNat = \nat -> case nat of
  Nat f -> f 0 (\n -> n + 1)

zero = Nat (\zero _ -> zero)

succ = \n -> case n of
  Nat f -> Nat (\zero succ -> succ (f zero succ))

add = \n m -> case n of
  Nat f -> case m of
    Nat g -> Nat (\zero succ -> g (f zero succ) succ)

one = succ zero
two = succ zero
four = add two two
fourNumber = runNat four

main = Debug.Trace.trace "Done"


some more tests

some more tests

module Main where

import Data.Array
import Data.Maybe

import Debug.Trace

import Data.DOM.Simple.Types
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Events

import Test.QuickCheck

foreign import inspect
  "function inspect(msg) { console.log(msg.textContent); }"
  :: forall a. a -> Unit

foreign import tagname
  "function tagname(obj) { return obj.tagName; }"
  :: forall a. a -> String

main = do
  document <- getDocument globalWindow

  trace "Able to look up elements"

  testDiv1 <- getElementById "test1" document

  quickCheck' 1 $ tagname testDiv1 == "DIV"

  testDiv1Contents <- textContent testDiv1

  quickCheck' 1 $ testDiv1Contents == "testContent1"

  testDiv2 <- querySelector ".test2" document

  quickCheck' 1 $ tagname testDiv2 == "DIV"

  testDiv2Contents <- textContent testDiv2

  quickCheck' 1 $ testDiv2Contents == "testContent2"

  testDiv3 <- querySelector "test3" document

  quickCheck' 1 $ tagname testDiv3 == "TEST3"

  testDiv3Contents <- textContent testDiv3

  quickCheck' 1 $ testDiv3Contents == "testContent3"

  trace "Able to modify an elements contents"

  setTextContent "Hello" testDiv1
  testDiv1Contents' <- textContent testDiv1

  quickCheck' 1 $ testDiv1Contents' == "Hello"

  trace "Able to set an attribute on an element"

  setAttribute "data-test" "hello" testDiv1
  testDiv1Attribute <- getAttribute "data-test" testDiv1

  quickCheck' 1 $ testDiv1Attribute == "hello"

  trace "Able to remove an attribute from an element"

  testDiv1HasAttribute <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute == true
  removeAttribute "data-test" testDiv1
  testDiv1HasAttribute' <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute' == false

  trace "Done"

module Main where

import Data.Array
import Data.Maybe

import Debug.Trace

import Data.DOM.Simple.Types
import Data.DOM.Simple.Element

import Test.QuickCheck

foreign import inspect
  "function inspect(msg) { console.log(msg.textContent); }"
  :: forall a. a -> Unit

main = do
  document <- getDocument globalWindow

  trace "Able to look up elements"

  testDiv1 <- getElementById "test1" document
  testDiv1Contents <- textContent testDiv1

  quickCheck' 1 $ testDiv1Contents == "testContent1"

  testDiv2 <- querySelector ".test2" document
  testDiv2Contents <- textContent testDiv2

  quickCheck' 1 $ testDiv2Contents == "testContent2"

  testDiv3 <- querySelector "test3" document
  testDiv3Contents <- textContent testDiv3

  quickCheck' 1 $ testDiv3Contents == "testContent3"

  trace "Able to modify an elements contents"

  setTextContent "Hello" testDiv1
  testDiv1Contents' <- textContent testDiv1

  quickCheck' 1 $ testDiv1Contents' == "Hello"

  trace "Able to set an attribute on an element"

  setAttribute "data-test" "hello" testDiv1
  testDiv1Attribute <- getAttribute "data-test" testDiv1

  quickCheck' 1 $ testDiv1Attribute == "hello"

  trace "Able to remove an attribute from an element"

  testDiv1HasAttribute <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute == true
  removeAttribute "data-test" testDiv1
  testDiv1HasAttribute' <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute' == false


Nicer names

Nicer names

Original commit 7ae479eea1cff11f79c012657e276b40cc70d95b

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: forbidNamer (swiftNameStyle true) (\n -> [swiftNameStyle true n])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = swiftNameStyle true $ combineNames names

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To parse the JSON, add this file to your project and do:"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        typ <- renderType topLevelType
        line $ "//   let " <> decapitalize topLevelName <> " = " <> topLevelName <> "(fromString: jsonString)!"
    blank
    line "import Foundation"

    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        top <- renderType topLevelType
        line $ "typealias "<> topLevelName <> " = " <> top

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

supportFunctions :: Doc Unit
supportFunctions = do
    line """// Helpers

fileprivate func convertArray<T>(_ converter: (Any) -> T?, _ json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr = [T]()
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(_ converter: (Any) -> T?, _ json: Any?) -> T?? {
    guard let v = json else { return .some(nil) }
    return converter(v)
}

fileprivate func convertDict<T>(_ converter: (Any) -> T?, _ json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict = [String: T]()
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(_ dictionary: [String: T], _ converter: (T) -> Any) -> Any {
    var result = [String: Any]()
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double { return w }
    if let w = v as? Int { return Double(w) }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil { return .none }
    return .some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(" <> converter <> ", " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(" <> converter <> ", " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertAnyFunc :: IRType -> Doc String
convertAnyFunc = case _ of
    IRClass i -> do
        name <- lookupClassName i
        -- TODO make this look less alien
        pure $ "{ " <> name <> "(fromAny: $0) }"
    IRUnion ur ->
        case nullableFromSet $ unionToSet ur of
        Just t -> do
            converter <- convertAnyFunc t
            pure $ "{ (json: Any) in convertOptional(" <> converter <> ", json) }"
        Nothing -> do
            name <- lookupUnionName ur
            pure $ name <> ".fromJson"
    IRDouble -> pure "convertDouble"
    IRNull -> pure "checkNull"
    t -> do
        converted <- convertAny t "$0"
        pure $ "{ " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    convertCode <- convertToAny a "$0"
    pure $ var <> ".map({ " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    convertCode <- convertToAny m "$0"
    pure $ "convertToAny(" <> var <> ", { "<> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["json", "any"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
    line "}"

renderTopLevelExtensions :: String -> IRType -> Doc Unit
renderTopLevelExtensions topLevelName topLevelType = do
    blank

    topLevelRendered <- renderType topLevelType
    extensionType <- case topLevelType of
        IRArray t -> ("Array where Element == " <> _) <$> renderType t
        IRMap t -> ("Dictionary where Key == String, Value == " <> _) <$> renderType t
        _ -> pure topLevelRendered

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "init?(fromString json: String, using encoding: String.Encoding = .utf8) {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line "self.init(fromData: data)"
        line "}"
        blank
        line $ "init?(fromData data: Data) {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line "self.init(fromAny: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init()"
                    line $ "elements.forEach { self[$0.key] = $0.value }"
                line "}"
            _ -> pure unit

        blank
        line $ "var jsonData: Data? {"
        indent do
            convertCode <- convertToAny topLevelType "self"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"

        blank
        line $ "var jsonString: String? {"
        indent do
            line $ "guard let data = self.jsonData else { return nil }"
            line $ "return String(data: data, encoding: .utf8)"
        line "}"

    line "}"

renderClassExtension :: String -> Map String IRType -> Doc Unit
renderClassExtension className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        line $ "fileprivate init?(fromAny any: Any) {"
        indent do
            line "guard let json = any as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames properties "Any" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames properties "" forbidden
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname convertedNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                    line "else { return nil }"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname convertedNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "fileprivate var any: Any {"
        indent do
            if null properties
                then line "return [String: Any]()"
                else do
                    line "return ["
                    indent do
                        forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                            convertCode <- convertToAny ptype ("self." <> fieldName)
                            line $ "\"" <> stringEscape pname <> "\": " <> convertCode <> ","
                    line "]"
        line "}"
    line "}"

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
forEachProperty_ properties propertyNames f =
    let propertyArray = M.toUnfoldable properties :: Array _
        lastIndex = A.length propertyArray - 1
    in
        forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
            let fieldName = lookupName pname propertyNames
            f pname ptype fieldName (i == lastIndex)

makePropertyNames :: Map String IRType -> String -> Array String -> Map String String
makePropertyNames properties suffix forbidden =
    transformPropertyNames (fieldNamer suffix) otherField forbidden properties
    where
        fieldNamer :: String -> Namer String
        fieldNamer suffix = simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name = "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
    line "}"

renderUnionExtension :: String -> Set IRType -> Doc Unit
renderUnionExtension unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return ." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                convertCode <- convertToAny typ "x"
                line $ "case ." <> name <> letString <> ": return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
    renderCase :: IRType -> Doc Unit
    renderCase t = do
        convertCode <- convertAny t "v"
        name <- caseName t
        line $ "if let x = " <> convertCode <> " { return ." <> name <> "(x) }"

caseName :: IRType -> Doc String
caseName t = swiftNameStyle false <$> getTypeNameForUnion t

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: forbidNamer (swiftNameStyle true) (\n -> [swiftNameStyle true n])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = swiftNameStyle true $ combineNames names

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To parse the JSON, add this file to your project and do:"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        typ <- renderType topLevelType
        line $ "//   let " <> decapitalize topLevelName <> " = " <> topLevelName <> "(fromString: jsonString)!"
    blank
    line "import Foundation"

    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        top <- renderType topLevelType
        line $ "typealias "<> topLevelName <> " = " <> top

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

supportFunctions :: Doc Unit
supportFunctions = do
    line """// Helpers

fileprivate func convertArray<T>(_ converter: (Any) -> T?, _ json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr = [T]()
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(_ converter: (Any) -> T?, _ json: Any?) -> T?? {
    guard let v = json else { return .some(nil) }
    return converter(v)
}

fileprivate func convertDict<T>(_ converter: (Any) -> T?, _ json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict = [String: T]()
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(_ dictionary: [String: T], _ converter: (T) -> Any) -> Any {
    var result = [String: Any]()
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double { return w }
    if let w = v as? Int { return Double(w) }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil { return .none }
    return .some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(" <> converter <> ", " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(" <> converter <> ", " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertAnyFunc :: IRType -> Doc String
convertAnyFunc = case _ of
    IRClass i -> do
        name <- lookupClassName i
        -- TODO make this look less alien
        pure $ "{ " <> name <> "(fromAny: $0) }"
    IRUnion ur ->
        case nullableFromSet $ unionToSet ur of
        Just t -> do
            converter <- convertAnyFunc t
            pure $ "{ (json: Any) in convertOptional(" <> converter <> ", json) }"
        Nothing -> do
            name <- lookupUnionName ur
            pure $ name <> ".fromJson"
    IRDouble -> pure "convertDouble"
    IRNull -> pure "checkNull"
    t -> do
        converted <- convertAny t "$0"
        pure $ "{ " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    convertCode <- convertToAny a "$0"
    pure $ var <> ".map({ " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    convertCode <- convertToAny m "$0"
    pure $ "convertToAny(" <> var <> ", { "<> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["json", "any"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
    line "}"

renderTopLevelExtensions :: String -> IRType -> Doc Unit
renderTopLevelExtensions topLevelName topLevelType = do
    blank

    topLevelRendered <- renderType topLevelType
    extensionType <- case topLevelType of
        IRArray t -> ("Array where Element == " <> _) <$> renderType t
        IRMap t -> ("Dictionary where Key == String, Value == " <> _) <$> renderType t
        _ -> pure topLevelRendered

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "init?(fromString json: String, using encoding: String.Encoding = .utf8) {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line "self.init(fromData: data)"
        line "}"
        blank
        line $ "init?(fromData data: Data) {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line "self.init(fromAny: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init()"
                    line $ "elements.forEach { self[$0.key] = $0.value }"
                line "}"
            _ -> pure unit

        blank
        line $ "var jsonData: Data? {"
        indent do
            convertCode <- convertToAny topLevelType "self"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"

        blank
        line $ "var jsonString: String? {"
        indent do
            line $ "guard let data = self.jsonData else { return nil }"
            line $ "return String(data: data, encoding: .utf8)"
        line "}"

    line "}"

renderClassExtension :: String -> Map String IRType -> Doc Unit
renderClassExtension className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        line $ "fileprivate init?(fromAny any: Any) {"
        indent do
            line "guard let json = any as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames properties "Untyped" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames properties "" forbidden
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname convertedNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                    line "else { return nil }"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname convertedNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "fileprivate var any: Any {"
        indent do
            if null properties
                then line "return [String: Any]()"
                else do
                    line "return ["
                    indent do
                        forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                            convertCode <- convertToAny ptype ("self." <> fieldName)
                            line $ "\"" <> stringEscape pname <> "\": " <> convertCode <> ","
                    line "]"
        line "}"
    line "}"

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
forEachProperty_ properties propertyNames f =
    let propertyArray = M.toUnfoldable properties :: Array _
        lastIndex = A.length propertyArray - 1
    in
        forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
            let fieldName = lookupName pname propertyNames
            f pname ptype fieldName (i == lastIndex)

makePropertyNames :: Map String IRType -> String -> Array String -> Map String String
makePropertyNames properties suffix forbidden =
    transformPropertyNames (fieldNamer suffix) otherField forbidden properties
    where
        fieldNamer :: String -> Namer String
        fieldNamer suffix = simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name = "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
    line "}"

renderUnionExtension :: String -> Set IRType -> Doc Unit
renderUnionExtension unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return ." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                convertCode <- convertToAny typ "x"
                line $ "case ." <> name <> letString <> ": return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
    renderCase :: IRType -> Doc Unit
    renderCase t = do
        convertCode <- convertAny t "v"
        name <- caseName t
        line $ "if let x = " <> convertCode <> " { return ." <> name <> "(x) }"

caseName :: IRType -> Doc String
caseName t = swiftNameStyle false <$> getTypeNameForUnion t


remove unused import

remove unused import

module Fetch (HTTP, fetch) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Data.Foreign (Foreign)
import Data.Options (Options, options)
import Fetch.Options (FetchOptions, defaults)
import Prelude (Unit, ($), (<>))

foreign import data HTTP :: !

foreign import fetchImpl ::
  forall eff.
    Foreign
    -> (String -> Eff (http :: HTTP | eff) Unit)
    -> (Error -> Eff (http :: HTTP | eff) Unit)
    -> (Eff (http :: HTTP | eff) Unit)

fetch :: forall eff. Options FetchOptions -> Aff (http :: HTTP | eff) String
fetch opts = makeAff \ng ok ->
  fetchImpl (options $ defaults <> opts) ok ng

module Fetch (HTTP, fetch) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Data.Foreign (Foreign)
import Data.Options (Options, options)
import Fetch.Options (FetchOptions, defaults)
import Prelude (Unit, ($), (<>), (<<<))

foreign import data HTTP :: !

foreign import fetchImpl ::
  forall eff.
    Foreign
    -> (String -> Eff (http :: HTTP | eff) Unit)
    -> (Error -> Eff (http :: HTTP | eff) Unit)
    -> (Eff (http :: HTTP | eff) Unit)

fetch :: forall eff. Options FetchOptions -> Aff (http :: HTTP | eff) String
fetch opts = makeAff \ng ok ->
  fetchImpl (options $ defaults <> opts) ok ng


Formatting

Formatting

module App.Layout where

import Prelude ((<$>), ($), (#))
import App.Game as Game
import App.Routes (Route(Home, NotFound))
import Control.Monad.Eff.Random (RANDOM)
import Pux (EffModel, noEffects, mapEffects, mapState)
import Pux.Html (Html, text, a, h1, div)
import Pux.Html.Attributes (href)

data Action
  = Child (Game.Action)
  | PageView Route

type State =
  { route :: Route
  , game :: Game.State
  }

init :: State
init =
  { route: NotFound
  , game: Game.init
  }

update :: forall e. Action -> State -> EffModel State Action (random :: RANDOM | e)
update (PageView route) state = noEffects $ state { route = route }
update (Child action) state =
  Game.update action state.game
    # mapState (state { game = _ })
    # mapEffects Child

view :: State -> Html Action
view state =
  div
    []
    [ h1 [] [ a [ href "http://www.alexmingoia.com/purescript-pux/" ] [ text "Pux" ]
            , text " Rock, Paper, Scissors!"
            ]
    , case state.route of
        Home -> Child <$> Game.view state.game
        NotFound -> App.NotFound.view state
    ]

module App.Layout where

import Prelude ((<$>), ($))
import App.Game as Game
import App.Routes (Route(Home, NotFound))
import Control.Monad.Eff.Random (RANDOM)
import Pux (EffModel, noEffects, mapEffects, mapState)
import Pux.Html (Html, text, a, h1, div)
import Pux.Html.Attributes (href)

data Action
  = Child (Game.Action)
  | PageView Route

type State =
  { route :: Route
  , game :: Game.State
  }

init :: State
init =
  { route: NotFound
  , game: Game.init
  }

update :: forall e. Action -> State -> EffModel State Action (random :: RANDOM | e)
update (PageView route) state = noEffects $ state { route = route }
update (Child action) state = mapEffects Child
                            $ mapState (state { game = _ })
                            $ Game.update action state.game

view :: State -> Html Action
view state =
  div
    []
    [ h1 [] [ a [ href "http://www.alexmingoia.com/purescript-pux/" ] [ text "Pux" ]
            , text " Rock, Paper, Scissors!"
            ]
    , case state.route of
        Home -> Child <$> Game.view state.game
        NotFound -> App.NotFound.view state
    ]