Add scanl test

Add scanl test

module Test.TypeChecker where

import AST
import TypeChecker
import Parser

import Prelude hiding (apply,compose)
import Data.Either
import Data.List
import Data.Tuple
import Data.Map as Map
import Data.Maybe
import Data.Foldable

import Text.Parsing.Parser

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Control.Monad.Except.Trans
import Control.Monad.State

testInfer:: forall a  eff. String -> a -> (TypeEnv -> a -> Infer (Tuple Subst Type))
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testInfer name input f expected
  = test name  expected $ runInfer $ f emptyTyenv input

testProgramm:: forall eff. String -> List Definition -> Expr
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testProgramm name defs exp expected
 = test name expected $ typeProgramn defs exp

-- test  name -> expected -> actuall -> Eff ...
test:: forall eff. String -> Either TypeError Scheme -> Either TypeError Scheme
 -> Eff (console :: CONSOLE | eff ) Unit
test name expected actuall = if eqTypErrScheme expected actuall
  then log $ "Typing success ("  ++ name ++ ")"
  else log $ "\n \n Typing fail (" ++ name ++ ") :  expected result: \n"
    ++ show expected ++ "\n actuall result: \n" ++ show actuall ++ "\n \n"
     ++ "Pretty Print expected: \n" ++ prettyPrint expected
      ++ "\n Pretty Print actuall: \n" ++ prettyPrint actuall ++ "\n \n"

eqTypErrScheme:: Either TypeError Scheme -> Either TypeError Scheme -> Boolean
eqTypErrScheme (Left a) (Left a') = (a == a')
eqTypErrScheme (Right a) (Right a') = eqScheme a a'
eqTypErrScheme _ _ = false

eqScheme :: Scheme -> Scheme -> Boolean
eqScheme (Forall l1 t1) (Forall l2 t2)
  = ((length l1) == (length l2)) && (fst (eqType Map.empty t1 t2))

eqType:: Map.Map TVar TVar -> Type -> Type ->Tuple Boolean (Map.Map TVar TVar)
eqType map (TypVar a) (TypVar b) = case  Map.lookup a map of
  (Just b') -> Tuple (b' == b) (map)
  Nothing -> Tuple true (Map.insert a b map)
eqType map (TypCon a) (TypCon b) = Tuple (a == b) map
eqType map (TypArr a b) (TypArr a' b') = Tuple (fst tup1 && fst tup2) (snd tup2)
  where
  tup1 = eqType map a a'
  tup2 = eqType (snd tup1) b b'
eqType map (AD (TList a)) (AD (TList b)) = eqType map a b
eqType map (AD (TTuple a)) (AD (TTuple b)) = eqTypeList map a b
eqType map _ _ = Tuple false map

eqTypeList:: Map.Map TVar TVar -> List Type -> List Type -> Tuple Boolean (Map.Map TVar TVar)
eqTypeList map (Cons a as) (Cons b bs) = let tup1 = eqType map a b in if (fst tup1)
  then eqTypeList (snd tup1) as bs
  else Tuple false (snd tup1)
eqTypeList map Nil Nil = Tuple true map
eqTypeList map _ _ = Tuple false map

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

tvar :: String -> Type
tvar s = TypVar $ TVar s

out::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
out s = log s

parseExp:: String -> Either ParseError Expr
parseExp exp = runParser exp expression

parseDef:: String -> Either ParseError Definition
parseDef def = runParser def definition

typeStr:: String -> Either TypeError Scheme
typeStr expS = case runParser expS expression of
  Right exp -> runInfer $ inferType emptyTyenv exp
  Left _ -> Left $ UnknownError "Parse Error"

typeStrPre:: String -> Either TypeError Scheme
typeStrPre expS = case runParser expS expression of
  Right exp -> typeProgramn Test.Parser.parsedPrelude exp
  Left _ -> Left $ UnknownError "Parse Error"

typeExp:: Expr -> Either TypeError Scheme
typeExp exp = runInfer $ inferType emptyTyenv exp

typeDef:: Definition -> Either TypeError Scheme
typeDef def = runInfer $ inferDef emptyTyenv def

prettyPrint:: Either TypeError Scheme -> String
prettyPrint a@(Left _) = show a
prettyPrint (Right (Forall _ t)) = prettyPrintType t

printTypeExp::forall eff. Expr -> Eff (console :: CONSOLE | eff ) Unit
printTypeExp e = out $ prettyPrint $ typeExp e

printTypeStr::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
printTypeStr s = out $ prettyPrint $ typeStr s

-- default 1
d1 = Right (Forall Nil $ tvar "a")

runTests :: forall eff. Eff (console :: CONSOLE | eff) Unit
runTests = do
  log "Running Typing Tests"

  testInfer "SectL" (SectL (aint 3) Power)
    inferType(Right (Forall Nil $ TypArr (TypCon "Int") (TypCon "Int")))
  testInfer "SectR" (SectR Power (aint 3))
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (TypCon "Int"))))
  testInfer "Lambda1" (Lambda (toList $ [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c",Lit $ Name "d"]) (App (aname "a") (toList [aname "b", aname "c", aname "d"])))
    inferType(Right (Forall (toList [TVar "b",TVar "c", TVar "d", TVar "e"]) (TypArr (TypArr (tvar "b") (TypArr (tvar "c") (TypArr (tvar "d") (tvar "e")))) (TypArr ( tvar "b")  ((TypArr (tvar "c") (TypArr (tvar "d") (tvar "e"))))))))
  testInfer "Lambda2" (Lambda (toList [Lit $ Name "a", Lit $ Name "b"]) (App (aname "a") (toList [aname "b"])))
    inferType(Right (Forall (Cons ((TVar "t_3")) (Cons ((TVar "t_4")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_4"))) (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_4"))))))
  testInfer "List1" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5])) inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List2" (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List3" (List $ toList [PrefixOp Add, aint 4])
    inferType(Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInfer "Nil List" (List Nil)
    inferType  (Right (Forall (Cons ((TVar "t_0")) (Nil)) (AD (TList (TypVar  (TVar "t_0"))))))
  testInfer "Append" (Binary Append
    (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    (List Nil))
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "Colon" (Binary Colon (aint 3) (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4),Atom $ Char "Hallo"]))
    inferType(Left ((UnificationFail (TypCon "Char") (TypCon "Int"))))
  testInfer "NTuple" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
    inferType(Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInfer "SectR Colon" (SectR Colon $ List $ toList [aint 3])
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInfer "Def ~map" (Def "map" (toList [Lit $ Name "f", Lit $ Name "xs"]) (App (aname "map") (toList [aname "f",aname"xs"])))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_4")) (Cons ((TVar "t_5")) (Nil)))) (TypArr (TypVar  (TVar "t_2")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_5"))))))
  testInfer "Lambda Wildcard" (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aint 5))
    inferType(Right (Forall (Cons ((TVar "t_1")) (Cons ((TVar "t_3")) (Nil))) (TypArr (TypVar  (TVar "t_1")) (TypArr (TypVar  (TVar "t_3")) (TypCon "Int")))))
  testInfer "Lambda ConsBinding" (Lambda (toList [ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (aname "x"))
    inferType(Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "singel map" (Def "map" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App  (PrefixOp Colon) (toList [App (aname "f") $ toList [(aname"x")], App (aname "map") (toList [aname"f", aname"xs"])])))
    inferDef (Right (Forall (Cons ((TVar "t_11")) (Cons ((TVar "t_5")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_5")) (TypVar  (TVar "t_11"))) (TypArr (AD (TList (TypVar  (TVar "t_5")))) (AD (TList (TypVar  (TVar "t_11"))))))))
  testInfer "foldr" (Def "foldr" (toList [Lit $ Name "f", Lit $ Name "ini", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App (aname "f") (toList [aname "x",App (aname "foldr") (toList [aname "f", aname "ini" ,aname "xs"  ] )])))
    inferDef (Right (Forall (Cons ((TVar "t_5")) (Cons ((TVar "t_4")) (Cons ((TVar "t_7")) Nil))) (TypArr (TypArr (TypVar  (TVar "t_7")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_4")))) (TypArr (TypVar  (TVar "t_5")) (TypArr (AD (TList (TypVar  (TVar "t_7")))) (TypVar  (TVar "t_4")))))))
  testInfer "let Expr"  (LetExpr (Lit $ Name "x") (aint 3) (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aname "x")))
    inferType(Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_4")) (Nil))) (TypArr (TypVar  (TVar "t_2")) (TypArr (TypVar  (TVar "t_4")) (TypCon "Int")))))
  testInfer "ConsLit Binding 1" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "x"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "ConsLit Binding 2" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xs"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "ConsLit Binding 3" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xss"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (AD (TList (TypVar  (TVar "t_2")))))))
  testInfer "Binding Tuple 1" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "a"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_3")) (Nil))) (TypArr (AD (TTuple $ Cons ((TypVar  (TVar "t_2"))) (Cons ((TypVar  (TVar "t_3"))) (Nil)))) (TypVar  (TVar "t_2")))))
  testInfer "Binding Tuple 2" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "b"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_3")) (Nil))) (TypArr (AD (TTuple (Cons ((TypVar  (TVar "t_2"))) (Cons ((TypVar  (TVar "t_3"))) (Nil))))) (TypVar  (TVar "t_3")))))
  testInfer "Binding Tuple 3" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Right (Forall (Cons ((TVar "t_3")) (Cons ((TVar "t_4")) (Cons ((TVar "t_5")) (Nil)))) (TypArr (AD (TTuple (Cons ((TypArr (TypVar  (TVar "t_3")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_5"))))) (Cons ((TypVar  (TVar "t_3"))) (Cons ((TypVar  (TVar "t_4"))) (Nil)))))) (TypVar  (TVar "t_5")))))
  testInfer "ListLit Binding" (Def "list" (toList [ListLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Left ((InfiniteType (TVar "t_4") (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_7"))))))
  testInfer "NTupleLit Binding LetExp"  (LetExpr (NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])) (NTuple (toList [(Lambda (toList [Lit $ Name "f"]) (aname "f")), (Atom $ Char "Hello")])) (App (aname "a") (toList [aname "b"])))
    inferType (Right (Forall (Nil) (TypCon "Char")))
  testInfer "Lambda App" (App (Lambda (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))) (Cons (PrefixOp Add) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))
    inferType (Right (Forall (Nil) (TypCon "Int")))

  testInfer "zipWith - Group" (toList [Def "zipWith" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs"), ConsLit (Lit $ Name "y") (Lit $ Name "ys")])
      (App (PrefixOp Colon) (toList [App (aname "f") (toList [aname "x",aname "y"]), App (aname "zipWith") (toList [aname "f",aname"xs",aname "ys"])])),
      Def "zipWith" (toList [Lit $ Name "_",ListLit Nil,Lit $ Name "_"]) (List Nil),
      Def "zipWith" (toList [Lit $ Name "_",Lit $ Name "_",ListLit Nil]) (List Nil)])
    inferGroup (Right (Forall (Cons ((TVar "t_23")) (Cons ((TVar "t_33")) (Cons ((TVar "t_34")) (Nil)))) (TypArr (TypArr (TypVar  (TVar "t_23")) (TypArr (TypVar  (TVar "t_33")) (TypVar  (TVar "t_34")))) (TypArr (AD (TList (TypVar  (TVar "t_23")))) (TypArr (AD (TList (TypVar  (TVar "t_33")))) (AD (TList (TypVar  (TVar "t_34")))))))))

  testInfer "real foldr - Group" (toList [(Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
      (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil)))))])
    inferGroup ((Right (Forall ((Cons ((TVar "t_4")) (Cons ((TVar "t_7")) Nil))) (TypArr (TypArr (TypVar  (TVar "t_7")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_4")))) (TypArr (TypVar  (TVar "t_4")) (TypArr (AD (TList (TypVar  (TVar "t_7")))) (TypVar  (TVar "t_4"))))))))

  testInfer "scanl - Group" (toList [Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil))),
                                     Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))])
          inferGroup (Right (Forall (Cons ((TVar "t_39")) (Cons ((TVar "t_48")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_48")) (TypArr (TypVar  (TVar "t_39")) (TypVar  (TVar "t_48")))) (TypArr (TypVar  (TVar "t_48")) (TypArr (AD (TList (TypVar  (TVar "t_39")))) (AD (TList (TypVar  (TVar "t_48")))))))))

  testProgramm "Prelude with exp" Test.Parser.parsedPrelude
    ((App (Atom (Name "sum")) (Cons (App (Atom (Name "map")) (Cons (SectR Power (Atom (AInt 2))) (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))) (Nil)))) (Nil))))
    (Right (Forall (Nil) (TypCon "Int")))

module Test.TypeChecker where

import AST
import TypeChecker
import Parser

import Prelude hiding (apply,compose)
import Data.Either
import Data.List
import Data.Tuple
import Data.Map as Map
import Data.Maybe
import Data.Foldable

import Text.Parsing.Parser

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Control.Monad.Except.Trans
import Control.Monad.State

testInfer:: forall a  eff. String -> a -> (TypeEnv -> a -> Infer (Tuple Subst Type))
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testInfer name input f expected
  = test name  expected $ runInfer $ f emptyTyenv input

testProgramm:: forall eff. String -> List Definition -> Expr
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testProgramm name defs exp expected
 = test name expected $ typeProgramn defs exp

-- test  name -> expected -> actuall -> Eff ...
test:: forall eff. String -> Either TypeError Scheme -> Either TypeError Scheme
 -> Eff (console :: CONSOLE | eff ) Unit
test name expected actuall = if eqTypErrScheme expected actuall
  then log $ "Typing success ("  ++ name ++ ")"
  else log $ "\n \n Typing fail (" ++ name ++ ") :  expected result: \n"
    ++ show expected ++ "\n actuall result: \n" ++ show actuall ++ "\n \n"
     ++ "Pretty Print expected: \n" ++ prettyPrint expected
      ++ "\n Pretty Print actuall: \n" ++ prettyPrint actuall ++ "\n \n"

eqTypErrScheme:: Either TypeError Scheme -> Either TypeError Scheme -> Boolean
eqTypErrScheme (Left a) (Left a') = (a == a')
eqTypErrScheme (Right a) (Right a') = eqScheme a a'
eqTypErrScheme _ _ = false

eqScheme :: Scheme -> Scheme -> Boolean
eqScheme (Forall l1 t1) (Forall l2 t2)
  = ((length l1) == (length l2)) && (fst (eqType Map.empty t1 t2))

eqType:: Map.Map TVar TVar -> Type -> Type ->Tuple Boolean (Map.Map TVar TVar)
eqType map (TypVar a) (TypVar b) = case  Map.lookup a map of
  (Just b') -> Tuple (b' == b) (map)
  Nothing -> Tuple true (Map.insert a b map)
eqType map (TypCon a) (TypCon b) = Tuple (a == b) map
eqType map (TypArr a b) (TypArr a' b') = Tuple (fst tup1 && fst tup2) (snd tup2)
  where
  tup1 = eqType map a a'
  tup2 = eqType (snd tup1) b b'
eqType map (AD (TList a)) (AD (TList b)) = eqType map a b
eqType map (AD (TTuple a)) (AD (TTuple b)) = eqTypeList map a b
eqType map _ _ = Tuple false map

eqTypeList:: Map.Map TVar TVar -> List Type -> List Type -> Tuple Boolean (Map.Map TVar TVar)
eqTypeList map (Cons a as) (Cons b bs) = let tup1 = eqType map a b in if (fst tup1)
  then eqTypeList (snd tup1) as bs
  else Tuple false (snd tup1)
eqTypeList map Nil Nil = Tuple true map
eqTypeList map _ _ = Tuple false map

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

tvar :: String -> Type
tvar s = TypVar $ TVar s

out::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
out s = log s

parseExp:: String -> Either ParseError Expr
parseExp exp = runParser exp expression

parseDef:: String -> Either ParseError Definition
parseDef def = runParser def definition

typeStr:: String -> Either TypeError Scheme
typeStr expS = case runParser expS expression of
  Right exp -> runInfer $ inferType emptyTyenv exp
  Left _ -> Left $ UnknownError "Parse Error"

typeStrPre:: String -> Either TypeError Scheme
typeStrPre expS = case runParser expS expression of
  Right exp -> typeProgramn Test.Parser.parsedPrelude exp
  Left _ -> Left $ UnknownError "Parse Error"

typeExp:: Expr -> Either TypeError Scheme
typeExp exp = runInfer $ inferType emptyTyenv exp

typeDef:: Definition -> Either TypeError Scheme
typeDef def = runInfer $ inferDef emptyTyenv def

prettyPrint:: Either TypeError Scheme -> String
prettyPrint a@(Left _) = show a
prettyPrint (Right (Forall _ t)) = prettyPrintType t

printTypeExp::forall eff. Expr -> Eff (console :: CONSOLE | eff ) Unit
printTypeExp e = out $ prettyPrint $ typeExp e

printTypeStr::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
printTypeStr s = out $ prettyPrint $ typeStr s

-- default 1
d1 = Right (Forall Nil $ tvar "a")

runTests :: forall eff. Eff (console :: CONSOLE | eff) Unit
runTests = do
  log "Running Typing Tests"

  testInfer "SectL" (SectL (aint 3) Power)
    inferType(Right (Forall Nil $ TypArr (TypCon "Int") (TypCon "Int")))
  testInfer "SectR" (SectR Power (aint 3))
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (TypCon "Int"))))
  testInfer "Lambda1" (Lambda (toList $ [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c",Lit $ Name "d"]) (App (aname "a") (toList [aname "b", aname "c", aname "d"])))
    inferType(Right (Forall (toList [TVar "b",TVar "c", TVar "d", TVar "e"]) (TypArr (TypArr (tvar "b") (TypArr (tvar "c") (TypArr (tvar "d") (tvar "e")))) (TypArr ( tvar "b")  ((TypArr (tvar "c") (TypArr (tvar "d") (tvar "e"))))))))
  testInfer "Lambda2" (Lambda (toList [Lit $ Name "a", Lit $ Name "b"]) (App (aname "a") (toList [aname "b"])))
    inferType(Right (Forall (Cons ((TVar "t_3")) (Cons ((TVar "t_4")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_4"))) (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_4"))))))
  testInfer "List1" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5])) inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List2" (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List3" (List $ toList [PrefixOp Add, aint 4])
    inferType(Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInfer "Nil List" (List Nil)
    inferType  (Right (Forall (Cons ((TVar "t_0")) (Nil)) (AD (TList (TypVar  (TVar "t_0"))))))
  testInfer "Append" (Binary Append
    (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    (List Nil))
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "Colon" (Binary Colon (aint 3) (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4),Atom $ Char "Hallo"]))
    inferType(Left ((UnificationFail (TypCon "Char") (TypCon "Int"))))
  testInfer "NTuple" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
    inferType(Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInfer "SectR Colon" (SectR Colon $ List $ toList [aint 3])
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInfer "Def ~map" (Def "map" (toList [Lit $ Name "f", Lit $ Name "xs"]) (App (aname "map") (toList [aname "f",aname"xs"])))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_4")) (Cons ((TVar "t_5")) (Nil)))) (TypArr (TypVar  (TVar "t_2")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_5"))))))
  testInfer "Lambda Wildcard" (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aint 5))
    inferType(Right (Forall (Cons ((TVar "t_1")) (Cons ((TVar "t_3")) (Nil))) (TypArr (TypVar  (TVar "t_1")) (TypArr (TypVar  (TVar "t_3")) (TypCon "Int")))))
  testInfer "Lambda ConsBinding" (Lambda (toList [ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (aname "x"))
    inferType(Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "singel map" (Def "map" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App  (PrefixOp Colon) (toList [App (aname "f") $ toList [(aname"x")], App (aname "map") (toList [aname"f", aname"xs"])])))
    inferDef (Right (Forall (Cons ((TVar "t_11")) (Cons ((TVar "t_5")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_5")) (TypVar  (TVar "t_11"))) (TypArr (AD (TList (TypVar  (TVar "t_5")))) (AD (TList (TypVar  (TVar "t_11"))))))))
  testInfer "foldr" (Def "foldr" (toList [Lit $ Name "f", Lit $ Name "ini", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App (aname "f") (toList [aname "x",App (aname "foldr") (toList [aname "f", aname "ini" ,aname "xs"  ] )])))
    inferDef (Right (Forall (Cons ((TVar "t_5")) (Cons ((TVar "t_4")) (Cons ((TVar "t_7")) Nil))) (TypArr (TypArr (TypVar  (TVar "t_7")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_4")))) (TypArr (TypVar  (TVar "t_5")) (TypArr (AD (TList (TypVar  (TVar "t_7")))) (TypVar  (TVar "t_4")))))))
  testInfer "let Expr"  (LetExpr (Lit $ Name "x") (aint 3) (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aname "x")))
    inferType(Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_4")) (Nil))) (TypArr (TypVar  (TVar "t_2")) (TypArr (TypVar  (TVar "t_4")) (TypCon "Int")))))
  testInfer "ConsLit Binding 1" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "x"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "ConsLit Binding 2" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xs"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "ConsLit Binding 3" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xss"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (AD (TList (TypVar  (TVar "t_2")))))))
  testInfer "Binding Tuple 1" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "a"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_3")) (Nil))) (TypArr (AD (TTuple $ Cons ((TypVar  (TVar "t_2"))) (Cons ((TypVar  (TVar "t_3"))) (Nil)))) (TypVar  (TVar "t_2")))))
  testInfer "Binding Tuple 2" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "b"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_3")) (Nil))) (TypArr (AD (TTuple (Cons ((TypVar  (TVar "t_2"))) (Cons ((TypVar  (TVar "t_3"))) (Nil))))) (TypVar  (TVar "t_3")))))
  testInfer "Binding Tuple 3" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Right (Forall (Cons ((TVar "t_3")) (Cons ((TVar "t_4")) (Cons ((TVar "t_5")) (Nil)))) (TypArr (AD (TTuple (Cons ((TypArr (TypVar  (TVar "t_3")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_5"))))) (Cons ((TypVar  (TVar "t_3"))) (Cons ((TypVar  (TVar "t_4"))) (Nil)))))) (TypVar  (TVar "t_5")))))
  testInfer "ListLit Binding" (Def "list" (toList [ListLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Left ((InfiniteType (TVar "t_4") (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_7"))))))
  testInfer "NTupleLit Binding LetExp"  (LetExpr (NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])) (NTuple (toList [(Lambda (toList [Lit $ Name "f"]) (aname "f")), (Atom $ Char "Hello")])) (App (aname "a") (toList [aname "b"])))
    inferType (Right (Forall (Nil) (TypCon "Char")))
  testInfer "Lambda App" (App (Lambda (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))) (Cons (PrefixOp Add) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))
    inferType (Right (Forall (Nil) (TypCon "Int")))

  testInfer "zipWith - Group" (toList [Def "zipWith" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs"), ConsLit (Lit $ Name "y") (Lit $ Name "ys")])
      (App (PrefixOp Colon) (toList [App (aname "f") (toList [aname "x",aname "y"]), App (aname "zipWith") (toList [aname "f",aname"xs",aname "ys"])])),
      Def "zipWith" (toList [Lit $ Name "_",ListLit Nil,Lit $ Name "_"]) (List Nil),
      Def "zipWith" (toList [Lit $ Name "_",Lit $ Name "_",ListLit Nil]) (List Nil)])
    inferGroup (Right (Forall (Cons ((TVar "t_23")) (Cons ((TVar "t_33")) (Cons ((TVar "t_34")) (Nil)))) (TypArr (TypArr (TypVar  (TVar "t_23")) (TypArr (TypVar  (TVar "t_33")) (TypVar  (TVar "t_34")))) (TypArr (AD (TList (TypVar  (TVar "t_23")))) (TypArr (AD (TList (TypVar  (TVar "t_33")))) (AD (TList (TypVar  (TVar "t_34")))))))))

  testInfer "real foldr - Group" (toList [(Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
      (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil)))))])
    inferGroup ((Right (Forall ((Cons ((TVar "t_4")) (Cons ((TVar "t_7")) Nil))) (TypArr (TypArr (TypVar  (TVar "t_7")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_4")))) (TypArr (TypVar  (TVar "t_4")) (TypArr (AD (TList (TypVar  (TVar "t_7")))) (TypVar  (TVar "t_4"))))))))

  testProgramm "Prelude with exp" Test.Parser.parsedPrelude
    ((App (Atom (Name "sum")) (Cons (App (Atom (Name "map")) (Cons (SectR Power (Atom (AInt 2))) (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))) (Nil)))) (Nil))))
    (Right (Forall (Nil) (TypCon "Int")))


Fix let test for set write to a unique path

module Test.WritingSpec (writingSpec) where

import Prelude (Unit, bind, ($), class Show)

import Control.Monad.Aff (Aff(), launchAff)
import Control.Monad.Aff.AVar (AVAR(), AVar, makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Data.Maybe (Maybe(Nothing))
import Data.Either (Either(Right))
import Web.Firebase as FB
import Web.Firebase.Monad.Aff (onceValue)
import Web.Firebase.UnsafeRef (refFor)
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types as FBT
import Test.Spec                  (describe, pending, it, Spec())
import Test.Spec.Runner           (Process())
import Test.Spec.Assertions       (shouldEqual, shouldNotEqual)
import PlayWithFire (Success(Success), snapshot2success)
import Data.Foreign as F

entriesRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
entriesRef = refFor "https://purescript-spike.firebaseio.com/entries"

setRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
setRef = refFor "https://purescript-spike.firebaseio.com/entries/wecanset/arbitrary/paths"

writingSpec ::  forall eff. Spec ( avar :: AVAR, firebase :: FBT.FirebaseEff, err :: EXCEPTION | eff) Unit
writingSpec = do
  describe "Writing" do
      it "can add an item to a list" do
        location <- entriesRef
        newChildRef <- liftEff $ FB.push (F.toForeign $ {success: "random numbered string"}) Nothing location
        snap <- onceValue newChildRef
        (D.key snap) `shouldNotEqual` Nothing
        -- key is different on every write. Checking unique keys is work for QuickCheck
        (snapshot2success snap) `shouldEqual` (Right (Success {success: "random numbered string"}))
        -- use key to read value

      it "can overwrite an existing item" do
        let secondValue = {success: "second value"}
        location <- entriesRef
        newChildRef <- liftEff $ FB.push (F.toForeign $ {success: "initial value"}) Nothing location
        _ <- liftEff $ FB.set (F.toForeign $ secondValue) Nothing newChildRef
        snap <- onceValue newChildRef
        (snapshot2success snap) `shouldEqual` (Right (Success secondValue))
      it "pushE calls back with Nothing when no error occurs" do
          location <- entriesRef
          respVar  <- makeVar
          handle  <- liftEff $ FB.pushE (F.toForeign {some: "object"}) (\Nothing -> launchAff $ putVar respVar Nothing) location
          actual :: Maybe FBT.FirebaseErr <- takeVar respVar
          actual `shouldEqual` Nothing
      it "setE calls back with Nothing when no error occurs" do
          location <- setRef
          respVar  <- makeVar
          handle  <- liftEff $ FB.setE (F.toForeign {some: "object"}) (\Nothing -> launchAff $ putVar respVar Nothing) location
          actual :: Maybe FBT.FirebaseErr <- takeVar respVar
          actual `shouldEqual` Nothing

      pending "can overwrite an existing item in Aff"
      pending "can add a server-side timestamp to new items"
      pending "push Aff when writing to non-existant location returns an error"
      pending "Removal confirmed by subscription on()" -- baby steps
      pending "Removal not notified after subscription turned off()" -- test with timeout? how?
      -- implement AFF with error callback (it is error object or nothing, so we can make it 'or Right "write successful", which we can reuse in a value writeSuccess so we can assert against that. Not sure how to combine that with the value of the key that is also returned from the js function'

module Test.WritingSpec (writingSpec) where

import Prelude (Unit, bind, ($), class Show)

import Control.Monad.Aff (Aff(), launchAff)
import Control.Monad.Aff.AVar (AVAR(), AVar, makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Data.Maybe (Maybe(Nothing))
import Data.Either (Either(Right))
import Web.Firebase as FB
import Web.Firebase.Monad.Aff (onceValue)
import Web.Firebase.UnsafeRef (refFor)
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types as FBT
import Test.Spec                  (describe, pending, it, Spec())
import Test.Spec.Runner           (Process())
import Test.Spec.Assertions       (shouldEqual, shouldNotEqual)
import PlayWithFire (Success(Success), snapshot2success)
import Data.Foreign as F

entriesRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
entriesRef = refFor "https://purescript-spike.firebaseio.com/entries"

writingSpec ::  forall eff. Spec ( avar :: AVAR, firebase :: FBT.FirebaseEff, err :: EXCEPTION | eff) Unit
writingSpec = do
  describe "Writing" do
      it "can add an item to a list" do
        location <- entriesRef
        newChildRef <- liftEff $ FB.push (F.toForeign $ {success: "random numbered string"}) Nothing location
        snap <- onceValue newChildRef
        (D.key snap) `shouldNotEqual` Nothing
        -- key is different on every write. Checking unique keys is work for QuickCheck
        (snapshot2success snap) `shouldEqual` (Right (Success {success: "random numbered string"}))
        -- use key to read value

      it "can overwrite an existing item" do
        let secondValue = {success: "second value"}
        location <- entriesRef
        newChildRef <- liftEff $ FB.push (F.toForeign $ {success: "initial value"}) Nothing location
        _ <- liftEff $ FB.set (F.toForeign $ secondValue) Nothing newChildRef
        snap <- onceValue newChildRef
        (snapshot2success snap) `shouldEqual` (Right (Success secondValue))
      it "pushE calls back with Nothing when no error occurs" do
          location <- entriesRef
          respVar  <- makeVar
          handle  <- liftEff $ FB.pushE (F.toForeign {some: "object"}) (\Nothing -> launchAff $ putVar respVar Nothing) location
          actual :: Maybe FBT.FirebaseErr <- takeVar respVar
          actual `shouldEqual` Nothing
      it "setE calls back with Nothing when no error occurs" do
          location <- entriesRef
          respVar  <- makeVar
          handle  <- liftEff $ FB.setE (F.toForeign {some: "object"}) (\Nothing -> launchAff $ putVar respVar Nothing) location
          actual :: Maybe FBT.FirebaseErr <- takeVar respVar
          actual `shouldEqual` Nothing

      pending "can overwrite an existing item in Aff"
      pending "can add a server-side timestamp to new items"
      pending "push Aff when writing to non-existant location returns an error"
      pending "Removal confirmed by subscription on()" -- baby steps
      pending "Removal not notified after subscription turned off()" -- test with timeout? how?
      -- implement AFF with error callback (it is error object or nothing, so we can make it 'or Right "write successful", which we can reuse in a value writeSuccess so we can assert against that. Not sure how to combine that with the value of the key that is also returned from the js function'


Add Resource port

Add Resource port

{-
Copyright 2015 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 Notebook.Cell.Port
  ( Port(..)
  , _SlamDown
  , _VarMap
  , _Resource
  ) where

import Data.Lens (PrismP(), prism')
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap())

import Model.Resource as R

import Text.Markdown.SlamDown (SlamDown())
import Text.Markdown.SlamDown.Html (FormFieldValue())

data Port
  = SlamDown SlamDown
  | VarMap (StrMap FormFieldValue)
  | Resource R.Resource

_SlamDown :: PrismP Port SlamDown
_SlamDown = prism' SlamDown \p -> case p of
  SlamDown x -> Just x
  _ -> Nothing

_VarMap :: PrismP Port (StrMap FormFieldValue)
_VarMap = prism' VarMap \p -> case p of
  VarMap x -> Just x
  _ -> Nothing

_Resource :: PrismP Port R.Resource
_Resource = prism' Resource \p -> case p of
  Resource r -> Just r
  _ -> Nothing

{-
Copyright 2015 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 Notebook.Cell.Port
  ( Port(..)
  , _SlamDown
  , _VarMap
  ) where

import Data.Lens (PrismP(), prism')
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap())

import Text.Markdown.SlamDown (SlamDown())
import Text.Markdown.SlamDown.Html (FormFieldValue())

data Port
  = SlamDown SlamDown
  | VarMap (StrMap FormFieldValue)

_SlamDown :: PrismP Port SlamDown
_SlamDown = prism' SlamDown \p -> case p of
  SlamDown x -> Just x
  _ -> Nothing

_VarMap :: PrismP Port (StrMap FormFieldValue)
_VarMap = prism' VarMap \p -> case p of
  VarMap x -> Just x
  _ -> Nothing


Functions for rendering tracks as multiple points per drawing

module Genetics.Browser.Track.Backend where
       -- ( demoBrowser
       -- , demoLegend
       -- , getDataDemo
       -- ) where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alternative (class Alternative, alt, empty)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Array as Array
import Data.Filterable (partition)
import Data.Foldable (class Foldable, fold, foldMap, foldl, foldr, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', Traversal', Traversal, over, to, traverseOf, traversed, view, viewOn, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Star (Star(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (unfoldr)
import Data.Variant (Variant, case_, inj, on, onMatch)
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), _BrowserIntervals, _Index, _Interval, intervalToScreen, intervalsOverlap, intervalsToMap, lookupInterval)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type BrowserView = Interval BrowserPoint

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

type ChrCtx r = Map ChrId (Record r)

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

type GenomePosV = Variant ( point :: Bp
                          , range :: Interval Bp )

type FeatureR r = ( position :: GenomePosV
                  , frameSize :: Bp
                  | r )
type Feature r = Record (FeatureR r)

type DrawingR  = ( point :: Drawing
                 , range :: Pixels -> Drawing )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Interval (Normalized Number) )
type HPos = Variant HorPlaceR

type Renderer a = { draw     :: a -> DrawingV
                  , horPlace :: a -> HPos
                  , verPlace :: a -> Normalized Number
                  }

type ReadyGlyph = { drawing :: DrawingV
                  , horPos  :: HPos
                  , verPos  :: Normalized Number
                  }

horPlace :: forall r.
            Feature r
         -> HPos
horPlace {position, frameSize} =
  let f p = Normalized (unwrap $ p / frameSize)
  in case_
    # onMatch
      { point: inj _point <<< f
      , range: inj _range <<< (map f)
      }
    $ position

verPlace :: forall r.
            (Getter' (Feature r) (Normalized Number))
         -> Feature r
         -> Normalized Number
verPlace = view

render :: forall err a.
          Renderer a
       -> a
       -> ReadyGlyph
render render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

type CanvasSingleGlyph = { drawing :: Drawing, point :: Point }
type CanvasBatchGlyph  = { drawing :: Drawing, points :: Array Point }

type BatchedTrack = Array CanvasBatchGlyph

type CanvasReadyDrawing = Drawing

type BrowserTrack = Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> CanvasReadyDrawing

-- Given a frame-normalized drawing, finalize it so it can be rendered to a canvas;
-- `width` is the width in pixels of the frame the drawing resides in.
resizeDrawing :: forall r.
                 { width :: Pixels | r }
              -> DrawingV
              -> Drawing
resizeDrawing {width} = case_
  # onMatch
     { point: (\x -> x)
     , range: (_ $ width) }

renderGlyphs :: forall f r a.
                Canvas.Dimensions
             -> { width :: Pixels, offset :: Pixels }
             -> Array ReadyGlyph
             -> Array CanvasSingleGlyph
renderGlyphs {height} {width, offset} gs = map drawIt gs
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in { drawing: d, point: { x: (x + offset), y } }

batchGlyphs :: Array CanvasSingleGlyph
            -> Array CanvasBatchGlyph
batchGlyphs = unfoldr f
  where f gs = Array.uncons gs >>= \ {head, tail} ->
                 let { no, yes } = partition (\ {drawing} -> head.drawing == drawing) tail
                     points = Array.cons head.point $ map _.point yes
                 in pure $ Tuple { drawing: head.drawing, points } no

drawIntervalFeature :: forall f r a.
                       Foldable f
                    => Canvas.Dimensions
                    -> { width :: Pixels, offset :: Pixels }
                    -> f ReadyGlyph
                    -> CanvasReadyDrawing
drawIntervalFeature {height} {width, offset} = foldMap drawIt
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in translate (x + offset) y d

-- | Returns the left-hand-edge offset, and width, in pixels,
-- | of each interval (chromosome) in the provided coordinate system
viewportIntervals :: forall i a r.
                     Ord i
                  => CoordSys i BrowserPoint
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Map i { width :: Pixels, offset :: Pixels }
viewportIntervals cs cdim bView =
  intervalToScreen cdim bView <$> (view _Interval <$> intervalsToMap cs)

pureTrack :: forall f i a.
             Ord i
          => Foldable f
          => CoordSys i BrowserPoint
          -> Map i (f ReadyGlyph)
          -> BrowserTrack
pureTrack cs drawings cd v =
  fold $ zipMapsWith (drawIntervalFeature cd) (viewportIntervals cs cd v) drawings

pureBatchTrack :: forall f i a.
                  Ord i
               => CoordSys i BrowserPoint
               -> Map i (Array ReadyGlyph)
               -> Canvas.Dimensions
               -> Interval BrowserPoint
               -> Map i (Array CanvasBatchGlyph)
pureBatchTrack cs glyphs cd v =
  zipMapsWith (\v gs -> batchGlyphs $ renderGlyphs cd v gs) (viewportIntervals cs cd v) glyphs

renderBatchTrack ::  forall f i a.
                     Ord i
                  => Foldable f
                  => Traversable f
                  => CoordSys i BrowserPoint
                  -> Renderer a
                  -> Map i (f a)
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Array CanvasBatchGlyph
renderBatchTrack cs r trackData =
  let data' = map Array.fromFoldable trackData
      glyphs = (map <<< map) (render r) data'
  in \cd v -> fold $ pureBatchTrack cs glyphs cd v

renderTrack :: forall f i a.
               Ord i
            => Foldable f
            => Traversable f
            => CoordSys i BrowserPoint
            -> Renderer a
            -> Map i (f a)
            -> BrowserTrack
renderTrack cs r trackData =
  let validDrawings :: Map i (f ReadyGlyph)
      validDrawings = Debug.trace ("Creating ReadyGlyphs for some track")
                      \_ -> (map <<< map) (render r) trackData
  in pureTrack cs validDrawings

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> BrowserTrack
horRulerTrack {min, max, sig} color f _ = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        y = f.height - (normY * f.height)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

chrLabelTrack :: CoordSys ChrId BrowserPoint
              -> BrowserTrack
chrLabelTrack cs = pureTrack cs (Map.fromFoldable results)
  where mkLabel :: ChrId -> ReadyGlyph
        mkLabel chr = { drawing: inj _point $ chrText chr
                      , horPos:  inj _point $ Normalized (0.5)
                      , verPos: Normalized (0.05) }

        font' = font sansSerif 12 mempty

        chrText :: ChrId -> Drawing
        chrText chr = Drawing.text font' zero zero (fillColor black) (unwrap chr)

        results :: Array _
        results = map (\x -> Tuple (x^._Index) [mkLabel (x^._Index)]) $ cs^._BrowserIntervals

boxesTrack :: Number
           -> CoordSys ChrId BrowserPoint
           -> BrowserTrack
boxesTrack h cs = pureTrack cs $ map (const [glyph]) $ intervalsToMap cs
  where glyph :: ReadyGlyph
        glyph = { drawing: inj _range draw
                , horPos:  inj _range $ Normalized <$> (Pair zero one)
                , verPos: Normalized one }
        draw = \w ->
             let rect = rectangle 0.0 0.0 w h
             in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Interval Bp
featureInterval {position} = case_
  # onMatch
     { point: (\x -> Pair x x)
     , range: (\x -> x)
     }
  $ position

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number (FeatureR i) (FeatureR o)
             => RowLacks l (FeatureR i)
             => IsSymbol l
             => Getter' (Feature a) Number
             -> SProxy l
             -> Bp
             -> f (Feature a)
             -> f (Feature i)
             -> f (Feature o)
bumpFeatures f l radius other = map bump
  where maxInRadius :: Interval Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if intervalsOverlap (featureInterval g) lr
                                          then f `view` g else 0.0) other

        bump :: Record (FeatureR i) -> Record (FeatureR o)
        bump a =
          let y = maxInRadius (featureInterval a)
          in Record.insert l y a

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Pixels
              , color :: Color
              | VScaleRow () }

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  -- should have some padding here too; hardcode for now
  let hPad = vscale.width  / 5.0
      vPad = height / 10.0
      x = vscale.width / 2.0

      y1 = 0.0
      y2 = height

      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)

      p = Drawing.path [{x, y:y1}, {x, y:y2}]

      bar w y = Drawing.path [{x:x-w, y}, {x, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vscale.max
      btmLabel = mkT (y2+vPad)       $ show vscale.min

  in outlined (outlineColor vscale.color <> lineWidth 2.0) (p <> ps)
     <> topLabel <> btmLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Pixels
              , entries :: Array LegendEntry }

mkIcon :: Color -> String -> LegendEntry
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

drawLegendItem :: LegendEntry
               -> Drawing
drawLegendItem {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Legend
           -> Number
           -> Drawing
drawLegend {width, entries} height =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length entries
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem ic
      d = (height - 2.0*vPad) / (length entries)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) entries
  in fold ds

type Padding = { vertical :: Pixels
               , horizontal :: Pixels
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

getData :: forall a i c.
           CoordSys i c
        -> (CoordSys i c -> Json -> Maybe a)
        -> String
        -> Aff _ (Array a)
getData cs p url = do
  json <- _.response <$> Affjax.get url

  maybe (throwError $ error $ "Error when parsing features from " <> url)
        pure
        $ json ^? _Array >>= traverse (p cs)

getDataGrouped :: forall a i c.
                  CoordSys ChrId c
               -> (CoordSys ChrId c -> Json -> Maybe _)
               -> String
               -> Aff _ (Map ChrId (Array _))
getDataGrouped cs p url = groupToChrs <$> getData cs p url

type TrackRow c a = ( url :: String
                    , parse :: c -> Json -> Maybe a
                    , render :: Renderer a )

type GWASTrack c a  = { vscale :: { | VScaleRow () }
                      | TrackRow c a }

type AnnotTrack c a = { getEntry :: a -> LegendEntry | TrackRow c a }

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as

module Genetics.Browser.Track.Backend where
       -- ( demoBrowser
       -- , demoLegend
       -- , getDataDemo
       -- ) where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alternative (class Alternative, alt, empty)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Array as Array
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', Traversal', Traversal, over, to, traverseOf, traversed, view, viewOn, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Star (Star(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Variant (Variant, case_, inj, on, onMatch)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), _BrowserIntervals, _Index, _Interval, intervalToScreen, intervalsOverlap, intervalsToMap, lookupInterval)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type BrowserView = Interval BrowserPoint

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

type ChrCtx r = Map ChrId (Record r)

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

type GenomePosV = Variant ( point :: Bp
                          , range :: Interval Bp )

type FeatureR r = ( position :: GenomePosV
                  , frameSize :: Bp
                  | r )
type Feature r = Record (FeatureR r)

type DrawingR  = ( point :: Drawing
                 , range :: Pixels -> Drawing )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Interval (Normalized Number) )
type HPos = Variant HorPlaceR

type Renderer a = { draw     :: a -> DrawingV
                  , horPlace :: a -> HPos
                  , verPlace :: a -> Normalized Number
                  }

type ReadyGlyph = { drawing :: DrawingV
                  , horPos  :: HPos
                  , verPos  :: Normalized Number
                  }

horPlace :: forall r.
            Feature r
         -> HPos
horPlace {position, frameSize} =
  let f p = Normalized (unwrap $ p / frameSize)
  in case_
    # onMatch
      { point: inj _point <<< f
      , range: inj _range <<< (map f)
      }
    $ position

verPlace :: forall r.
            (Getter' (Feature r) (Normalized Number))
         -> Feature r
         -> Normalized Number
verPlace = view

render :: forall err a.
          Renderer a
       -> a
       -> ReadyGlyph
render render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

type CanvasReadyDrawing = Drawing

type BrowserTrack = Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> CanvasReadyDrawing

-- Given a frame-normalized drawing, finalize it so it can be rendered to a canvas;
-- `width` is the width in pixels of the frame the drawing resides in.
resizeDrawing :: forall r.
                 { width :: Pixels | r }
              -> DrawingV
              -> Drawing
resizeDrawing {width} = case_
  # onMatch
     { point: (\x -> x)
     , range: (_ $ width) }

drawIntervalFeature :: forall f r a.
                     Foldable f
                  => Canvas.Dimensions
                  -> { width :: Pixels, offset :: Pixels }
                  -> f ReadyGlyph
                  -> CanvasReadyDrawing
drawIntervalFeature {height} {width, offset} = foldMap drawIt
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in translate (x + offset) y d

-- | Returns the left-hand-edge offset, and width, in pixels,
-- | of each interval (chromosome) in the provided coordinate system
viewportIntervals :: forall i a r.
                     Ord i
                  => CoordSys i BrowserPoint
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Map i { width :: Pixels, offset :: Pixels }
viewportIntervals cs cdim bView =
  intervalToScreen cdim bView <$> (view _Interval <$> intervalsToMap cs)

pureTrack :: forall f i a.
             Ord i
          => Foldable f
          => CoordSys i BrowserPoint
          -> Map i (f ReadyGlyph)
          -> BrowserTrack
pureTrack cs drawings cd v =
  fold $ zipMapsWith (drawIntervalFeature cd) (viewportIntervals cs cd v) drawings

renderTrack :: forall f i a.
               Ord i
            => Foldable f
            => Traversable f
            => CoordSys i BrowserPoint
            -> Renderer a
            -> Map i (f a)
            -> BrowserTrack
renderTrack cs r chrs =
  let validDrawings :: Map i (f ReadyGlyph)
      validDrawings = (map <<< map) (render r) chrs
  in pureTrack cs validDrawings

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> BrowserTrack
horRulerTrack {min, max, sig} color f _ = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        y = f.height - (normY * f.height)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

chrLabelTrack :: CoordSys ChrId BrowserPoint
              -> BrowserTrack
chrLabelTrack cs = pureTrack cs (Map.fromFoldable results)
  where mkLabel :: ChrId -> ReadyGlyph
        mkLabel chr = { drawing: inj _point $ chrText chr
                      , horPos:  inj _point $ Normalized (0.5)
                      , verPos: Normalized (0.05) }

        font' = font sansSerif 12 mempty

        chrText :: ChrId -> Drawing
        chrText chr = Drawing.text font' zero zero (fillColor black) (unwrap chr)

        results :: Array _
        results = map (\x -> Tuple (x^._Index) [mkLabel (x^._Index)]) $ cs^._BrowserIntervals

boxesTrack :: Number
           -> CoordSys ChrId BrowserPoint
           -> BrowserTrack
boxesTrack h cs = pureTrack cs $ map (const [glyph]) $ intervalsToMap cs
  where glyph :: ReadyGlyph
        glyph = { drawing: inj _range draw
                , horPos:  inj _range $ Normalized <$> (Pair zero one)
                , verPos: Normalized one }
        draw = \w ->
             let rect = rectangle 0.0 0.0 w h
             in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Interval Bp
featureInterval {position} = case_
  # onMatch
     { point: (\x -> Pair x x)
     , range: (\x -> x)
     }
  $ position

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number (FeatureR i) (FeatureR o)
             => RowLacks l (FeatureR i)
             => IsSymbol l
             => Getter' (Feature a) Number
             -> SProxy l
             -> Bp
             -> f (Feature a)
             -> f (Feature i)
             -> f (Feature o)
bumpFeatures f l radius other = map bump
  where maxInRadius :: Interval Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if intervalsOverlap (featureInterval g) lr
                                          then f `view` g else 0.0) other

        bump :: Record (FeatureR i) -> Record (FeatureR o)
        bump a =
          let y = maxInRadius (featureInterval a)
          in Record.insert l y a

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Pixels
              , color :: Color
              | VScaleRow () }

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  -- should have some padding here too; hardcode for now
  let hPad = vscale.width  / 5.0
      vPad = height / 10.0
      x = vscale.width / 2.0

      y1 = 0.0
      y2 = height

      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)

      p = Drawing.path [{x, y:y1}, {x, y:y2}]

      bar w y = Drawing.path [{x:x-w, y}, {x, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vscale.max
      btmLabel = mkT (y2+vPad)       $ show vscale.min

  in outlined (outlineColor vscale.color <> lineWidth 2.0) (p <> ps)
     <> topLabel <> btmLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Pixels
              , entries :: Array LegendEntry }

mkIcon :: Color -> String -> LegendEntry
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

drawLegendItem :: LegendEntry
               -> Drawing
drawLegendItem {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Legend
           -> Number
           -> Drawing
drawLegend {width, entries} height =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length entries
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem ic
      d = (height - 2.0*vPad) / (length entries)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) entries
  in fold ds

type Padding = { vertical :: Pixels
               , horizontal :: Pixels
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

getData :: forall a i c.
           CoordSys i c
        -> (CoordSys i c -> Json -> Maybe a)
        -> String
        -> Aff _ (Array a)
getData cs p url = do
  json <- _.response <$> Affjax.get url

  maybe (throwError $ error $ "Error when parsing features from " <> url)
        pure
        $ json ^? _Array >>= traverse (p cs)

getDataGrouped :: forall a i c.
                  CoordSys ChrId c
               -> (CoordSys ChrId c -> Json -> Maybe _)
               -> String
               -> Aff _ (Map ChrId (Array _))
getDataGrouped cs p url = groupToChrs <$> getData cs p url

type TrackRow c a = ( url :: String
                    , parse :: c -> Json -> Maybe a
                    , render :: Renderer a )

type GWASTrack c a  = { vscale :: { | VScaleRow () }
                      | TrackRow c a }

type AnnotTrack c a = { getEntry :: a -> LegendEntry | TrackRow c a }

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as