Implement `IsForeign` for `EmptyableLayout`

module Neodoc.Data.EmptyableLayout where

import Prelude
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse, for)
import Data.NonEmpty (NonEmpty, (:|))
import Data.NonEmpty.Extra (concat)
import Data.List (List(..), (:), fromFoldable, length, catMaybes)
import Data.Tuple (Tuple, fst, snd)
import Data.Tuple.Nested ((/\))
import Data.Foreign (F)
import Data.Foreign as F
import Data.Foreign.Class as F
import Data.Foreign.Index as F
import Data.Foreign.Index ((!))
import Data.Foreign.Class
import Neodoc.Data.Layout

-- XXX: This type is required i.o to be able to have 0-length branches in case
--      an expansion yields an empty result. Ideally, we would use the same
--      data structure from `Data.Layout` (parameterised over the type of
--      container, where it's currently fixed to be `List a`)
type EmptyableBranch a = List (EmptyableLayout a)
data EmptyableLayout a
  = EmptyableGroup
      Boolean -- optional
      Boolean -- repeatable
      (List (EmptyableBranch a))
  | EmptyableElem a

instance functorEmptyableLayout :: Functor EmptyableLayout where
  map f (EmptyableGroup o r xs) = EmptyableGroup o r $ ((f <$> _) <$> _) <$> xs
  map f (EmptyableElem x)       = EmptyableElem (f x)

instance showEmptyableLayout :: (Show a) => Show (EmptyableLayout a) where
  show (EmptyableElem  x)      = "EmptyableElem " <> show x
  show (EmptyableGroup o r xs) = "Group " <> show o <> " " <> show r <> " " <> show xs

instance isForeignEmptyableLayout :: (IsForeign a) => IsForeign (EmptyableLayout a) where
  read v = do
    typ :: String <- F.readProp "type" v

    case typ of
      "Elem" -> EmptyableElem
        <$> F.readProp "elem" v
      "Group" -> EmptyableGroup
        <$> F.readProp "optional" v
        <*> F.readProp "repeatable" v
        <*> do
            fromFoldable <$> do
              (fromFoldable <$> _) <$> do
                F.readProp "branches" v :: F (Array (Array (EmptyableLayout a)))
      _ -> Left $ F.errorAt "type" (F.JSONError $ "unknown type: " <> typ)

toStrictLayout
  :: ∀ a
   . EmptyableLayout a
  -> Maybe (Layout a)
toStrictLayout (EmptyableElem x) = Just (Elem x)
toStrictLayout (EmptyableGroup o r branches) =
  let branches' = catMaybes $ toStrictBranch <$> branches
   in case branches' of
        x : xs -> Just (Group o r (x :| xs))
        Nil    -> Nothing

toStrictBranch
  :: ∀ a
   . EmptyableBranch a
  -> Maybe (Branch a)
toStrictBranch branch =
  let elems = catMaybes $ toStrictLayout <$> branch
  in case elems of
        x : xs -> Just (x :| xs)
        Nil    -> Nothing

toEmptyableLayout
  :: ∀ a
   . Layout a
  -> EmptyableLayout a
toEmptyableLayout (Elem x) = EmptyableElem x
toEmptyableLayout (Group o r xs)
  = EmptyableGroup o r $ fromFoldable
                       $ toEmptyableBranch <$> xs

toEmptyableBranch
  :: ∀ a
   . Branch a
  -> EmptyableBranch a
toEmptyableBranch xs = fromFoldable $ toEmptyableLayout <$> xs

module Neodoc.Data.EmptyableLayout where

import Prelude
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse, for)
import Data.NonEmpty (NonEmpty, (:|))
import Data.NonEmpty.Extra (concat)
import Data.List (List(..), (:), fromFoldable, length, catMaybes)
import Data.Tuple (Tuple, fst, snd)
import Data.Tuple.Nested ((/\))
import Neodoc.Data.Layout

-- XXX: This type is required i.o to be able to have 0-length branches in case
--      an expansion yields an empty result. Ideally, we would use the same
--      data structure from `Data.Layout` (parameterised over the type of
--      container, where it's currently fixed to be `List a`)
type EmptyableBranch a = List (EmptyableLayout a)
data EmptyableLayout a
  = EmptyableGroup
      Boolean -- optional
      Boolean -- repeatable
      (List (EmptyableBranch a))
  | EmptyableElem a

instance functorEmptyableLayout :: Functor EmptyableLayout where
  map f (EmptyableGroup o r xs) = EmptyableGroup o r $ ((f <$> _) <$> _) <$> xs
  map f (EmptyableElem x)       = EmptyableElem (f x)

instance showEmptyableLayout :: (Show a) => Show (EmptyableLayout a) where
  show (EmptyableElem  x)      = "EmptyableElem " <> show x
  show (EmptyableGroup o r xs) = "Group " <> show o <> " " <> show r <> " " <> show xs

toStrictLayout
  :: ∀ a
   . EmptyableLayout a
  -> Maybe (Layout a)
toStrictLayout (EmptyableElem x) = Just (Elem x)
toStrictLayout (EmptyableGroup o r branches) =
  let branches' = catMaybes $ toStrictBranch <$> branches
   in case branches' of
        x : xs -> Just (Group o r (x :| xs))
        Nil    -> Nothing

toStrictBranch
  :: ∀ a
   . EmptyableBranch a
  -> Maybe (Branch a)
toStrictBranch branch =
  let elems = catMaybes $ toStrictLayout <$> branch
  in case elems of
        x : xs -> Just (x :| xs)
        Nil    -> Nothing

toEmptyableLayout
  :: ∀ a
   . Layout a
  -> EmptyableLayout a
toEmptyableLayout (Elem x) = EmptyableElem x
toEmptyableLayout (Group o r xs)
  = EmptyableGroup o r $ fromFoldable
                       $ toEmptyableBranch <$> xs

toEmptyableBranch
  :: ∀ a
   . Branch a
  -> EmptyableBranch a
toEmptyableBranch xs = fromFoldable $ toEmptyableLayout <$> xs


semiring

semiring

-- | Getting `hashchange` events and wraps
-- | `oldURL` and `newURL` to RouteMatch
-- | or RouteDiff instances
module Routing.Getter (
  route,
  or,
  contains,
  runRouter,
  hashes,
  matches,
  routes,
  PErr(),
  Router(),
  RouteDiff,
  fromMatch,
  RouteMatch(),
  RouteMatches()
  ) where

import Data.Either
import Data.Maybe
import Data.Tuple
import Control.Monad.Eff
import Control.Monad.State
import Control.Monad.Trans
import Control.Monad.State.Class
import Control.Monad.Error
import Data.Monoid
import Control.Apply ((*>))
import Control.Alt ((<|>))
import Data.String.Regex (replace, noFlags, Regex(), regex)
import Data.Array (findIndex, drop, take)
import Data.Traversable (traverse)

import qualified Data.StrMap as M
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P

import Routing.Parser (parse, template, StateObj())

-- | Shortcut for parser
type RouteParser = P.ParserT String StateObj RouteMatches
-- | Main data produced by matching hash
-- | Tuple routeName mappedTemplateArgumentsValues
type RouteMatch = Tuple String (M.StrMap String)
-- | nonempty list of matches
type RouteMatches = Tuple RouteMatch [RouteMatch]
-- | Shortcut for parsing errors
type PErr a = Either P.ParseError a
-- |
newtype Router = Router RouteParser

-- | check if `s` matches router
runRouter :: String -> Router -> PErr RouteMatches
runRouter s (Router p) =
  evalState (P.runParserT s p) M.empty

-- | define router by name and template
route :: String -> String -> PErr Router
route name templateStr = do
  parser <- parse <$> P.runParser templateStr template
  let p = parser *> lift get >>= \res ->
        pure $ Tuple (Tuple name res) []
  pure $ Router p

-- | construct router from two routers
-- | will match first **or** second
or :: Router -> Router -> Router
or (Router one) (Router two) =
  Router $ one <|> two

-- | construct router from two routers
-- | will try to match first router and
-- | if it matches try to match second
-- | produced result of matching first if
-- | second fails or aggregated result otherwise
contains :: Router -> Router -> Router
contains (Router parent) (Router child) =
  let put' :: M.StrMap String -> StateObj Unit
      put' = put
  in Router $ do
    Tuple pHead pTail <- parent
    lift $ put' M.empty
    c <- P.optionMaybe child
    pure $ case c of
      -- when name == "" we don't include match results for
      -- this router since it's one router
      Just (Tuple cHead@(Tuple name params) []) | name /= "" ->
        Tuple cHead (pHead:pTail)
      _ -> Tuple pHead pTail

-- | Main driver of routing
foreign import hashChanged """
function hashChanged(handler) {
  return function() {
    var currentHash = document.location.hash;
    handler("")(currentHash)();
    window.addEventListener("hashchange", function(ev) {
      handler(ev.oldURL)(ev.newURL)();
    });
  };
}
""" :: forall e. (String -> String -> Eff e Unit) -> Eff e Unit

-- | stream of hashes without hash symbol
hashes :: forall e. (String -> String -> Eff e Unit) -> Eff e Unit
hashes cb =
  hashChanged $ \old new -> do
    cb (dropHash old) (dropHash new)
  where dropHash h = replace (regex "^[^#]+#" noFlags) "" h

-- | Class of types that can be produced by matching
-- | diffs of hashes
class RouteDiff a where
  fromMatch :: RouteMatch -> Maybe a

-- | Tuple name argValMap is just RouteMatch
instance strMap :: RouteDiff (Tuple String (M.StrMap String)) where
  fromMatch = Just

-- | Stream of `RouteMatch`es
matches :: forall e. Router -> (RouteMatches -> Eff e Unit) -> Eff e Unit
matches route callback =
  hashes $ \old new -> do
    let diff = do
          -- Get old url matches
          Tuple headOld olds <- runRouter old route
          -- Get new url matches
          Tuple headNew news <- runRouter new route
          -- if new url is substate of old url
          case findIndex ((==) headOld) news of
            -1 -> pure $ Tuple headNew news
            -- find depth of substate and return only new part
            i -> if drop i news == (headOld:olds) then
                   pure $ Tuple headNew (take i news)
                   else
                   pure $ Tuple headNew news
    case diff of
      -- If router matches hash then callback
      Right matches -> callback matches
      -- Otherwise do nothing
      _ -> pure unit

-- Stream of decoded messages. i.e. in case of
-- purescript-halogen `i` from `HTML a i`
routes :: forall e a. (RouteDiff a) =>
          Router -> (Tuple a [a] -> Eff e Unit) -> Eff e Unit
routes route callback =
  matches route $ \(Tuple match matches) ->
    maybe (pure unit) callback do
          r <- fromMatch match
          rs <- traverse fromMatch matches
          pure $ Tuple r rs

zeroR :: Router
zeroR = Router $ P.fail "zero router always fails"

oneR :: Router
oneR = Router $ pure $ Tuple (Tuple "" M.empty) []

-- | Router is semigroup over `or`
instance semigroupRouter :: Semigroup Router where
  (<>) = or
-- | Router is monoid with always failing router as `mempty`
instance monoidRouter :: Monoid Router where
  mempty = Router $ P.fail "mempty"

instance semiringRouter :: Semiring Router where
  (+) = or
  (*) = contains
  zero = zeroR
  one = oneR

-- | Getting `hashchange` events and wraps
-- | `oldURL` and `newURL` to RouteMatch
-- | or RouteDiff instances
module Routing.Getter (
  route,
  or,
  contains,
  runRouter,
  hashes,
  matches,
  routes,
  PErr(),
  Router(),
  RouteDiff,
  fromMatch,
  RouteMatch(),
  RouteMatches()
  ) where

import Data.Either
import Data.Maybe
import Data.Tuple
import Control.Monad.Eff
import Control.Monad.State
import Control.Monad.Trans
import Control.Monad.State.Class
import Control.Monad.Error
import Data.Monoid
import Control.Apply ((*>))
import Control.Alt ((<|>))
import Data.String.Regex (replace, noFlags, Regex(), regex)
import Data.Array (findIndex, drop, take)
import Data.Traversable (traverse)

import qualified Data.StrMap as M
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P

import Routing.Parser (parse, template, StateObj())

-- | Shortcut for parser
type RouteParser = P.ParserT String StateObj RouteMatches
-- | Main data produced by matching hash
-- | Tuple routeName mappedTemplateArgumentsValues
type RouteMatch = Tuple String (M.StrMap String)
-- | nonempty list of matches
type RouteMatches = Tuple RouteMatch [RouteMatch]
-- | Shortcut for parsing errors
type PErr a = Either P.ParseError a
-- |
newtype Router = Router RouteParser

-- | check if `s` matches router
runRouter :: String -> Router -> PErr RouteMatches
runRouter s (Router p) =
  evalState (P.runParserT s p) M.empty

-- | define router by name and template
route :: String -> String -> PErr Router
route name templateStr = do
  parser <- parse <$> P.runParser templateStr template
  let p = parser *> lift get >>= \res ->
        pure $ Tuple (Tuple name res) []
  pure $ Router p

-- | construct router from two routers
-- | will match first **or** second
or :: Router -> Router -> Router
or (Router one) (Router two) =
  Router $ one <|> two

-- | construct router from two routers
-- | will try to match first router and
-- | if it matches try to match second
-- | produced result of matching first if
-- | second fails or aggregated result otherwise
contains :: Router -> Router -> Router
contains (Router parent) (Router child) =
  let put' :: M.StrMap String -> StateObj Unit
      put' = put
  in Router $ do
    Tuple pHead pTail <- parent
    lift $ put' M.empty
    c <- P.optionMaybe child
    pure $ case c of
      Nothing -> Tuple pHead pTail
      Just (Tuple cHead []) -> Tuple cHead (pHead:pTail)

-- | Main driver of routing
foreign import hashChanged """
function hashChanged(handler) {
  return function() {
    var currentHash = document.location.hash;
    handler("")(currentHash)();
    window.addEventListener("hashchange", function(ev) {
      handler(ev.oldURL)(ev.newURL)();
    });
  };
}
""" :: forall e. (String -> String -> Eff e Unit) -> Eff e Unit

-- | stream of hashes without hash symbol
hashes :: forall e. (String -> String -> Eff e Unit) -> Eff e Unit
hashes cb =
  hashChanged $ \old new -> do
    cb (dropHash old) (dropHash new)
  where dropHash h = replace (regex "^[^#]+#" noFlags) "" h

-- | Class of types that can be produced by matching
-- | diffs of hashes
class RouteDiff a where
  fromMatch :: RouteMatch -> Maybe a

-- | Tuple name argValMap is just RouteMatch
instance strMap :: RouteDiff (Tuple String (M.StrMap String)) where
  fromMatch = Just

-- | Stream of `RouteMatch`es
matches :: forall e. Router -> (RouteMatches -> Eff e Unit) -> Eff e Unit
matches route callback =
  hashes $ \old new -> do
    let diff = do
          -- Get old url matches
          Tuple headOld olds <- runRouter old route
          -- Get new url matches
          Tuple headNew news <- runRouter new route
          -- if new url is substate of old url
          case findIndex ((==) headOld) news of
            -1 -> pure $ Tuple headNew news
            -- find depth of substate and return only new part
            i -> if drop i news == (headOld:olds) then
                   pure $ Tuple headNew (take i news)
                   else
                   pure $ Tuple headNew news
    case diff of
      -- If router matches hash then callback
      Right matches -> callback matches
      -- Otherwise do nothing
      _ -> pure unit

-- Stream of decoded messages. i.e. in case of
-- purescript-halogen `i` from `HTML a i`
routes :: forall e a. (RouteDiff a) =>
          Router -> (Tuple a [a] -> Eff e Unit) -> Eff e Unit
routes route callback =
  matches route $ \(Tuple match matches) ->
    maybe (pure unit) callback do
          r <- fromMatch match
          rs <- traverse fromMatch matches
          pure $ Tuple r rs

-- | Router is semigroup over `or`
instance semigroupRouter :: Semigroup Router where
  (<>) = or
-- | Router is monoid with always failing router as `mempty`
instance monoidRouter :: Monoid Router where
  mempty = Router $ P.fail "mempty"


Use `Dot` over `TripleDot`

Use `Dot` over `TripleDot`

Since `TripleDot` can be expressed interms of `Dot`

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray)
import Data.List ((:))
import Docopt.Parser.Base

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dot
  | Dash
  | Name String

prettyPrintToken :: Token -> String
prettyPrintToken LParen  = "("
prettyPrintToken RParen  = ")"
prettyPrintToken LSquare = "["
prettyPrintToken RSquare = "]"
prettyPrintToken LAngle  = "<"
prettyPrintToken RAngle  = ">"
prettyPrintToken Dash    = "-"
prettyPrintToken Dot     = "."
prettyPrintToken (Name name) = name

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char '(' *> pure LParen
  , P.try $ P.char ')' *> pure RParen
  , P.try $ P.char '[' *> pure LSquare
  , P.try $ P.char ']' *> pure RSquare
  , P.try $ P.char '<' *> pure LAngle
  , P.try $ P.char '>' *> pure RAngle
  , P.try $ P.char '-' *> pure Dash
  , P.try $ P.char '.' *> pure Dot
  , Name <$> parseName
  ] <* P.skipSpaces

 where
  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray)
import Data.List ((:))
import Docopt.Parser.Base

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | TripleDot
  | Dash
  | Name String

prettyPrintToken :: Token -> String
prettyPrintToken LParen      = "("
prettyPrintToken RParen      = ")"
prettyPrintToken LSquare     = "["
prettyPrintToken RSquare     = "]"
prettyPrintToken LAngle      = "<"
prettyPrintToken RAngle      = ">"
prettyPrintToken Dash        = "-"
prettyPrintToken TripleDot   = "..."
prettyPrintToken (Name name) = name

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.string "..." *> pure TripleDot
  , Name <$> parseName
  ] <* P.skipSpaces

 where
  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']


Update tests to use assertEqual

Update tests to use assertEqual

module Test.Data.Enum (testEnum) where

import Prelude

import Data.Enum (class BoundedEnum, class Enum, defaultCardinality, defaultFromEnum, defaultToEnum, downFrom, enumFromThenTo, enumFromTo, upFrom, upFromIncluding)
import Data.Maybe (Maybe(..))
import Data.NonEmpty ((:|))
import Effect (Effect)
import Effect.Console (log)
import Test.Assert (assertEqual)

data T = A | B | C | D | E

derive instance eqT  :: Eq  T
derive instance ordT :: Ord T

instance showT :: Show T where
  show = case _ of
    A -> "A"
    B -> "B"
    C -> "C"
    D -> "D"
    E -> "E"

instance enumT :: Enum T where
  succ A = Just B
  succ B = Just C
  succ C = Just D
  succ D = Just E
  succ E = Nothing

  pred A = Nothing
  pred B = Just A
  pred C = Just B
  pred D = Just C
  pred E = Just D

instance boundedT :: Bounded T where
  bottom = A
  top = E

instance boundedEnumT :: BoundedEnum T where
  cardinality = defaultCardinality
  toEnum = defaultToEnum
  fromEnum = defaultFromEnum

testEnum :: Effect Unit
testEnum = do
  log "enumFromTo"
  assertEqual
    { actual: enumFromTo A A
    , expected: [A]
    }
  assertEqual
    { actual: enumFromTo B A
    , expected: []
    }
  assertEqual
    { actual: enumFromTo A C
    , expected: [A, B, C]
    }
  assertEqual
    { actual: enumFromTo A E
    , expected: [A, B, C, D, E]
    }

  log "enumFromThenTo"
  assertEqual
    { actual: enumFromThenTo A B E
    , expected: [A, B, C, D, E]
    }
  assertEqual
    { actual: enumFromThenTo A C E
    , expected: [A, C, E]
    }
  assertEqual
    { actual: enumFromThenTo A E E
    , expected: [A, E]
    }
  assertEqual
    { actual: enumFromThenTo A C C
    , expected: [A, C]
    }
  assertEqual
    { actual: enumFromThenTo A C D
    , expected: [A, C]
    }

  log "upFrom"
  assertEqual
    { actual: upFrom B
    , expected: [C, D, E]
    }
  assertEqual
    { actual: upFrom D
    , expected: [E]
    }
  assertEqual
    { actual: upFrom E
    , expected: []
    }

  log "upFromIncluding"
  assertEqual
    { actual: upFromIncluding B
    , expected: B :| [C, D, E]
    }
  assertEqual
    { actual: upFromIncluding D
    , expected: D :| [E]
    }
  assertEqual
    { actual: upFromIncluding E
    , expected: E :| []
    }

  log "downFrom"
  assertEqual
    { actual: downFrom D
    , expected: [C, B, A]
    }
  assertEqual
    { actual: downFrom B
    , expected: [A]
    }
  assertEqual
    { actual: downFrom A
    , expected: []
    }

module Test.Data.Enum (testEnum) where

import Prelude

import Data.Enum (class BoundedEnum, class Enum, defaultCardinality, defaultFromEnum, defaultToEnum, downFrom, enumFromThenTo, enumFromTo, upFrom, upFromIncluding)
import Data.Maybe (Maybe(..))
import Data.NonEmpty ((:|))
import Effect (Effect)
import Effect.Console (log)
import Test.Assert (assert)

data T = A | B | C | D | E

derive instance eqT  :: Eq  T
derive instance ordT :: Ord T

instance enumT :: Enum T where
  succ A = Just B
  succ B = Just C
  succ C = Just D
  succ D = Just E
  succ E = Nothing

  pred A = Nothing
  pred B = Just A
  pred C = Just B
  pred D = Just C
  pred E = Just D

instance boundedT :: Bounded T where
  bottom = A
  top = E

instance boundedEnumT :: BoundedEnum T where
  cardinality = defaultCardinality
  toEnum = defaultToEnum
  fromEnum = defaultFromEnum

testEnum :: Effect Unit
testEnum = do
  log "enumFromTo"
  assert $ enumFromTo A A == [A]
  assert $ enumFromTo B A == []
  assert $ enumFromTo A C == [A, B, C]
  assert $ enumFromTo A E == [A, B, C, D, E]

  log "enumFromThenTo"
  assert $ enumFromThenTo A B E == [A, B, C, D, E]
  assert $ enumFromThenTo A C E == [A,    C,    E]
  assert $ enumFromThenTo A E E == [A,          E]
  assert $ enumFromThenTo A C C == [A,    C      ]
  assert $ enumFromThenTo A C D == [A,    C      ]

  log "upFrom"
  assert $ upFrom B == [C, D, E]
  assert $ upFrom D == [      E]
  assert $ upFrom E == [       ]

  log "upFromIncluding"
  assert $ upFromIncluding B == B :| [C, D, E]
  assert $ upFromIncluding D == D :| [      E]
  assert $ upFromIncluding E == E :| [       ]

  log "downFrom"
  assert $ downFrom D == [C, B, A]
  assert $ downFrom B == [      A]
  assert $ downFrom A == [       ]


add IDBKey instance for numbers

add IDBKey instance for numbers

module Database.IndexedDB.IDBKey.Internal
    ( Key(..)
    , class IDBKey, toKey , fromKey , unsafeFromKey
    , extractForeign
    ) where

import Prelude

import Control.Alt                 ((<|>))
import Control.Monad.Except        (ExceptT(..), runExceptT)
import Data.Date                    as Date
import Data.DateTime               (DateTime(..), Time(..))
import Data.Enum                   (fromEnum, toEnum)
import Data.Foreign                 as Foreign
import Data.Foreign                (Foreign, F)
import Data.Function.Uncurried      as Fn
import Data.Function.Uncurried     (Fn2, Fn4, Fn7)
import Data.List.NonEmpty          (NonEmptyList(..))
import Data.List.Types             (List(..))
import Data.NonEmpty               (NonEmpty(..))
import Data.Either                 (Either(..), isRight)
import Data.Identity               (Identity(..))
import Data.Nullable               (Nullable, toNullable)
import Data.Time                    as Time
import Data.Traversable            (traverse)

newtype Key = Key Foreign

extractForeign :: Key -> Foreign
extractForeign (Key f) =
  f

--------------------
-- INTERFACES
--
class IDBKey a where
  toKey         :: a -> Key
  fromKey       :: Key -> F a
  unsafeFromKey :: Key -> a

--------------------
-- INSTANCES
--
instance eqKey :: Eq Key where
  eq a b = (runExceptT >>> runIdentity >>> isRight) $
      eq <$> ((fromKey a) :: F Int) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F String) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F DateTime) <*> fromKey b
    where
      runIdentity :: forall a. Identity a -> a
      runIdentity (Identity x) = x

instance idbKeyInt :: IDBKey Int where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readInt f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyNumber :: IDBKey Number where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readNumber f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyString :: IDBKey String where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readString f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyDate :: IDBKey DateTime where
  toKey (DateTime d t)  = Key $ Fn.runFn7 _dateTimeToForeign
    (fromEnum $ Date.year d)
    (fromEnum $ Date.month d)
    (fromEnum $ Date.day d)
    (fromEnum $ Time.hour t)
    (fromEnum $ Time.minute t)
    (fromEnum $ Time.second t)
    (fromEnum $ Time.millisecond t)
  fromKey (Key f)       = Fn.runFn4 _readDateTime dateTime dateTimeF dateTimeE f
  unsafeFromKey (Key f) = Fn.runFn2 _unsafeReadDateTime dateTime f

instance idbKeyArray :: IDBKey a => IDBKey (Array a) where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readArray f >>= traverse (Key >>> fromKey)
  unsafeFromKey (Key f) = map unsafeFromKey (Foreign.unsafeFromForeign f)

dateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime
dateTime y m d h mi s ms =
  toNullable $ DateTime
  <$> (Date.canonicalDate <$> toEnum y <*> toEnum m <*> toEnum d)
  <*> (Time <$> toEnum h <*> toEnum mi <*> toEnum s <*> toEnum ms)

dateTimeF :: DateTime -> F DateTime
dateTimeF =
  Right >>> Identity >>> ExceptT

dateTimeE :: String -> F DateTime
dateTimeE =
  Foreign.TypeMismatch "Date" >>> flip NonEmpty Nil >>> NonEmptyList >>> Left >>> Identity >>> ExceptT

--------------------
-- FFI
--
foreign import _dateTimeToForeign  :: Fn7 Int Int Int Int Int Int Int Foreign

foreign import _readDateTime :: Fn4 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) (DateTime -> F DateTime) (String -> F DateTime) Foreign (F DateTime)

foreign import _unsafeReadDateTime :: Fn2 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) Foreign DateTime

module Database.IndexedDB.IDBKey.Internal
    ( Key(..)
    , class IDBKey, toKey , fromKey , unsafeFromKey
    , extractForeign
    ) where

import Prelude

import Control.Alt                 ((<|>))
import Control.Monad.Except        (ExceptT(..), runExceptT)
import Data.Date                    as Date
import Data.DateTime               (DateTime(..), Time(..))
import Data.Enum                   (fromEnum, toEnum)
import Data.Foreign                 as Foreign
import Data.Foreign                (Foreign, F)
import Data.Function.Uncurried      as Fn
import Data.Function.Uncurried     (Fn2, Fn4, Fn7)
import Data.List.NonEmpty          (NonEmptyList(..))
import Data.List.Types             (List(..))
import Data.NonEmpty               (NonEmpty(..))
import Data.Either                 (Either(..), isRight)
import Data.Identity               (Identity(..))
import Data.Nullable               (Nullable, toNullable)
import Data.Time                    as Time
import Data.Traversable            (traverse)

newtype Key = Key Foreign

extractForeign :: Key -> Foreign
extractForeign (Key f) =
  f

--------------------
-- INTERFACES
--
class IDBKey a where
  toKey         :: a -> Key
  fromKey       :: Key -> F a
  unsafeFromKey :: Key -> a

--------------------
-- INSTANCES
--
instance eqKey :: Eq Key where
  eq a b = (runExceptT >>> runIdentity >>> isRight) $
      eq <$> ((fromKey a) :: F Int) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F String) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F DateTime) <*> fromKey b
    where
      runIdentity :: forall a. Identity a -> a
      runIdentity (Identity x) = x

instance idbKeyInt :: IDBKey Int where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readInt f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyString :: IDBKey String where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readString f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyDate :: IDBKey DateTime where
  toKey (DateTime d t)  = Key $ Fn.runFn7 _dateTimeToForeign
    (fromEnum $ Date.year d)
    (fromEnum $ Date.month d)
    (fromEnum $ Date.day d)
    (fromEnum $ Time.hour t)
    (fromEnum $ Time.minute t)
    (fromEnum $ Time.second t)
    (fromEnum $ Time.millisecond t)
  fromKey (Key f)       = Fn.runFn4 _readDateTime dateTime dateTimeF dateTimeE f
  unsafeFromKey (Key f) = Fn.runFn2 _unsafeReadDateTime dateTime f

instance idbKeyArray :: IDBKey a => IDBKey (Array a) where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readArray f >>= traverse (Key >>> fromKey)
  unsafeFromKey (Key f) = map unsafeFromKey (Foreign.unsafeFromForeign f)

dateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime
dateTime y m d h mi s ms =
  toNullable $ DateTime
  <$> (Date.canonicalDate <$> toEnum y <*> toEnum m <*> toEnum d)
  <*> (Time <$> toEnum h <*> toEnum mi <*> toEnum s <*> toEnum ms)

dateTimeF :: DateTime -> F DateTime
dateTimeF =
  Right >>> Identity >>> ExceptT

dateTimeE :: String -> F DateTime
dateTimeE =
  Foreign.TypeMismatch "Date" >>> flip NonEmpty Nil >>> NonEmptyList >>> Left >>> Identity >>> ExceptT

--------------------
-- FFI
--
foreign import _dateTimeToForeign  :: Fn7 Int Int Int Int Int Int Int Foreign

foreign import _readDateTime :: Fn4 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) (DateTime -> F DateTime) (String -> F DateTime) Foreign (F DateTime)

foreign import _unsafeReadDateTime :: Fn2 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) Foreign DateTime


[PR Feedback] use `for` instead of `flip traverse`

thanks @cryogenian!

module Test.Main where

import Prelude
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (CONSOLE(), log)

import Data.Traversable (traverse, for)
import qualified Data.BrowserFeatures.InputType as IT
import DOM
import DOM.BrowserFeatures.Detectors

main :: Eff (dom :: DOM, console :: CONSOLE) Unit
main = do
  features <- detectBrowserFeatures
  void $ for IT.allInputTypes \ty ->
    log $ show ty ++ if features.inputTypeSupported ty then " supported" else " not supported"

module Test.Main where

import Prelude
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (CONSOLE(), log)

import Data.Traversable (traverse)
import qualified Data.BrowserFeatures.InputType as IT
import DOM
import DOM.BrowserFeatures.Detectors

main :: Eff (dom :: DOM, console :: CONSOLE) Unit
main = do
  features <- detectBrowserFeatures
  void $ flip traverse IT.allInputTypes \ty ->
    log $ show ty ++ if features.inputTypeSupported ty then " supported" else " not supported"


Reserved words are fine in property names

Original commit 452e5f2dd74eb2c423802ccb40ac626ef982ddb7

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Either as Either
import Data.Foldable (all, any, elem, for_, intercalate, maximum)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: ["Convert"] <> reservedWords
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

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

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c = isLetter c || generalCategory c == Just LetterNumber

isStartCharacter :: Char -> Boolean
isStartCharacter c = isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a@(IRUnion _) -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

quote :: String -> String
quote s = "\"" <> s <> "\""

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = quote $ Str.stringEscape s
    | Str.null s = quote ""
    | any (not <<< isStartCharacter) (Str.toCharArray s) = quote $ Str.stringEscape s
    | otherwise =  Str.stringEscape s

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    topType <- getTopLevel
    topFull <- renderType topType
    topClassName <- getContainedClassName topType
    module_ <- getTopLevelNameGiven
    let imports =
            case topClassName of
                Just name -> {
                    basic:    "{ " <> name  <> " }",
                    advanced: "{ " <> name  <> ", Convert }"
                }
                Nothing -> {
                    basic:    "* as " <> module_,
                    advanced: "{ Convert }"
                }

    line $ """// To parse this data:
//
//   import """ <> imports.basic  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = JSON.parse(json);
//
// Or use Convert.fromJson to perform a type-checking conversion:
//
//   import """ <> imports.advanced  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank

    line "//"
    line "// The Convert module parses JSON and asserts types"
    line "//"
    blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure $ quote "undefined"
    IRNull -> pure $ quote "undefined"
    IRInteger -> pure $ quote "number"
    IRDouble -> pure $ quote "number"
    IRBool -> pure $ quote "boolean"
    IRString -> pure $ quote "string"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object(" <> quote name <> ")"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`;
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == "undefined") return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`["${prop}"]`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

reservedWords :: Array String
reservedWords = ["break", "case", "catch", "class", "const", "continue", "debugger", "default", "delete", "do", "else", "enum", "export", "extends", "false", "finally", "for", "function", "if", "import", "in", "instanceof", "new", "null", "return", "super", "switch", "this", "throw", "true", "try", "typeof", "var", "void", "while", "with", "as", "implements", "interface", "let", "package", "private", "protected", "public", "static", "yield", "any", "boolean", "constructor", "declare", "get", "module", "require", "number", "set", "string", "symbol", "type", "from", "of"]

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Either as Either
import Data.Foldable (all, any, elem, for_, intercalate, maximum)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: ["Convert", "Converted"] <> reservedWords
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

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

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c = isLetter c || generalCategory c == Just LetterNumber

isStartCharacter :: Char -> Boolean
isStartCharacter c = isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a@(IRUnion _) -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

quote :: String -> String
quote s = "\"" <> s <> "\""

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = quote $ Str.stringEscape s
    | Str.null s = quote ""
    | s `elem` reservedWords = quote s
    | any (not <<< isStartCharacter) (Str.toCharArray s) = quote $ Str.stringEscape s
    | otherwise =  Str.stringEscape s

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    topType <- getTopLevel
    topFull <- renderType topType
    topClassName <- getContainedClassName topType
    module_ <- getTopLevelNameGiven
    let imports =
            case topClassName of
                Just name -> {
                    basic:    "{ " <> name  <> " }",
                    advanced: "{ " <> name  <> ", Convert }"
                }
                Nothing -> {
                    basic:    "* as " <> module_,
                    advanced: "{ Convert }"
                }

    line $ """// To parse this data:
//
//   import """ <> imports.basic  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = JSON.parse(json);
//
// Or use Convert.fromJson to perform a type-checking conversion:
//
//   import """ <> imports.advanced  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank

    line "//"
    line "// The Convert module parses JSON and asserts types"
    line "//"
    blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure $ quote "undefined"
    IRNull -> pure $ quote "undefined"
    IRInteger -> pure $ quote "number"
    IRDouble -> pure $ quote "number"
    IRBool -> pure $ quote "boolean"
    IRString -> pure $ quote "string"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object(" <> quote name <> ")"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`;
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == "undefined") return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`["${prop}"]`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

reservedWords :: Array String
reservedWords = ["break", "case", "catch", "class", "const", "continue", "debugger", "default", "delete", "do", "else", "enum", "export", "extends", "false", "finally", "for", "function", "if", "import", "in", "instanceof", "new", "null", "return", "super", "switch", "this", "throw", "true", "try", "typeof", "var", "void", "while", "with", "as", "implements", "interface", "let", "package", "private", "protected", "public", "static", "yield", "any", "boolean", "constructor", "declare", "get", "module", "require", "number", "set", "string", "symbol", "type", "from", "of"]


loaded handler

loaded handler

module CalendarChart.Component.Chart where

import CalendarChart.Component.Types

import Prelude

import Data.Maybe
import Data.JSON
import Data.Const
import Data.Void

import CalendarChart.Chart
import CalendarChart.Activities
import CalendarChart.Strava
import CalendarChart.RA
import CalendarChart.Util

import Data.Array(mapMaybe,length,filter,concat,(..),findIndex,modifyAt,(:))
import Data.Date
import Data.Time
import Data.Tuple
import Data.Foldable(for_)

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Class(liftEff)
import Control.Monad.Aff(launchAff,Aff())
import Network.HTTP.Affjax
import Control.Monad.Eff.Console

import qualified Browser.WebStorage as WS

import Data.Either
import Data.Foreign(readString)
import Control.Bind
import DOM
import DOM.File.Types
import DOM.Node.Types
import DOM.HTML.Types
import DOM.Node.Document
import DOM.HTML (window)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (querySelector)

import Halogen
import Halogen.Component
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Properties as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Types as ET
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.Query.StateF as S
import Data.Functor (($>))
import Control.Plus (empty)
import qualified Data.Int as I

import Control.Monad.Free
import Data.Coyoneda

import Control.Monad.Rec.Class (MonadRec)

import Network.RemoteCallback

import CalendarChart.Downloads
import CalendarChart.Component.Main
import CalendarChart.Component.Chart

savedStateKey = "savedState"

chartUi :: forall p. Component ChartState ChartInput (Aff AppEffects) p
chartUi = component render eval
  where
  render :: Render ChartState ChartInput p
  render _ =  H.div [ initializer, A.classes [H.className "monthchart", H.className "hcl2"] ] [ ]

  -- possibly should use this elt to pass to chart rather than go via css selector?
  initializer = H.Initializer "" (\el -> action (Init el))

  eval :: Eval ChartInput ChartState ChartInput (Aff AppEffects)
  eval (ChartInput (s@ (State { data=acts, years=y })) next) = do
    liftEff' $ log "child chart got state"
    S.modify _ { state = s }

    liftEff' $ WS.setItem WS.localStorage savedStateKey $ encode s
    let onLoad = \_ -> ((chart y $ allActivities acts) :: (Eff AppEffects Unit))
    liftEff' $ DOM.Event.EventTarget.addEventListener DOM.Event.EventTypes.load (DOM.Event.EventTarget.eventListener onLoad) false <<< DOM.HTML.Types.windowToEventTarget =<< window

    liftEff' $ chart y $ allActivities acts
    pure next
  eval (Init el next) = do
    liftEff' $ log "Child chart got init"
    S.modify _{ elt = Just el }
    pure next

chart y = chartMonths y <<< filter (\(Activity a) -> a.type == Run)

module CalendarChart.Component.Chart where

import CalendarChart.Component.Types

import Prelude

import Data.Maybe
import Data.JSON
import Data.Const
import Data.Void

import CalendarChart.Chart
import CalendarChart.Activities
import CalendarChart.Strava
import CalendarChart.RA
import CalendarChart.Util

import Data.Array(mapMaybe,length,filter,concat,(..),findIndex,modifyAt,(:))
import Data.Date
import Data.Time
import Data.Tuple
import Data.Foldable(for_)

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Class(liftEff)
import Control.Monad.Aff(launchAff,Aff())
import Network.HTTP.Affjax
import Control.Monad.Eff.Console

import qualified Browser.WebStorage as WS

import Data.Either
import Data.Foreign(readString)
import Control.Bind
import DOM
import DOM.File.Types
import DOM.Node.Types
import DOM.HTML.Types
import DOM.Node.Document
import DOM.HTML (window)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (querySelector)

import Halogen
import Halogen.Component
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Properties as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Types as ET
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.Query.StateF as S
import Data.Functor (($>))
import Control.Plus (empty)
import qualified Data.Int as I

import Control.Monad.Free
import Data.Coyoneda

import Control.Monad.Rec.Class (MonadRec)

import Network.RemoteCallback

import CalendarChart.Downloads
import CalendarChart.Component.Main
import CalendarChart.Component.Chart

savedStateKey = "savedState"

chartUi :: forall p. Component ChartState ChartInput (Aff AppEffects) p
chartUi = component render eval
  where
  render :: Render ChartState ChartInput p
  render _ =  H.div [ initializer, A.classes [H.className "monthchart", H.className "hcl2"] ] [ ]

  -- possibly should use this elt to pass to chart rather than go via css selector?
  initializer = H.Initializer "" (\el -> action (Init el))

  eval :: Eval ChartInput ChartState ChartInput (Aff AppEffects)
  eval (ChartInput (s@ (State { data=acts, years=y })) next) = do
    liftEff' $ log "child chart got state"
    S.modify _ { state = s }

    liftEff' $ WS.setItem WS.localStorage savedStateKey $ encode s
    -- let onLoad = \_ -> ((chart y $ allActivities acts) :: (Eff AppEffects Unit))
    -- DOM.Event.EventTarget.addEventListener DOM.Event.EventTypes.load (DOM.Event.EventTarget.eventListener onLoad) false <<< DOM.HTML.Types.windowToEventTarget =<< window

    liftEff' $ chart y $ allActivities acts
    pure next
  eval (Init el next) = do
    liftEff' $ log "Child chart got init"
    S.modify _{ elt = Just el }
    pure next

chart y = chartMonths y <<< filter (\(Activity a) -> a.type == Run)


chat update

chat update

module Component.Chat where

import Prelude
import WebAPI.Settings
import WebAPI
import Chat.ServerTypes
import Component.LoginWidget as Login
import Halogen.HTML.Events as E
import Halogen.HTML as H
import Halogen.HTML.Properties as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar(AVAR)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Either (Either(..))
import Data.Function (const, (<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup ((<>))
import Data.String (take)
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, SubscribeStatus(Listening), action, eventSource, modify, subscribe, get, put)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Events (input_, onClick, onInput, onKeyPress, onSubmit)
import Halogen.HTML (button, input, textarea)
import Network.HTTP.Affjax (AJAX)
import Halogen.Component
import Servant.PureScript.Affjax (errorToString)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Servant.Subscriber.Internal (doCallback)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebSocket (WEBSOCKET)
import DOM(DOM)
import DOM.HTML
import DOM.HTML.Window
import DOM.HTML.Location

type State = {cur :: String , text :: Array ChatMessage, sub :: Boolean, auth :: Maybe AuthToken, login :: String}

initial :: State
initial = {cur: "", text: [], sub: false, auth: Nothing, login: ""}

data Query a = Connect a | Disconnect a | UpdateText (Array ChatMessage) a | SendMessage a | UpdateCurrent String a | SetAuth a | UpdateLogin String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET, avar :: AVAR, dom :: DOM, err :: EXCEPTION | eff)

chat :: forall eff. Component H.HTML Query Unit Void (Aff (Effects eff))
chat = lifecycleComponent spec
        where
              spec :: LifecycleComponentSpec H.HTML State Query Unit Void (Aff (Effects eff))
              spec = { initialState: const initial
                     , render
                     , eval
                     , receiver: const Nothing
                     , initializer: Just (action Connect)
                     , finalizer: Just (action Disconnect)}
              render :: State -> ComponentHTML Query
              render {text, cur, sub, auth: Just _ } = H.div_ $
                    append (if not sub
                        then []
                        else [ H.input [ P.value cur
                                       , E.onValueInput (E.input UpdateCurrent)
                                       , E.onKeyPress  ((E.input_ SendMessage))
                                       ]
                            , H.button [E.onClick (E.input_ SendMessage)] [H.text "Send"]])
                        $ (\(ChatMessage t) -> H.div_ [H.text (t.userName <> ": " <> t.messageBody)]) <$> text
              render _ = Login.render UpdateLogin SetAuth
              eval :: Query ~> ComponentDSL State Query Void (Aff (Effects eff))
              eval (Connect a) = do
                st <- get
                case st.auth of
                  Nothing -> pure a
                  Just token -> do
                    sub <- liftEff (initSubscriber token)
                    subscribe (chatMessages sub.messages)
                    modify (\s -> s {sub = true})
                    pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= t})
                pure a
              eval (SendMessage a) = do
                st <- get
                case st.auth of
                  Nothing -> pure a
                  Just t -> do
                       merr <- liftAff $ sendMessage st.cur t
                       case merr of
                           Just err -> do modify (\s ->  s {text= append [systemMessage err] s.text})
                                          pure a
                           Nothing -> do modify (\s -> s {cur = ""})
                                         pure a
              eval (UpdateCurrent s a) = do
                modify (\st -> st {cur = s})
                pure a
              eval (UpdateLogin l a) = do
                modify (\st -> st {login = l})
                pure a
              eval (SetAuth a) = do
                st <- get
                let t = (AuthToken st.login)
                put $ st {auth = Just t}
                sub <- liftEff $ initSubscriber t
                subscribe (chatMessages sub.messages)
                modify (\s -> s {sub = true})
                pure a

data Action = Update (Array ChatMessage)
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}
websocketUrl :: forall eff. Eff (dom :: DOM | eff) String
websocketUrl = do
  l <- location =<< window
  h <- host l
  hname <- hostname l
  let p = case hname of
            "localhost" -> "ws:"
            _ -> "wss:"
  pure $ p <> "//"<> h

initSubscriber :: forall eff. AuthToken -> SubscriberEff (channel :: CHANNEL, dom ::DOM  | eff) (SubscriberData (channel :: CHANNEL, dom ::DOM | eff))
initSubscriber a = do
  ch <- channel Nop
  url <- websocketUrl
  let
    c :: Config (channel :: CHANNEL, dom ::DOM | eff) Action
    c = {
        url : url <> "/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getChat (maybe (ReportError) Update) a
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  Signal Action ->
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       )
       Unit
callback sig eff = do
    runSignal (eff <$> sig)

systemMessage :: String -> ChatMessage
systemMessage s = ChatMessage {userName: "System", messageBody: s}

chatMessages ::  forall eff.  Signal Action ->  EventSource Query (Aff(Effects eff))
chatMessages sig = eventSource (callback sig) (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText [systemMessage "No op"]
            ReportError -> f $ UpdateText [systemMessage "Error"]
            SubscriberLog s -> f $ UpdateText [systemMessage s]
        )
        where
            f :: (SubscribeStatus -> Query SubscribeStatus) -> Maybe (Query SubscribeStatus)
            f x = Just $ x Listening

sendMessage :: forall eff. String -> AuthToken -> Aff (ajax :: AJAX | eff) (Maybe String)
sendMessage s a = do
    ebs <- runExceptT $ runReaderT (postChat a s) settings
    pure $ case ebs of
        Left err -> Just $ errorToString err
        _ -> Nothing

module Component.Chat where

import Prelude
import WebAPI.Settings
import WebAPI
import Chat.ServerTypes
import Component.LoginWidget as Login
import Halogen.HTML.Events as E
import Halogen.HTML as H
import Halogen.HTML.Properties as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Either (Either(..))
import Data.Function (const, (<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup ((<>))
import Data.String (take)
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, liftH, modify, subscribe)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Events (input_, onClick, onInput, onKeyPress, onSubmit)
import Halogen.HTML (button, input, textarea)
import Halogen.Query (get, set)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (errorToString)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Servant.Subscriber.Internal (doCallback)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebSocket (WEBSOCKET)
import DOM(DOM)
import DOM.HTML
import DOM.HTML.Window
import DOM.HTML.Location

type State = {cur :: String , text :: Array ChatMessage, sub :: Boolean, auth :: Maybe AuthToken, login :: String}

initial :: State
initial = {cur: "", text: [], sub: false, auth: Nothing, login: ""}

data Query a = Connect a | Disconnect a | UpdateText (Array ChatMessage) a | SendMessage a | UpdateCurrent String a | SetAuth a | UpdateLogin String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

onlyForKey :: forall props g ev.
  (Functor g) => Number
                   -> ({ "keyCode" :: Number
                       | props
                       }
                       -> g (Maybe ev)
                      )
                      -> { "keyCode" :: Number
                         | props
                         }
                         -> g (Maybe ev)
onlyForKey i input  = (\ (a@{keyCode}) -> (if keyCode == 13.0 then id else const Nothing) <$> input a)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadAff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text, cur, sub, auth: Just _ } = H.div_ $
                    append (if not sub
                        then []
                        else [ H.input [ P.value cur
                                       , E.onValueInput (E.input UpdateCurrent)
                                       , E.onKeyPress  (onlyForKey 13.0 (E.input_ SendMessage))
                                       ]
                            , H.button [E.onClick (E.input_ SendMessage)] [H.text "Send"]])
                        $ (\(ChatMessage t) -> H.div_ [H.text (t.userName <> ": " <> t.messageBody)]) <$> text
              render _ = Login.render UpdateLogin SetAuth
              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                st <- get
                case st.auth of
                  Nothing -> pure a
                  Just token -> do
                    sub <- liftH $ liftEff (initSubscriber token)
                    subscribe (chatMessages sub.messages)
                    modify (\s -> s {sub = true})
                    pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= t})
                pure a
              eval (SendMessage a) = do
                st <- get
                case st.auth of
                  Nothing -> pure a
                  Just t -> do
                       merr <- liftH <<< liftAff $ sendMessage st.cur t
                       case merr of
                           Just err -> do modify (\s ->  s {text= append [systemMessage err] s.text})
                                          pure a
                           Nothing -> do modify (\s -> s {cur = ""})
                                         pure a
              eval (UpdateCurrent s a) = do
                modify (\st -> st {cur = s})
                pure a
              eval (UpdateLogin l a) = do
                modify (\st -> st {login = l})
                pure a
              eval (SetAuth a) = do
                st <- get
                let t = (AuthToken st.login)
                set $ st {auth = Just t}
                sub <- liftH $ liftEff $ initSubscriber t
                subscribe (chatMessages sub.messages)
                modify (\s -> s {sub = true})
                pure a

data Action = Update (Array ChatMessage)
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}
websocketUrl :: forall eff. Eff (dom :: DOM | eff) String
websocketUrl = do
  l <- location =<< window
  h <- host l
  hname <- hostname l
  let p = case hname of
            "localhost" -> "ws:"
            _ -> "wss:"
  pure $ p <> "//"<> h

initSubscriber :: forall eff. AuthToken -> SubscriberEff (channel :: CHANNEL, dom ::DOM  | eff) (SubscriberData (channel :: CHANNEL, dom ::DOM | eff))
initSubscriber a = do
  ch <- channel Nop
  url <- websocketUrl
  let
    c :: Config (channel :: CHANNEL, dom ::DOM | eff) Action
    c = {
        url : url <> "/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getChat (maybe (ReportError) Update) a
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  Signal Action ->
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       )
       Unit
callback sig eff = do
    runSignal (eff <$> sig)

systemMessage :: String -> ChatMessage
systemMessage s = ChatMessage {userName: "System", messageBody: s}

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => Signal Action ->  EventSource Query g
chatMessages sig = eventSource (callback sig) (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText [systemMessage "No op"]
            ReportError -> f $ UpdateText [systemMessage "Error"]
            SubscriberLog s -> f $ UpdateText [systemMessage s]
        )
        where
            f x = pure $ action x

sendMessage :: forall eff. String -> AuthToken -> Aff (ajax :: AJAX | eff) (Maybe String)
sendMessage s a = do
    ebs <- runExceptT $ runReaderT (postChat a s) settings
    pure $ case ebs of
        Left err -> Just $ errorToString err
        _ -> Nothing


Added text to 404 in file response

Added text to 404 in file response

module Network.Wai.Handler.Swai.Response (makeResponseCallback) where

import Data.Function
import Control.Monad.Aff
import Network.HTTP
import Network.Wai.Internal
import Network.Wai
import Network.Wai.Handler.Swai.Types

foreign import fs "var fs = require('fs');" :: Unit

makeResponseCallback :: forall e. NodeResponse -> ResponseCallback e

makeResponseCallback response (ResponseString status headers body) = do
    liftEff' $ runFn4 respondString response (status2Number status) (headerToH <$> headers) body
    return ResponseReceived

makeResponseCallback response (ResponseFile status headers filename) = do
    liftEff' $ runFn4 respondFile response (status2Number status) (headerToH <$> headers) filename
    return ResponseReceived

data H = H String String

headerToH :: Header -> H
headerToH (Header head value) = H (show head) value

foreign import respondString """
function respondString(response, status, headers, body) {
    return function() {
        response.statusCode = status;
        headers.forEach(function(header) {
            response.setHeader(header.value0, header.value1);
        });
        response.end(body);
    };
}""" :: forall e. Fn4 NodeResponse Number [H] String (WaiEff e)

foreign import respondFile """
function respondFile(response, status, header, filepath) {
    return function() {
        fs.readFile(filepath, function(error, content) {
            if(error) {
                response.writeHead(404);
                response.end("404 - Not Found");
            } else {
                response.end(content);
            }
        });
    };
}""" :: forall e. Fn4 NodeResponse Number [H] String (WaiEff e)

module Network.Wai.Handler.Swai.Response (makeResponseCallback) where

import Data.Function
import Control.Monad.Aff
import Network.HTTP
import Network.Wai.Internal
import Network.Wai
import Network.Wai.Handler.Swai.Types

foreign import fs "var fs = require('fs');" :: Unit

makeResponseCallback :: forall e. NodeResponse -> ResponseCallback e

makeResponseCallback response (ResponseString status headers body) = do
    liftEff' $ runFn4 respondString response (status2Number status) (headerToH <$> headers) body
    return ResponseReceived

makeResponseCallback response (ResponseFile status headers filename) = do
    liftEff' $ runFn4 respondFile response (status2Number status) (headerToH <$> headers) filename
    return ResponseReceived

data H = H String String

headerToH :: Header -> H
headerToH (Header head value) = H (show head) value

foreign import respondString """
function respondString(response, status, headers, body) {
    return function() {
        response.statusCode = status;
        headers.forEach(function(header) {
            response.setHeader(header.value0, header.value1);
        });
        response.end(body);
    };
}""" :: forall e. Fn4 NodeResponse Number [H] String (WaiEff e)

foreign import respondFile """
function respondFile(response, status, header, filepath) {
    return function() {
        fs.readFile(filepath, function(error, content) {
            if(error) {
                response.writeHead(404);
                response.end();
            } else {
                response.end(content);
            }
        });
    };
}""" :: forall e. Fn4 NodeResponse Number [H] String (WaiEff e)


Don't blow the call stack.

Don't blow the call stack.

This code compiles unfortunately poorly.

module Test.Main where

import Test.Spec                  (describe, it, pending)
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Runner           (run)
import Test.Spec.Reporter.Console (consoleReporter)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Node.Process (PROCESS)

import Prelude
import Data.InfiniteList
import Data.List as L
import Data.NonEmpty ((:|))
import Data.Tuple
import Data.Filterable (filter)

main :: forall e. Eff (console :: CONSOLE, process :: PROCESS | e) Unit
main = run [consoleReporter] allSpecs

-- main :: forall e. Eff (console :: CONSOLE | e) Unit
allSpecs = describe "Infinite List" do
  iterateSpecs
  repeatedSpecs
  dropWhileSpecs
  takeWhileSpecs
  functorSpecs
  filterableSpecs

iterateSpecs = describe "Iteated infinite lists" do
  it "The natural numbers" do
    let il = iterate ((+) 1) 1
    head il `shouldEqual` 1
    (head <<< tail $ il) `shouldEqual` 2
    (head <<< tail <<< tail $ il) `shouldEqual` 3
    (head <<< tail <<< tail <<< tail $ il) `shouldEqual` 4
    (head <<< tail <<< tail <<< tail <<< tail $ il) `shouldEqual` 5
  it "Created a descending list of negative numbers" do
    let il = iterate (\x -> x - 1) 0
    head il `shouldEqual` 0
    (head <<< tail $ il) `shouldEqual` (-1)
    (head <<< tail <<< tail $ il) `shouldEqual` (-2)
    (head <<< tail <<< tail <<< tail $ il) `shouldEqual` (-3)
    (head <<< tail <<< tail <<< tail <<< tail $ il) `shouldEqual` (-4)
  it "From a thousand and beyond" do
    let il = iterate ((+) 1) 1000
    head il `shouldEqual` 1000
    (head <<< tail $ il) `shouldEqual` 1001
    (head <<< tail <<< tail $ il) `shouldEqual` 1002
    (head <<< tail <<< tail <<< tail $ il) `shouldEqual` 1003
    (head <<< tail <<< tail <<< tail <<< tail $ il) `shouldEqual` 1004
  it "create the binary list" do
    let il = iterate not true
    head il `shouldEqual` true
    (head <<< tail $ il) `shouldEqual` false
    (head <<< tail <<< tail $ il) `shouldEqual` true
    (head <<< tail <<< tail <<< tail $ il) `shouldEqual` false

repeatedSpecs = describe "Repeated infinite lists" do
  it "The numbers from one to three repeated" do
    let il = repeat (1 :| L.fromFoldable [2, 3])
    take 8 il `shouldEqual` L.fromFoldable [1, 2, 3, 1, 2, 3, 1, 2]

  it "strange numbers repeated work" do
    let il = repeat (1 :| L.fromFoldable [5, 2, 1, 3, 4])
    take 8 il `shouldEqual` L.fromFoldable [1, 5, 2, 1, 3, 4, 1, 5]

dropWhileSpecs = describe "dropWhile" do
  it "'head' after a 'dropWhile' should return something that matches the condition" do
    let il = iterate ((+) 1) 0
    let result = dropWhile (\x -> x < 10) il
    head il `shouldEqual` 0
    head result `shouldEqual` 10
  it "dropWhile should skip many elements" do
    let il = iterate ((+) 1) 0
    let result = dropWhile (\x -> x < 10000) il
    head result `shouldEqual` 10000

takeWhileSpecs = describe "takeWhile" do
  it "takeWhile should generate a good list of elements" do
    let il = iterate ((+) 1) 0
    takeWhile (\x -> x < 10) il `shouldEqual` L.fromFoldable [0, 1, 2, 3, 4, 5, 6, 7, 8 ,9]
  it "takeWhile on many elements should be fast" do
    let il = iterate ((+) 1) 0
    let result = takeWhile (\x -> x < 10000) il
    L.length result `shouldEqual` 10000

functorSpecs = describe "Functor" do
  it "can increment an infinite list by five" do
    let il = iterate ((+) 1) 0
    let result = map ((+) 5) il
    take 5 result `shouldEqual` L.fromFoldable [5, 6, 7, 8, 9]
  it "can map an infinite list to boolean values" do
    let il = iterate ((+) 1) 0
    let result = map (\x -> x `mod` 3 == 0) il
    take 5 result `shouldEqual` L.fromFoldable [true, false, false, true, false]
  it "can map an infinite list into tuple values" do
    let il = iterate ((+) 1) 0
    let result = map (\x -> Tuple x ("n: " <> show x)) il
    take 5 result `shouldEqual` L.fromFoldable [Tuple 0 "n: 0", Tuple 1 "n: 1", Tuple 2 "n: 2", Tuple 3 "n: 3", Tuple 4 "n: 4"]

filterableSpecs = describe "Filterable" do
  it "can filter numbers from an infinite list" do
    let il = iterate ((+) 1) 1
    let result = filter (\x -> (x `mod` 3 == 0) || (x `mod` 5 == 0)) il
    takeWhile (\x -> x <= 20) result `shouldEqual` L.fromFoldable [3, 5, 6, 9, 10, 12, 15, 18, 20]

module Test.Main where

import Test.Spec                  (describe, it, pending)
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Runner           (run)
import Test.Spec.Reporter.Console (consoleReporter)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Node.Process (PROCESS)

import Prelude
import Data.InfiniteList
import Data.List as L
import Data.NonEmpty ((:|))
import Data.Tuple
import Data.Filterable (filter)

main :: forall e. Eff (console :: CONSOLE, process :: PROCESS | e) Unit
main = run [consoleReporter] allSpecs

-- main :: forall e. Eff (console :: CONSOLE | e) Unit
allSpecs = describe "Infinite List" do
  iterateSpecs
  repeatedSpecs
  dropWhileSpecs
  takeWhileSpecs
  functorSpecs
  filterableSpecs

iterateSpecs = describe "Iteated infinite lists" do
  it "The natural numbers" do
    let il = iterate ((+) 1) 1
    head il `shouldEqual` 1
    (head <<< tail $ il) `shouldEqual` 2
    (head <<< tail <<< tail $ il) `shouldEqual` 3
    (head <<< tail <<< tail <<< tail $ il) `shouldEqual` 4
    (head <<< tail <<< tail <<< tail <<< tail $ il) `shouldEqual` 5
  it "Created a descending list of negative numbers" do
    let il = iterate (\x -> x - 1) 0
    head il `shouldEqual` 0
    (head <<< tail $ il) `shouldEqual` (-1)
    (head <<< tail <<< tail $ il) `shouldEqual` (-2)
    (head <<< tail <<< tail <<< tail $ il) `shouldEqual` (-3)
    (head <<< tail <<< tail <<< tail <<< tail $ il) `shouldEqual` (-4)
  it "From a thousand and beyond" do
    let il = iterate ((+) 1) 1000
    head il `shouldEqual` 1000
    (head <<< tail $ il) `shouldEqual` 1001
    (head <<< tail <<< tail $ il) `shouldEqual` 1002
    (head <<< tail <<< tail <<< tail $ il) `shouldEqual` 1003
    (head <<< tail <<< tail <<< tail <<< tail $ il) `shouldEqual` 1004
  it "create the binary list" do
    let il = iterate not true
    head il `shouldEqual` true
    (head <<< tail $ il) `shouldEqual` false
    (head <<< tail <<< tail $ il) `shouldEqual` true
    (head <<< tail <<< tail <<< tail $ il) `shouldEqual` false

repeatedSpecs = describe "Repeated infinite lists" do
  it "The numbers from one to three repeated" do
    let il = repeat (1 :| L.fromFoldable [2, 3])
    take 8 il `shouldEqual` L.fromFoldable [1, 2, 3, 1, 2, 3, 1, 2]

  it "strange numbers repeated work" do
    let il = repeat (1 :| L.fromFoldable [5, 2, 1, 3, 4])
    take 8 il `shouldEqual` L.fromFoldable [1, 5, 2, 1, 3, 4, 1, 5]

dropWhileSpecs = describe "dropWhile" do
  it "'head' after a 'dropWhile' should return something that matches the condition" do
    let il = iterate ((+) 1) 0
    let result = dropWhile (\x -> x < 10) il
    head il `shouldEqual` 0
    head result `shouldEqual` 10
  it "dropWhile should skip many elements" do
    let il = iterate ((+) 1) 0
    let result = dropWhile (\x -> x < 100000) il
    head result `shouldEqual` 100000

takeWhileSpecs = describe "takeWhile" do
  it "takeWhile should generate a good list of elements" do
    let il = iterate ((+) 1) 0
    takeWhile (\x -> x < 10) il `shouldEqual` L.fromFoldable [0, 1, 2, 3, 4, 5, 6, 7, 8 ,9]
  it "takeWhile on many elements should be fast" do
    let il = iterate ((+) 1) 0
    let result = takeWhile (\x -> x < 10000) il
    L.length result `shouldEqual` 10000

functorSpecs = describe "Functor" do
  it "can increment an infinite list by five" do
    let il = iterate ((+) 1) 0
    let result = map ((+) 5) il
    take 5 result `shouldEqual` L.fromFoldable [5, 6, 7, 8, 9]
  it "can map an infinite list to boolean values" do
    let il = iterate ((+) 1) 0
    let result = map (\x -> x `mod` 3 == 0) il
    take 5 result `shouldEqual` L.fromFoldable [true, false, false, true, false]
  it "can map an infinite list into tuple values" do
    let il = iterate ((+) 1) 0
    let result = map (\x -> Tuple x ("n: " <> show x)) il
    take 5 result `shouldEqual` L.fromFoldable [Tuple 0 "n: 0", Tuple 1 "n: 1", Tuple 2 "n: 2", Tuple 3 "n: 3", Tuple 4 "n: 4"]

filterableSpecs = describe "Filterable" do
  it "can filter numbers from an infinite list" do
    let il = iterate ((+) 1) 1
    let result = filter (\x -> (x `mod` 3 == 0) || (x `mod` 5 == 0)) il
    takeWhile (\x -> x <= 20) result `shouldEqual` L.fromFoldable [3, 5, 6, 9, 10, 12, 15, 18, 20]


new typeclasses

new typeclasses

module Math.Vec3 where

import Math
import Data.Foldable

newtype Vec3 = Vec3 { x :: Number, y :: Number, z :: Number }

v3 :: Number -> Number -> Number -> Vec3
v3 x y z = Vec3 $ { x: x, y: y, z: z }

instance showVec3 :: Show Vec3 where
  show (Vec3 v) = "(" ++ show v.x ++ ", " ++ show v.y ++ ", " ++ show v.z ++ ")"

instance semiringVec3 :: Semiring Vec3 where
  (+) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x + w.x
                                 , y: v.y + w.y
                                 , z: v.z + w.z }

  (*) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x * w.x
                                 , y: v.y * w.y
                                 , z: v.z * w.z }

  zero = Vec3 { x: 0, y: 0, z: 0}

  one = Vec3 { x: 1, y: 1, z: 1 }

instance ringVec3 :: Ring Vec3 where
  (-) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x - w.x
                                 , y: v.y - w.y
                                 , z: v.z - w.z }

instance moduleSemiringVec3 :: ModuloSemiring Vec3 where
  (/) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x / w.x
                                 , y: v.y / w.y
                                 , z: v.z / w.z }

  mod (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x `mod` w.x
                                 , y: v.y `mod` w.y
                                 , z: v.z `mod` w.z }

(.*) :: Vec3 -> Number -> Vec3
(.*) (Vec3 v) n = Vec3 $ { x: v.x * n
                         , y: v.y * n
                         , z: v.z * n }

(./) :: Vec3 -> Number -> Vec3
(./) (Vec3 v) n = Vec3 $ { x: v.x / n
                         , y: v.y / n
                         , z: v.z / n }

length_sq :: Vec3 -> Number
length_sq (Vec3 v) = v.x * v.x + v.y * v.y + v.z * v.z

length :: Vec3 -> Number
length v = sqrt $ length_sq v

norm :: Vec3 -> Vec3
norm v = v ./ length v

distance_to_sq :: Vec3 -> Vec3 -> Number
distance_to_sq v w = length_sq (w - v)

distance_to :: Vec3 -> Vec3 -> Number
distance_to v w = sqrt $ distance_to_sq v w

v3_sum :: [Vec3] -> Vec3
v3_sum vs = foldl (+) (v3 0 0 0) vs

module Math.Vec3 where

import Math
import Data.Foldable

newtype Vec3 = Vec3 { x :: Number, y :: Number, z :: Number }

v3 :: Number -> Number -> Number -> Vec3
v3 x y z = Vec3 $ { x: x, y: y, z: z }

instance showVec3 :: Show Vec3 where
  show (Vec3 v) = "(" ++ show v.x ++ ", " ++ show v.y ++ ", " ++ show v.z ++ ")"

instance numVec3 :: Num Vec3 where
  (+) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x + w.x
                                 , y: v.y + w.y
                                 , z: v.z + w.z }

  (-) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x - w.x
                                 , y: v.y - w.y
                                 , z: v.z - w.z }

  (*) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x * w.x
                                 , y: v.y * w.y
                                 , z: v.z * w.z }

  (/) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x / w.x
                                 , y: v.y / w.y
                                 , z: v.z / w.z }

  (%) (Vec3 v) (Vec3 w) = Vec3 $ { x: v.x % w.x
                                 , y: v.y % w.y
                                 , z: v.z % w.z }

  negate (Vec3 v) = Vec3 $ { x: -v.x, y: -v.y, z: -v.z }

(.*) :: Vec3 -> Number -> Vec3
(.*) (Vec3 v) n = Vec3 $ { x: v.x * n
                         , y: v.y * n
                         , z: v.z * n }

(./) :: Vec3 -> Number -> Vec3
(./) (Vec3 v) n = Vec3 $ { x: v.x / n
                         , y: v.y / n
                         , z: v.z / n }

length_sq :: Vec3 -> Number
length_sq (Vec3 v) = v.x * v.x + v.y * v.y + v.z * v.z

length :: Vec3 -> Number
length v = sqrt $ length_sq v

norm :: Vec3 -> Vec3
norm v = v ./ length v

distance_to_sq :: Vec3 -> Vec3 -> Number
distance_to_sq v w = length_sq (w - v)

distance_to :: Vec3 -> Vec3 -> Number
distance_to v w = sqrt $ distance_to_sq v w

v3_sum :: [Vec3] -> Vec3
v3_sum vs = foldl (+) (v3 0 0 0) vs