Add support for history

Add support for history

module Main where

import AST (Expr, Atom(Name), Tree(Atom))
import Parser as Parser
import Evaluator as Eval
import Web as Web
import JSHelpers (ctrlKeyPressed, getType)

import Prelude
import DOM (DOM)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.StrMap (empty)
import Data.Array (cons)
import Data.Traversable (for)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.JQuery as J

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = log "hello"

makeCE :: forall eff. String -> String -> Eff (dom :: DOM | eff) Unit
makeCE input selector = do
  container <- J.select selector
  let expr = parseExpr input
  let env = preludeEnv
  showExprIn expr env [] container Nothing
  return unit

makeCEwithDefs :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithDefs input defs selector = do
  container <- J.select selector
  let expr = parseExpr input
  let env = stringToEnv defs
  showExprIn expr env [] container Nothing

makeCEwithHistory :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithHistory input selector histSelector = do
  container <- J.select selector
  histContainer <- J.select histSelector
  let expr = parseExpr input
  let env = preludeEnv
  showExprIn expr env [] container (Just histContainer)

parseExpr :: String -> Expr
parseExpr input = case Parser.parseExpr input of
  Left _     -> (Atom unit (Name "foo"))
  Right expr -> expr

eval1 :: Eval.Env -> Expr -> Expr
eval1 env expr = case Eval.runEvalM (Eval.eval1 env expr) of
  Left _      -> expr
  Right expr' -> expr'

makeCallback :: Eval.Env -> Array Expr -> J.JQuery -> Maybe J.JQuery-> Web.Callback
makeCallback env history container histContainer expr hole event jq = do
  J.stopImmediatePropagation event
  let evalFunc = if ctrlKeyPressed event then Eval.eval else eval1
  case getType event of
    "click"     -> if evalFunc env expr /= expr
                   then showExprIn (hole (evalFunc env expr)) env (cons (hole expr) history) container histContainer
                   else return unit
    "mouseover" -> if evalFunc env expr /= expr
                   then void $ J.addClass "highlight" jq
                   else return unit
    "mouseout"  -> void $ J.removeClass "highlight" jq
    _           -> return unit
  return unit

exprToJQuery :: forall eff. Web.Callback -> Expr -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery callback = Web.exprToDiv >>> Web.divToJQuery callback

showExprIn :: forall eff. Expr -> Eval.Env -> Array Expr -> J.JQuery -> Maybe J.JQuery-> Eff (dom :: DOM | eff) Unit
showExprIn expr env history container histContainer = do
  content <- exprToJQuery (makeCallback env history container histContainer) expr
  J.clear container
  J.append content container
  case histContainer of
    Nothing -> return unit
    Just histContainer -> do
      J.clear histContainer
      for history $ \expr -> do
        histExpr <- exprToJQuery (\_ _ _ _ -> return unit) expr
        histDiv <- J.create "

"
        J.addClass "history-element" histDiv
        J.append histExpr histDiv
        J.append histDiv histContainer
      return unit
  return unit

stringToEnv :: String -> Eval.Env
stringToEnv str = case Parser.parseDefs str of
  Left _     -> empty
  Right defs -> Eval.defsToEnv defs

preludeEnv :: Eval.Env
preludeEnv = stringToEnv prelude

prelude :: String
prelude =
  "and (True:xs)  = and xs\n" ++
  "and (False:xs) = False\n" ++
  "and []         = True\n" ++
  "\n" ++
  "or (False:xs) = or xs\n" ++
  "or (True:xs)  = True\n" ++
  "or []         = False\n" ++
  "\n" ++
  "all p = and . map p\n" ++
  "any p = or . map p\n" ++
  "\n" ++
  "head (x:xs) = x\n" ++
  "tail (x:xs) = xs\n" ++
  "\n" ++
  "take 0 xs     = []\n" ++
  "take n (x:xs) = x : take (n - 1) xs\n" ++
  "\n" ++
  "drop 0 xs     = xs\n" ++
  "drop n (x:xs) = drop (n - 1) xs\n" ++
  "\n" ++
  "elem e []     = False\n" ++
  "elem e (x:xs) = if e == x then True else elem e xs\n" ++
  "\n" ++
  "max a b = if a >= b then a else b\n" ++
  "min a b = if b >= a then a else b\n" ++
  "\n" ++
  "maximum (x:xs) = foldr max x xs\n" ++
  "minimum (x:xs) = foldr min x xs\n" ++
  "\n" ++
  "length []     = 0\n" ++
  "length (x:xs) = 1 + length xs\n" ++
  "\n" ++
  "zip (x:xs) (y:ys) = (x, y) : zip xs ys\n" ++
  "zip []      _     = []\n" ++
  "zip _       []    = []\n" ++
  "\n" ++
  "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" ++
  "zipWith _ []     _      = []\n" ++
  "zipWith _ _      []     = []\n" ++
  "\n" ++
  "unzip []          = ([], [])\n" ++
  "unzip ((a, b):xs) = (\\(as, bs) -> (a:as, b:bs)) $ unzip xs\n" ++
  "\n" ++
  "fst (x,_) = x\n" ++
  "snd (_,x) = x\n" ++
  "\n" ++
  "curry f a b = f (a, b)\n" ++
  "uncurry f (a, b) = f a b\n" ++
  "\n" ++
  "repeat x = x : repeat x\n" ++
  "\n" ++
  "replicate 0 _ = []\n" ++
  "replicate n x = x : replicate (n - 1) x\n" ++
  "\n" ++
  "enumFromTo a b = if a <= b then a : enumFromTo (a + 1) b else []\n" ++
  "\n" ++
  "sum (x:xs) = x + sum xs\n" ++
  "sum [] = 0\n" ++
  "\n" ++
  "product (x:xs) = x * product xs\n" ++
  "product [] = 1\n" ++
  "\n" ++
  "reverse []     = []\n" ++
  "reverse (x:xs) = reverse xs ++ [x]\n" ++
  "\n" ++
  "concat = foldr (++) []\n" ++
  "\n" ++
  "map f []     = []\n" ++
  "map f (x:xs) = f x : map f xs\n" ++
  "\n" ++
  "not True  = False\n" ++
  "not False = True\n" ++
  "\n" ++
  "filter p (x:xs) = if p x then x : filter p xs else filter p xs\n" ++
  "filter p []     = []\n" ++
  "\n" ++
  "foldr f ini []     = ini\n" ++
  "foldr f ini (x:xs) = f x (foldr f ini xs)\n" ++
  "\n" ++
  "foldl f acc []     = acc\n" ++
  "foldl f acc (x:xs) = foldl f (f acc x) xs\n" ++
  "\n" ++
  "scanl f b []     = [b]\n" ++
  "scanl f b (x:xs) = b : scanl f (f b x) xs\n" ++
  "\n" ++
  "iterate f x = x : iterate f (f x)\n" ++
  "\n" ++
  "id x = x\n" ++
  "\n" ++
  "const x _ = x\n" ++
  "\n" ++
  "flip f x y = f y x\n" ++
  "\n" ++
  "even n = (n `mod` 2) == 0\n" ++
  "odd n = (n `mod` 2) == 1\n" ++
  "\n" ++
  "fix f = f (fix f)\n"

-- import Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
-- import Data.Foreign (unsafeFromForeign)
-- import Data.Foldable (any)
-- import Data.Either (Either(Right, Left), either)
-- import Data.Maybe (Maybe(Just, Nothing), maybe)
-- import Data.List (List(Nil), (:), singleton, (!!), drop, deleteAt, length, (..), zipWithA)

-- import Control.Monad.State.Trans (StateT, modify, get, runStateT)
-- import Control.Monad.Eff.Class (liftEff)

-- import Text.Parsing.Parser (ParseError(ParseError))
-- import Text.Parsing.Parser.Pos (Position(Position))
-- import Ace.Types (ACE())
-- import Ace.Editor as Editor
-- import Ace.EditSession as Session
-- import Ace.Range as  Range

-- import Web (exprToJQuery, getPath, idExpr, makeDiv)
-- import Evaluator (evalPath1, evalPathAll, Env(), defsToEnv, envToDefs, EvalError(..), MatchingError(..))
-- import AST (Path, Expr, TypeTree, Output, TypeError)
-- import TypeChecker (TypeEnv, txToABC, buildPartiallyTypedTree, typeTreeProgramnEnv, checkForError, prettyPrintTypeError, buildTypeEnv)
-- import Parser (parseDefs, parseExpr)
-- import JSHelpers (ctrlKeyPressed, prepend, jqMap, warnOnRefresh, isEnterKey, showTypes)

-- main :: DOMEff J.JQuery
-- main = J.ready $ do
--   J.select "#input"
--     >>= J.on "change" (\_ _ -> startEvaluation)
--     >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
--   startEvaluation

-- type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

-- type EvalState = { env :: Env, out :: Output, history :: List Output, typEnv :: TypeEnv }

-- type EvalM a = StateT EvalState DOMEff a

-- startEvaluation :: DOMEff Unit
-- startEvaluation = do
--   clearInfo
--   editor <- Ace.edit "definitions" Ace.ace
--   definitions <- Editor.getValue editor
--   input       <- J.select "#input"       >>= getValue

--   case parseExpr input of
--     Left err   -> showInfo "Expression" (show err)
--     Right expr -> do
--       case defsToEnv <$> parseDefs definitions of
--         Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
--           showInfo "Definitions" (show err)
--           markText (line - 1) column
--         Right env -> case buildTypeEnv (envToDefs env) of --  type Env
--           Left err -> showInfo "Definitions" (prettyPrintTypeError err)
--           Right typEnv -> do
--             let showEvalState typ' = let typ = txToABC typ' in
--               let idTree = idExpr expr in
--               void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }
--             case typeTreeProgramnEnv typEnv expr of
--               Left err -> do
--                 showTypes
--                 let typ' = buildPartiallyTypedTree typEnv expr
--                 showEvalState typ'
--               Right typ' -> showEvalState typ'

-- outIfErr::forall b. String -> Either TypeError b -> DOMEff Unit
-- outIfErr origin either = case either of
--   Left err -> showInfo origin (prettyPrintTypeError err)
--   Right _ -> return unit

-- markText :: Int -> Int -> DOMEff Unit
-- markText line column = do
--   editor <- Ace.edit "definitions" Ace.ace
--   session <- Editor.getSession editor
--   rang <- Range.create line column 100000 100000
--   void $ Session.addMarker rang "syntaxError" "" false session

-- showEvaluationState :: EvalM Unit
-- showEvaluationState = do
--   liftEff $ warnOnRefresh
--   output <- liftEff $ prepareContainer "output"
--   history <- liftEff $ prepareContainer "history"
--   typContainer <- liftEff $ prepareContainer "typ"
--   svgContainer <- liftEff $ prepareContainer "svg"

--   { env = env, out = out, history = histExprs } <- get :: EvalM EvalState
--   liftEff $ print out.expr
--   liftEff $ print out.typ

--   liftEff $ exprToJQuery out >>= wrapInDiv "output" >>= flip J.append output
--   showHistoryList histExprs >>= liftEff <<< flip J.append history

--   liftEff (J.find ".binary, .app, .func, .list, .if, .name" output)
--      >>= makeClickable
--   liftEff (J.find ".output div" output)
--     >>= addMouseOverListener
--     >>= addClickListener (out.typ)
--   liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

--   liftEff $ return unit :: DOMEff Unit

-- forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
-- forIndex as f = zipWithA f as (0 .. (length as - 1))

-- showHistoryList :: (List Output) -> EvalM J.JQuery
-- showHistoryList exprs = do
--   box <- liftEff $ J.create "

" >>= J.addClass "historyBox" >>= J.addClass "vertical" >>= J.addClass "frame"
--   forIndex exprs $ \expr i -> do
--     showHistoryRow expr i >>= liftEff <<< flip J.append box
--   scroll <- liftEff $ J.create "

" >>= J.addClass "scroll"
--   liftEff $ J.append box scroll
--   return scroll

-- showHistoryRow :: Output -> Int -> EvalM J.JQuery
-- showHistoryRow out i = do
--   row <- liftEff $ J.create "

" >>= J.addClass "history"
--   tdExpr <- liftEff $ J.create "	"
--   liftEff $ exprToJQuery out >>= flip J.append tdExpr
--   liftEff $ J.append tdExpr row
--   es <- get :: EvalM EvalState
--   let deleteHandler = \_ _ -> do
--                         let es' = es { history = maybe es.history id (deleteAt i es.history) }
--                         void $ runStateT showEvaluationState es'
--   delete <- liftEff $ J.create "<button></button>"
--     >>= J.setText "Delete"
--     >>= J.addClass "delete"
--     >>= J.on "click" deleteHandler
--   tdDelete <- liftEff $ J.create "	"
--   liftEff $ J.append delete tdDelete
--   liftEff $ J.append tdDelete row
--   let restoreHandler = \_ _ -> do
--                          let es' = es { history = drop (i + 1) es.history, out = maybe es.out id (es.history !! i) }
--                          void $ runStateT showEvaluationState es'
--   restore <- liftEff $ J.create "<button></button>"
--     >>= J.setText "Restore"
--     >>= J.addClass "restore"
--     >>= J.on "click" restoreHandler
--   tdRestore <- liftEff $ J.create "	"
--   liftEff $ J.append restore tdRestore
--   liftEff $ J.append tdRestore row
--   return row

-- showInfo :: String -> String -> DOMEff Unit
-- showInfo origin msg = do
--   info <- J.create "

"
--     >>= J.addClass "info"
--     >>= J.setText ("Error in " ++ origin ++ " => " ++ msg)
--   clearInfo
--   J.select "#info"
--     >>= J.append info
--   return unit

-- clearInfo :: DOMEff Unit
-- clearInfo = void $ J.select "#info" >>= J.clear

-- prepareContainer :: String -> DOMEff J.JQuery
-- prepareContainer name = do
--   J.select ("#" ++ name ++ "-container") >>= J.clear

-- wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
-- wrapInDiv name jq = do
--   J.create "

" >>= J.addClass name >>= J.append jq

-- makeClickable :: J.JQuery -> EvalM Unit
-- makeClickable jq = do
--   { env = env, out = out } <- get
--   let expr = out.expr
--   let typeTree = out.typ
--   liftEff $ jqMap (testEval env expr typeTree) jq
--   where
--   testEval :: Env -> Expr -> TypeTree -> J.JQuery -> DOMEff Unit
--   testEval env expr typeTree jq = do
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> return unit
--       Just path ->
--         case evalPath1 env path expr of
--           Left err -> displayEvalError err jq
--           Right _  -> if checkForError path typeTree
--             then return unit
--             else void $ J.addClass "clickable" jq

-- displayEvalError :: EvalError -> J.JQuery -> DOMEff Unit
-- displayEvalError err jq = case err of
--   DivByZero -> void $ makeDiv "Division by zero!" (singleton "evalError") >>= flip prepend jq
--   NoMatchingFunction _ errs -> if (any missesArguments errs)
--     then return unit
--     else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip prepend jq
--   _         -> return unit
--   where
--     missesArguments (TooFewArguments _ _) = true
--     missesArguments (StrictnessError _ _) = true
--     missesArguments _                     = false

-- addMouseOverListener :: J.JQuery -> EvalM J.JQuery
-- addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
--   where
--   handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
--   handler jEvent jq = do
--     J.stopPropagation jEvent
--     removeMouseOver
--     J.addClass "mouseOver" jq
--     return unit

-- addClickListener :: TypeTree ->  J.JQuery -> EvalM J.JQuery
-- addClickListener typeTree jq = do
--   evaluationState <- get
--   liftEff $ J.on "click" (handler evaluationState) jq
--   where
--   handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
--   handler evaluationState jEvent jq = do
--     J.stopImmediatePropagation jEvent
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> return unit
--       Just path -> do
--         return unit
--         if checkForError path typeTree
--           then return unit
--           else case ctrlKeyPressed jEvent of
--                 false -> void $ runStateT (evalExpr evalPath1 path) evaluationState
--                 true  -> void $ runStateT (evalExpr evalPathAll path) evaluationState

-- removeMouseOver :: DOMEff Unit
-- removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

-- evalExpr :: (Env -> Path -> Expr -> Either EvalError Expr) -> Path -> EvalM Unit
-- evalExpr eval path = do
--   { env = env, out = out, typEnv = typEnv} <- get
--   let expr = out.expr
--   liftEff $ print path
--   case eval env path expr of
--     Left msg    -> return unit
--     Right expr' -> do
--         let eitherTyp = typeTreeProgramnEnv typEnv expr'
--         let typ'' = either (\_ -> buildPartiallyTypedTree typEnv expr') id eitherTyp
--         let typ' = txToABC typ''
--         modify (\es -> es { out = {expr:expr', typ:typ', idTree:idExpr expr'} })
--         modify (\es -> es { history = out : es.history })
--         showEvaluationState

-- getValue :: J.JQuery -> DOMEff String
-- getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import AST (Expr, Atom(Name), Tree(Atom))
import Parser as Parser
import Evaluator as Eval
import Web as Web
import JSHelpers (ctrlKeyPressed, getType)

import Prelude
import DOM (DOM)
import Data.Either (Either(Left, Right))
import Data.StrMap (empty)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.JQuery as J

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = log "hello"

makeCE :: forall eff. String -> String -> Eff (dom :: DOM | eff) Unit
makeCE input selector = do
  container <- J.select selector
  let expr = parseExpr input
  let env = preludeEnv
  showExprIn expr env container
  return unit

makeCEwithDefs :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) Unit
makeCEwithDefs input defs selector = do
  container <- J.select selector
  let expr = parseExpr input
  let env = stringToEnv defs
  showExprIn expr env container

parseExpr :: String -> Expr
parseExpr input = case Parser.parseExpr input of
  Left _     -> (Atom unit (Name "foo"))
  Right expr -> expr

eval1 :: Eval.Env -> Expr -> Expr
eval1 env expr = case Eval.runEvalM (Eval.eval1 env expr) of
  Left _      -> expr
  Right expr' -> expr'

makeCallback :: Eval.Env -> J.JQuery -> Web.Callback
makeCallback env container expr hole event jq = do
  J.stopImmediatePropagation event
  let evalFunc = if ctrlKeyPressed event then Eval.eval else eval1
  case getType event of
    "click"     -> showExprIn (hole (evalFunc env expr)) env container
    "mouseover" -> if evalFunc env expr /= expr
                   then void $ J.addClass "highlight" jq
                   else return unit
    "mouseout"  -> void $ J.removeClass "highlight" jq
    _           -> return unit
  return unit

exprToJQuery :: forall eff. Web.Callback -> Expr -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery callback = Web.exprToDiv >>> Web.divToJQuery callback

showExprIn :: forall eff. Expr -> Eval.Env -> J.JQuery -> Eff (dom :: DOM | eff) Unit
showExprIn expr env container = do
  content <- exprToJQuery (makeCallback env container) expr
  J.clear container
  J.append content container
  return unit

stringToEnv :: String -> Eval.Env
stringToEnv str = case Parser.parseDefs str of
  Left _     -> empty
  Right defs -> Eval.defsToEnv defs

preludeEnv :: Eval.Env
preludeEnv = stringToEnv prelude

prelude :: String
prelude =
  "and (True:xs)  = and xs\n" ++
  "and (False:xs) = False\n" ++
  "and []         = True\n" ++
  "\n" ++
  "or (False:xs) = or xs\n" ++
  "or (True:xs)  = True\n" ++
  "or []         = False\n" ++
  "\n" ++
  "all p = and . map p\n" ++
  "any p = or . map p\n" ++
  "\n" ++
  "head (x:xs) = x\n" ++
  "tail (x:xs) = xs\n" ++
  "\n" ++
  "take 0 xs     = []\n" ++
  "take n (x:xs) = x : take (n - 1) xs\n" ++
  "\n" ++
  "drop 0 xs     = xs\n" ++
  "drop n (x:xs) = drop (n - 1) xs\n" ++
  "\n" ++
  "elem e []     = False\n" ++
  "elem e (x:xs) = if e == x then True else elem e xs\n" ++
  "\n" ++
  "max a b = if a >= b then a else b\n" ++
  "min a b = if b >= a then a else b\n" ++
  "\n" ++
  "maximum (x:xs) = foldr max x xs\n" ++
  "minimum (x:xs) = foldr min x xs\n" ++
  "\n" ++
  "length []     = 0\n" ++
  "length (x:xs) = 1 + length xs\n" ++
  "\n" ++
  "zip (x:xs) (y:ys) = (x, y) : zip xs ys\n" ++
  "zip []      _     = []\n" ++
  "zip _       []    = []\n" ++
  "\n" ++
  "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" ++
  "zipWith _ []     _      = []\n" ++
  "zipWith _ _      []     = []\n" ++
  "\n" ++
  "unzip []          = ([], [])\n" ++
  "unzip ((a, b):xs) = (\\(as, bs) -> (a:as, b:bs)) $ unzip xs\n" ++
  "\n" ++
  "fst (x,_) = x\n" ++
  "snd (_,x) = x\n" ++
  "\n" ++
  "curry f a b = f (a, b)\n" ++
  "uncurry f (a, b) = f a b\n" ++
  "\n" ++
  "repeat x = x : repeat x\n" ++
  "\n" ++
  "replicate 0 _ = []\n" ++
  "replicate n x = x : replicate (n - 1) x\n" ++
  "\n" ++
  "enumFromTo a b = if a <= b then a : enumFromTo (a + 1) b else []\n" ++
  "\n" ++
  "sum (x:xs) = x + sum xs\n" ++
  "sum [] = 0\n" ++
  "\n" ++
  "product (x:xs) = x * product xs\n" ++
  "product [] = 1\n" ++
  "\n" ++
  "reverse []     = []\n" ++
  "reverse (x:xs) = reverse xs ++ [x]\n" ++
  "\n" ++
  "concat = foldr (++) []\n" ++
  "\n" ++
  "map f []     = []\n" ++
  "map f (x:xs) = f x : map f xs\n" ++
  "\n" ++
  "not True  = False\n" ++
  "not False = True\n" ++
  "\n" ++
  "filter p (x:xs) = if p x then x : filter p xs else filter p xs\n" ++
  "filter p []     = []\n" ++
  "\n" ++
  "foldr f ini []     = ini\n" ++
  "foldr f ini (x:xs) = f x (foldr f ini xs)\n" ++
  "\n" ++
  "foldl f acc []     = acc\n" ++
  "foldl f acc (x:xs) = foldl f (f acc x) xs\n" ++
  "\n" ++
  "scanl f b []     = [b]\n" ++
  "scanl f b (x:xs) = b : scanl f (f b x) xs\n" ++
  "\n" ++
  "iterate f x = x : iterate f (f x)\n" ++
  "\n" ++
  "id x = x\n" ++
  "\n" ++
  "const x _ = x\n" ++
  "\n" ++
  "flip f x y = f y x\n" ++
  "\n" ++
  "even n = (n `mod` 2) == 0\n" ++
  "odd n = (n `mod` 2) == 1\n" ++
  "\n" ++
  "fix f = f (fix f)\n"

-- import Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
-- import Data.Foreign (unsafeFromForeign)
-- import Data.Foldable (any)
-- import Data.Either (Either(Right, Left), either)
-- import Data.Maybe (Maybe(Just, Nothing), maybe)
-- import Data.List (List(Nil), (:), singleton, (!!), drop, deleteAt, length, (..), zipWithA)

-- import Control.Monad.State.Trans (StateT, modify, get, runStateT)
-- import Control.Monad.Eff.Class (liftEff)

-- import Text.Parsing.Parser (ParseError(ParseError))
-- import Text.Parsing.Parser.Pos (Position(Position))
-- import Ace.Types (ACE())
-- import Ace.Editor as Editor
-- import Ace.EditSession as Session
-- import Ace.Range as  Range

-- import Web (exprToJQuery, getPath, idExpr, makeDiv)
-- import Evaluator (evalPath1, evalPathAll, Env(), defsToEnv, envToDefs, EvalError(..), MatchingError(..))
-- import AST (Path, Expr, TypeTree, Output, TypeError)
-- import TypeChecker (TypeEnv, txToABC, buildPartiallyTypedTree, typeTreeProgramnEnv, checkForError, prettyPrintTypeError, buildTypeEnv)
-- import Parser (parseDefs, parseExpr)
-- import JSHelpers (ctrlKeyPressed, prepend, jqMap, warnOnRefresh, isEnterKey, showTypes)

-- main :: DOMEff J.JQuery
-- main = J.ready $ do
--   J.select "#input"
--     >>= J.on "change" (\_ _ -> startEvaluation)
--     >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
--   startEvaluation

-- type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

-- type EvalState = { env :: Env, out :: Output, history :: List Output, typEnv :: TypeEnv }

-- type EvalM a = StateT EvalState DOMEff a

-- startEvaluation :: DOMEff Unit
-- startEvaluation = do
--   clearInfo
--   editor <- Ace.edit "definitions" Ace.ace
--   definitions <- Editor.getValue editor
--   input       <- J.select "#input"       >>= getValue

--   case parseExpr input of
--     Left err   -> showInfo "Expression" (show err)
--     Right expr -> do
--       case defsToEnv <$> parseDefs definitions of
--         Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
--           showInfo "Definitions" (show err)
--           markText (line - 1) column
--         Right env -> case buildTypeEnv (envToDefs env) of --  type Env
--           Left err -> showInfo "Definitions" (prettyPrintTypeError err)
--           Right typEnv -> do
--             let showEvalState typ' = let typ = txToABC typ' in
--               let idTree = idExpr expr in
--               void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }
--             case typeTreeProgramnEnv typEnv expr of
--               Left err -> do
--                 showTypes
--                 let typ' = buildPartiallyTypedTree typEnv expr
--                 showEvalState typ'
--               Right typ' -> showEvalState typ'

-- outIfErr::forall b. String -> Either TypeError b -> DOMEff Unit
-- outIfErr origin either = case either of
--   Left err -> showInfo origin (prettyPrintTypeError err)
--   Right _ -> return unit

-- markText :: Int -> Int -> DOMEff Unit
-- markText line column = do
--   editor <- Ace.edit "definitions" Ace.ace
--   session <- Editor.getSession editor
--   rang <- Range.create line column 100000 100000
--   void $ Session.addMarker rang "syntaxError" "" false session

-- showEvaluationState :: EvalM Unit
-- showEvaluationState = do
--   liftEff $ warnOnRefresh
--   output <- liftEff $ prepareContainer "output"
--   history <- liftEff $ prepareContainer "history"
--   typContainer <- liftEff $ prepareContainer "typ"
--   svgContainer <- liftEff $ prepareContainer "svg"

--   { env = env, out = out, history = histExprs } <- get :: EvalM EvalState
--   liftEff $ print out.expr
--   liftEff $ print out.typ

--   liftEff $ exprToJQuery out >>= wrapInDiv "output" >>= flip J.append output
--   showHistoryList histExprs >>= liftEff <<< flip J.append history

--   liftEff (J.find ".binary, .app, .func, .list, .if, .name" output)
--      >>= makeClickable
--   liftEff (J.find ".output div" output)
--     >>= addMouseOverListener
--     >>= addClickListener (out.typ)
--   liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

--   liftEff $ return unit :: DOMEff Unit

-- forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
-- forIndex as f = zipWithA f as (0 .. (length as - 1))

-- showHistoryList :: (List Output) -> EvalM J.JQuery
-- showHistoryList exprs = do
--   box <- liftEff $ J.create "

" >>= J.addClass "historyBox" >>= J.addClass "vertical" >>= J.addClass "frame"
--   forIndex exprs $ \expr i -> do
--     showHistoryRow expr i >>= liftEff <<< flip J.append box
--   scroll <- liftEff $ J.create "

" >>= J.addClass "scroll"
--   liftEff $ J.append box scroll
--   return scroll

-- showHistoryRow :: Output -> Int -> EvalM J.JQuery
-- showHistoryRow out i = do
--   row <- liftEff $ J.create "

" >>= J.addClass "history"
--   tdExpr <- liftEff $ J.create "	"
--   liftEff $ exprToJQuery out >>= flip J.append tdExpr
--   liftEff $ J.append tdExpr row
--   es <- get :: EvalM EvalState
--   let deleteHandler = \_ _ -> do
--                         let es' = es { history = maybe es.history id (deleteAt i es.history) }
--                         void $ runStateT showEvaluationState es'
--   delete <- liftEff $ J.create "<button></button>"
--     >>= J.setText "Delete"
--     >>= J.addClass "delete"
--     >>= J.on "click" deleteHandler
--   tdDelete <- liftEff $ J.create "	"
--   liftEff $ J.append delete tdDelete
--   liftEff $ J.append tdDelete row
--   let restoreHandler = \_ _ -> do
--                          let es' = es { history = drop (i + 1) es.history, out = maybe es.out id (es.history !! i) }
--                          void $ runStateT showEvaluationState es'
--   restore <- liftEff $ J.create "<button></button>"
--     >>= J.setText "Restore"
--     >>= J.addClass "restore"
--     >>= J.on "click" restoreHandler
--   tdRestore <- liftEff $ J.create "	"
--   liftEff $ J.append restore tdRestore
--   liftEff $ J.append tdRestore row
--   return row

-- showInfo :: String -> String -> DOMEff Unit
-- showInfo origin msg = do
--   info <- J.create "

"
--     >>= J.addClass "info"
--     >>= J.setText ("Error in " ++ origin ++ " => " ++ msg)
--   clearInfo
--   J.select "#info"
--     >>= J.append info
--   return unit

-- clearInfo :: DOMEff Unit
-- clearInfo = void $ J.select "#info" >>= J.clear

-- prepareContainer :: String -> DOMEff J.JQuery
-- prepareContainer name = do
--   J.select ("#" ++ name ++ "-container") >>= J.clear

-- wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
-- wrapInDiv name jq = do
--   J.create "

" >>= J.addClass name >>= J.append jq

-- makeClickable :: J.JQuery -> EvalM Unit
-- makeClickable jq = do
--   { env = env, out = out } <- get
--   let expr = out.expr
--   let typeTree = out.typ
--   liftEff $ jqMap (testEval env expr typeTree) jq
--   where
--   testEval :: Env -> Expr -> TypeTree -> J.JQuery -> DOMEff Unit
--   testEval env expr typeTree jq = do
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> return unit
--       Just path ->
--         case evalPath1 env path expr of
--           Left err -> displayEvalError err jq
--           Right _  -> if checkForError path typeTree
--             then return unit
--             else void $ J.addClass "clickable" jq

-- displayEvalError :: EvalError -> J.JQuery -> DOMEff Unit
-- displayEvalError err jq = case err of
--   DivByZero -> void $ makeDiv "Division by zero!" (singleton "evalError") >>= flip prepend jq
--   NoMatchingFunction _ errs -> if (any missesArguments errs)
--     then return unit
--     else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip prepend jq
--   _         -> return unit
--   where
--     missesArguments (TooFewArguments _ _) = true
--     missesArguments (StrictnessError _ _) = true
--     missesArguments _                     = false

-- addMouseOverListener :: J.JQuery -> EvalM J.JQuery
-- addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
--   where
--   handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
--   handler jEvent jq = do
--     J.stopPropagation jEvent
--     removeMouseOver
--     J.addClass "mouseOver" jq
--     return unit

-- addClickListener :: TypeTree ->  J.JQuery -> EvalM J.JQuery
-- addClickListener typeTree jq = do
--   evaluationState <- get
--   liftEff $ J.on "click" (handler evaluationState) jq
--   where
--   handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
--   handler evaluationState jEvent jq = do
--     J.stopImmediatePropagation jEvent
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> return unit
--       Just path -> do
--         return unit
--         if checkForError path typeTree
--           then return unit
--           else case ctrlKeyPressed jEvent of
--                 false -> void $ runStateT (evalExpr evalPath1 path) evaluationState
--                 true  -> void $ runStateT (evalExpr evalPathAll path) evaluationState

-- removeMouseOver :: DOMEff Unit
-- removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

-- evalExpr :: (Env -> Path -> Expr -> Either EvalError Expr) -> Path -> EvalM Unit
-- evalExpr eval path = do
--   { env = env, out = out, typEnv = typEnv} <- get
--   let expr = out.expr
--   liftEff $ print path
--   case eval env path expr of
--     Left msg    -> return unit
--     Right expr' -> do
--         let eitherTyp = typeTreeProgramnEnv typEnv expr'
--         let typ'' = either (\_ -> buildPartiallyTypedTree typEnv expr') id eitherTyp
--         let typ' = txToABC typ''
--         modify (\es -> es { out = {expr:expr', typ:typ', idTree:idExpr expr'} })
--         modify (\es -> es { history = out : es.history })
--         showEvaluationState

-- getValue :: J.JQuery -> DOMEff String
-- getValue jq = unsafeFromForeign <$> J.getValue jq


Add location.

Add location.

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)

import Network.HTTP.Affjax (AJAX, get)

foreign import test :: Int

type WeekDay = String

main :: forall e. Eff ( ajax :: AJAX
                      , console :: CONSOLE
                      , dom :: DOM
                      , err :: EXCEPTION
                      , locale :: LOCALE
                      , now :: NOW
                      , ref :: REF
                      , storage :: STORAGE
                      | e ) Unit
main = ready $ do
  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body

  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey

  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  stateRef <- newRef $ AppState { isLoading: true
                                , visibleCards: Map.empty
                                , selectedCities
                                , spinner
                                , cardTemplate
                                , container
                                , addDialog }

  case storedSelectedCities of
    Just cities ->
      foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
    Nothing -> do
      -- The user is using the app for the first time, or the user has not
      -- saved any cities, so show the user some fake data. A real app in this
      -- scenario could guess the user's location via IP lookup and then inject
      -- that data into the page.
      updateForecastCard stateRef initialWeatherForecast
      saveSelectedCities stateRef

-- Methods to update/refresh the UI --

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData =
  let dataLastUpdated = toDateTime <$> parse cardData.created  -- Maybe DT.DateTime
      key = cardData.key
      current = cardData.channel.item.condition
      forcast = cardData.channel.item.forecast
  in do
    card <- getOrCreateCard stateRef key
    find "> .location" card >>= setText cardData.label
    find "> .description" card >>= setText current.text
    find "> .date" card >>= setText current.date
    find ".current .icon" card >>= setClass (getIconClass current.code) true
    find ".current .temperature .value" card >>= (setText $ show current.temp)
    find ".current .sunrise" card >>= setText cardData.channel.astronomy.sunrise
    find ".current .sunset" card >>= setText cardData.channel.astronomy.sunset
    find ".current .humidity" card >>= (setText $ show cardData.channel.atmosphere.humidity <> "%")
    find ".current .wind .value" card >>= (setText $ show cardData.channel.wind.speed)
    find ".current .wind .direction" card >>= (setText $ show cardData.channel.wind.direction)

    nextDays <- find ".future .oneday" card >>= toArray
    ndw <- nextDaysOfWeek
    foreachE (zip3 nextDays forcast ndw) updateNextDay

    AppState state <- readRef stateRef
    when state.isLoading do
      hide state.spinner
      modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t =
  let c = get1 t
      daily = get2 t
      wd = get3 t
  in do
    find ".icon" c >>= setClass (getIconClass daily.code) true
    find ".date" c >>= setText wd
    find ".temp-high .value" c >>= (setText $ show daily.high)
    find ".temp-low .value" c >>= (setText $ show daily.low)

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)

import Network.HTTP.Affjax (AJAX, get)

foreign import test :: Int

type WeekDay = String

main :: forall e. Eff ( ajax :: AJAX
                      , console :: CONSOLE
                      , dom :: DOM
                      , err :: EXCEPTION
                      , locale :: LOCALE
                      , now :: NOW
                      , ref :: REF
                      , storage :: STORAGE
                      | e ) Unit
main = ready $ do
  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body

  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey

  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  stateRef <- newRef $ AppState { isLoading: true
                                , visibleCards: Map.empty
                                , selectedCities
                                , spinner
                                , cardTemplate
                                , container
                                , addDialog }

  case storedSelectedCities of
    Just cities ->
      foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
    Nothing -> do
      -- The user is using the app for the first time, or the user has not
      -- saved any cities, so show the user some fake data. A real app in this
      -- scenario could guess the user's location via IP lookup and then inject
      -- that data into the page.
      updateForecastCard stateRef initialWeatherForecast
      saveSelectedCities stateRef

-- Methods to update/refresh the UI --

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData =
  let dataLastUpdated = toDateTime <$> parse cardData.created  -- Maybe DT.DateTime
      key = cardData.key
      current = cardData.channel.item.condition
      forcast = cardData.channel.item.forecast
  in do
    card <- getOrCreateCard stateRef key
    find "> .description" card >>= setText current.text
    find "> .date" card >>= setText current.date
    find ".current .icon" card >>= setClass (getIconClass current.code) true
    find ".current .temperature .value" card >>= (setText $ show current.temp)
    find ".current .sunrise" card >>= setText cardData.channel.astronomy.sunrise
    find ".current .sunset" card >>= setText cardData.channel.astronomy.sunset
    find ".current .humidity" card >>= (setText $ show cardData.channel.atmosphere.humidity <> "%")
    find ".current .wind .value" card >>= (setText $ show cardData.channel.wind.speed)
    find ".current .wind .direction" card >>= (setText $ show cardData.channel.wind.direction)

    nextDays <- find ".future .oneday" card >>= toArray
    ndw <- nextDaysOfWeek
    foreachE (zip3 nextDays forcast ndw) updateNextDay

    AppState state <- readRef stateRef
    when state.isLoading do
      hide state.spinner
      modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t =
  let c = get1 t
      daily = get2 t
      wd = get3 t
  in do
    find ".icon" c >>= setClass (getIconClass daily.code) true
    find ".date" c >>= setText wd
    find ".temp-high .value" c >>= (setText $ show daily.high)
    find ".temp-low .value" c >>= (setText $ show daily.low)

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }


Render DisplayCell content

Render DisplayCell content

module Cells.View where

import Prelude (map, show, (<<<))

import Types (AppState, Action(..), Cell(..), CellType(..), _cells, _notebook)
import Pux.Html (Html, ul, text, li, textarea)
import Pux.Html.Events (onInput)
import Pux.Html.Attributes (defaultValue, id_)
import Data.Lens as L

renderCell :: Cell -> Html Action
renderCell (Cell c@{ cellType : TextCell}) = renderTextCell (Cell c)
renderCell (Cell c@{ cellType : CodeCell}) = renderCodeCell (Cell c)
renderCell (Cell c@{ cellType : DisplayCell}) = renderDisplayCell (Cell c)

renderTextCell :: Cell -> Html Action
renderTextCell (Cell c) =
    li
        []
        [ textarea
            [ id_ (show c.cellId)
            , onInput (CheckInput c.cellId)
            , defaultValue c.cellContent
            ]
            []
        ]

renderCodeCell :: Cell -> Html Action
renderCodeCell (Cell c) =
    li
        []
        [ textarea
            [ onInput (CheckInput c.cellId)
            , id_ (show c.cellId)
            , defaultValue c.cellContent
            ]
            []
        ]

renderDisplayCell :: Cell -> Html Action
renderDisplayCell (Cell c) =
    li [] [ text c.cellContent ]

renderCells :: AppState -> Array (Html Action)
renderCells = map renderCell <<< L.view (_notebook <<< _cells)

view :: AppState -> Html Action
view appState = ul [] (renderCells appState)

module Cells.View where

import Prelude (map, show, (<<<))

import Types (AppState, Action(..), Cell(..), CellType(..), _cells, _notebook)
import Pux.Html (Html, ul, text, li, textarea)
import Pux.Html.Events (onInput)
import Pux.Html.Attributes (defaultValue, id_)
import Data.Lens as L

renderCell :: Cell -> Html Action
renderCell (Cell c@{ cellType : TextCell}) = renderTextCell (Cell c)
renderCell (Cell c@{ cellType : CodeCell}) = renderCodeCell (Cell c)
renderCell (Cell c@{ cellType : DisplayCell}) = renderDisplayCell (Cell c)

renderTextCell :: Cell -> Html Action
renderTextCell (Cell c) =
    li
        []
        [ textarea
            [ id_ (show c.cellId)
            , onInput (CheckInput c.cellId)
            , defaultValue c.cellContent
            ]
            []
        ]

renderCodeCell :: Cell -> Html Action
renderCodeCell (Cell c) =
    li
        []
        [ textarea
            [ onInput (CheckInput c.cellId)
            , id_ (show c.cellId)
            , defaultValue c.cellContent
            ]
            []
        ]

renderDisplayCell :: Cell -> Html Action
renderDisplayCell (Cell c) =
    li [] [ text "" ]

renderCells :: AppState -> Array (Html Action)
renderCells = map renderCell <<< L.view (_notebook <<< _cells)

view :: AppState -> Html Action
view appState = ul [] (renderCells appState)


add bounded and boundedInt perturbers

add bounded and boundedInt perturbers

module Test.StrongCheck.Perturb
  ( Attempts(..)
  , Perturb
  , Perturber(..)
  , bounded
  , boundedInt
  , perturb
  , perturber2
  , perturber3
  , perturber4
  , perturber5
  , perturber6
  , perturber7
  , perturber8
  , perturber9
  , perturber10
  , dist
  , dims
  , searchIn'
  , searchIn
  ) where

  import Test.StrongCheck.Gen
  import Test.StrongCheck

  import Data.Traversable
  import Data.Foldable
  import Data.Char
  import Data.Tuple
  import Data.Monoid
  import Data.Either
  import Data.Maybe
  import Data.Maybe.Unsafe
  import Data.Monoid.Sum
  import Data.Enum
  import qualified Data.String as S
  import qualified Data.Array as A

  import Math

  import Data.Function

  newtype Attempts = Attempts Number

  newtype Perturber a = Perturber {
    perturb :: Number -> a -> Gen a,
    dist    :: a -> a -> Number,
    dims    :: a -> Number }

  -- | The class for things which can be perturbed.
  -- |
  -- | Laws:
  -- |   forall a, 0 >= n <= 1:
  -- |   ((>=) n) <<< dist a <$> (perturb n a) must be an infinite generator of `true` values.
  class Perturb a where
    perturb :: Number -> a -> Gen a

    dist :: a -> a -> Number

    dims :: a -> Number

  -- | Given one example, searches for other examples that satisfy a provided
  -- | boolean predicate.
  -- |
  -- | The search operates out-to-in, in an attempt to find examples that are
  -- | as far removed from the provided example as possible. The sampling size
  -- | parameter determines how many samples to take at every level of
  -- | searching, while the attempts parameter determines how many levels.
  searchIn' :: forall a. (Perturb a) => Attempts -> Number -> (a -> Boolean) -> a -> Gen a
  searchIn' (Attempts k) n f a = search0 k 1
    where search0 k d = ifThenElse (k <= 0) mempty
                        (do a' <- find f <$> (takeGen 1 $ chunked n (perturb d a))
                            fromMaybe mempty (pure <$> a') <> search0 (k - 1) (d / 2))

  -- | The same as search', but uses defaults for attempt count and sample size.
  -- | Will search a total of 10,000 examples before giving up.
  searchIn :: forall a. (Perturb a) => (a -> Boolean) -> a -> Gen a
  searchIn = searchIn' (Attempts 1000) 10

  -- | Creates a perturber for numbers that fall within the specified range.
  bounded :: Number -> Number -> Perturber Number
  bounded a b =
    let l = min a b
        u = max a b

        length = u - l

        clamp n = max l (min u n)

        perturb' d v = do dx <- arbitrary
                          return <<< clamp $ dx * length * d + v

        dist' a b = abs (a - b)

        dims' = const 1

    in  Perturber { perturb : perturb', dist : dist', dims : dims' }

  -- | Creates a perturber for integers that fall within the specified range.
  boundedInt :: Number -> Number -> Perturber Number
  boundedInt a b =
    let l = floor $ min a b
        u = ceil $ max a b

        length = u - l

        clamp n = max l (min u n)

        perturb' d v = do dx <- arbitrary
                          return <<< clamp <<< round $ dx * length * d + v

        dist' a b = abs (a - b)

        dims' = const 1

    in  Perturber { perturb : perturb', dist : dist', dims : dims' }

  perturber2 :: forall a b. (Perturb a, Perturb b) => Perturber (Tuple a b)
  perturber2 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a b) = let dx = delta 2 d in Tuple <$> perturb dx a <*> perturb dx b
          dist' (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]
          dims' (Tuple a b) = (dims a) * (dims b)

  perturber3 :: forall a b c. (Perturb a, Perturb b, Perturb c) => Perturber (Tuple a (Tuple b c))
  perturber3 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a (Tuple b c)) =
            let dx = delta 3 d
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> perturb dx c)

          dist' (Tuple a1 (Tuple b1 c1)) (Tuple a2 (Tuple b2 c2)) = toDist [dist a1 a2, dist b1 b2, dist c1 c2]

          dims' (Tuple a (Tuple b c)) = (dims a) * (dims b) * (dims c)

  perturber4 :: forall a b c d. (Perturb a, Perturb b, Perturb c, Perturb d) => Perturber (Tuple a (Tuple b (Tuple c d)))
  perturber4 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c d))) =
            let dx = delta 4 d0
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> (Tuple <$> perturb dx c <*> perturb dx d))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 d1)))
                (Tuple a2 (Tuple b2 (Tuple c2 d2))) = toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2]

          dims' (Tuple a (Tuple b (Tuple c d))) = (dims a) * (dims b) * (dims c) * (dims d)

  perturber5 :: forall a b c d e. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d e))))
  perturber5 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            let dx = delta 5 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*> perturb dx e)))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 e1))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 e2)))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e)

  perturber6 :: forall a b c d e f. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f)))))
  perturber6 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            let dx = delta 6 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*> perturb dx f))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 f1)))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 f2))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f)

  perturber7 :: forall a b c d e f g. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g))))))
  perturber7 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            let dx = delta 7 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*> perturb dx g)))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 g1))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 g2)))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g)

  perturber8 :: forall a b c d e f g h. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h)))))))
  perturber8 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            let dx = delta 8 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*> perturb dx h))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 h1)))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 h2))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2, dist h1 h2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h)

  perturber9 :: forall a b c d e f g h i. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i))))))))
  perturber9 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            let dx = delta 9 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*> perturb dx i)))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 i1))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 i2)))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i)

  perturber10 :: forall a b c d e f g h i j. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i, Perturb j) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j)))))))))
  perturber10 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            let dx = delta 10 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*>
                (Tuple <$> perturb dx i <*> perturb dx j))))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 (Tuple i1 j1)))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 (Tuple i2 j2))))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2, dist j1 j2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i) * (dims j)

  instance perturbArbEnum :: (Enum a) => Perturb (ArbEnum a) where
    perturb n e = cardPerturb1 (cardPerturb1F e n)

    dist a b = cardDist1 f a b where
      f (Cardinality sz) a b = if runArbEnum a == runArbEnum b then 0 else 1 / (2 * sz)

    dims e = enumDims f e where
      f (Cardinality sz) e = if sz <= 0 then 0 else 1

  instance perturbNumber :: Perturb Number where
    perturb 0 n = pure n
    perturb d n = do
      u <- uniform -- 'up to' d
      s <- runSignum <$> arbitrary
      return $ s * (Math.exp(k0 * (u * d)) - 1) + n

    dist a b =
      let from y = Math.log(y + 1) / k0
      in  (Math.min 1) <<< Math.abs <<< from $ Math.abs (a - b)

    dims = const 1

  instance perturbArray :: (Perturb a) => Perturb [a] where
    perturb d []  = pure $ []
    perturb 0 a   = sequence $ perturb 0 <$> a
    perturb d a   = let dx = delta (A.length a) d
                    in  sequence $ perturb dx <$> a

    dist a b = toDist $ A.zipWith dist a b

    dims = A.length

  instance perturbTuple :: (Perturb a, Perturb b) => Perturb (Tuple a b) where
    perturb d (Tuple a b) = let dx = delta 2 d
                            in  Tuple <$> (perturb dx a) <*> (perturb dx b)

    dist (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]

    dims (Tuple a b) = dims a + dims b

  instance perturbChar :: Perturb Char where
    perturb n e = if n < 1 / (2 * 65536) then pure e else arbitrary

    dist a b = if a == b then 0 else 1 / (2 * 65536)

    dims = const 1

  instance perturbBoolean :: Perturb Boolean where
    perturb n e = runArbEnum <$> perturb n (ArbEnum e)

    dist a b = dist (ArbEnum a) (ArbEnum b)

    dims = const 1

  instance perturbString :: Perturb String where
    perturb d s = S.fromCharArray <$> perturb d (S.toCharArray s)

    dist s1 s2 = dist (S.toCharArray s1) (S.toCharArray s2)

    dims = dims <<< S.toCharArray

  -- magical constants
  maxNumber :: Number
  maxNumber = 9007199254740992

  -- math
  k0 :: Number
  k0 = Math.log(maxNumber + 1)

  square :: Number -> Number
  square = flip Math.pow 2

  toDist :: [Number] -> Number
  toDist xs = Math.sqrt (sum $ square <$> xs)

  delta :: Number -> Number -> Number
  delta n d = Math.sqrt (d * d / n)

  -- FIXME: this workaround is still required as of psc 0.5.6.3
  ifThenElse p a b = if p then a else b

  -- ScopedTypeVariables
  enumDims :: forall a. (Enum a) => (Cardinality a -> a -> Number) -> a -> Number
  enumDims f = f cardinality

  -- ScopedTypeVariables
  cardPerturb1 :: forall f a. (Enum a) => (Cardinality a -> f a) -> f a
  cardPerturb1 f = f cardinality

  -- ScopedTypeVariables
  cardDist1 :: forall a. (Enum a) => (Cardinality a -> a -> a -> Number) -> a -> a -> Number
  cardDist1 f = f cardinality

  -- workaround to avoid:
  -- Attempted to unify a constrained type (Test.StrongCheck.Arbitrary u15286) =>
  -- Test.StrongCheck.Gen.Gen<u15286> with another type.
  cardPerturb1F :: forall a. (Enum a) => a -> Number -> Cardinality a -> Gen a
  cardPerturb1F a n (Cardinality sz) = if n < 1 / (2 * sz) then pure a else (runArbEnum <$> arbitrary)

module Test.StrongCheck.Perturb
  ( Attempts(..)
  , Perturb
  , Perturber(..)
  , perturb
  , perterber2
  , perterber3
  , perterber4
  , perterber5
  , perterber6
  , perterber7
  , perterber8
  , perterber9
  , perterber10
  , dist
  , dims
  , searchIn'
  , searchIn
  ) where

  import Test.StrongCheck.Gen
  import Test.StrongCheck

  import Data.Traversable
  import Data.Foldable
  import Data.Char
  import Data.Tuple
  import Data.Monoid
  import Data.Either
  import Data.Maybe
  import Data.Maybe.Unsafe
  import Data.Monoid.Sum
  import Data.Enum
  import qualified Data.String as S
  import qualified Data.Array as A

  import Math

  import Data.Function

  newtype Attempts = Attempts Number

  newtype Perturber a = Perturber {
    perturb :: Number -> a -> Gen a,
    dist    :: a -> a -> Number,
    dims    :: a -> Number }

  -- | The class for things which can be perturbed.
  -- |
  -- | Laws:
  -- |   forall a, 0 >= n <= 1:
  -- |   ((>=) n) <<< dist a <$> (perturb n a) must be an infinite generator of `true` values.
  class Perturb a where
    perturb :: Number -> a -> Gen a

    dist :: a -> a -> Number

    dims :: a -> Number

  -- | Given one example, searches for other examples that satisfy a provided
  -- | boolean predicate.
  -- |
  -- | The search operates out-to-in, in an attempt to find examples that are
  -- | as far removed from the provided example as possible. The sampling size
  -- | parameter determines how many samples to take at every level of
  -- | searching, while the attempts parameter determines how many levels.
  searchIn' :: forall a. (Perturb a) => Attempts -> Number -> (a -> Boolean) -> a -> Gen a
  searchIn' (Attempts k) n f a = search0 k 1
    where search0 k d = ifThenElse (k <= 0) mempty
                        (do a' <- find f <$> (takeGen 1 $ chunked n (perturb d a))
                            fromMaybe mempty (pure <$> a') <> search0 (k - 1) (d / 2))

  -- | The same as search', but uses defaults for attempt count and sample size.
  -- | Will search a total of 10,000 examples before giving up.
  searchIn :: forall a. (Perturb a) => (a -> Boolean) -> a -> Gen a
  searchIn = searchIn' (Attempts 1000) 10

  perterber2 :: forall a b. (Perturb a, Perturb b) => Perturber (Tuple a b)
  perterber2 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a b) = let dx = delta 2 d in Tuple <$> perturb dx a <*> perturb dx b
          dist' (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]
          dims' (Tuple a b) = (dims a) * (dims b)

  perterber3 :: forall a b c. (Perturb a, Perturb b, Perturb c) => Perturber (Tuple a (Tuple b c))
  perterber3 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a (Tuple b c)) =
            let dx = delta 3 d
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> perturb dx c)

          dist' (Tuple a1 (Tuple b1 c1)) (Tuple a2 (Tuple b2 c2)) = toDist [dist a1 a2, dist b1 b2, dist c1 c2]

          dims' (Tuple a (Tuple b c)) = (dims a) * (dims b) * (dims c)

  perterber4 :: forall a b c d. (Perturb a, Perturb b, Perturb c, Perturb d) => Perturber (Tuple a (Tuple b (Tuple c d)))
  perterber4 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c d))) =
            let dx = delta 4 d0
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> (Tuple <$> perturb dx c <*> perturb dx d))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 d1)))
                (Tuple a2 (Tuple b2 (Tuple c2 d2))) = toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2]

          dims' (Tuple a (Tuple b (Tuple c d))) = (dims a) * (dims b) * (dims c) * (dims d)

  perterber5 :: forall a b c d e. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d e))))
  perterber5 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            let dx = delta 5 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*> perturb dx e)))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 e1))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 e2)))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e)

  perterber6 :: forall a b c d e f. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f)))))
  perterber6 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            let dx = delta 6 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*> perturb dx f))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 f1)))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 f2))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f)

  perterber7 :: forall a b c d e f g. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g))))))
  perterber7 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            let dx = delta 7 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*> perturb dx g)))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 g1))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 g2)))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g)

  perterber8 :: forall a b c d e f g h. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h)))))))
  perterber8 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            let dx = delta 8 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*> perturb dx h))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 h1)))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 h2))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2, dist h1 h2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h)

  perterber9 :: forall a b c d e f g h i. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i))))))))
  perterber9 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            let dx = delta 9 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*> perturb dx i)))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 i1))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 i2)))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i)

  perterber10 :: forall a b c d e f g h i j. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i, Perturb j) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j)))))))))
  perterber10 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            let dx = delta 10 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*>
                (Tuple <$> perturb dx i <*> perturb dx j))))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 (Tuple i1 j1)))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 (Tuple i2 j2))))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2, dist j1 j2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i) * (dims j)

  instance perturbArbEnum :: (Enum a) => Perturb (ArbEnum a) where
    perturb n e = cardPerturb1 (cardPerturb1F e n)

    dist a b = cardDist1 f a b where
      f (Cardinality sz) a b = if runArbEnum a == runArbEnum b then 0 else 1 / (2 * sz)

    dims e = enumDims f e where
      f (Cardinality sz) e = if sz <= 0 then 0 else 1

  instance perturbNumber :: Perturb Number where
    perturb 0 n = pure n
    perturb d n = do
      u <- uniform -- 'up to' d
      s <- runSignum <$> arbitrary
      return $ s * (Math.exp(k0 * (u * d)) - 1) + n

    dist a b =
      let from y = Math.log(y + 1) / k0
      in  (Math.min 1) <<< Math.abs <<< from $ Math.abs (a - b)

    dims = const 1

  instance perturbArray :: (Perturb a) => Perturb [a] where
    perturb d []  = pure $ []
    perturb 0 a   = sequence $ perturb 0 <$> a
    perturb d a   = let dx = delta (A.length a) d
                    in  sequence $ perturb dx <$> a

    dist a b = toDist $ A.zipWith dist a b

    dims = A.length

  instance perturbTuple :: (Perturb a, Perturb b) => Perturb (Tuple a b) where
    perturb d (Tuple a b) = let dx = delta 2 d
                            in  Tuple <$> (perturb dx a) <*> (perturb dx b)

    dist (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]

    dims (Tuple a b) = dims a + dims b

  instance perturbChar :: Perturb Char where
    perturb n e = if n < 1 / (2 * 65536) then pure e else arbitrary

    dist a b = if a == b then 0 else 1 / (2 * 65536)

    dims = const 1

  instance perturbBoolean :: Perturb Boolean where
    perturb n e = runArbEnum <$> perturb n (ArbEnum e)

    dist a b = dist (ArbEnum a) (ArbEnum b)

    dims = const 1

  instance perturbString :: Perturb String where
    perturb d s = S.fromCharArray <$> perturb d (S.toCharArray s)

    dist s1 s2 = dist (S.toCharArray s1) (S.toCharArray s2)

    dims = dims <<< S.toCharArray

  -- magical constants
  maxNumber :: Number
  maxNumber = 9007199254740992

  -- math
  k0 :: Number
  k0 = Math.log(maxNumber + 1)

  square :: Number -> Number
  square = flip Math.pow 2

  toDist :: [Number] -> Number
  toDist xs = Math.sqrt (sum $ square <$> xs)

  delta :: Number -> Number -> Number
  delta n d = Math.sqrt (d * d / n)

  -- FIXME: this workaround is still required as of psc 0.5.6.3
  ifThenElse p a b = if p then a else b

  -- ScopedTypeVariables
  enumDims :: forall a. (Enum a) => (Cardinality a -> a -> Number) -> a -> Number
  enumDims f = f cardinality

  -- ScopedTypeVariables
  cardPerturb1 :: forall f a. (Enum a) => (Cardinality a -> f a) -> f a
  cardPerturb1 f = f cardinality

  -- ScopedTypeVariables
  cardDist1 :: forall a. (Enum a) => (Cardinality a -> a -> a -> Number) -> a -> a -> Number
  cardDist1 f = f cardinality

  -- workaround to avoid:
  -- Attempted to unify a constrained type (Test.StrongCheck.Arbitrary u15286) =>
  -- Test.StrongCheck.Gen.Gen<u15286> with another type.
  cardPerturb1F :: forall a. (Enum a) => a -> Number -> Cardinality a -> Gen a
  cardPerturb1F a n (Cardinality sz) = if n < 1 / (2 * sz) then pure a else (runArbEnum <$> arbitrary)


Make any variable a valid selection in the open card

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Open.Eval
  ( evalOpen
  ) where

import SlamData.Prelude

import Control.Monad.Writer.Class (class MonadTell)
import Data.Functor.Mu (Mu)
import Data.Json.Extended as EJ
import Data.Lens ((^?), (?~), (.~))
import Data.List as L
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Matryoshka as M
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Open.Model as Open
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port.VarMap as VM
import SqlSquared as Sql
import Utils.SqlSquared (all)

evalOpen
  ∷ ∀ m
  . MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ QuasarDSL m
  ⇒ Open.Model
  → Port.DataMap
  → m Port.Out
evalOpen model varMap = case model of
  Nothing → CE.throwOpenError CE.OpenNoResourceSelected
  Just (Open.Resource res) → do
    filePath ← maybe (CE.throwOpenError CE.OpenNoFileSelected) pure $ res ^? R._filePath
    checkPath filePath >>= case _ of
      Nothing → do
        CEM.addSource filePath
        pure (Port.resourceOut (Port.Path filePath))
      Just err → CE.throwOpenError err
  Just (Open.Variable (VM.Var var)) → do
    res ← CEM.temporaryOutputResource
    let
      sql =
        case SM.lookup var varMap of
          Just (Right v) → do
            -- If the var is an ident, use `SELECT * FROM :ident`
            -- If the var is an literal, use `SELECT :literal AS varName`
            -- If the var is any other expr, use it directly
            case unwrapParens (unwrap v) of
              Sql.Ident _ →
                Sql.buildSelect
                  $ all
                  ∘ (Sql._relations ?~ Sql.VariRelation { vari: var, alias: Nothing })
              Sql.Literal _ →
                Sql.buildSelect
                  $ Sql._projections .~ pure (Sql.projection (unwrap v) # Sql.as var)
              Sql.SetLiteral _ →
                Sql.buildSelect
                  $ Sql._projections .~ pure (Sql.projection (unwrap v) # Sql.as var)
              _ →
                unwrap v
          _ →
            -- This case should be impossible - if we selected a var in the
            -- card, the var should exist during eval
            Sql.set L.Nil
      varMap' =
        map (Sql.print ∘ unwrap) $ Port.flattenResources varMap
      backendPath =
        fromMaybe Path.rootDir $ Path.parentDir res
    CE.liftQ $ QQ.viewQuery res sql varMap'
    pure $ Port.resourceOut $ Port.View res (Sql.print sql) varMap

  where
  unwrapParens ∷ Sql.Sql → Sql.SqlF EJ.EJsonF (Mu (Sql.SqlF EJ.EJsonF))
  unwrapParens expr =
    case M.project expr of
      Sql.Parens expr' → unwrapParens expr'
      expr' → expr'

  checkPath filePath =
    CE.liftQ $ QFS.messageIfFileNotFound filePath $ CE.OpenFileNotFound (Path.printPath filePath)

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Open.Eval
  ( evalOpen
  ) where

import SlamData.Prelude

import Control.Monad.Writer.Class (class MonadTell)
import Data.Lens ((^?), (?~))
import Data.Path.Pathy as Path
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Open.Model as Open
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port.VarMap as VM
import SqlSquared as Sql
import Utils.SqlSquared (all)

evalOpen
  ∷ ∀ m
  . MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ QuasarDSL m
  ⇒ Open.Model
  → Port.DataMap
  → m Port.Out
evalOpen model varMap = case model of
  Nothing → CE.throwOpenError CE.OpenNoResourceSelected
  Just (Open.Resource res) → do
    filePath ← maybe (CE.throwOpenError CE.OpenNoFileSelected) pure $ res ^? R._filePath
    checkPath filePath >>= case _ of
      Nothing → do
        CEM.addSource filePath
        pure (Port.resourceOut (Port.Path filePath))
      Just err → CE.throwOpenError err
  Just (Open.Variable (VM.Var var)) → do
    res ← CEM.temporaryOutputResource
    let
      sql =
        Sql.buildSelect
          $ all
          ∘ (Sql._relations ?~ Sql.VariRelation { vari: var, alias: Nothing })
      varMap' =
        map (Sql.print ∘ unwrap) $ Port.flattenResources varMap
      backendPath =
        fromMaybe Path.rootDir $ Path.parentDir res

    CE.liftQ $ QQ.viewQuery res sql varMap'
    pure $ Port.resourceOut $ Port.View res (Sql.print sql) varMap

  where
  checkPath filePath =
    CE.liftQ $ QFS.messageIfFileNotFound filePath $ CE.OpenFileNotFound (Path.printPath filePath)


add Request.Helper.P

add Request.Helper.P

module Request.Helper.P
  ( P
  , p
  , ps
  ) where

import Data.Show (class Show)
import Data.Traversable (class Traversable, intercalate)
import Prelude ((<>), (<$>), ($), show)

data P = P String String

instance showP :: Show P where
  show (P k v) = show k <> ": " <> v

p :: forall a. (Show a) => String -> a -> P
p k v = P k $ show v

ps :: forall t. (Traversable t) => t P -> String
ps a = "{ " <> (intercalate ", " $ show <$> a) <> " }"

error: pathspec 'src/Request/Helper/P.purs' did not match any file(s) known to git


break out Attr code prior to reimplement

module TaglessD3.Attr where

import Prelude
import TaglessD3.Base (SVGPathString)
import D3.Base (DomElement, Peers)
import Color (Color)
import DOM.Event.Types (Event)

data Callback d b =   Lambda1 (d ->                                  b)
                    | Lambda2 (d -> Number ->                        b)
                    | Lambda4 (d -> Number -> Peers -> DomElement -> b)

data ValueOrCallback d b =  V b
                          | F (Callback d b)

instance showValueOrCallback :: (Show b) => Show (ValueOrCallback d b) where
  show (V b) = " " <> show b
  show (F _) = " Callback"

-- ideally all of this attribute guff would be tagless as well

-- there are a _lot_ of combinations hidden here by JavaScript's typeless nature (and coercions!)
-- attr Int
-- attr Number
-- attr String
-- attr Char
-- attr (d -> Int)
-- attr (d -> Number)
-- attr (d -> String)
-- attr (d -> Char)
data Attr d  = CX                  (ValueOrCallback d Number)  -- circles only
             | CY                  (ValueOrCallback d Number)  -- circles only
             | R                   (ValueOrCallback d Number)  -- circles only
             | X                   (ValueOrCallback d Number)
             | Y                   (ValueOrCallback d Number)
             | DX                  (ValueOrCallback d String) -- string because it might have units with
             | DY                  (ValueOrCallback d String)
             | Height              (ValueOrCallback d Number)
             | Width               (ValueOrCallback d Number)
             | StrokeWidth         (ValueOrCallback d Number)
             | StrokeOpacity       (ValueOrCallback d Number)
             | FillOpacity         (ValueOrCallback d Number)
             | Opacity             (ValueOrCallback d Number)
             | D                   (ValueOrCallback d SVGPathString)
             | Id                  (ValueOrCallback d String)
             | StrokeLineCap       (ValueOrCallback d String) -- Round | Butt | Square
             | PatternUnits        (ValueOrCallback d String) -- userSpaceOnUse | objectBoundingBox
             | Style        String (ValueOrCallback d String)
             | Class               (ValueOrCallback d String)
             | Text                (ValueOrCallback d String)
             | Type                (ValueOrCallback d String) -- images only
             | Fill                (ValueOrCallback d Color)
             | Stroke              (ValueOrCallback d Color)
             | Transform    String  -- would be nice to build this up from ADT too
             | EventHandlerS Event (Callback d String) -- click | mouseenter | mouseleave | mouseover
             | EventHandlerN Event (Callback d Number)

renderArrayOfAttributes :: ∀ d. Array (Attr d) -> String
renderArrayOfAttributes attrs = "[" <> show attrs <> "]"

-- 1) in keeping with D3 practice this is a mish-mash of HTML and SVG attributes,
-- which very probably should be rationalized better and perhaps taken from more
-- comprehensive libraries in Purescript which track the standards in question.
-- however, for now, it's useful simplification and gives us one single place to
-- put them all

-- 2) another idea entirely would be to investigate if the syntax here can be
-- made tagless too, in this way the 'vcb' could render differently in different
-- contexts too which is kind of what you'd expect / want

-- 3) another thought is that we really don't want a show instance here, what we
-- really want is to get back:
-- attrname | (attrname, value) | (attrname, callback)
instance showAttr :: Show (Attr d) where
    show (CX vcb)            = "cx" <> show vcb
    show (CY vcb)            = "cy" <> show vcb
    show (R vcb)             = "r" <> show vcb
    show (X vcb)             = "x" <> show vcb
    show (Y vcb)             = "y" <> show vcb
    show (DX vcb)            = "dx" <> show vcb
    show (DY vcb)            = "dy" <> show vcb
    show (Height vcb)        = "height" <> show vcb
    show (Width vcb)         = "width" <> show vcb
    show (StrokeWidth vcb)   = "strokewidth" <> show vcb
    show (StrokeOpacity vcb) = "strokeopacity" <> show vcb
    show (FillOpacity vcb)   = "fillopacity" <> show vcb
    show (Opacity vcb)       = "opacity" <> show vcb
    show (D vcb)             = "d" <> show vcb
    show (Id vcb)            = "id" <> show vcb
    show (StrokeLineCap vcb) = "strokelinecap" <> show vcb
    show (PatternUnits vcb)  = "patternunits"  <> show vcb
    show (Style s vcb)       = "style" <> s <> ": " <> show vcb
    show (Class vcb)         = "class" <> show vcb
    show (Text vcb)          = "text" <> show vcb
    show (Type vcb)          = "type" <> show vcb
    show (Fill vcb)          = "fill" <> show vcb
    show (Stroke vcb)        = "stroke" <> show vcb
    show (Transform s)       = "transform" <> s
    show (EventHandlerS _ _) = "EventHandlerS: "
    show (EventHandlerN _ _) = "EventHandlerN: "

error: pathspec 'src/TaglessD3/Attr.purs' did not match any file(s) known to git


Add unsafe choice

Add unsafe choice

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/hdgarrood/purescript-random.git/'