Convert now-illegal escape code into legal string (#22)

module Benchotron.UI.Console where

import Prelude
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..))
import Data.Foldable (traverse_)
import Data.Profunctor.Strong (second, (&&&))
import Data.Array as A
import Data.Int (fromNumber)
import Data.String (joinWith)
import Data.JSDate as JSD
import Data.DateTime.Instant as DDI
import Test.QuickCheck (randomSeed)
import Test.QuickCheck.Gen (GenState)
import Random.LCG (unSeed)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Class (get)
import Effect (Effect)
import Effect.Now (now)
import Node.FS.Sync (writeTextFile, mkdir, stat, exists)
import Node.FS.Stats (isDirectory)
import Node.Encoding (Encoding(..))
import Global (readInt)

import Benchotron.Core (BenchmarkResult, Benchmark, BenchM,
                        runBenchM, runBenchmark, unpackBenchmark)
import Benchotron.StdIO (stdoutWrite, stderrWrite, question)
import Benchotron.Utils (unsafeJsonStringify)

data Answer = All | One Int

parseAnswer :: String -> Maybe Answer
parseAnswer "*" = Just All
parseAnswer x = let y = fromNumber $ readInt 10 x
                in  map One y

-- | TODO: Only fetch one seed from global random generator, have this return
-- | BenchM instead?
runSuite :: Array Benchmark -> Effect Unit
runSuite bs = do
  case bs of
    []  -> stdoutWrite "Empty suite; nothing to do.\n"
    [b] -> go b
    _   -> do
      stdoutWrite "Choose a benchmark to run:\n\n"
      stdoutWrite (joinWith "\n" (showOptions bs))
      stdoutWrite "\n\n"
      questionLoop

  where
  go b = do
    stdoutWrite "\n"
    exists <- doesDirectoryExist "tmp"
    when (not exists) (mkdir "tmp")
    benchmarkToFile b ("tmp/" <> slug b <> ".json")

  doesDirectoryExist dir = do
    ex <- exists dir
    if ex
       then isDirectory <$> stat dir
       else pure false

  slug = unpackBenchmark _.slug

  questionLoop =
    question "Enter a number, or enter '*' to run all benchmarks: " \answer ->
      case parseAnswer answer of
        Nothing -> stdoutWrite "Unrecognised input.\n" *> questionLoop
        Just All -> traverse_ go bs
        Just (One i) ->
          case bs A.!! (i - 1) of
            Just b  -> go b
            Nothing -> stdoutWrite "No such benchmark.\n" *> questionLoop

showOptions :: Array Benchmark -> Array String
showOptions = map (showOption <<< second getSlugAndTitle) <<< withIndices
  where
  getSlugAndTitle =
    unpackBenchmark _.slug &&& unpackBenchmark _.title
  showOption (Tuple index (Tuple slug title)) =
    "  " <> show index <> ") " <> slug <> " - " <> title
  withIndices arr =
    A.zip (A.range 1 (A.length arr)) arr

runBenchmarkConsole :: Benchmark -> BenchM BenchmarkResult
runBenchmarkConsole benchmark = do
  state <- get
  let seed = unSeed state.newSeed :: Int
  lift $ do
    stderrWrite $ "### Benchmark: " <> unpackBenchmark _.title benchmark <> " ###\n"
    stderrWrite $ "Using seed: " <> show seed <> "\n"
    noteTime \t -> "Started at: " <> t <> "\n"
  r <- runBenchmark benchmark progress
  lift $ do
    stderrWrite "\n"
    noteTime \t -> "Finished at: " <> t <> "\n"
  pure r
  where
  noteTime f = nowString >>= (stderrWrite <<< f)
  nowString = (JSD.toTimeString<<<JSD.fromDateTime<<<DDI.toDateTime) <$> now
  countSizes = A.length $ unpackBenchmark _.sizes benchmark
  clearLine = "\r\x1b[K"
  progress idx size =
    lift $ stderrWrite $ joinWith ""
      [ clearLine
      , "Running... n="
      , show size
      , " ("
      , show idx
      , "/"
      , show countSizes
      , ")"
      ]

getInitialState :: Effect GenState
getInitialState = { newSeed: _, size: 10 } <$> randomSeed

runBenchM' :: forall a. BenchM a -> Effect a
runBenchM' action =
  getInitialState >>= runBenchM action

-- | Run a benchmark and print the results to a file. This will only work on
-- | node.js.
benchmarkToFile :: Benchmark -> String -> Effect Unit
benchmarkToFile bench path = do
  results <- runBenchM' $ runBenchmarkConsole bench
  writeTextFile UTF8 path $ stringifyResult results
  stderrWrite $ "Results written to " <> path <> "\n"

-- | Run a benchmark and print the results to standard output. This will only
-- | work on node.js.
benchmarkToStdout :: Benchmark -> Effect Unit
benchmarkToStdout bench = do
  results <- runBenchM' $ runBenchmarkConsole bench
  stdoutWrite $ stringifyResult results

stringifyResult :: BenchmarkResult -> String
stringifyResult = unsafeJsonStringify

module Benchotron.UI.Console where

import Prelude
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..))
import Data.Foldable (traverse_)
import Data.Profunctor.Strong (second, (&&&))
import Data.Array as A
import Data.Int (fromNumber)
import Data.String (joinWith)
import Data.JSDate as JSD
import Data.DateTime.Instant as DDI
import Test.QuickCheck (randomSeed)
import Test.QuickCheck.Gen (GenState)
import Random.LCG (unSeed)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Class (get)
import Effect (Effect)
import Effect.Now (now)
import Node.FS.Sync (writeTextFile, mkdir, stat, exists)
import Node.FS.Stats (isDirectory)
import Node.Encoding (Encoding(..))
import Global (readInt)

import Benchotron.Core (BenchmarkResult, Benchmark, BenchM,
                        runBenchM, runBenchmark, unpackBenchmark)
import Benchotron.StdIO (stdoutWrite, stderrWrite, question)
import Benchotron.Utils (unsafeJsonStringify)

data Answer = All | One Int

parseAnswer :: String -> Maybe Answer
parseAnswer "*" = Just All
parseAnswer x = let y = fromNumber $ readInt 10 x
                in  map One y

-- | TODO: Only fetch one seed from global random generator, have this return
-- | BenchM instead?
runSuite :: Array Benchmark -> Effect Unit
runSuite bs = do
  case bs of
    []  -> stdoutWrite "Empty suite; nothing to do.\n"
    [b] -> go b
    _   -> do
      stdoutWrite "Choose a benchmark to run:\n\n"
      stdoutWrite (joinWith "\n" (showOptions bs))
      stdoutWrite "\n\n"
      questionLoop

  where
  go b = do
    stdoutWrite "\n"
    exists <- doesDirectoryExist "tmp"
    when (not exists) (mkdir "tmp")
    benchmarkToFile b ("tmp/" <> slug b <> ".json")

  doesDirectoryExist dir = do
    ex <- exists dir
    if ex
       then isDirectory <$> stat dir
       else pure false

  slug = unpackBenchmark _.slug

  questionLoop =
    question "Enter a number, or enter '*' to run all benchmarks: " \answer ->
      case parseAnswer answer of
        Nothing -> stdoutWrite "Unrecognised input.\n" *> questionLoop
        Just All -> traverse_ go bs
        Just (One i) ->
          case bs A.!! (i - 1) of
            Just b  -> go b
            Nothing -> stdoutWrite "No such benchmark.\n" *> questionLoop

showOptions :: Array Benchmark -> Array String
showOptions = map (showOption <<< second getSlugAndTitle) <<< withIndices
  where
  getSlugAndTitle =
    unpackBenchmark _.slug &&& unpackBenchmark _.title
  showOption (Tuple index (Tuple slug title)) =
    "  " <> show index <> ") " <> slug <> " - " <> title
  withIndices arr =
    A.zip (A.range 1 (A.length arr)) arr

runBenchmarkConsole :: Benchmark -> BenchM BenchmarkResult
runBenchmarkConsole benchmark = do
  state <- get
  let seed = unSeed state.newSeed :: Int
  lift $ do
    stderrWrite $ "### Benchmark: " <> unpackBenchmark _.title benchmark <> " ###\n"
    stderrWrite $ "Using seed: " <> show seed <> "\n"
    noteTime \t -> "Started at: " <> t <> "\n"
  r <- runBenchmark benchmark progress
  lift $ do
    stderrWrite "\n"
    noteTime \t -> "Finished at: " <> t <> "\n"
  pure r
  where
  noteTime f = nowString >>= (stderrWrite <<< f)
  nowString = (JSD.toTimeString<<<JSD.fromDateTime<<<DDI.toDateTime) <$> now
  countSizes = A.length $ unpackBenchmark _.sizes benchmark
  clearLine = "\r\ESC[K"
  progress idx size =
    lift $ stderrWrite $ joinWith ""
      [ clearLine
      , "Running... n="
      , show size
      , " ("
      , show idx
      , "/"
      , show countSizes
      , ")"
      ]

getInitialState :: Effect GenState
getInitialState = { newSeed: _, size: 10 } <$> randomSeed

runBenchM' :: forall a. BenchM a -> Effect a
runBenchM' action =
  getInitialState >>= runBenchM action

-- | Run a benchmark and print the results to a file. This will only work on
-- | node.js.
benchmarkToFile :: Benchmark -> String -> Effect Unit
benchmarkToFile bench path = do
  results <- runBenchM' $ runBenchmarkConsole bench
  writeTextFile UTF8 path $ stringifyResult results
  stderrWrite $ "Results written to " <> path <> "\n"

-- | Run a benchmark and print the results to standard output. This will only
-- | work on node.js.
benchmarkToStdout :: Benchmark -> Effect Unit
benchmarkToStdout bench = do
  results <- runBenchM' $ runBenchmarkConsole bench
  stdoutWrite $ stringifyResult results

stringifyResult :: BenchmarkResult -> String
stringifyResult = unsafeJsonStringify


Skip spaces before parsing

Skip spaces before parsing

module Parser where

import Global              (readInt)
import Data.String         (joinWith, split)
import Data.Identity       (Identity())
import Data.Either
import Control.Alt         ((<|>))
import Control.Apply       ((*>))
import Control.Alternative (some, many)
import Control.Lazy        (fix1)

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.String

import AST

eatSpaces :: Parser String Unit
eatSpaces = void $ many $ string " " <|> string "\t"

parse :: forall a. Parser String a -> String -> Either String a
parse p s = case runParser s p of
  Left err -> Left $ show err
  Right a  -> Right a

---------------------------------------
-- Parsers for the 'Atom' type
---------------------------------------

num :: Parser String Atom
num = do
  str <- string "0" <|> nat
  return $ Num $ readInt 10 str
  where
  nat = do
    d <- oneOf $ split "" "123456789"
    ds <- many $ oneOf $ split "" "0123456789"
    return $ joinWith "" $ d:ds

bool :: Parser String Atom
bool = do
  f <|> t
  where
  f = string "false" *> return (Bool false)
  t = string "true" *> return (Bool true)

name :: Parser String String
name = do
  str <- some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'"
  return $ joinWith "" str

atom :: Parser String Atom
atom = do
  num <|> try bool <|> (Name <$> name) <?> "Atom (Number, Boolean, Name)"

---------------------------------------
-- Parsers for the 'Expr' type
---------------------------------------

parseExpr :: String -> Either String Expr
parseExpr = parse (eatSpaces *> expr)

list :: forall a. Parser String a -> Parser String [a]
list p = do
  string "["
  eatSpaces
  ls <- p `sepBy` (try (eatSpaces *> string ","))
  eatSpaces
  string "]"
  return ls

app :: Parser String Expr -> Parser String Expr
app expr = do
  str <- name
  exprs <- some (try $ eatSpaces *> expr)
  return $ App str exprs

bracket :: forall a. Parser String a -> Parser String a
bracket p = do
  string "("
  eatSpaces
  e <- p
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = bracket (try sectR <|> sectL)
  where
  sectR = do
    op <- choice opList
    eatSpaces
    e <- expr
    return $ SectR op e
  sectL = do
    e <- expr
    eatSpaces
    op <- choice opList
    return $ SectL e op

opList :: [Parser String Op]
opList =
  [ opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string "*")     Mul
  , opP (string "`div`") Div
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "&&")    And
  , opP (string "||")    Or
  ]

base :: Parser String Expr -> Parser String Expr
base expr =  (List <$> list expr)
         <|> bracket expr
         <|> (Atom <$> atom)

termSect :: Parser String Expr -> Parser String Expr
termSect expr = try (section (base expr)) <|> base expr

termApp :: Parser String Expr -> Parser String Expr
termApp expr = try (app (termSect expr)) <|> termSect expr

opP :: forall a. Parser String a -> Op -> Parser String Op
opP strP opConstructor = try $
  (eatSpaces *> strP *> eatSpaces *> return opConstructor)

term7l :: Parser String Expr -> Parser String Expr
term7l expr = chainl1 (termApp expr) (mulP <|> divP)
  where
  mulP = Binary <$> opP (string "*") Mul
  divP = Binary <$> opP (string "`div`") Div

term6neg :: Parser String Expr -> Parser String Expr
term6neg expr = try negation <|> (term7l expr)
  where
  negation = do
    string "-"
    eatSpaces
    e <- (term7l expr)
    return $ Unary Sub e

term6l :: Parser String Expr -> Parser String Expr
term6l expr = chainl1 (term6neg expr) (addP <|> subP)
  where
  addP = Binary <$> opP (string "+" *> notFollowedBy (string "+")) Add
  subP = Binary <$> opP (string "-") Sub

term5r :: Parser String Expr -> Parser String Expr
term5r expr = chainr1 (term6l expr) (consP <|> appendP)
  where
  consP = Binary <$> opP (string ":") Cons
  appendP = Binary <$> opP (string "++") Append

term3r :: Parser String Expr -> Parser String Expr
term3r expr = chainr1 (term5r expr) (Binary <$> opP (string "&&") And)

term2r :: Parser String Expr -> Parser String Expr
term2r expr = chainr1 (term3r expr) (Binary <$> opP (string "||") Or)

expr :: Parser String Expr
expr = fix1 $ \expr -> term2r expr

---------------------------------------
-- Parsers for the 'Binding' type
---------------------------------------

lit :: Parser String Binding
lit = Lit <$> atom

listLit :: Parser String Binding -> Parser String Binding
listLit binding = ListLit <$> list binding

consLit :: Parser String Binding -> Parser String Binding
consLit binding = bracket recurse
  where
  recurse = fix1 $ \recurse -> try (cons recurse) <|> binding
  cons recurse = do
    b <- binding
    eatSpaces
    string ":"
    eatSpaces
    bs <- recurse
    return $ ConsLit b bs

binding :: Parser String Binding
binding = fix1 $ \binding -> lit <|> consLit binding <|> listLit binding

---------------------------------------
-- Parsers for the 'Definition' type
---------------------------------------

parseDefs :: String -> Either String [Definition]
parseDefs = parse (skipSpaces *> defs)

def :: Parser String Definition
def = do
  defName <- name
  eatSpaces
  binds <- binding `sepEndBy` eatSpaces
  string "="
  eatSpaces
  body <- expr
  return $ Def defName binds body

defs :: Parser String [Definition]
defs = def `sepEndBy` skipSpaces

module Parser where

import Global              (readInt)
import Data.String         (joinWith, split)
import Data.Identity       (Identity())
import Data.Either
import Control.Alt         ((<|>))
import Control.Apply       ((*>))
import Control.Alternative (some, many)
import Control.Lazy        (fix1)

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.String

import AST

eatSpaces :: Parser String Unit
eatSpaces = void $ many $ string " " <|> string "\t"

parse :: forall a. Parser String a -> String -> Either String a
parse p s = case runParser s p of
  Left err -> Left $ show err
  Right a  -> Right a

---------------------------------------
-- Parsers for the 'Atom' type
---------------------------------------

num :: Parser String Atom
num = do
  str <- string "0" <|> nat
  return $ Num $ readInt 10 str
  where
  nat = do
    d <- oneOf $ split "" "123456789"
    ds <- many $ oneOf $ split "" "0123456789"
    return $ joinWith "" $ d:ds

bool :: Parser String Atom
bool = do
  f <|> t
  where
  f = string "false" *> return (Bool false)
  t = string "true" *> return (Bool true)

name :: Parser String String
name = do
  str <- some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'"
  return $ joinWith "" str

atom :: Parser String Atom
atom = do
  num <|> try bool <|> (Name <$> name) <?> "Atom (Number, Boolean, Name)"

---------------------------------------
-- Parsers for the 'Expr' type
---------------------------------------

parseExpr :: String -> Either String Expr
parseExpr = parse expr

list :: forall a. Parser String a -> Parser String [a]
list p = do
  string "["
  eatSpaces
  ls <- p `sepBy` (try (eatSpaces *> string ","))
  eatSpaces
  string "]"
  return ls

app :: Parser String Expr -> Parser String Expr
app expr = do
  str <- name
  exprs <- some (try $ eatSpaces *> expr)
  return $ App str exprs

bracket :: forall a. Parser String a -> Parser String a
bracket p = do
  string "("
  eatSpaces
  e <- p
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = bracket (try sectR <|> sectL)
  where
  sectR = do
    op <- choice opList
    eatSpaces
    e <- expr
    return $ SectR op e
  sectL = do
    e <- expr
    eatSpaces
    op <- choice opList
    return $ SectL e op

opList :: [Parser String Op]
opList =
  [ opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string "*")     Mul
  , opP (string "`div`") Div
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "&&")    And
  , opP (string "||")    Or
  ]

base :: Parser String Expr -> Parser String Expr
base expr =  (List <$> list expr)
         <|> bracket expr
         <|> (Atom <$> atom)

termSect :: Parser String Expr -> Parser String Expr
termSect expr = try (section (base expr)) <|> base expr

termApp :: Parser String Expr -> Parser String Expr
termApp expr = try (app (termSect expr)) <|> termSect expr

opP :: forall a. Parser String a -> Op -> Parser String Op
opP strP opConstructor = try $
  (eatSpaces *> strP *> eatSpaces *> return opConstructor)

term7l :: Parser String Expr -> Parser String Expr
term7l expr = chainl1 (termApp expr) (mulP <|> divP)
  where
  mulP = Binary <$> opP (string "*") Mul
  divP = Binary <$> opP (string "`div`") Div

term6neg :: Parser String Expr -> Parser String Expr
term6neg expr = try negation <|> (term7l expr)
  where
  negation = do
    string "-"
    eatSpaces
    e <- (term7l expr)
    return $ Unary Sub e

term6l :: Parser String Expr -> Parser String Expr
term6l expr = chainl1 (term6neg expr) (addP <|> subP)
  where
  addP = Binary <$> opP (string "+" *> notFollowedBy (string "+")) Add
  subP = Binary <$> opP (string "-") Sub

term5r :: Parser String Expr -> Parser String Expr
term5r expr = chainr1 (term6l expr) (consP <|> appendP)
  where
  consP = Binary <$> opP (string ":") Cons
  appendP = Binary <$> opP (string "++") Append

term3r :: Parser String Expr -> Parser String Expr
term3r expr = chainr1 (term5r expr) (Binary <$> opP (string "&&") And)

term2r :: Parser String Expr -> Parser String Expr
term2r expr = chainr1 (term3r expr) (Binary <$> opP (string "||") Or)

expr :: Parser String Expr
expr = fix1 $ \expr -> term2r expr

---------------------------------------
-- Parsers for the 'Binding' type
---------------------------------------

lit :: Parser String Binding
lit = Lit <$> atom

listLit :: Parser String Binding -> Parser String Binding
listLit binding = ListLit <$> list binding

consLit :: Parser String Binding -> Parser String Binding
consLit binding = bracket recurse
  where
  recurse = fix1 $ \recurse -> try (cons recurse) <|> binding
  cons recurse = do
    b <- binding
    eatSpaces
    string ":"
    eatSpaces
    bs <- recurse
    return $ ConsLit b bs

binding :: Parser String Binding
binding = fix1 $ \binding -> lit <|> consLit binding <|> listLit binding

---------------------------------------
-- Parsers for the 'Definition' type
---------------------------------------

parseDefs :: String -> Either String [Definition]
parseDefs = parse defs

def :: Parser String Definition
def = do
  defName <- name
  eatSpaces
  binds <- binding `sepEndBy` eatSpaces
  string "="
  eatSpaces
  body <- expr
  return $ Def defName binds body

defs :: Parser String [Definition]
defs = def `sepEndBy` skipSpaces


added test for put() API

added test for put() API

module Test.Main where

import Prelude                     (Unit, bind)
import Data.Maybe                  (Maybe(Just, Nothing))
-- import Test.QuickCheck
-- import Unsafe.Coerce               (unsafeCoerce)
import Control.Monad.Eff           (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Console   (CONSOLE, log)
-- import Control.Monad.Eff.Random    (RANDOM)
import Debug.Trace (traceA)
import API.PouchDB                 (PouchDBDocument(PouchDBDocument), put, pouchDB, destroy, info, logRaw)

showDBCreateInfo :: forall a e. a -> Eff(console :: CONSOLE | e) Unit
showDBCreateInfo = \anyData -> do
                               logRaw anyData
                               log "PouchDB database created!"

showDBDestroyInfo :: forall a e. a -> Eff(console :: CONSOLE | e) Unit
showDBDestroyInfo = \anyData -> do
                                logRaw anyData
                                log "PouchDB database deleted!"

showDBPutInfo :: forall a e. a -> Eff(console :: CONSOLE | e) Unit
showDBPutInfo = \anyData -> do
                            logRaw anyData
                            log "New document created!"

main :: forall e. Eff(err :: EXCEPTION | e) Unit
main = do
      traceA "\r\n[TEST] create new PouchDB"
      pdb <- pouchDB (Just "dummyDB") Nothing
      traceA "\r\n[TEST] get info from PouchDB"
      info (Just showDBCreateInfo) pdb
      traceA "\r\n[TEST] destroy PouchDB instance"
      destroy Nothing (Just showDBDestroyInfo) pdb
      traceA "\r\n[TEST] put Document into PouchDB"
      let doc = PouchDBDocument { name : "Harris", occupation: "Procrastinator", city: "Troisdorf" }
      pdb2 <- pouchDB (Just "dummyDB") Nothing
      put doc (Just "myDummyId") Nothing Nothing (Just showDBPutInfo) pdb2

module Test.Main where

import Prelude
import Data.Maybe
import Test.QuickCheck
import Unsafe.Coerce               (unsafeCoerce)
import Control.Monad.Eff           (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Console
import Control.Monad.Eff.Random    (RANDOM)
import Debug.Trace
import API.PouchDB

showDBCreateInfo :: forall a e. a -> Eff(console :: CONSOLE | e) Unit
showDBCreateInfo = \anyData -> do
                               logRaw anyData
                               log "PouchDB database created!"

showDBDestroyInfo :: forall a e. a -> Eff(console :: CONSOLE | e) Unit
showDBDestroyInfo = \anyData -> do
                                logRaw anyData
                                log "PouchDB database deleted!"

main = do
      traceA "\r\n[TEST] create new PouchDB"
      pdb <- pouchDB (Just "dummyDB") Nothing
      traceA "\r\n[TEST] get info from PouchDB"
      info (Just showDBCreateInfo) pdb
      traceA "\r\n[TEST] destroy PouchDB instance"
      destroy Nothing (Just showDBDestroyInfo) pdb


Add example for map / bind instead of do-Notation

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module Main where

import Prelude (Unit, bind, map, (<>), (>>=))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array (head, tail)
import Data.Maybe (Maybe(..))
import Node.Process (PROCESS, argv)

greeting :: String -> String
greeting who = "Hello " <> who <> "!"

getArgsBind :: Array String -> Maybe (String)
getArgsBind args = tail args >>= tail >>= head

getArgsDo :: Array String -> Maybe (String)
getArgsDo args = do
  a <- tail args
  b <- tail a
  head b

get :: Maybe String -> String
get (Just str) = str
get Nothing    = ""

-- main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
-- main = do
--   arr <- argv
--   log (greeting (get (getArgsBind arr)))

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = bind (map greeting (map get (map getArgsBind argv))) log

module Main where

import Prelude (Unit, bind, (<>), (>>=))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array (head, tail)
import Data.Maybe (Maybe(..))
import Node.Process (PROCESS, argv)

greeting :: String -> String
greeting who = "Hello " <> who <> "!"

getArgsBind :: Array String -> Maybe (String)
getArgsBind args = tail args >>= tail >>= head

getArgsDo :: Array String -> Maybe (String)
getArgsDo args = do
  a <- tail args
  b <- tail a
  head b

get :: Maybe String -> String
get (Just str) = str
get Nothing    = ""

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = do
  arr <- argv
  log (greeting (get (getArgsBind arr)))


WIP - Geometry updated for arcs

WIP - Geometry updated for arcs

module App.Geometry where

import Prelude
import Data.List (List(..), concatMap, foldl, head, mapMaybe, nub, reverse, singleton, sort, zipWith, (:))
import Data.Map (Map, empty, insert)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), snd)
import Math (Radians, abs, atan2, cos, pi, pow, sin, sqrt)

data Point = Point Number Number

instance ptEq :: Eq Point where
  eq (Point x1 y1) (Point x2 y2) = x1 == x2 && y1 == y2

instance ptShow :: Show Point where
  show (Point x y) = "(" <> show x <> ", " <> show y <> ")"

instance ptRing :: Ring Point where
  sub (Point x1 y1) (Point x2 y2) = Point (x1 - x2) (y1 - y2)

instance ptSemiring :: Semiring Point where
  add (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2)
  mul (Point x1 y1) (Point x2 y2) = Point (x1 * x2) (y1 * y2)
  zero = Point 0.0 0.0
  one = Point 1.0 1.0

mapPt :: (Number -> Number) -> Point -> Point
mapPt f (Point x y) = Point (f x) (f y)

-- | arbitrarily compare xs first then ys
instance ptOrd :: Ord Point where
  compare (Point x1 y1) (Point x2 y2) | x1 == x2 = compare y1 y2
  compare (Point x1 _ ) (Point x2 _) = compare x1 x2

distance :: Point -> Point -> Number
distance (Point x1 y1) (Point x2 y2) = pow (x1 - x2) 2.0 + pow (y1 - y2) 2.0

crossProduct :: Point -> Point -> Number
crossProduct (Point x1 y1) (Point x2 y2) = x1 * y2 - x2 * y1

dotProduct :: Point -> Point -> Number
dotProduct (Point x1 y1) (Point x2 y2) = x1*x2 + y1*y2

getNearestPoint :: Point -> List Point -> Maybe Point
getNearestPoint _ Nil = Nothing
getNearestPoint p ps = foldl updateMax Nothing ps
  where
    updateMax :: Maybe Point -> Point -> Maybe Point
    updateMax Nothing p1 = Just p1
    updateMax (Just p1) p2 = if (distance p p1) < (distance p p2) then Just p1 else Just p2

data Stroke = Line Point Point
            | Arc Point Number Number Number

instance strokeEq :: Eq Stroke where
  eq (Line p1 p2) (Line q1 q2) = p1 == q1 && p2 == q2
  eq (Arc c r a s) (Arc c' r' a' s') = c == c' && r == r' && a == a' && s == s'
  eq _ _ = false

unorderedEq :: Stroke -> Stroke -> Boolean
unorderedEq s1 s2 = s1 == s2 || (flipStroke s1) == s2

instance strokeShow :: Show Stroke where
  show (Line p1 p2) =
    "[" <> show p1 <> " --- " <> show p2 <> "]"

  show (Arc c r a s) =
    "(" <> show c <> ", radius: " <> show r <> ", angle: " <> show a <> ", sweep: " <> show s <> ")"

compareMap :: (Ord a) => List (Stroke -> a) -> Ordering
compareMap (fn : rest) s1 s2= case compare (fn s1) (fn s2) of
                                      EQ -> compareMap rest
                                      ord -> ord
compareMap Nil _ _ = EQ

instance strokeOrd :: Ord Stroke where
  compare = compareMap (firstPoint : outboundAngle : curvature : length : Nil)

firstPoint :: Stroke -> Point
firstPoint (Line p1 _) = p1
firstPoint (Arc c r a _) = c + (Point (r * (cos a)) (r * (sin a)))

secondPoint :: Stroke -> Point
secondPoint (Line _ p2) = p2
secondPoint (Arc c r a s) = c + (Point (r * (cos a + s)) (r * (sin a + s)))

outboundAngle :: Stroke -> Radians
outboundAngle (Line (Point x1 y1) (Point x2 y2)) =
  atan2 (x2 - x1) (y2 - y1)
outboundAngle (Arc _ _ a s) =
  a + if s > 0.0 then (pi / 2.0) else (- pi / 2.0)

inboundAngle :: Stroke -> Radians
inboundAngle s@(Line _ _) = outboundAngle s
inboundAngle (Arc _ _ a s) =
  a + s + if s > 0.0 then (pi / 2.0) else (- pi / 2.0)

-- communicates how aggressively the curve turns. Lines don't turn at all, so have curvature 0
-- arcs, when sorted by curvature will go from small-radii counterclockwise arcs, to large-radii ones (with a limit
-- of a line at 0), then large-radii clockwise arcs (which are negative) and finally small-radii counterclockwise
-- arcs (which are the most negative).
curvature :: Stroke -> Number
curvature (Line _ _) = 0.0
curvature (Arc _ r _ s) = if s > 0.0 then (1.0 / r) else (- 1.0 / r)

length :: Stroke -> Number
length (Line (Point x1 y1) (Point x2 y2)) = (pow (x2 - x1) 2.0) + (pow (y2 - y1) 2.0)
length (Arc _ r _ s) = (abs s) * 2.0 * pi * r

-- clockwise rotation -> positive angle
-- ->/ == negative
-- ->\ == positive
-- TODO: what if we do a 180? (currently should never happen due to simplify)
angleDiff :: Stroke -> Stroke -> Radians
angleDiff strokeFrom strokeTo =
  atan2Radians (inboundAngle strokeFrom - outboundAngle strokeTo)

sweep :: Stroke -> Radians
sweep (Line _ _) = 0.0
sweep (Arc _ _ _ s) = atan2Radians s

findWrap :: Path -> Radians
findWrap Nil = 0.0
findWrap path@(_ : rest) =
  foldl (+) 0.0 (angles <> sweep <$> path)
  where
    angles = zipWith angleDiff path rest

flipStroke :: Stroke -> Stroke
flipStroke (Line p1 p2) = Line p2 p1
flipStroke (Arc c r a s) = (Arc c r (positiveRadians $ a + s) (-s))

positiveRadians :: Radians -> Radians
positiveRadians a
  | a < 0.0 = a + 2.0 * pi
  | a > 2.0 * pi = a - 2.0 * pi
  | otherwise = a

atan2Radians :: Radians -> Radians
atan2Radians a
  | a > pi = (mod a 2.0*pi) - pi
  | a < pi = (mod a 2.0*pi) + pi
  | otherwise = a

getAngleDiff :: Point -> Radians -> Radians -> Radians
getAngleDiff (Point x y) a s =
  case (atan2 y x) - a of diff | diff >= 0.0 && s >= 0.0 -> diff
                               | diff <= 0.0 && s <= 0.0 -> diff
                               | otherwise -> -diff

type Path = List Stroke
type Intersections = Map Stroke (List Stroke)

reversePath :: Path -> Path
reversePath path =
  flipStroke <$> reverse path

swapEdge :: Path -> Stroke -> Path -> Path
swapEdge (c : cs) s ss
  | c == s = ss <> cs
  | c == (flipStroke s) = (reversePath ss) <> cs
  | otherwise = c : (swapEdge cs s ss)
swapEdge Nil _ _ = Nil

intersect :: Stroke -> Stroke -> (List Point)
intersect (Line p p') (Line q q') =
  let
    r = p' - p
    s = q' - q
    rxs = r `crossProduct` s
    qp = q - p
    qpxs = qp `crossProduct` s
    qpxr = qp `crossProduct` r
  in
    if rxs == 0.0 then
      if qpxr == 0.0 then -- segments are colinear
        let
          rr = (r `dotProduct` r)
          t0 = (qp `dotProduct` r) / rr
          t1 = ((qp + s) `dotProduct` r) / rr
          s1 = min t0 t1
          s2 = max t0 t1
        in Nil -- TODO: segments are colinear and overlapping
      else Nil -- segments are parallel and not colinear
    else
      let
        t = qpxs / rxs
        u = qpxr / rxs
      in
        if 0.0 <= t && t <= 1.0 && 0.0 <= u && u <= 1.0 then singleton (p + ((*) t) `mapPt` r)
                                                        else Nil

intersect (Line (Point lx1 ly1) (Point lx2 ly2)) (Arc c@(Point cx cy) r a s) =
  let m = (ly2 - ly1) / (lx2 - lx1) -- TODO : what if line is vertical
      b = ly1 - (m * lx1)
      cA = m * m + 1.0
      cB = 2.0 * (m * b - m * cy - cx)
      cC = cy * cy - r * r + cx * cx - 2.0 * b * cy + b * b
      disc = cB*cB - 4.0 * cA * cC

      -- check if a potential solution is inside our segment and arc
      withinBounds p@(Point x y) =
        let adiff = getAngleDiff (p - c) a s
            minx = min lx1 lx2
            maxx = max lx1 lx2
            miny = min ly1 ly2
            maxy = max ly1 ly2
         in x >= minx && x <= maxx && y >= miny && y <= maxy && adiff <= s

      -- plug in a value for the determinant
      getSolution d =
        let x = (-cB + d) / (2.0 * cA)
            y = m * x + b
            solution = Point x y
         in if withinBounds solution then Just solution
                                     else Nothing

   in case disc of
           _ | disc < 0.0 -> Nil
             | disc == 0.0 -> mapMaybe getSolution (0.0 : Nil)
             | otherwise -> mapMaybe getSolution (sqrt disc : -(sqrt disc) : Nil)

intersect (Arc c r a s) (Arc c' r' a' s') = Nil

intersect a@(Arc _ _ _ _) l@(Line _ _) = intersect l a

insertSplitStroke ::  Stroke -> Path -> Intersections -> Intersections
insertSplitStroke  stroke splitStroke intersections =
  insert stroke splitStroke $ insert (flipStroke stroke) (reversePath splitStroke) intersections

intersectMultiple :: Stroke -> List Stroke -> Intersections
intersectMultiple stroke strokes =
  let
    intersectionPoints = do
      toIntersect <- strokes
      case intersect stroke toIntersect of
           Nil -> Nil
           newPoints -> pure $ Tuple toIntersect newPoints

    allPoints = concatMap snd intersectionPoints
    insertPoints i (Tuple edge points) =
      insertSplitStroke edge (split edge points) i

    intersections = foldl insertPoints empty intersectionPoints
  in
    insertSplitStroke stroke (split stroke allPoints) intersections

-- given a stroke and a list of intersections, return a list of strokes
split :: Stroke -> List Point -> List Stroke
split (Line p1 p2) points =
  case head lines of -- ensure we still go from p1 to p2
       Just (Line p _) | p == p1 -> lines
       _ -> reversePath lines
  where
    sortedPoints = sort $ nub $ p1 : p2 : points
    zipPointPairs (p : q : rest) = (Line p q) : (zipPointPairs (q : rest))
    zipPointPairs _ = Nil
    lines = zipPointPairs sortedPoints

split (Arc c r a s) points =
  let angles = sort $ nub $ a : (a + s) : ((\p -> getAngleDiff (p - c) a s) <$> points)
      orderedAngles = if s > 0.0 then angles else reverse angles
      zipAnglePairs (a1 : a2 : rest) =
        (Arc c r (atan2Radians a1) (a2 - a1)) : zipAnglePairs (a2 : rest)
      zipAnglePairs _ = Nil

   in zipAnglePairs orderedAngles

module App.Geometry where

import Prelude
import Data.List (List(..), concatMap, foldl, foldr, head, last, nub, reverse, singleton, sort, zipWith, (:))
import Data.Map (Map, empty, insert)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), fst, snd)
import Math (Radians, atan2, pi, pow)

data Point = Point Number Number

instance ptEq :: Eq Point where
  eq (Point x1 y1) (Point x2 y2) = x1 == x2 && y1 == y2

instance ptShow :: Show Point where
  show (Point x y) = "(" <> show x <> ", " <> show y <> ")"

instance ptRing :: Ring Point where
  sub (Point x1 y1) (Point x2 y2) = Point (x1 - x2) (y1 - y2)

instance ptSemiring :: Semiring Point where
  add (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2)
  mul (Point x1 y1) (Point x2 y2) = Point (x1 * x2) (y1 * y2)
  zero = Point 0.0 0.0
  one = Point 1.0 1.0

mapPt :: (Number -> Number) -> Point -> Point
mapPt f (Point x y) = Point (f x) (f y)

-- | arbitrarily compare xs first then ys
instance ptOrd :: Ord Point where
  compare (Point x1 y1) (Point x2 y2) | x1 == x2 = compare y1 y2
  compare (Point x1 _ ) (Point x2 _) = compare x1 x2

distance :: Point -> Point -> Number
distance (Point x1 y1) (Point x2 y2) = pow (x1 - x2) 2.0 + pow (y1 - y2) 2.0

crossProduct :: Point -> Point -> Number
crossProduct (Point x1 y1) (Point x2 y2) = x1 * y2 - x2 * y1

dotProduct :: Point -> Point -> Number
dotProduct (Point x1 y1) (Point x2 y2) = x1*x2 + y1*y2

getNearestPoint :: Point -> List Point -> Maybe Point
getNearestPoint _ Nil = Nothing
getNearestPoint p ps = foldl updateMax Nothing ps
  where
    updateMax :: Maybe Point -> Point -> Maybe Point
    updateMax Nothing p1 = Just p1
    updateMax (Just p1) p2 = if (distance p p1) < (distance p p2) then Just p1 else Just p2

data Stroke = Line Point Point

instance strokeEq :: Eq Stroke where
  eq (Line p1 p2) (Line q1 q2) = p1 == q1 && p2 == q2

unorderedEq :: Stroke -> Stroke -> Boolean
unorderedEq s1 s2 = s1 == s2 || (flipStroke s1) == s2

instance strokeShow :: Show Stroke where
  show (Line p1 p2) =
    "[" <> show p1 <> " --- " <> show p2 <> "]"

instance strokeOrd :: Ord Stroke where
  compare (Line p1 p2) (Line q1 q2) =
    case compare p1 q1 of
         EQ -> compare p2 q2
         ord -> ord

firstPoint :: Stroke -> Point
firstPoint (Line p1 _) = p1

secondPoint :: Stroke -> Point
secondPoint (Line _ p2) = p2

angle :: Stroke -> Radians
angle (Line (Point x1 y1) (Point x2 y2)) =
  atan2 (x2 - x1) (y2 - y1)

-- clockwise rotation -> positive angle
-- ->/ == negative
-- ->\ == positive
-- TODO: what if we do a 180? (currently should never happen due to simplify)
angleDiff :: Stroke -> Stroke -> Radians
angleDiff strokeFrom strokeTo =
  let diff = angle strokeFrom - angle strokeTo
   in if diff > pi then diff - pi
      else if diff < - pi then diff + pi
      else diff

findWrap :: Path -> Radians
findWrap Nil = 0.0
findWrap path@(_ : rest) =
  foldl (+) 0.0 angles
  where
    angles = zipWith angleDiff path rest

flipStroke :: Stroke -> Stroke
flipStroke (Line p1 p2) = Line p2 p1

type Path = List Stroke
type Intersections = Map Stroke (List Stroke)

reversePath :: Path -> Path
reversePath path =
  flipStroke <$> reverse path

swapEdge :: Path -> Stroke -> Path -> Path
swapEdge (c : cs) s ss
  | c == s = ss <> cs
  | c == (flipStroke s) = (reversePath ss) <> cs
  | otherwise = c : (swapEdge cs s ss)
swapEdge Nil _ _ = Nil

compareAngle :: Stroke -> Stroke -> Ordering
compareAngle s1 s2 =
  compare (angle s1) (angle s2)
  -- TODO - if a line and arc have the same angle, sort based on arc curvature

intersect :: Stroke -> Stroke -> (List Point)
intersect (Line p p') (Line q q') =
  let
    r = p' - p
    s = q' - q
    rxs = r `crossProduct` s
    qp = q - p
    qpxs = qp `crossProduct` s
    qpxr = qp `crossProduct` r
  in
    if rxs == 0.0 then
      if qpxr == 0.0 then -- segments are colinear
        let
          rr = (r `dotProduct` r)
          t0 = (qp `dotProduct` r) / rr
          t1 = ((qp + s) `dotProduct` r) / rr
          s1 = min t0 t1
          s2 = max t0 t1
        in Nil -- TODO: segments are colinear and overlapping
      else Nil -- segments are parallel and not colinear
    else
      let
        t = qpxs / rxs
        u = qpxr / rxs
      in
        if 0.0 <= t && t <= 1.0 && 0.0 <= u && u <= 1.0 then singleton (p + ((*) t) `mapPt` r)
                                                        else Nil

insertSplitStroke ::  Stroke -> Path -> Intersections -> Intersections
insertSplitStroke  stroke splitStroke intersections =
  insert stroke splitStroke $ insert (flipStroke stroke) (reversePath splitStroke) intersections

intersectMultiple :: Stroke -> List Stroke -> Intersections
intersectMultiple stroke strokes =
  let
    intersectionPoints = do
      toIntersect <- strokes
      case intersect stroke toIntersect of
           Nil -> Nil
           newPoints -> pure $ Tuple toIntersect newPoints

    allPoints = concatMap snd intersectionPoints
    insertPoints i (Tuple edge points) =
      insertSplitStroke edge (split edge points) i

    intersections = foldl insertPoints empty intersectionPoints
  in
    insertSplitStroke stroke (split stroke allPoints) intersections

-- given a stroke and a list of intersections, return a list of strokes
-- TODO: currently relies on sorting points since the result will be correct for lines
-- ... need to sort 'along the arc' for arcs
split :: Stroke -> List Point -> List Stroke
split (Line p1 p2) points =
  case head lines of -- ensure we still go from p1 to p2
       Just (Line p _) | p == p1 -> lines
       _ -> reversePath lines
  where
    sortedPoints = sort $ nub $ p1 : p2 : points
    makeLines (p : q : rest) = (Line p q) : (makeLines (q : rest))
    makeLines _ = Nil
    lines = makeLines sortedPoints


Changed annotation to include AJAX effect

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, start)
import Pux.Renderer.React (renderToDOM)
import Control.Monad.Eff.Random (RANDOM)
import Network.HTTP.Affjax (AJAX, get)
import Flag.Core (view, foldp, init)

main ∷ Eff (CoreEffects (random ∷ RANDOM, ajax ∷ AJAX)) Unit
main = do
  app <- start { initialState: init, view, foldp, inputs: [] }
  renderToDOM ".app" app.markup app.input

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, start)
import Pux.Renderer.React (renderToDOM)
import Control.Monad.Eff.Random (RANDOM)
import Flag.Core (view, foldp, init)

main ∷ Eff (CoreEffects (random ∷ RANDOM)) Unit
main = do
  app <- start { initialState: init, view, foldp, inputs: [] }
  renderToDOM ".app" app.markup app.input


Start rewrite of Events to use derived classes & Json

module Genetics.Browser.Events
       ( Event(..)
       , handleLocation
       , handleRange
       , _eventLocation
       , _eventRange
       , _eventScore
       , EventLocation(..)
       , EventRange(..)
       , EventScore(..)
       , Location(..)
       , Range(..)
       , Score(..)
       )
       where

import Prelude

import Data.Lens (re)
import Data.Newtype (class Newtype)
import Data.Symbol (SProxy(..))
import Data.Variant (Variant, on)
import Genetics.Browser.Units (Bp, Chr)

newtype Event r = Event (Variant r)

newtype Location = Location { chr :: Chr
                            , pos :: Bp
                            }

derive instance newtypeLocation :: Newtype Location _
derive newtype instance genericLocation :: Generic Location _

type EventLocation r = ( location :: Location | r)

handleLocation :: forall r a.
                  (Location -> a)
               -> (Variant r -> a)
               -> Variant (EventLocation r)
               -> a
handleLocation = on _eventLocation

type Range = { chr :: Chr
             , minPos :: Bp
             , maxPos :: Bp
             }
_eventRange = (SProxy :: SProxy "range")
type EventRange r = ( range :: Range | r)
handleRange :: forall r a.
                  (Range -> a)
               -> (Variant r -> a)
               -> Variant (EventRange r)
               -> a
handleRange = on _eventRange

type Score = { score :: Number }
_eventScore = (SProxy :: SProxy "score")
type EventScore r = ( score :: Score | r)

module Genetics.Browser.Events
       ( Event(..)
       , handleLocation
       , handleRange
       , _eventLocation
       , _eventRange
       , _eventScore
       , EventLocation(..)
       , EventRange(..)
       , EventScore(..)
       , Location(..)
       , Range(..)
       , Score(..)
       )
       where

import Prelude
import Data.Symbol (SProxy(..))
import Data.Variant (Variant, on)
import Genetics.Browser.Units (Bp, Chr)

newtype Event r = Event (Variant r)

type Location = { chr :: Chr
                , pos :: Bp
                }
_eventLocation = (SProxy :: SProxy "location")
type EventLocation r = ( location :: Location | r)
handleLocation :: forall r a.
                  (Location -> a)
               -> (Variant r -> a)
               -> Variant (EventLocation r)
               -> a
handleLocation = on _eventLocation

type Range = { chr :: Chr
             , minPos :: Bp
             , maxPos :: Bp
             }
_eventRange = (SProxy :: SProxy "range")
type EventRange r = ( range :: Range | r)
handleRange :: forall r a.
                  (Range -> a)
               -> (Variant r -> a)
               -> Variant (EventRange r)
               -> a
handleRange = on _eventRange

type Score = { score :: Number }
_eventScore = (SProxy :: SProxy "score")
type EventScore r = ( score :: Score | r)


[CSE-172] Fix build

[CSE-172] Fix build

-- | Helper functions to mock data.
-- |
-- | _Note_: All these functions are used for testing only.

module Explorer.Test.MockFactory where

import Prelude

import Data.Array ((..))
import Data.Lens (set)
import Data.Maybe (Maybe(..))
import Data.Time.NominalDiffTime (NominalDiffTime, mkTime)
import Data.Tuple (Tuple(..))
import Explorer.Types.State (CTxBriefs)
import Explorer.Util.Factory (mkCAddress, mkCHash, mkCTxId, mkCoin)
import Pos.Explorer.Web.ClientTypes (CAddress, CAddressSummary(..), CAddressType(..), CBlockEntry(..), CCoin, CGenesisAddressInfo(..), CGenesisSummary(..), CHash, CTxBrief(..), CTxEntry(..), CTxId)
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddressSummary, _CBlockEntry, _CTxEntry, caTxList, cbeBlkHash, cbeEpoch, cbeSlot, cbeTimeIssued, cteId, cteTimeIssued)

-- | Creates a `CTxEntry` with "empty" data
mkEmptyCTxEntry :: CTxEntry
mkEmptyCTxEntry = CTxEntry
    { cteId: mkCTxId "--"
    , cteTimeIssued: mkTime 0.0
    , cteAmount: mkCoin "0"
    }

-- | Update hash of a transcation
setIdOfTx :: CTxId -> CTxEntry -> CTxEntry
setIdOfTx txId tx =
    set (_CTxEntry <<< cteId) txId tx

-- | Update time of a transaction
setTimeOfTx :: NominalDiffTime -> CTxEntry -> CTxEntry
setTimeOfTx time tx =
    set (_CTxEntry <<< cteTimeIssued) time tx

mkEmptyCAddressSummary :: CAddressSummary
mkEmptyCAddressSummary = CAddressSummary
    { caAddress: mkCAddress "--"
    , caType: CUnknownAddress
    , caTxNum: 0
    , caBalance: mkCoin "0"
    , caTxList: []
    , caIsRedeemed: Nothing
    }

-- | Update txs of a `CAddressSummary`
setTxOfAddressSummary :: CTxBriefs -> CAddressSummary -> CAddressSummary
setTxOfAddressSummary txs addr =
    set (_CAddressSummary <<< caTxList) txs addr

mkCBlockEntry :: CBlockEntry
mkCBlockEntry = CBlockEntry
    { cbeEpoch: 0
    , cbeSlot: 0
    , cbeBlkHash: mkCHash "0"
    , cbeTimeIssued: Nothing
    , cbeTxNum: 0
    , cbeTotalSent: mkCoin "0"
    , cbeSize: 0
    , cbeBlockLead: Nothing
    }

-- | Update time of a slot
setTimeOfBlock :: NominalDiffTime -> CBlockEntry -> CBlockEntry
setTimeOfBlock time block =
    set (_CBlockEntry <<< cbeTimeIssued) (Just time) block

-- | Update slot / epoch of a slot
setEpochSlotOfBlock :: Int -> Int -> CBlockEntry -> CBlockEntry
setEpochSlotOfBlock epoch slot block =
    set (_CBlockEntry <<< cbeEpoch) epoch $
    set (_CBlockEntry <<< cbeSlot) slot block

-- | Update hash of a slot
setHashOfBlock :: CHash -> CBlockEntry -> CBlockEntry
setHashOfBlock hash block =
    set (_CBlockEntry <<< cbeBlkHash) hash block

mkCTxBriefs :: Array Int -> CTxBriefs
mkCTxBriefs indexes =
    map mkCTxBrief indexes

mkCTxBrief :: Int -> CTxBrief
mkCTxBrief index = CTxBrief
    { ctbId: mkCTxId $ show index
    , ctbTimeIssued: mkTime 0.0
    , ctbInputs: mkCtbInOutputs [index]
    , ctbOutputs: mkCtbInOutputs ((index + 1)..(index + 2))
    , ctbInputSum: mkCoin "0"
    , ctbOutputSum: mkCoin "0"
    }

mkCtbInOutput :: Int -> Int -> Tuple CAddress CCoin
mkCtbInOutput addr coin =
    Tuple (mkCAddress $ "address-" <> show addr) (mkCoin $ show coin)

mkCtbInOutputs :: Array Int -> Array (Tuple CAddress CCoin)
mkCtbInOutputs indexes =
    map (\index -> mkCtbInOutput index index) indexes

mkCGenesisSummary :: CGenesisSummary
mkCGenesisSummary = CGenesisSummary
    { cgsNumTotal    : 2
    , cgsNumRedeemed : 1
    }

mkCGenesisAddressInfo :: CGenesisAddressInfo
mkCGenesisAddressInfo =
    -- Commenting out RSCoin addresses until they can actually be displayed.
    -- See comment in src/Pos/Explorer/Web/ClientTypes.hs for more information.
    CGenesisAddressInfo
    { cgaiCardanoAddress : mkCAddress "3meLwrCDE4C7RofEdkZbUuR75ep3EcTmZv9ebcdjfMtv5H"
    -- , cgaiRSCoinAddress  : mkCAddress "JwvXUQ31cvrFpqqtx6fB-NOp0Q-eGQs74yXMGa-72Ak="
    , cgaiGenesisAmount  : mkCoin "15000000"
    , cgaiIsRedeemed     : false
    }

-- | Helper functions to mock data.
-- |
-- | _Note_: All these functions are used for testing only.

module Explorer.Test.MockFactory where

import Prelude

import Data.Array ((..))
import Data.Lens (set)
import Data.Maybe (Maybe(..))
import Data.Time.NominalDiffTime (NominalDiffTime, mkTime)
import Data.Tuple (Tuple(..))
import Explorer.Types.State (CTxBriefs)
import Explorer.Util.Factory (mkCAddress, mkCHash, mkCTxId, mkCoin)
import Pos.Explorer.Web.ClientTypes (CAddress, CAddressSummary(..), CAddressType(..), CBlockEntry(..), CCoin, CGenesisAddressInfo(..), CGenesisSummary(..), CHash, CTxBrief(..), CTxEntry(..), CTxId)
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddressSummary, _CBlockEntry, _CTxEntry, caTxList, cbeBlkHash, cbeEpoch, cbeSlot, cbeTimeIssued, cteId, cteTimeIssued)

-- | Creates a `CTxEntry` with "empty" data
mkEmptyCTxEntry :: CTxEntry
mkEmptyCTxEntry = CTxEntry
    { cteId: mkCTxId "--"
    , cteTimeIssued: mkTime 0.0
    , cteAmount: mkCoin "0"
    }

-- | Update hash of a transcation
setIdOfTx :: CTxId -> CTxEntry -> CTxEntry
setIdOfTx txId tx =
    set (_CTxEntry <<< cteId) txId tx

-- | Update time of a transaction
setTimeOfTx :: NominalDiffTime -> CTxEntry -> CTxEntry
setTimeOfTx time tx =
    set (_CTxEntry <<< cteTimeIssued) time tx

mkEmptyCAddressSummary :: CAddressSummary
mkEmptyCAddressSummary = CAddressSummary
    { caAddress: mkCAddress "--"
    , caType: CUnknownAddress
    , caTxNum: 0
    , caBalance: mkCoin "0"
    , caTxList: []
    }

-- | Update txs of a `CAddressSummary`
setTxOfAddressSummary :: CTxBriefs -> CAddressSummary -> CAddressSummary
setTxOfAddressSummary txs addr =
    set (_CAddressSummary <<< caTxList) txs addr

mkCBlockEntry :: CBlockEntry
mkCBlockEntry = CBlockEntry
    { cbeEpoch: 0
    , cbeSlot: 0
    , cbeBlkHash: mkCHash "0"
    , cbeTimeIssued: Nothing
    , cbeTxNum: 0
    , cbeTotalSent: mkCoin "0"
    , cbeSize: 0
    , cbeBlockLead: Nothing
    }

-- | Update time of a slot
setTimeOfBlock :: NominalDiffTime -> CBlockEntry -> CBlockEntry
setTimeOfBlock time block =
    set (_CBlockEntry <<< cbeTimeIssued) (Just time) block

-- | Update slot / epoch of a slot
setEpochSlotOfBlock :: Int -> Int -> CBlockEntry -> CBlockEntry
setEpochSlotOfBlock epoch slot block =
    set (_CBlockEntry <<< cbeEpoch) epoch $
    set (_CBlockEntry <<< cbeSlot) slot block

-- | Update hash of a slot
setHashOfBlock :: CHash -> CBlockEntry -> CBlockEntry
setHashOfBlock hash block =
    set (_CBlockEntry <<< cbeBlkHash) hash block

mkCTxBriefs :: Array Int -> CTxBriefs
mkCTxBriefs indexes =
    map mkCTxBrief indexes

mkCTxBrief :: Int -> CTxBrief
mkCTxBrief index = CTxBrief
    { ctbId: mkCTxId $ show index
    , ctbTimeIssued: mkTime 0.0
    , ctbInputs: mkCtbInOutputs [index]
    , ctbOutputs: mkCtbInOutputs ((index + 1)..(index + 2))
    , ctbInputSum: mkCoin "0"
    , ctbOutputSum: mkCoin "0"
    }

mkCtbInOutput :: Int -> Int -> Tuple CAddress CCoin
mkCtbInOutput addr coin =
    Tuple (mkCAddress $ "address-" <> show addr) (mkCoin $ show coin)

mkCtbInOutputs :: Array Int -> Array (Tuple CAddress CCoin)
mkCtbInOutputs indexes =
    map (\index -> mkCtbInOutput index index) indexes

mkCGenesisSummary :: CGenesisSummary
mkCGenesisSummary = CGenesisSummary
    { cgsNumTotal    : 2
    , cgsNumRedeemed : 1
    }

mkCGenesisAddressInfo :: CGenesisAddressInfo
mkCGenesisAddressInfo =
    -- Commenting out RSCoin addresses until they can actually be displayed.
    -- See comment in src/Pos/Explorer/Web/ClientTypes.hs for more information.
    CGenesisAddressInfo
    { cgaiCardanoAddress : mkCAddress "3meLwrCDE4C7RofEdkZbUuR75ep3EcTmZv9ebcdjfMtv5H"
    -- , cgaiRSCoinAddress  : mkCAddress "JwvXUQ31cvrFpqqtx6fB-NOp0Q-eGQs74yXMGa-72Ak="
    , cgaiGenesisAmount  : mkCoin "15000000"
    , cgaiIsRedeemed     : false
    }


adding Show and Eq instance for Move

adding Show and Eq instance for Move

-- | A tiny EDSL for creating presentations

module Slides
  ( runSlides
  , runSlidesWithMoves
  , mkSlides
  , Move(..)
  , Slides()
  , Slide()
  , Element()
  , (<+>)
  , appendPlus
  , slide
  , empty
  , title
  , text
  , code
  , image
  , link
  , valign
  , halign
  , ulist
  , group
  , center
  , withClass
  , withId
  , bold
  , italic
  ) where

import Prelude
import Data.List.Zipper as Z
import Signal (Signal)
import Slides.Internal.Input as I
import Control.Comonad (extract)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Array ((:), uncons, singleton)
import Data.Foldable (foldMap, fold, foldr)
import Data.Generic (class Generic, gShow, gEq)
import Data.List (List(..), length)
import Data.Maybe (Maybe(..), fromMaybe)
import Signal (foldp, runSignal) as S
import Text.Smolder.HTML (p, div, img, a, h2, ul, li, span, pre) as H
import Text.Smolder.HTML.Attributes (className, id, src, href, target) as H
import Text.Smolder.Markup (Markup, text) as H
import Text.Smolder.Markup ((!))
import Text.Smolder.Renderer.String (render) as H

-------------
-- Running --
-------------

-- | run a component for a presentation
runSlides :: forall e. Slides -> Eff ( dom :: DOM | e ) Unit
runSlides slides = do
  inn <- I.input
  runSlidesWithMoves (inputToMove <$> inn) slides

-- | run a component for a presentation with a custom Move
-- | Signal to determine when the slides should move and to which
-- | Slide.
runSlidesWithMoves :: forall e. Signal Move -> Slides -> Eff ( dom :: DOM | e ) Unit
runSlidesWithMoves move (Slides slides) = do
  let ui = S.foldp moveSlides slides move
  S.runSignal (setHtml <<< H.render <<< render <$> ui)

-- Rendering

render :: forall a. SlidesInternal -> H.Markup a
render slides =
  H.div ! H.id "main" $ do
    H.span ! H.className "counter" $
      H.text $ show (position slides + 1) <> " / " <> show (zipLength slides)
    renderSlides (extract slides)

foreign import setHtml :: forall e. String -> Eff ( dom :: DOM | e ) Unit

-- | Which way should the slides move:
-- | - `Back`: Go back one slide. If at the beginning will do nothing
-- | - `Next`: Go to next slide. If at the end will do nothing
-- | - `Start`: Go to the start
-- | - `End`: Go to the end
-- | - `BackOrEnd`: Like `Back` but will wrap around
-- | - `NextOrEnd`: Like `Next` but will wrap around
data Move
  = Back
  | Next
  | Start
  | End
  | BackOrEnd
  | NextOrStart
  | None

derive instance genericMove :: Generic Move

instance eqMove :: Eq Move where
  eq = gEq

instance showMove :: Show Move where
  show = gShow

inputToMove :: I.Input -> Move
inputToMove i
  | I.clickOrHold (i.arrows.right) = Next
  | I.clickOrHold (i.arrows.left)  = Back
  | I.clickOrHold (i.arrows.down)  = Start
  | I.clickOrHold (i.arrows.up)    = End
  | otherwise = None

moveSlides :: Move -> SlidesInternal -> SlidesInternal
moveSlides m slides = case m of
  NextOrStart ->
    fromMaybe (moveSlides Start slides) (Z.up slides)

  BackOrEnd ->
    fromMaybe (moveSlides End slides) (Z.up slides)

  Next ->
    fromMaybe slides (Z.down slides)

  Back ->
    fromMaybe slides (Z.up slides)

  Start ->
    Z.beginning slides

  End ->
    Z.end slides

  None ->
    slides

position :: forall a. Z.Zipper a -> Int
position (Z.Zipper b _ _) = length b

zipLength :: forall a. Z.Zipper a -> Int
zipLength (Z.Zipper b _ a) = 1 + length b + length a

-----------
-- Model --
-----------

-- | Slides state for a component
data Slides = Slides SlidesInternal

type SlidesInternal
  = Z.Zipper Slide

-- | A single slide
data Slide
  = Slide Element

-- | A data type defining the AST
data Element
  = Empty
  | Title  String
  | Text   String
  | Code   String
  | Image  String
  | Link   String Element
  | HAlign (Array Element)
  | VAlign (Array Element)
  | UList  (Array Element)
  | Group  (Array Element)
  | Class String Element
  | Id    String Element

derive instance genericElement :: Generic Element

-- | A Show instance for testing
instance showElement :: Show Element where
  show = gShow

instance semigroupElement :: Semigroup Element where
  append e1 e2 = Group [e1, e2]

-- | Append two elements with some padding in between
appendPlus :: Element -> Element -> Element
appendPlus e1 e2 = e1 <> Class "padapp" Empty <> e2

-- | Append two elements with some padding in between
infixr 5 appendPlus as <+>

-----------
-- Utils --
-----------

-- | Create slides component from an array of slides
mkSlides :: Array Slide -> Slides
mkSlides sl = case uncons sl of
  Just {head, tail} ->
    Slides $ Z.Zipper Nil head (foldr Cons Nil tail)

  Nothing ->
    Slides $ Z.Zipper Nil empty Nil

-- | Create a slide from a title and an element
slide :: String -> Element -> Slide
slide ttl el = Slide (valign [title ttl, el])

-- | An empty slide
empty :: Slide
empty = Slide Empty

-- | A title
title :: String -> Element
title ttl = halign [valign [text ""], Title ttl, valign [text ""]]

-- | Turn an element into a link to url
link :: String -> Element -> Element
link = Link

-- | A text element
text :: String -> Element
text = Text

-- | An image element
image :: String -> Element
image = Image

-- | A <pre> element
code :: String -> Element
code = Code

-- | Group elements as a unit
group :: Array Element -> Element
group = Group

-- | Horizontally align elements in array
halign :: Array Element -> Element
halign = HAlign

-- | Vertically align elements in array
valign :: Array Element -> Element
valign = VAlign

-- | An unordered list of element from an array of elements
ulist :: Array Element -> Element
ulist = UList

-- | Add an Html class to an element
withClass :: String -> Element -> Element
withClass = Class

-- | Add an Html id to an element
withId :: String -> Element -> Element
withId = Id

-- | Position an element at the center of its parent
center :: Element -> Element
center = withClass "center" <<< group <<< singleton

-- | Format text with bold in this element
bold :: Element -> Element
bold = withClass "boldEl" <<< group <<< singleton

-- | Format text with italic in this element
italic :: Element -> Element
italic = withClass "italicEl" <<< group <<< singleton

---------------
-- Rendering --
---------------

renderSlides :: forall a. Slide -> H.Markup a
renderSlides (Slide el) =
  H.div ! H.className "slide" $ renderE el

renderE :: forall a. Element -> H.Markup a
renderE element =
  case element of
    Empty ->
      H.span (H.text "")

    Title tl ->
      H.span ! H.className "title" $ H.h2 (H.text tl)

    Link l el ->
      H.a ! H.href l ! H.target "_top" $ renderE el

    Text str ->
      H.p ! H.className "marwid" $ H.text str

    Code c ->
      H.pre ! H.className "marwid" $ H.text c

    Image url ->
      H.img ! H.className "marwid" ! H.src url

    VAlign els ->
      H.span ! H.className "colflex" $ fold $ applyRest block $ map renderE els

    HAlign els ->
      H.span ! H.className "rowflex" $ foldMap renderE els

    UList els ->
      H.span $ H.ul $ foldMap (H.li <<< renderE) els

    Group els ->
      H.span $ foldMap renderE els

    Class c e ->
      renderE e ! H.className c

    Id i e ->
      renderE e ! H.id i

block :: forall a. H.Markup a -> H.Markup a
block = H.span ! H.className "block"

applyRest :: forall a. (a -> a) -> Array a -> Array a
applyRest f xs =
  case uncons xs of
    Nothing -> xs
    Just list -> list.head : map f list.tail

-- | A tiny EDSL for creating presentations

module Slides
  ( runSlides
  , runSlidesWithMoves
  , mkSlides
  , Move(..)
  , Slides()
  , Slide()
  , Element()
  , (<+>)
  , appendPlus
  , slide
  , empty
  , title
  , text
  , code
  , image
  , link
  , valign
  , halign
  , ulist
  , group
  , center
  , withClass
  , withId
  , bold
  , italic
  ) where

import Prelude
import Data.List.Zipper as Z
import Signal (Signal)
import Slides.Internal.Input as I
import Control.Comonad (extract)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Array ((:), uncons, singleton)
import Data.Foldable (foldMap, fold, foldr)
import Data.Generic (class Generic, gShow)
import Data.List (List(..), length)
import Data.Maybe (Maybe(..), fromMaybe)
import Signal (foldp, runSignal) as S
import Text.Smolder.HTML (p, div, img, a, h2, ul, li, span, pre) as H
import Text.Smolder.HTML.Attributes (className, id, src, href, target) as H
import Text.Smolder.Markup (Markup, text) as H
import Text.Smolder.Markup ((!))
import Text.Smolder.Renderer.String (render) as H

-------------
-- Running --
-------------

-- | run a component for a presentation
runSlides :: forall e. Slides -> Eff ( dom :: DOM | e ) Unit
runSlides slides = do
  inn <- I.input
  runSlidesWithMoves (inputToMove <$> inn) slides

-- | run a component for a presentation with a custom Move
-- | Signal to determine when the slides should move and to which
-- | Slide.
runSlidesWithMoves :: forall e. Signal Move -> Slides -> Eff ( dom :: DOM | e ) Unit
runSlidesWithMoves move (Slides slides) = do
  let ui = S.foldp moveSlides slides move
  S.runSignal (setHtml <<< H.render <<< render <$> ui)

-- Rendering

render :: forall a. SlidesInternal -> H.Markup a
render slides =
  H.div ! H.id "main" $ do
    H.span ! H.className "counter" $
      H.text $ show (position slides + 1) <> " / " <> show (zipLength slides)
    renderSlides (extract slides)

foreign import setHtml :: forall e. String -> Eff ( dom :: DOM | e ) Unit

-- | Which way should the slides move:
-- | - `Back`: Go back one slide. If at the beginning will do nothing
-- | - `Next`: Go to next slide. If at the end will do nothing
-- | - `Start`: Go to the start
-- | - `End`: Go to the end
-- | - `BackOrEnd`: Like `Back` but will wrap around
-- | - `NextOrEnd`: Like `Next` but will wrap around
data Move
  = Back
  | Next
  | Start
  | End
  | BackOrEnd
  | NextOrStart
  | None

inputToMove :: I.Input -> Move
inputToMove i
  | I.clickOrHold (i.arrows.right) = Next
  | I.clickOrHold (i.arrows.left)  = Back
  | I.clickOrHold (i.arrows.down)  = Start
  | I.clickOrHold (i.arrows.up)    = End
  | otherwise = None

moveSlides :: Move -> SlidesInternal -> SlidesInternal
moveSlides m slides = case m of
  NextOrStart ->
    fromMaybe (moveSlides Start slides) (Z.up slides)

  BackOrEnd ->
    fromMaybe (moveSlides End slides) (Z.up slides)

  Next ->
    fromMaybe slides (Z.down slides)

  Back ->
    fromMaybe slides (Z.up slides)

  Start ->
    Z.beginning slides

  End ->
    Z.end slides

  None ->
    slides

position :: forall a. Z.Zipper a -> Int
position (Z.Zipper b _ _) = length b

zipLength :: forall a. Z.Zipper a -> Int
zipLength (Z.Zipper b _ a) = 1 + length b + length a

-----------
-- Model --
-----------

-- | Slides state for a component
data Slides = Slides SlidesInternal

type SlidesInternal
  = Z.Zipper Slide

-- | A single slide
data Slide
  = Slide Element

-- | A data type defining the AST
data Element
  = Empty
  | Title  String
  | Text   String
  | Code   String
  | Image  String
  | Link   String Element
  | HAlign (Array Element)
  | VAlign (Array Element)
  | UList  (Array Element)
  | Group  (Array Element)
  | Class String Element
  | Id    String Element

derive instance genericElement :: Generic Element

-- | A Show instance for testing
instance showElement :: Show Element where
  show = gShow

instance semigroupElement :: Semigroup Element where
  append e1 e2 = Group [e1, e2]

-- | Append two elements with some padding in between
appendPlus :: Element -> Element -> Element
appendPlus e1 e2 = e1 <> Class "padapp" Empty <> e2

-- | Append two elements with some padding in between
infixr 5 appendPlus as <+>

-----------
-- Utils --
-----------

-- | Create slides component from an array of slides
mkSlides :: Array Slide -> Slides
mkSlides sl = case uncons sl of
  Just {head, tail} ->
    Slides $ Z.Zipper Nil head (foldr Cons Nil tail)

  Nothing ->
    Slides $ Z.Zipper Nil empty Nil

-- | Create a slide from a title and an element
slide :: String -> Element -> Slide
slide ttl el = Slide (valign [title ttl, el])

-- | An empty slide
empty :: Slide
empty = Slide Empty

-- | A title
title :: String -> Element
title ttl = halign [valign [text ""], Title ttl, valign [text ""]]

-- | Turn an element into a link to url
link :: String -> Element -> Element
link = Link

-- | A text element
text :: String -> Element
text = Text

-- | An image element
image :: String -> Element
image = Image

-- | A <pre> element
code :: String -> Element
code = Code

-- | Group elements as a unit
group :: Array Element -> Element
group = Group

-- | Horizontally align elements in array
halign :: Array Element -> Element
halign = HAlign

-- | Vertically align elements in array
valign :: Array Element -> Element
valign = VAlign

-- | An unordered list of element from an array of elements
ulist :: Array Element -> Element
ulist = UList

-- | Add an Html class to an element
withClass :: String -> Element -> Element
withClass = Class

-- | Add an Html id to an element
withId :: String -> Element -> Element
withId = Id

-- | Position an element at the center of its parent
center :: Element -> Element
center = withClass "center" <<< group <<< singleton

-- | Format text with bold in this element
bold :: Element -> Element
bold = withClass "boldEl" <<< group <<< singleton

-- | Format text with italic in this element
italic :: Element -> Element
italic = withClass "italicEl" <<< group <<< singleton

---------------
-- Rendering --
---------------

renderSlides :: forall a. Slide -> H.Markup a
renderSlides (Slide el) =
  H.div ! H.className "slide" $ renderE el

renderE :: forall a. Element -> H.Markup a
renderE element =
  case element of
    Empty ->
      H.span (H.text "")

    Title tl ->
      H.span ! H.className "title" $ H.h2 (H.text tl)

    Link l el ->
      H.a ! H.href l ! H.target "_top" $ renderE el

    Text str ->
      H.p ! H.className "marwid" $ H.text str

    Code c ->
      H.pre ! H.className "marwid" $ H.text c

    Image url ->
      H.img ! H.className "marwid" ! H.src url

    VAlign els ->
      H.span ! H.className "colflex" $ fold $ applyRest block $ map renderE els

    HAlign els ->
      H.span ! H.className "rowflex" $ foldMap renderE els

    UList els ->
      H.span $ H.ul $ foldMap (H.li <<< renderE) els

    Group els ->
      H.span $ foldMap renderE els

    Class c e ->
      renderE e ! H.className c

    Id i e ->
      renderE e ! H.id i

block :: forall a. H.Markup a -> H.Markup a
block = H.span ! H.className "block"

applyRest :: forall a. (a -> a) -> Array a -> Array a
applyRest f xs =
  case uncons xs of
    Nothing -> xs
    Just list -> list.head : map f list.tail


Fix some Elm indentation

Fix some Elm indentation

Original commit 78dd4470f27a3dc0059fc31b9945d3422f849283

module Elm
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isLetter)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, decapitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (forEnumerated_, removeElement, sortByKey, sortByKeyM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenNames

renderer :: Renderer
renderer =
    { name: "Elm"
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , transforms:
        { nameForClass: elmNamer nameForClass
        , unionName: Just $ elmNamer unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelNameFromGiven: const "Root"
        , forbiddenFromTopLevelNameGiven
        }
    }

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> a -> Maybe String -> NamingResult
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbidAlso: alsoForbiddenForTypeName name }

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

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> upperNameStyle
    # intercalate "Or"

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

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

forbiddenFromTopLevelNameGiven :: String -> Array String
forbiddenFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

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

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

lowerNameStyle :: String -> String
lowerNameStyle = camelCase >>> decapitalize >>> (legalizeIdentifier false)

upperNameStyle :: String -> String
upperNameStyle = camelCase >>> capitalize >>> (legalizeIdentifier true)

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

elmDoc :: Doc Unit
elmDoc = do
    givenTopLevel <- upperNameStyle <$> getTopLevelNameGiven
    let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--    import Json.Decode exposing (decodeString)"""
    line $ "--    import " <> givenTopLevel <> " exposing (" <> topLevelDecoder <> ")"
    line """--
-- and you're off to the races with
--"""
    line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> givenTopLevel <> " exposing (" <> givenTopLevel <> ", " <> topLevelDecoder <> ", " <> topLevelEncoder <> ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array exposing (Array, map)
import Dict exposing (Dict, map, toList)

-- top level type
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> givenTopLevel <> " = " <> topLevelRendered
    blank
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> givenTopLevel
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> givenTopLevel <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    blank
    line "-- JSON types"
    classes <- getClasses
    unions <- getUnions
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeDefinition i cls
    for_ unions \types -> do
        blank
        renderUnionDefinition types
    blank
    line "-- decoders and encoders"
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeFunctions i cls
    for_ unions \types -> do
        blank
        renderUnionFunctions types
    blank
    line """--- encoder helpers

makeArrayEncoder : (a -> Jenc.Value) -> Array a -> Jenc.Value
makeArrayEncoder f arr =
    Jenc.array (Array.map f arr)

makeDictEncoder : (a -> Jenc.Value) -> Dict String a -> Jenc.Value
makeDictEncoder f dict =
    Jenc.object (toList (Dict.map (\k -> f) dict))

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNothing -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        multiWord "Array" $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName s

unionConstructorName :: Set IRType -> IRType -> Doc String
unionConstructorName s t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    unionName <- lookupUnionName s
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNothing -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        multiWord "Jdec.array" $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName s

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNothing -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        multiWord "makeArrayEncoder" $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName s

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u ->
        case nullableFromSet $ unionToSet u of
        Just t -> true
        Nothing -> false
    -- IRNull -> true
    -- IRUnion u -> S.member IRNull $ unionToSet u
    _ -> false

renderTypeDefinition :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition classIndex className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions classIndex className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
            when (propsList == L.Nil) do
                line "["
            line "]"

typeRenderer :: (Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit) -> Int -> IRClassData -> Doc Unit
typeRenderer renderer classIndex (IRClassData { properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames (simpleNamer lowerNameStyle) (\n -> "other" <> capitalize n) forbiddenPropertyNames $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    renderer classIndex className propertyNames propsList

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    unionName <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: Set IRType -> Doc Unit
renderUnionFunctions allTypes = do
    unionName <- lookupUnionName allTypes
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let { element: maybeArray, rest: nonArrayFields } = removeElement isArray allTypes
        nonArrayDecFields <- L.fromFoldable nonArrayFields # sortByKeyM (unionConstructorName allTypes)
        let decFields = maybe nonArrayDecFields (\f -> f : nonArrayDecFields) maybeArray
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName allTypes t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"


Fix doc-comments

Fix doc-comments

module Data.EuclideanRing
  ( class EuclideanRing, degree, div, mod, (/)
  , gcd
  , lcm
  , quot
  , rem
  , module Data.CommutativeRing
  , module Data.Ring
  , module Data.Semiring
  , intDiv
  , intMod
  ) where

import Data.BooleanAlgebra ((||))
import Data.CommutativeRing (class CommutativeRing)
import Data.Eq (class Eq, (==))
import Data.Ring (class Ring, sub, (-))
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))

-- | The `EuclideanRing` class is for commutative rings that support division.
-- | The mathematical structure this class is based on is sometimes also called
-- | a *Euclidean domain*.
-- |
-- | Instances must satisfy the following laws in addition to the `Ring`
-- | laws:
-- |
-- | - Integral domain: `one /= zero`, and if `a` and `b` are both nonzero then
-- |   so is their product `a * b`
-- | - Euclidean function `degree`:
-- |   - Nonnegativity: For all nonzero `a`, `degree a >= 0`
-- |   - Quotient/remainder: For all `a` and `b`, where `b` is nonzero,
-- |     let `q = a / b` and ``r = a `mod` b``; then `a = q*b + r`, and also
-- |     either `r = zero` or `degree r < degree b`
-- | - Submultiplicative euclidean function:
-- |   - For all nonzero `a` and `b`, `degree a <= degree (a * b)`
-- |
-- | The behaviour of division by `zero` is unconstrained by these laws,
-- | meaning that individual instances are free to choose how to behave in this
-- | case. Similarly, there are no restrictions on what the result of
-- | `degree zero` is; it doesn't make sense to ask for `degree zero` in the
-- | same way that it doesn't make sense to divide by `zero`, so again,
-- | individual instances may choose how to handle this case.
-- |
-- | For any `EuclideanRing` which is also a `Field`, one valid choice
-- | for `degree` is simply `const 1`. In fact, unless there's a specific
-- | reason not to, `Field` types should normally use this definition of
-- | `degree`.
-- |
-- | The `EuclideanRing Int` instance is one of the most commonly used
-- | `EuclideanRing` instances and deserves a little more discussion. In
-- | particular, there are a few different sensible law-abiding implementations
-- | to choose from, with slightly different behaviour in the presence of
-- | negative dividends or divisors. The most common definitions are "truncating"
-- | division, where the result of `a / b` is rounded towards 0, and "Knuthian"
-- | or "flooring" division, where the result of `a / b` is rounded towards
-- | negative infinity. A slightly less common, but arguably more useful, option
-- | is "Euclidean" division, which is defined so as to ensure that ``a `mod` b``
-- | is always nonnegative. With Euclidean division, `a / b` rounds towards
-- | negative infinity if the divisor is positive, and towards positive infinity
-- | if the divisor is negative. Note that all three definitions are identical if
-- | we restrict our attention to nonnegative dividends and divisors.
-- |
-- | In versions 1.x, 2.x, and 3.x of the Prelude, the `EuclideanRing Int`
-- | instance used truncating division. As of 4.x, the `EuclideanRing Int`
-- | instance uses Euclidean division. Additional functions `quot` and `rem` are
-- | supplied if truncating division is desired.
class CommutativeRing a <= EuclideanRing a where
  degree :: a -> Int
  div :: a -> a -> a
  mod :: a -> a -> a

infixl 7 div as /

instance euclideanRingInt :: EuclideanRing Int where
  degree = intDegree
  div = intDiv
  mod = intMod

instance euclideanRingNumber :: EuclideanRing Number where
  degree _ = 1
  div = numDiv
  mod _ _ = 0.0

foreign import intDegree :: Int -> Int
foreign import intDiv :: Int -> Int -> Int
foreign import intMod :: Int -> Int -> Int

foreign import numDiv :: Number -> Number -> Number

-- | The *greatest common divisor* of two values.
gcd :: forall a. Eq a => EuclideanRing a => a -> a -> a
gcd a b =
  if b == zero
    then a
    else gcd b (a `mod` b)

-- | The *least common multiple* of two values.
lcm :: forall a. Eq a => EuclideanRing a => a -> a -> a
lcm a b =
  if a == zero || b == zero
    then zero
    else a * b / gcd a b

-- | The `quot` function provides _truncating_ integer division (see the
-- | documentation for the `EuclideanRing` class). It is identical to `div` in
-- | the `EuclideanRing Int` instance if the dividend is positive, but will be
-- | slightly different if the dividend is negative. For example:
-- |
-- | ```purescript
-- | div 2 3 == 0
-- | quot 2 3 == 0
-- |
-- | div (-2) 3 == (-1)
-- | quot (-2) 3 == 0
-- |
-- | div 2 (-3) == 0
-- | quot 2 (-3) == 0
-- | ```
foreign import quot :: Int -> Int -> Int

-- | The `rem` function provides the remainder after _truncating_ integer
-- | division (see the documentation for the `EuclideanRing` class). It is
-- | identical to `mod` in the `EuclideanRing Int` instance if the dividend is
-- | positive, but will be slightly different if the dividend is negative. For
-- | example:
-- |
-- | ```purescript
-- | mod 2 3 == 2
-- | rem 2 3 == 2
-- |
-- | mod (-2) 3 == 1
-- | rem (-2) 3 == (-2)
-- |
-- | mod 2 (-3) == 2
-- | rem 2 (-3) == 2
-- | ```
foreign import rem :: Int -> Int -> Int

module Data.EuclideanRing
  ( class EuclideanRing, degree, div, mod, (/)
  , gcd
  , lcm
  , quot
  , rem
  , module Data.CommutativeRing
  , module Data.Ring
  , module Data.Semiring
  , intDiv
  , intMod
  ) where

import Data.BooleanAlgebra ((||))
import Data.CommutativeRing (class CommutativeRing)
import Data.Eq (class Eq, (==))
import Data.Ring (class Ring, sub, (-))
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))

-- | The `EuclideanRing` class is for commutative rings that support division.
-- | The mathematical structure this class is based on is sometimes also called
-- | a *Euclidean domain*.
-- |
-- | Instances must satisfy the following laws in addition to the `Ring`
-- | laws:
-- |
-- | - Integral domain: `one /= zero`, and if `a` and `b` are both nonzero then
-- |   so is their product `a * b`
-- | - Euclidean function `degree`:
-- |   - Nonnegativity: For all nonzero `a`, `degree a >= 0`
-- |   - Quotient/remainder: For all `a` and `b`, where `b` is nonzero,
-- |     let `q = a / b` and ``r = a `mod` b``; then `a = q*b + r`, and also
-- |     either `r = zero` or `degree r < degree b`
-- | - Submultiplicative euclidean function:
-- |   - For all nonzero `a` and `b`, `degree a <= degree (a * b)`
-- |
-- | The behaviour of division by `zero` is unconstrained by these laws,
-- | meaning that individual instances are free to choose how to behave in this
-- | case. Similarly, there are no restrictions on what the result of
-- | `degree zero` is; it doesn't make sense to ask for `degree zero` in the
-- | same way that it doesn't make sense to divide by `zero`, so again,
-- | individual instances may choose how to handle this case.
-- |
-- | For any `EuclideanRing` which is also a `Field`, one valid choice
-- | for `degree` is simply `const 1`. In fact, unless there's a specific
-- | reason not to, `Field` types should normally use this definition of
-- | `degree`.
-- |
-- | The `EuclideanRing Int` instance is one of the most commonly used
-- | `EuclideanRing` instances and deserves a little more discussion. In
-- | particular, there are a few different sensible law-abiding implementations
-- | to choose from, with slightly different behaviour in the presence of
-- | negative dividends or divisors. The most common definitions are "truncating"
-- | division, where the result of `a / b` is rounded towards 0, and "Knuthian"
-- | or "flooring" division, where the result of `a / b` is rounded towards
-- | negative infinity. A slightly less common, but arguably more useful, option
-- | is "Euclidean" division, which is defined so as to ensure that ``a `mod` b``
-- | is always nonnegative. With Euclidean division, `a / b` rounds towards
-- | negative infinity if the divisor is positive, and towards positive infinity
-- | if the divisor is negative. Note that all three definitions are identical if
-- | we restrict our attention to nonnegative dividends and divisors.

-- | In versions 1.x, 2.x, and 3.x of the Prelude, the `EuclideanRing Int`
-- | instance used truncating division. As of 4.x, the `EuclideanRing Int`
-- | instance uses Euclidean division. Additional functions `quot` and `rem` are
-- | supplied if truncating division is desired.
class CommutativeRing a <= EuclideanRing a where
  degree :: a -> Int
  div :: a -> a -> a
  mod :: a -> a -> a

infixl 7 div as /

instance euclideanRingInt :: EuclideanRing Int where
  degree = intDegree
  div = intDiv
  mod = intMod

instance euclideanRingNumber :: EuclideanRing Number where
  degree _ = 1
  div = numDiv
  mod _ _ = 0.0

foreign import intDegree :: Int -> Int
foreign import intDiv :: Int -> Int -> Int
foreign import intMod :: Int -> Int -> Int

foreign import numDiv :: Number -> Number -> Number

-- | The *greatest common divisor* of two values.
gcd :: forall a. Eq a => EuclideanRing a => a -> a -> a
gcd a b =
  if b == zero
    then a
    else gcd b (a `mod` b)

-- | The *least common multiple* of two values.
lcm :: forall a. Eq a => EuclideanRing a => a -> a -> a
lcm a b =
  if a == zero || b == zero
    then zero
    else a * b / gcd a b

-- | The `quot` function provides _truncating_ integer division (see the
-- | documentation for the `EuclideanRing` class). It is identical to `div` in
-- | the `EuclideanRing Int` instance if the dividend is positive, but will be
-- | slightly different if the dividend is negative. For example:
-- |
-- | ```purescript
-- | div 2 3 == 0
-- | quot 2 3 == 0
-- |
-- | div (-2) 3 == (-1)
-- | quot (-2) 3 == 0
-- |
-- | div 2 (-3) == 0
-- | quot 2 (-3) == 0
-- | ```
foreign import quot :: Int -> Int -> Int

-- | The `rem` function provides the remainder after _truncating_ integer
-- | division (see the documentation for the `EuclideanRing` class). It is
-- | identical to `mod` in the `EuclideanRing Int` instance if the dividend is
-- | positive, but will be slightly different if the dividend is negative. For
-- | example:
-- |
-- | ```purescript
-- | mod 2 3 == 2
-- | rem 2 3 == 2
-- |
-- | mod (-2) 3 == 1
-- | rem (-2) 3 == (-2)
-- |
-- | mod 2 (-3) == 2
-- | rem 2 (-3) == 2
-- | ```
foreign import rem :: Int -> Int -> Int