Extracts out a `Collection` typeclass from `class Database`.

module Abstract.Database.Class
	( readProp
	, readPropFlipped
	, (..)
	, readProp'
	, readProp'Flipped
	, (.?)
	, readPropAtIndex
	, readPropAtIndexFlipped
	, (.!!)
	, readPropAtIndex'
	, readPropAtIndex'Flipped
	, (.!!?)
	, readPropDefault
	, readPropDefaultFlipped
	, writeProp
	, (.=)
	, dbObject
	, toForeign
	, fromForeign
	, typeMismatch
	, class FromDBObject
	, fromDBObject
	, fromDBObjectEither'
	, fromDBObject'
	, class ToDBObject
	, toDBObject
	, class IsDBObject
	, class Database
	, openConnection
	, closeConnection
	, createCollection
	, getCollection
	, deleteCollection
	, class Collection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Ord
	, Ordering(EQ, GT, LT)
	, Unit
	, const
	, flip
	, id
	, map
	, pure
	, show
	, unit
	, ($)
	, (<>)
	, (>>=)
	, (<<<)
	, (>>>)
	, (<$>)
	, (<*>)
	)

import Control.Alt             ((<|>))
import Control.Monad.Aff       (Aff)
import Control.Monad.Eff.Ref   (REF, Ref)
import Data.Array              (index, mapWithIndex)
import Data.Foreign
	( Foreign
	, tagOf
	, toForeign
	, unsafeFromForeign
	, writeObject
	) as F
import Data.Foreign            (Prop(Prop))
import Data.Foreign.Null       (Null(Null), writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	)
import Data.Either
	( Either(Left, Right)
	, either
	)
import Data.Foldable           (class Foldable, foldr)
import Data.DateTime           (DateTime)
import Data.JSDate             (JSDate, fromDateTime, toDateTime)
import Data.List
	( List
	, fromFoldable
	, toUnfoldable
	)
import Data.List.NonEmpty      (NonEmptyList, fromFoldable, toList) as NE
import Data.StrMap             (StrMap, fromFoldable, lookup, toUnfoldable) as M
import Data.Maybe
	( Maybe(Just, Nothing)
	, fromJust
	, fromMaybe
	, maybe
	)
import Data.Set                (Set, fromFoldable, toUnfoldable) as S
import Data.String             (singleton, toChar) as Str
import Data.String.Regex       (Regex, regex, source)
import Data.String.Regex.Flags (noFlags)
import Data.Tuple              (Tuple(Tuple))
import Partial.Unsafe          (unsafePartial)

import Abstract.Database.Types

foreign import toISOString :: JSDate -> String

readProp :: forall a. FromDBObject a =>
	    String                   ->
	    M.StrMap DBObject        ->
	    Either String a
readProp key o = case M.lookup key o of
	Just k -> fromDBObject k
	_      -> Left $ "Could not find key: "
		<> show key
		<> " in DBOBject: "
		<> show o
		<> "."

readPropFlipped :: forall a. FromDBObject a =>
		   M.StrMap DBObject        ->
		   String                   ->
		   Either String a
readPropFlipped = flip readProp
infix 8 readPropFlipped as ..

readProp' :: forall a. FromDBObject a =>
	     String                   ->
	     M.StrMap DBObject        ->
	     Either String (Maybe a)
readProp' key o = case M.lookup key o of
	Just k -> Just <$> fromDBObject k
	_      -> pure Nothing

readProp'Flipped :: forall a. FromDBObject a =>
		    M.StrMap DBObject        ->
		    String                   ->
		    Either String (Maybe a)
readProp'Flipped = flip readProp'
infix 8 readProp'Flipped as .?

readPropAtIndex :: forall a. FromDBObject a =>
		   Int                      ->
		   Array DBObject           ->
		   Either String a
readPropAtIndex i xs = case xs `index` i of
	Just el -> fromDBObject el
	Nothing -> Left $ show xs
		<> " does not have an element at index "
		<> show i <> "."

readPropAtIndexFlipped :: forall a. FromDBObject a =>
			  Array DBObject           ->
			  Int                      ->
			  Either String a
readPropAtIndexFlipped = flip readPropAtIndex
infix 8 readPropAtIndexFlipped as .!! -- .[]

readPropAtIndex' :: forall a. FromDBObject a =>
		   Int                       ->
		   Array DBObject            ->
		   Either String (Maybe a)
readPropAtIndex' i xs = case xs `index` i of
	Just el -> Just <$> fromDBObject el
	Nothing -> pure Nothing

readPropAtIndex'Flipped :: forall a. FromDBObject a =>
			   Array DBObject            ->
			   Int                       ->
			   Either String (Maybe a)
readPropAtIndex'Flipped = flip readPropAtIndex'
infix 8 readPropAtIndex'Flipped as .!!? -- .[]?

readPropDefault :: forall a. a -> Either String (Maybe a) -> Either String a
readPropDefault a = map (fromMaybe a)

readPropDefaultFlipped :: forall a. Either String (Maybe a) ->
			  a                                 ->
			  Either String a
readPropDefaultFlipped = flip readPropDefault
infix 8 readPropDefaultFlipped as ..=

writeProp :: forall a. ToDBObject a => String -> a -> Tuple String DBObject
writeProp k v = Tuple k (toDBObject v)
infixl 8 writeProp as .=

dbObject :: forall f. (Foldable f) => f (Tuple String DBObject) -> DBObject
dbObject = M.fromFoldable >>> DBObject

toForeign :: DBObject -> F.Foreign
toForeign (Boolean      b) = F.toForeign b
toForeign (Int          i) = F.toForeign i
toForeign (Number       n) = F.toForeign n
toForeign (String       s) = F.toForeign s
toForeign (Maybe (Just a)) = F.toForeign $ toForeign a
toForeign (Maybe  Nothing) = writeNull
toForeign (Array        a) = F.toForeign $ map toForeign a
toForeign (DBObject     o) = F.writeObject $ foldr fold [] $ toUnfoldable' o
	where
		toUnfoldable' :: M.StrMap DBObject -> Array (Tuple String DBObject)
		toUnfoldable' = M.toUnfoldable

		fold (Tuple k v) o' = o' <> [ Prop { key: k, value: toForeign v } ]

foreign import objFold :: forall a. ToDBObject a          =>
			  (String -> a -> Tuple String a) ->
			  F.Foreign                       ->
			  Array (Tuple String DBObject)
foreign import toString :: F.Foreign -> String

-- | Attempts to convert a primitiveish Foreign value to a DBObject. The
-- | primitiveish types that are supported are:
-- |
-- | - Undefined
-- | - Null
-- | - Boolean
-- | - Number
-- | - String
-- | - RegExp
-- | - Date
-- | - Array
-- | - Object
-- |
-- | Any supplied Foreign type that is not a member of the above is converted
-- | to a string using its `.toString()` method. **This is strongly *not*
-- | recommended**, and instead it is recommended to create a custom PureScript
-- | type, convert your Foreign to this type, and then create a ToDBObject
-- | instance for that type, then use it.
fromForeign :: F.Foreign -> DBObject
fromForeign f = case F.tagOf f of
	"Undefined" -> Maybe Nothing
	"Null"      -> Maybe Nothing
	"Boolean"   -> Boolean $ F.unsafeFromForeign f
	"Number"    -> Number $ F.unsafeFromForeign f
	"String"    -> String $ F.unsafeFromForeign f
	"RegExp"    -> String $ source $ F.unsafeFromForeign f
	"Date"      -> String $ toISOString $ F.unsafeFromForeign f
	"Array"     -> Array $ map toDBObject $ F.unsafeFromForeign f :: Array F.Foreign
	"Object"    -> dbObject $ objFold writeProp f
	_           -> String $ toString f

typeMismatch :: forall a. String -> DBObject -> Either String a
typeMismatch expected actual = Left $
	"Expected to convert a initial type of `" <> expected    <>
	"`, but instead got: `"                   <> show actual <>
	"`, which has a type of `"                <> typeName    <>
	"`"
	where
		typeName = case actual of
			Boolean  _ -> "Boolean"
			Int      _ -> "Int"
			Number   _ -> "Number"
			String   _ -> "String"
			Maybe    _ -> "Maybe"
			Array    _ -> "Array"
			DBObject _ -> "DBObject"

class FromDBObject a where
	fromDBObject :: DBObject -> Either String a

instance fromDBObjectDBObject :: FromDBObject DBObject where
	fromDBObject = pure <<< id

instance fromDBObjectUndefined :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject (Maybe (Just a)) = (Just >>> Undefined) <$> fromDBObject a
	fromDBObject (Maybe  Nothing) = pure $ Undefined Nothing
	fromDBObject               o  = typeMismatch "Maybe" o

instance fromDBObjectNull :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject (Maybe (Just a)) = (Just >>> Null) <$> fromDBObject a
	fromDBObject (Maybe  Nothing) = pure $ Null Nothing
	fromDBObject               o  = typeMismatch "Maybe" o

instance fromDBObjectNullOrUndefined :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject (Maybe (Just a)) = (Just >>> NullOrUndefined) <$> fromDBObject a
	fromDBObject (Maybe  Nothing) = pure $ NullOrUndefined Nothing
	fromDBObject               o  = typeMismatch "Maybe" o

instance fromDBObjectUnit :: FromDBObject Unit where
	fromDBObject (Maybe Nothing) = pure unit
	fromDBObject              o  = typeMismatch "Maybe" o

instance fromDBObjectBoolean :: FromDBObject Boolean where
	fromDBObject (Boolean b) = pure b
	fromDBObject          o  = typeMismatch "Boolean" o

instance fromDBObjectInt :: FromDBObject Int where
	fromDBObject (Int i) = pure i
	fromDBObject      o  = typeMismatch "Int" o

instance fromDBObjectNumber :: FromDBObject Number where
	fromDBObject (Number n) = pure n
	fromDBObject         o  = typeMismatch "Number" o

instance fromDBObjectChar :: FromDBObject Char where
	fromDBObject (String c) = maybe (error c) pure $ Str.toChar c
		where
			error c' = Left $ "Was not able to convert "
				<> show c'
				<> " into a `Char` because its length was too long."

	fromDBObject o = typeMismatch "String" o

instance fromDBObjectString :: FromDBObject String where
	fromDBObject (String s) = pure s
	fromDBObject         o  = typeMismatch "String" o

instance fromDBObjectRegex :: FromDBObject Regex where
	fromDBObject (String r) = either (error r) pure $ regex r noFlags
		where
			error r' e = Left $ "Was not able to convert "
				<> show r'
				<> " into a Regular Expression. The conversion error is:\n\t"
				<> e

	fromDBObject o = typeMismatch "String" o

foreign import parseISODateTimeString :: (String -> Either String JSDate) -> -- Left
					 (JSDate -> Either String JSDate) -> -- Right
					 String                           -> -- The ISO DateTime string
					 Either String JSDate

instance fromDBObjectDateTime :: FromDBObject DateTime where
	fromDBObject (String d) =
		either (error d) toDateTime' $
			parseISODateTimeString Left Right d
		where
			error d' e = Left $ "Was not able to convert "
				<> show d'
				<> " into a DateTime. The conversion error is:\n\t"
				<> e

			fromJust'   = unsafePartial fromJust
			toDateTime' = toDateTime >>> fromJust' >>> pure

	fromDBObject o = typeMismatch "String" o

instance fromDBObjectArray :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject (Array a) = foldr fold (Right []) $ mapWithIndex fromDBObject'' a -- XXX Maybe I can move this to JS to avoid the O(n*2)
		where
			fromDBObject'' i a' = Tuple i (fromDBObject a')

			errorAt :: Int -> String -> String
			errorAt i e = "\tindex " <> show i <> ": " <> e <> "\n"

			firstError :: Int -> String -> String
			firstError i e = "Was not able to convert the entire `Array`. Below are the errors found at their corresponding indices:\n" <> errorAt i e

			fold (Tuple i (Left  e)) (Left  es) = Left $ es <> errorAt i e
			fold (Tuple i (Left  e)) (Right xs) = Left $ firstError i e
			fold (Tuple i (Right x)) (Left  es) = Left es
			fold (Tuple i (Right x)) (Right xs) = Right $ xs <> [x]

	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectForeign :: FromDBObject F.Foreign where
	fromDBObject = pure <<< toForeign

instance fromDBObjectOrdering :: FromDBObject Ordering where
	fromDBObject (String "LT") = pure LT
	fromDBObject (String "EQ") = pure EQ
	fromDBObject (String "GT") = pure GT
	fromDBObject            o  = typeMismatch "String" o

instance fromDBObjectTuple :: (FromDBObject a, FromDBObject b) => FromDBObject (Tuple a b) where
	fromDBObject (Array [a1, a2]) = Tuple <$> (fromDBObject a1) <*> (fromDBObject a2)
	fromDBObject (Array        a) = Left $ "Was not able to convert "
		<> show a
		<> " into a `Tuple` because it does not have *exactly* two elements."

	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectMaybe :: FromDBObject a => FromDBObject (Maybe a) where
	fromDBObject (Maybe (Just a)) = Just <$> fromDBObject a
	fromDBObject (Maybe  Nothing) = pure Nothing
	fromDBObject               o  = typeMismatch "Maybe" o

-- | This instance biases towards attempting to evaluate a `Right` first.
-- | Failing that, it attempts to evaluate a potential `Left`.
instance fromDBObjectEither :: (FromDBObject a, FromDBObject b) => FromDBObject (Either a b) where
	fromDBObject (DBObject o) =
		(o.."Right") <|> (o.."Left") >>= fromDBObject

	fromDBObject o = typeMismatch "DBObject" o

-- | This function biases towards attempting to evaluate a `Left` first.
-- | Failing that, it attempts to evaluate a potential `Right`.
fromDBObjectEither' :: forall a b. (FromDBObject a, FromDBObject b) =>
		       DBObject                                     ->
		       Either String (Either a b)
fromDBObjectEither' (DBObject o) = (o.."Left") <|> (o.."Right") >>= fromDBObject
fromDBObjectEither'           o  = typeMismatch "DBObject" o

instance fromDBObjectList :: FromDBObject a => FromDBObject (List a) where
	fromDBObject (Array a) = fromFoldable' <$> fromDBObject (Array a) -- XXX Maybe I can move this to JS to avoid the O(n*2)
		where
			fromFoldable' :: Array a -> List a
			fromFoldable' = fromFoldable

	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectNonEmptyList :: FromDBObject a => FromDBObject (NE.NonEmptyList a) where
	fromDBObject (Array a) =
		fromDBObject'' (Array a) >>= (NE.fromFoldable >>> maybe error Right) -- XXX Maybe I can move this to JS to avoid the O(n*2)
			where
				fromDBObject'' :: forall a'. FromDBObject a' => DBObject -> Either String (Array a')
				fromDBObject'' = fromDBObject

				error = Left $ "Was not able to convert "
					<> show a
					<> " into a `NonEmptyList` because it was empty."

	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectSet :: (FromDBObject a, Ord a) => FromDBObject (S.Set a) where
	fromDBObject (Array a) =
		S.fromFoldable <$> fromDBObject (Array a) :: Either String (Array a) -- XXX Maybe I can move this to JS to avoid the O(n*2)
	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectStrMap :: (FromDBObject a) => FromDBObject (M.StrMap a) where
	fromDBObject (DBObject o) = map M.fromFoldable $ foldr fold (Right []) $ mapWithIndex fromDBObject'' $ toUnfoldable' o -- XXX Maybe I can move this to JS to avoid the O(n*4)
		where
			toUnfoldable' :: M.StrMap DBObject -> Array (Tuple String DBObject)
			toUnfoldable' = M.toUnfoldable

			fromDBObject'' i (Tuple k a) = Tuple i (Tuple k (fromDBObject a))

			errorAt :: Int -> String -> String
			errorAt i e = "\tindex " <> show i <> ": " <> e <> "\n"

			firstError :: Int -> String -> String
			firstError i e = "Was not able to convert the entire `StrMap`. Below are the errors that were be found at their corresponding indices (indices are based on if you were to turn this `StrMap` into an `Array (Tuple String a)`):\n" <> errorAt i e

			fold (Tuple i (Tuple k (Left  e))) (Left  es) = Left $ es <> errorAt i e
			fold (Tuple i (Tuple k (Left  e))) (Right xs) = Left $ firstError i e
			fold (Tuple i (Tuple k (Right x))) (Left  es) = Left es
			fold (Tuple i (Tuple k (Right x))) (Right xs) = Right $ xs <> [(Tuple k x)]

	fromDBObject o = typeMismatch "DBOBject" o

fromDBObject' :: forall a. FromDBObject a => DBObject -> Maybe a
fromDBObject' = fromDBObject >>> either (const Nothing) pure

class ToDBObject a where
	toDBObject :: a -> DBObject

instance toDBObjectDBObject :: ToDBObject DBObject where
	toDBObject = id

instance toDBObjectUndefined :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = Maybe $ map toDBObject a

instance toDBObjectNull :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = Maybe $ map toDBObject a

instance toDBObjectNullOrUndefined :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = Maybe $ map toDBObject a

instance toDBObjectUnit :: ToDBObject Unit where
	toDBObject _ = Maybe Nothing

instance toDBObjectBoolean :: ToDBObject Boolean where
	toDBObject = Boolean

instance toDBObjectInt :: ToDBObject Int where
	toDBObject = Int

instance toDBObjectNumber :: ToDBObject Number where
	toDBObject = Number

instance toDBObjectChar :: ToDBObject Char where
	toDBObject = Str.singleton >>> String

instance toDBObjectString :: ToDBObject String where
	toDBObject = String

instance toDBObjectRegex :: ToDBObject Regex where
	toDBObject = source >>> String

instance toDBObjectDateTime :: ToDBObject DateTime where
	toDBObject = fromDateTime >>> toISOString >>> String

instance toDBObjectArray :: ToDBObject a => ToDBObject (Array a) where
	toDBObject = Array <<< map toDBObject

instance toDBObjectForeign :: ToDBObject F.Foreign where
	toDBObject = fromForeign

instance toDBObjectOrdering :: ToDBObject Ordering where
	toDBObject LT = String "LT"
	toDBObject EQ = String "EQ"
	toDBObject GT = String "GT"

instance toDBObjectTuple :: (ToDBObject a, ToDBObject b) => ToDBObject (Tuple a b) where
	toDBObject (Tuple a b) = Array [toDBObject a, toDBObject b]

instance toDBObjectMaybe :: ToDBObject a => ToDBObject (Maybe a) where
	toDBObject = Maybe <<< map toDBObject

instance toDBObjectEither :: (ToDBObject a, ToDBObject b) => ToDBObject (Either a b) where
	toDBObject (Left  l) = dbObject [ "Left"  .= l ]
	toDBObject (Right r) = dbObject [ "Right" .= r ]

instance toDBObjectList :: ToDBObject a => ToDBObject (List a) where
	toDBObject = toUnfoldable' >>> toDBObject
		where
			toUnfoldable' :: List a -> Array a
			toUnfoldable' = toUnfoldable

instance toDBObjectNonEmptyList :: ToDBObject a => ToDBObject (NE.NonEmptyList a) where
	toDBObject = NE.toList >>> toDBObject

instance toDBObjectSet :: ToDBObject a => ToDBObject (S.Set a) where
	toDBObject = toUnfoldable' >>> toDBObject
		where
			toUnfoldable' :: forall a'. ToDBObject a =>
					 S.Set a'                ->
					 Array a'
			toUnfoldable' = S.toUnfoldable

instance toDBObjectStrMap :: ToDBObject a => ToDBObject (M.StrMap a) where
	toDBObject = toUnfoldable' >>> map toProp >>> dbObject -- XXX Maybe I can move this to JS to avoid the O(n*2)
		where
			toUnfoldable' :: M.StrMap a -> Array (Tuple String a)
			toUnfoldable' = M.toUnfoldable

			toProp (Tuple k v) = k .= v

class (FromDBObject a, ToDBObject a) <= IsDBObject a

instance dbObjectIsDBObject        :: IsDBObject DBObject
instance undefinedIsDBObject       :: IsDBObject a => IsDBObject (Undefined a)
instance nullIsDBObject            :: IsDBObject a => IsDBObject (Null a)
instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)
instance unitIsDBObject            :: IsDBObject Unit
instance booleanIsDBObject         :: IsDBObject Boolean
instance intIsDBObject             :: IsDBObject Int
instance numberIsDBObject          :: IsDBObject Number
instance charIsDBObject            :: IsDBObject Char
instance stringIsDBObject          :: IsDBObject String
instance regexIsDBObject           :: IsDBObject Regex
instance datetimeIsDBObject        :: IsDBObject DateTime
instance arrayIsDBObject           :: IsDBObject a => IsDBObject (Array a)
instance foreignIsDBObject         :: IsDBObject F.Foreign
instance orderingIsDBObject        :: IsDBObject Ordering
instance tupleIsDBObject           :: (IsDBObject a, IsDBObject b) => IsDBObject (Tuple a b)
instance maybeIsDBObject           :: IsDBObject a => IsDBObject (Maybe a)
instance eitherIsDBObject          :: (IsDBObject a, IsDBObject b) => IsDBObject (Either a b)
instance listIsDBObject            :: IsDBObject a => IsDBObject (List a)
instance nonEmptyListIsDBObject    :: IsDBObject a => IsDBObject (NE.NonEmptyList a)
instance setIsDBObject             :: (IsDBObject a, Ord a) => IsDBObject (S.Set a)
instance strMapIsDBObject          :: IsDBObject a => IsDBObject (M.StrMap a)

class Database datastore where
	openConnection :: forall e. String -> Aff (db :: DATABASE | e) datastore

	closeConnection :: forall e. datastore -> Aff (db :: DATABASE | e) Unit

	createCollection :: forall e. String ->
			    datastore        ->
			    Aff (db :: DATABASE | e) Unit

	getCollection    :: forall e t. String ->
			    datastore          ->
			    Aff (db :: DATABASE, ref :: REF | e) (Ref (Collection t))

	deleteCollection :: forall e. String ->
			    datastore        ->
			    Aff (db :: DATABASE | e) Unit

class Collection c where
	getWhere :: forall e t. FromDBObject t =>
		    Maybe Pagination           ->
		    Query t                    ->
		    Ref (Collection t)         ->
		    Aff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e t. FromDBObject t =>
		    Maybe Pagination            ->
		    Query t                     ->
		    Ref (Collection t)          ->
		    Aff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e t. FromDBObject t =>
		      Query t                    ->
		      Ref (Collection t)         ->
		      Aff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. ToDBObject t =>
		  t                          ->
		  Ref (Collection t)         ->
		  Aff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. ToDBObject t =>
		   List t                     ->
		   Ref (Collection t)         ->
		   Aff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t b. ToDBObject t =>
		       Query t                    ->
		       Ref (Collection t)         ->
		       Aff (db :: DATABASE, ref :: REF | e) b

module Abstract.Database.Class
	( readProp
	, readPropFlipped
	, (..)
	, readProp'
	, readProp'Flipped
	, (.?)
	, readPropAtIndex
	, readPropAtIndexFlipped
	, (.!!)
	, readPropAtIndex'
	, readPropAtIndex'Flipped
	, (.!!?)
	, readPropDefault
	, readPropDefaultFlipped
	, writeProp
	, (.=)
	, dbObject
	, toForeign
	, fromForeign
	, typeMismatch
	, class FromDBObject
	, fromDBObject
	, fromDBObjectEither'
	, fromDBObject'
	, class ToDBObject
	, toDBObject
	, class IsDBObject
	, class Database
	, openConnection
	, closeConnection
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Ord
	, Ordering(EQ, GT, LT)
	, Unit
	, const
	, flip
	, id
	, map
	, pure
	, show
	, unit
	, ($)
	, (<>)
	, (>>=)
	, (<<<)
	, (>>>)
	, (<$>)
	, (<*>)
	)

import Control.Alt             ((<|>))
import Control.Monad.Aff       (Aff)
import Control.Monad.Eff.Ref   (REF, Ref)
import Data.Array              (index, mapWithIndex)
import Data.Foreign
	( Foreign
	, tagOf
	, toForeign
	, unsafeFromForeign
	, writeObject
	) as F
import Data.Foreign            (Prop(Prop))
import Data.Foreign.Null       (Null(Null), writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	)
import Data.Either
	( Either(Left, Right)
	, either
	)
import Data.Foldable           (class Foldable, foldr)
import Data.DateTime           (DateTime)
import Data.JSDate             (JSDate, fromDateTime, toDateTime)
import Data.List
	( List
	, fromFoldable
	, toUnfoldable
	)
import Data.List.NonEmpty      (NonEmptyList, fromFoldable, toList) as NE
import Data.StrMap             (StrMap, fromFoldable, lookup, toUnfoldable) as M
import Data.Maybe
	( Maybe(Just, Nothing)
	, fromJust
	, fromMaybe
	, maybe
	)
import Data.Set                (Set, fromFoldable, toUnfoldable) as S
import Data.String             (singleton, toChar) as Str
import Data.String.Regex       (Regex, regex, source)
import Data.String.Regex.Flags (noFlags)
import Data.Tuple              (Tuple(Tuple))
import Partial.Unsafe          (unsafePartial)

import Abstract.Database.Types

foreign import toISOString :: JSDate -> String

readProp :: forall a. FromDBObject a =>
	    String                   ->
	    M.StrMap DBObject        ->
	    Either String a
readProp key o = case M.lookup key o of
	Just k -> fromDBObject k
	_      -> Left $ "Could not find key: "
		<> show key
		<> " in DBOBject: "
		<> show o
		<> "."

readPropFlipped :: forall a. FromDBObject a =>
		   M.StrMap DBObject        ->
		   String                   ->
		   Either String a
readPropFlipped = flip readProp
infix 8 readPropFlipped as ..

readProp' :: forall a. FromDBObject a =>
	     String                   ->
	     M.StrMap DBObject        ->
	     Either String (Maybe a)
readProp' key o = case M.lookup key o of
	Just k -> Just <$> fromDBObject k
	_      -> pure Nothing

readProp'Flipped :: forall a. FromDBObject a =>
		    M.StrMap DBObject        ->
		    String                   ->
		    Either String (Maybe a)
readProp'Flipped = flip readProp'
infix 8 readProp'Flipped as .?

readPropAtIndex :: forall a. FromDBObject a =>
		   Int                      ->
		   Array DBObject           ->
		   Either String a
readPropAtIndex i xs = case xs `index` i of
	Just el -> fromDBObject el
	Nothing -> Left $ show xs
		<> " does not have an element at index "
		<> show i <> "."

readPropAtIndexFlipped :: forall a. FromDBObject a =>
			  Array DBObject           ->
			  Int                      ->
			  Either String a
readPropAtIndexFlipped = flip readPropAtIndex
infix 8 readPropAtIndexFlipped as .!! -- .[]

readPropAtIndex' :: forall a. FromDBObject a =>
		   Int                       ->
		   Array DBObject            ->
		   Either String (Maybe a)
readPropAtIndex' i xs = case xs `index` i of
	Just el -> Just <$> fromDBObject el
	Nothing -> pure Nothing

readPropAtIndex'Flipped :: forall a. FromDBObject a =>
			   Array DBObject            ->
			   Int                       ->
			   Either String (Maybe a)
readPropAtIndex'Flipped = flip readPropAtIndex'
infix 8 readPropAtIndex'Flipped as .!!? -- .[]?

readPropDefault :: forall a. a -> Either String (Maybe a) -> Either String a
readPropDefault a = map (fromMaybe a)

readPropDefaultFlipped :: forall a. Either String (Maybe a) ->
			  a                                 ->
			  Either String a
readPropDefaultFlipped = flip readPropDefault
infix 8 readPropDefaultFlipped as ..=

writeProp :: forall a. ToDBObject a => String -> a -> Tuple String DBObject
writeProp k v = Tuple k (toDBObject v)
infixl 8 writeProp as .=

dbObject :: forall f. (Foldable f) => f (Tuple String DBObject) -> DBObject
dbObject = M.fromFoldable >>> DBObject

toForeign :: DBObject -> F.Foreign
toForeign (Boolean      b) = F.toForeign b
toForeign (Int          i) = F.toForeign i
toForeign (Number       n) = F.toForeign n
toForeign (String       s) = F.toForeign s
toForeign (Maybe (Just a)) = F.toForeign $ toForeign a
toForeign (Maybe  Nothing) = writeNull
toForeign (Array        a) = F.toForeign $ map toForeign a
toForeign (DBObject     o) = F.writeObject $ foldr fold [] $ toUnfoldable' o
	where
		toUnfoldable' :: M.StrMap DBObject -> Array (Tuple String DBObject)
		toUnfoldable' = M.toUnfoldable

		fold (Tuple k v) o' = o' <> [ Prop { key: k, value: toForeign v } ]

foreign import objFold :: forall a. ToDBObject a          =>
			  (String -> a -> Tuple String a) ->
			  F.Foreign                       ->
			  Array (Tuple String DBObject)
foreign import toString :: F.Foreign -> String

-- | Attempts to convert a primitiveish Foreign value to a DBObject. The
-- | primitiveish types that are supported are:
-- |
-- | - Undefined
-- | - Null
-- | - Boolean
-- | - Number
-- | - String
-- | - RegExp
-- | - Date
-- | - Array
-- | - Object
-- |
-- | Any supplied Foreign type that is not a member of the above is converted
-- | to a string using its `.toString()` method. **This is strongly *not*
-- | recommended**, and instead it is recommended to create a custom PureScript
-- | type, convert your Foreign to this type, and then create a ToDBObject
-- | instance for that type, then use it.
fromForeign :: F.Foreign -> DBObject
fromForeign f = case F.tagOf f of
	"Undefined" -> Maybe Nothing
	"Null"      -> Maybe Nothing
	"Boolean"   -> Boolean $ F.unsafeFromForeign f
	"Number"    -> Number $ F.unsafeFromForeign f
	"String"    -> String $ F.unsafeFromForeign f
	"RegExp"    -> String $ source $ F.unsafeFromForeign f
	"Date"      -> String $ toISOString $ F.unsafeFromForeign f
	"Array"     -> Array $ map toDBObject $ F.unsafeFromForeign f :: Array F.Foreign
	"Object"    -> dbObject $ objFold writeProp f
	_           -> String $ toString f

typeMismatch :: forall a. String -> DBObject -> Either String a
typeMismatch expected actual = Left $
	"Expected to convert a initial type of `" <> expected    <>
	"`, but instead got: `"                   <> show actual <>
	"`, which has a type of `"                <> typeName    <>
	"`"
	where
		typeName = case actual of
			Boolean  _ -> "Boolean"
			Int      _ -> "Int"
			Number   _ -> "Number"
			String   _ -> "String"
			Maybe    _ -> "Maybe"
			Array    _ -> "Array"
			DBObject _ -> "DBObject"

class FromDBObject a where
	fromDBObject :: DBObject -> Either String a

instance fromDBObjectDBObject :: FromDBObject DBObject where
	fromDBObject = pure <<< id

instance fromDBObjectUndefined :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject (Maybe (Just a)) = (Just >>> Undefined) <$> fromDBObject a
	fromDBObject (Maybe  Nothing) = pure $ Undefined Nothing
	fromDBObject               o  = typeMismatch "Maybe" o

instance fromDBObjectNull :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject (Maybe (Just a)) = (Just >>> Null) <$> fromDBObject a
	fromDBObject (Maybe  Nothing) = pure $ Null Nothing
	fromDBObject               o  = typeMismatch "Maybe" o

instance fromDBObjectNullOrUndefined :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject (Maybe (Just a)) = (Just >>> NullOrUndefined) <$> fromDBObject a
	fromDBObject (Maybe  Nothing) = pure $ NullOrUndefined Nothing
	fromDBObject               o  = typeMismatch "Maybe" o

instance fromDBObjectUnit :: FromDBObject Unit where
	fromDBObject (Maybe Nothing) = pure unit
	fromDBObject              o  = typeMismatch "Maybe" o

instance fromDBObjectBoolean :: FromDBObject Boolean where
	fromDBObject (Boolean b) = pure b
	fromDBObject          o  = typeMismatch "Boolean" o

instance fromDBObjectInt :: FromDBObject Int where
	fromDBObject (Int i) = pure i
	fromDBObject      o  = typeMismatch "Int" o

instance fromDBObjectNumber :: FromDBObject Number where
	fromDBObject (Number n) = pure n
	fromDBObject         o  = typeMismatch "Number" o

instance fromDBObjectChar :: FromDBObject Char where
	fromDBObject (String c) = maybe (error c) pure $ Str.toChar c
		where
			error c' = Left $ "Was not able to convert "
				<> show c'
				<> " into a `Char` because its length was too long."

	fromDBObject o = typeMismatch "String" o

instance fromDBObjectString :: FromDBObject String where
	fromDBObject (String s) = pure s
	fromDBObject         o  = typeMismatch "String" o

instance fromDBObjectRegex :: FromDBObject Regex where
	fromDBObject (String r) = either (error r) pure $ regex r noFlags
		where
			error r' e = Left $ "Was not able to convert "
				<> show r'
				<> " into a Regular Expression. The conversion error is:\n\t"
				<> e

	fromDBObject o = typeMismatch "String" o

foreign import parseISODateTimeString :: (String -> Either String JSDate) -> -- Left
					 (JSDate -> Either String JSDate) -> -- Right
					 String                           -> -- The ISO DateTime string
					 Either String JSDate

instance fromDBObjectDateTime :: FromDBObject DateTime where
	fromDBObject (String d) =
		either (error d) toDateTime' $
			parseISODateTimeString Left Right d
		where
			error d' e = Left $ "Was not able to convert "
				<> show d'
				<> " into a DateTime. The conversion error is:\n\t"
				<> e

			fromJust'   = unsafePartial fromJust
			toDateTime' = toDateTime >>> fromJust' >>> pure

	fromDBObject o = typeMismatch "String" o

instance fromDBObjectArray :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject (Array a) = foldr fold (Right []) $ mapWithIndex fromDBObject'' a -- XXX Maybe I can move this to JS to avoid the O(n*2)
		where
			fromDBObject'' i a' = Tuple i (fromDBObject a')

			errorAt :: Int -> String -> String
			errorAt i e = "\tindex " <> show i <> ": " <> e <> "\n"

			firstError :: Int -> String -> String
			firstError i e = "Was not able to convert the entire `Array`. Below are the errors found at their corresponding indices:\n" <> errorAt i e

			fold (Tuple i (Left  e)) (Left  es) = Left $ es <> errorAt i e
			fold (Tuple i (Left  e)) (Right xs) = Left $ firstError i e
			fold (Tuple i (Right x)) (Left  es) = Left es
			fold (Tuple i (Right x)) (Right xs) = Right $ xs <> [x]

	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectForeign :: FromDBObject F.Foreign where
	fromDBObject = pure <<< toForeign

instance fromDBObjectOrdering :: FromDBObject Ordering where
	fromDBObject (String "LT") = pure LT
	fromDBObject (String "EQ") = pure EQ
	fromDBObject (String "GT") = pure GT
	fromDBObject            o  = typeMismatch "String" o

instance fromDBObjectTuple :: (FromDBObject a, FromDBObject b) => FromDBObject (Tuple a b) where
	fromDBObject (Array [a1, a2]) = Tuple <$> (fromDBObject a1) <*> (fromDBObject a2)
	fromDBObject (Array        a) = Left $ "Was not able to convert "
		<> show a
		<> " into a `Tuple` because it does not have *exactly* two elements."

	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectMaybe :: FromDBObject a => FromDBObject (Maybe a) where
	fromDBObject (Maybe (Just a)) = Just <$> fromDBObject a
	fromDBObject (Maybe  Nothing) = pure Nothing
	fromDBObject               o  = typeMismatch "Maybe" o

-- | This instance biases towards attempting to evaluate a `Right` first.
-- | Failing that, it attempts to evaluate a potential `Left`.
instance fromDBObjectEither :: (FromDBObject a, FromDBObject b) => FromDBObject (Either a b) where
	fromDBObject (DBObject o) =
		(o.."Right") <|> (o.."Left") >>= fromDBObject

	fromDBObject o = typeMismatch "DBObject" o

-- | This function biases towards attempting to evaluate a `Left` first.
-- | Failing that, it attempts to evaluate a potential `Right`.
fromDBObjectEither' :: forall a b. (FromDBObject a, FromDBObject b) =>
		       DBObject                                     ->
		       Either String (Either a b)
fromDBObjectEither' (DBObject o) = (o.."Left") <|> (o.."Right") >>= fromDBObject
fromDBObjectEither'           o  = typeMismatch "DBObject" o

instance fromDBObjectList :: FromDBObject a => FromDBObject (List a) where
	fromDBObject (Array a) = fromFoldable' <$> fromDBObject (Array a) -- XXX Maybe I can move this to JS to avoid the O(n*2)
		where
			fromFoldable' :: Array a -> List a
			fromFoldable' = fromFoldable

	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectNonEmptyList :: FromDBObject a => FromDBObject (NE.NonEmptyList a) where
	fromDBObject (Array a) =
		fromDBObject'' (Array a) >>= (NE.fromFoldable >>> maybe error Right) -- XXX Maybe I can move this to JS to avoid the O(n*2)
			where
				fromDBObject'' :: forall a'. FromDBObject a' => DBObject -> Either String (Array a')
				fromDBObject'' = fromDBObject

				error = Left $ "Was not able to convert "
					<> show a
					<> " into a `NonEmptyList` because it was empty."

	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectSet :: (FromDBObject a, Ord a) => FromDBObject (S.Set a) where
	fromDBObject (Array a) =
		S.fromFoldable <$> fromDBObject (Array a) :: Either String (Array a) -- XXX Maybe I can move this to JS to avoid the O(n*2)
	fromDBObject o = typeMismatch "Array" o

instance fromDBObjectStrMap :: (FromDBObject a) => FromDBObject (M.StrMap a) where
	fromDBObject (DBObject o) = map M.fromFoldable $ foldr fold (Right []) $ mapWithIndex fromDBObject'' $ toUnfoldable' o -- XXX Maybe I can move this to JS to avoid the O(n*4)
		where
			toUnfoldable' :: M.StrMap DBObject -> Array (Tuple String DBObject)
			toUnfoldable' = M.toUnfoldable

			fromDBObject'' i (Tuple k a) = Tuple i (Tuple k (fromDBObject a))

			errorAt :: Int -> String -> String
			errorAt i e = "\tindex " <> show i <> ": " <> e <> "\n"

			firstError :: Int -> String -> String
			firstError i e = "Was not able to convert the entire `StrMap`. Below are the errors that were be found at their corresponding indices (indices are based on if you were to turn this `StrMap` into an `Array (Tuple String a)`):\n" <> errorAt i e

			fold (Tuple i (Tuple k (Left  e))) (Left  es) = Left $ es <> errorAt i e
			fold (Tuple i (Tuple k (Left  e))) (Right xs) = Left $ firstError i e
			fold (Tuple i (Tuple k (Right x))) (Left  es) = Left es
			fold (Tuple i (Tuple k (Right x))) (Right xs) = Right $ xs <> [(Tuple k x)]

	fromDBObject o = typeMismatch "DBOBject" o

fromDBObject' :: forall a. FromDBObject a => DBObject -> Maybe a
fromDBObject' = fromDBObject >>> either (const Nothing) pure

class ToDBObject a where
	toDBObject :: a -> DBObject

instance toDBObjectDBObject :: ToDBObject DBObject where
	toDBObject = id

instance toDBObjectUndefined :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = Maybe $ map toDBObject a

instance toDBObjectNull :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = Maybe $ map toDBObject a

instance toDBObjectNullOrUndefined :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = Maybe $ map toDBObject a

instance toDBObjectUnit :: ToDBObject Unit where
	toDBObject _ = Maybe Nothing

instance toDBObjectBoolean :: ToDBObject Boolean where
	toDBObject = Boolean

instance toDBObjectInt :: ToDBObject Int where
	toDBObject = Int

instance toDBObjectNumber :: ToDBObject Number where
	toDBObject = Number

instance toDBObjectChar :: ToDBObject Char where
	toDBObject = Str.singleton >>> String

instance toDBObjectString :: ToDBObject String where
	toDBObject = String

instance toDBObjectRegex :: ToDBObject Regex where
	toDBObject = source >>> String

instance toDBObjectDateTime :: ToDBObject DateTime where
	toDBObject = fromDateTime >>> toISOString >>> String

instance toDBObjectArray :: ToDBObject a => ToDBObject (Array a) where
	toDBObject = Array <<< map toDBObject

instance toDBObjectForeign :: ToDBObject F.Foreign where
	toDBObject = fromForeign

instance toDBObjectOrdering :: ToDBObject Ordering where
	toDBObject LT = String "LT"
	toDBObject EQ = String "EQ"
	toDBObject GT = String "GT"

instance toDBObjectTuple :: (ToDBObject a, ToDBObject b) => ToDBObject (Tuple a b) where
	toDBObject (Tuple a b) = Array [toDBObject a, toDBObject b]

instance toDBObjectMaybe :: ToDBObject a => ToDBObject (Maybe a) where
	toDBObject = Maybe <<< map toDBObject

instance toDBObjectEither :: (ToDBObject a, ToDBObject b) => ToDBObject (Either a b) where
	toDBObject (Left  l) = dbObject [ "Left"  .= l ]
	toDBObject (Right r) = dbObject [ "Right" .= r ]

instance toDBObjectList :: ToDBObject a => ToDBObject (List a) where
	toDBObject = toUnfoldable' >>> toDBObject
		where
			toUnfoldable' :: List a -> Array a
			toUnfoldable' = toUnfoldable

instance toDBObjectNonEmptyList :: ToDBObject a => ToDBObject (NE.NonEmptyList a) where
	toDBObject = NE.toList >>> toDBObject

instance toDBObjectSet :: ToDBObject a => ToDBObject (S.Set a) where
	toDBObject = toUnfoldable' >>> toDBObject
		where
			toUnfoldable' :: forall a'. ToDBObject a =>
					 S.Set a'                ->
					 Array a'
			toUnfoldable' = S.toUnfoldable

instance toDBObjectStrMap :: ToDBObject a => ToDBObject (M.StrMap a) where
	toDBObject = toUnfoldable' >>> map toProp >>> dbObject -- XXX Maybe I can move this to JS to avoid the O(n*2)
		where
			toUnfoldable' :: M.StrMap a -> Array (Tuple String a)
			toUnfoldable' = M.toUnfoldable

			toProp (Tuple k v) = k .= v

class (FromDBObject a, ToDBObject a) <= IsDBObject a

instance dbObjectIsDBObject        :: IsDBObject DBObject
instance undefinedIsDBObject       :: IsDBObject a => IsDBObject (Undefined a)
instance nullIsDBObject            :: IsDBObject a => IsDBObject (Null a)
instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)
instance unitIsDBObject            :: IsDBObject Unit
instance booleanIsDBObject         :: IsDBObject Boolean
instance intIsDBObject             :: IsDBObject Int
instance numberIsDBObject          :: IsDBObject Number
instance charIsDBObject            :: IsDBObject Char
instance stringIsDBObject          :: IsDBObject String
instance regexIsDBObject           :: IsDBObject Regex
instance datetimeIsDBObject        :: IsDBObject DateTime
instance arrayIsDBObject           :: IsDBObject a => IsDBObject (Array a)
instance foreignIsDBObject         :: IsDBObject F.Foreign
instance orderingIsDBObject        :: IsDBObject Ordering
instance tupleIsDBObject           :: (IsDBObject a, IsDBObject b) => IsDBObject (Tuple a b)
instance maybeIsDBObject           :: IsDBObject a => IsDBObject (Maybe a)
instance eitherIsDBObject          :: (IsDBObject a, IsDBObject b) => IsDBObject (Either a b)
instance listIsDBObject            :: IsDBObject a => IsDBObject (List a)
instance nonEmptyListIsDBObject    :: IsDBObject a => IsDBObject (NE.NonEmptyList a)
instance setIsDBObject             :: (IsDBObject a, Ord a) => IsDBObject (S.Set a)
instance strMapIsDBObject          :: IsDBObject a => IsDBObject (M.StrMap a)

class Database datastore where
	openConnection :: forall e. String -> Aff (db :: DATABASE | e) datastore

	closeConnection :: forall e. datastore -> Aff (db :: DATABASE | e) Unit

	createCollection :: forall e. String ->
			    datastore        ->
			    Aff (db :: DATABASE | e) Unit

	getCollection    :: forall e t. String ->
			    datastore          ->
			    Aff (db :: DATABASE, ref :: REF | e) (Ref (Collection t))

	deleteCollection :: forall e. String ->
			    datastore        ->
			    Aff (db :: DATABASE | e) Unit

	getWhere :: forall e t. FromDBObject t   =>
		    Maybe Pagination             ->
		    Query t                      ->
		    Ref (Collection t)           ->
		    Aff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e t. FromDBObject t  =>
		    Maybe Pagination             ->
		    Query t                      ->
		    Ref (Collection t)           ->
		    Aff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e t. FromDBObject t   =>
		      Query t                      ->
		      Ref (Collection t)           ->
		      Aff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. ToDBObject t   =>
		  t                            ->
		  Ref (Collection t)           ->
		  Aff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. ToDBObject t   =>
		   List t                       ->
		   Ref (Collection t)           ->
		   Aff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t b. ToDBObject t   =>
		       Query t                      ->
		       Ref (Collection t)           ->
		       Aff (db :: DATABASE, ref :: REF | e) b


start rewrite Canvas.purs to use Layer

start rewrite Canvas.purs to use Layer

-- | This module provides a HTML5 canvas interface for the genetics browser,
-- | which wraps and optimizes all rendering calls

module Genetics.Browser.Canvas where

import Prelude

import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Uncurried (EffFn2, EffFn3, EffFn4, runEffFn2, runEffFn3, runEffFn4)
import DOM.Node.Types (Element)
import Data.Either (Either(..))
import Data.Foldable (any, fold, foldl, for_)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', Traversal', iso, lens, lens', prism', re, to, united, view, (^.), (^?))
import Data.Lens.Iso (Iso')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, onMatch)
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerDimensions, LayerSlots, LayerType(..), LayerPadding, layerSlots)
import Graphics.Canvas (CanvasElement, Context2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing (render, translate) as Drawing
import Graphics.Drawing.Font (font, fontString) as Drawing
import Graphics.Drawing.Font (sansSerif)
import Unsafe.Coerce (unsafeCoerce)

_Element :: Iso' CanvasElement Element
_Element = iso unsafeCoerce unsafeCoerce

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS class
foreign import createCanvas :: ∀ eff.
                               { width :: Number, height :: Number }
                            -> String
                            -> Eff eff CanvasElement

foreign import setElementStyleImpl :: ∀ e.
                                      EffFn3 e
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Eff _ Unit
setElementStyle = runEffFn3 setElementStyleImpl

setElementStyles :: Element -> Array (Tuple String String) -> Eff _ Unit
setElementStyles el =
  traverse_ (uncurry $ setElementStyle el)

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Eff _ Unit
setCanvasStyles = setElementStyles <<< view _Element

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Eff _ Unit
setCanvasStyle ce = setElementStyle (ce ^. _Element)

setCanvasZIndex :: CanvasElement -> Int -> Eff _ Unit
setCanvasZIndex ce i = setCanvasStyle ce "z-index" (show i)

setCanvasPosition :: ∀ r.
                     { left :: Number, top :: Number | r }
                  -> CanvasElement
                  -> Eff _ Unit
setCanvasPosition {left, top} ce =
  setCanvasStyles ce
    [ Tuple "position" "absolute"
    , Tuple "top"  (show top  <> "px")
    , Tuple "left" (show left <> "px") ]

foreign import appendCanvasElem :: ∀ e.
                                   Element
                                -> CanvasElement
                                -> Eff e Unit

-- | Sets some of the browser container's CSS to reasonable defaults
foreign import setContainerStyle :: ∀ e. Element -> Canvas.Dimensions -> Eff e Unit

foreign import drawCopies :: ∀ eff a.
                             EffFn4 eff
                             CanvasElement Canvas.Dimensions Context2D (Array Point)
                             Unit

foreign import setCanvasTranslation :: ∀ e.
                                       Point
                                    -> CanvasElement
                                    -> Eff e Unit

foreign import canvasClickImpl :: ∀ e.
                                  EffFn2 e
                                  CanvasElement (Point -> Eff e Unit)
                                  Unit

canvasClick :: CanvasElement -> (Point -> Eff _ Unit) -> Eff _ Unit
canvasClick = runEffFn2 canvasClickImpl

-- | Attaches two callbacks to the BrowserCanvas click event handler,
-- | provided with the track canvas and static overlay canvas' relative
-- | coordinates of the click, respectively.
browserOnClick :: BrowserCanvas
               -> { track   :: Point -> Eff _ Unit
                  , overlay :: Point -> Eff _ Unit }
               -> Eff _ Unit
browserOnClick (BrowserCanvas bc) {track, overlay} =
  canvasClick bc.staticOverlay \o -> do
    let t = { x: o.x - bc.trackPadding.left
            , y: o.y - bc.trackPadding.top }
    overlay o
    track t

foreign import scrollCanvasImpl :: ∀ e.
                                   EffFn3 e
                                   CanvasElement CanvasElement Point
                                   Unit

scrollCanvas :: BufferedCanvas
             -> Point
             -> Eff _ Unit
scrollCanvas (BufferedCanvas bc) = runEffFn3 scrollCanvasImpl bc.back bc.front

scrollCanvas' :: BrowserContainer
              -> Point
              -> Eff _ Unit
scrollCanvas' (BrowserContainer {layers}) pt =
  for_ layers $ \lc -> case lc ^? _LayerCanvas <<< _Buffer of
    Nothing -> pure unit
    Just bc -> scrollCanvas bc pt

foreign import canvasDragImpl :: ∀ eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

foreign import canvasWheelCBImpl :: ∀ eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- | Takes a BrowserCanvas and a callback function that is called with the
-- | total dragged distance when a click & drag action is completed.
dragScroll :: BrowserCanvas
           -> (Point -> Eff _ Unit)
           -> Eff _ Unit
dragScroll (BrowserCanvas bc) cb = canvasDrag f bc.staticOverlay
  where f = case _ of
              Left  p     -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas (_.canvas $ unwrap bc.track) p'
                scrollCanvas bc.trackOverlay p'

dragScroll' :: BrowserContainer
            -> (Point -> Eff _ Unit)
            -> Eff _ Unit
dragScroll' bc@(BrowserContainer { element }) cb =
  canvasDrag f (unsafeCoerce element) -- actually safe
  where f = case _ of
              Left  p    -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas' bc p'

-- | Takes a BrowserCanvas and a callback function that is called with each
-- | wheel scroll `deltaY`. Callback is provided with only the sign of `deltaY`
-- | as to be `deltaMode` agnostic.
wheelZoom :: BrowserCanvas
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom (BrowserCanvas bc) cb =
  canvasWheelCBImpl bc.staticOverlay cb

-- | Helper function for erasing the contents of a canvas context given its dimensions
clearCanvas :: Context2D -> Canvas.Dimensions -> Eff _ Unit
clearCanvas ctx {width, height} =
  void $ Canvas.clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

blankLayer :: LayerContainer
           -> Eff _ Unit
blankLayer (LayerContainer ld lc) =
  case lc of
    Buffer bc -> blankBuffer bc
    Static el -> do
      setCanvasTranslation {x: zero, y: zero} el
      ctx <- Canvas.getContext2D el
      clearCanvas ctx ld.size

-- TODO browser background color shouldn't be hardcoded
backgroundColor :: String
backgroundColor = "white"

-- TODO the back canvas should have the option of being bigger than
-- the front, to minimize redrawing
-- needs adding the offset of the front canvas, and validating that back >= front
newtype BufferedCanvas =
  BufferedCanvas { back  :: CanvasElement
                 , front :: CanvasElement
                 }

derive instance newtypeBufferedCanvas :: Newtype BufferedCanvas _

createBufferedCanvas :: Canvas.Dimensions
                     -> Eff _ BufferedCanvas
createBufferedCanvas dim = do
  back  <- createCanvas dim "buffer"
  front <- createCanvas dim "front"
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

getBufferedContext :: BufferedCanvas
                   -> Eff _ Context2D
getBufferedContext = Canvas.getContext2D <$> _.front <<< unwrap

setBufferedCanvasSize :: Canvas.Dimensions
                      -> BufferedCanvas
                      -> Eff _ Unit
setBufferedCanvasSize dim bc@(BufferedCanvas {back, front}) = do
  _ <- Canvas.setCanvasDimensions dim back
  _ <- Canvas.setCanvasDimensions dim front
  blankBuffer bc
  pure unit

translateBuffer :: Point
                -> BufferedCanvas
                -> Eff _ Unit
translateBuffer p (BufferedCanvas bc) = do
  setCanvasTranslation p bc.back
  setCanvasTranslation p bc.front

drawToBuffer :: BufferedCanvas
             -> (Context2D -> Eff _ Unit)
             -> Eff _ Unit
drawToBuffer (BufferedCanvas {back}) f = do
  ctx <- Canvas.getContext2D back
  f ctx

blankBuffer :: BufferedCanvas
            -> Eff _ Unit
blankBuffer bc@(BufferedCanvas {back, front}) = do
  translateBuffer {x: zero, y: zero} bc

  dim <- Canvas.getCanvasDimensions back

  for_ [back, front]
    $ flip clearCanvas dim <=< Canvas.getContext2D

flipBuffer :: BufferedCanvas
           -> Eff _ Unit
flipBuffer (BufferedCanvas {back, front}) = do
-- NOTE this assumes back and front are the same size
  frontCtx <- Canvas.getContext2D front
  let imgSrc = Canvas.canvasElementToImageSource back

  dim <- Canvas.getCanvasDimensions front

  clearCanvas frontCtx dim
  _ <- Canvas.drawImage frontCtx imgSrc 0.0 0.0
  pure unit

-- | The `width` & `height` of the TrackCanvas is the area glyphs render to;
-- | the browser shows a `width` pixels slice of the whole coordinate system.
-- | `glyphBuffer` is what individual glyphs can be rendered to and copied from, for speed.
newtype TrackCanvas =
  TrackCanvas { canvas      :: BufferedCanvas
              , dimensions  :: Canvas.Dimensions
              , glyphBuffer :: CanvasElement
              }

-- | using hardcoded inner padding for now; makes it look a bit better
trackInnerPad :: Number
trackInnerPad = 5.0

derive instance newtypeTrackCanvas :: Newtype TrackCanvas _

_Dimensions :: ∀ n r1 r2.
               Newtype n { dimensions :: Canvas.Dimensions | r1 }
            => Lens' n Canvas.Dimensions
_Dimensions = _Newtype <<< Lens.prop (SProxy :: SProxy "dimensions")

trackTotalDimensions :: Canvas.Dimensions -> Canvas.Dimensions
trackTotalDimensions d = { width:  d.width  + extra
                         , height: d.height + extra }
  where extra = 2.0 * trackInnerPad

-- TODO calculate based on glyph bounding boxes
glyphBufferSize :: Canvas.Dimensions
glyphBufferSize = { width: 15.0, height: 300.0 }

trackCanvas :: Canvas.Dimensions
            -> Eff _ TrackCanvas
trackCanvas dim = do
  canvas <- createBufferedCanvas $ trackTotalDimensions dim
  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  pure $ TrackCanvas { dimensions: dim
                     , canvas, glyphBuffer }

setTrackCanvasSize :: Canvas.Dimensions
                   -> TrackCanvas
                   -> Eff _ TrackCanvas
setTrackCanvasSize dim (TrackCanvas tc) = do
  setBufferedCanvasSize (trackTotalDimensions dim) tc.canvas
  pure $ TrackCanvas
    $ tc { dimensions = dim }

-- TODO change name to BrowserPadding
type TrackPadding =
  { left :: Number, right :: Number
  , top :: Number, bottom :: Number }

-- | A `BrowserCanvas` consists of a double-buffered `track`
-- | which is what the genetics browser view is rendered onto,
-- | and a transparent `staticOverlay` canvas the UI is rendered onto,
-- | with a (also transparent) `trackOverlay` that scrolls with the track view.

-- | The `dimensions`, `trackPadding`, and track.width/height are
-- | related such that
-- | track.width + horizontal.left + horizontal.right = dimensions.width
-- | track.height + vertical.top + vertical.bottom = dimensions.height
newtype BrowserCanvas =
  BrowserCanvas { track         :: TrackCanvas
                , trackPadding  :: TrackPadding
                , dimensions    :: Canvas.Dimensions
                , staticOverlay :: CanvasElement
                , trackOverlay  :: BufferedCanvas
                , container :: Element
                }

derive instance newtypeBrowserCanvas :: Newtype BrowserCanvas _

newtype BrowserContainer =
  BrowserContainer { layers     :: List LayerContainer
                   , padding    :: LayerPadding      -- ?
                   , dimensions :: Canvas.Dimensions -- ?
                   , element    :: Element }

_Track :: Lens' BrowserCanvas TrackCanvas
_Track = _Newtype <<< Lens.prop (SProxy :: SProxy "track")

foreign import debugBrowserCanvas :: ∀ e.
                                     String
                                  -> BrowserCanvas
                                  -> Eff e Unit

subtractPadding :: Canvas.Dimensions
                -> TrackPadding
                -> Canvas.Dimensions
subtractPadding {width, height} pad =
  { width:  width - pad.left - pad.right
  , height: height - pad.top - pad.bottom }

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

data UISlotGravity = UILeft | UIRight | UITop | UIBottom

derive instance eqUISlotGravity :: Eq UISlotGravity
derive instance ordUISlotGravity :: Ord UISlotGravity

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

uiSlots :: BrowserCanvas
        -> UISlots
uiSlots (BrowserCanvas bc) =
  let track   = subtractPadding bc.dimensions bc.trackPadding
      browser = bc.dimensions
      pad     = bc.trackPadding
  in { left:   { offset: { x: 0.0, y: pad.top }
               , size:   { height: track.height, width: pad.left }}
     , right:  { offset: { x: browser.width - pad.right, y: pad.top }
               , size:   { height: track.height, width: pad.right }}
     , top:    { offset: { x: pad.left, y: 0.0 }
               , size:   { height: pad.top, width: track.width }}
     , bottom: { offset: { x: browser.width  - pad.right
                         , y: browser.height - pad.bottom }
               , size:   { height: pad.bottom, width: track.width }}
    }

setBrowserCanvasSize :: Canvas.Dimensions
                     -> BrowserCanvas
                     -> Eff _ BrowserCanvas
setBrowserCanvasSize dim (BrowserCanvas bc) = do

  setContainerStyle bc.container dim
  let trackDim = subtractPadding dim bc.trackPadding

  track <- setTrackCanvasSize trackDim bc.track

  setBufferedCanvasSize dim bc.trackOverlay
  _ <- Canvas.setCanvasDimensions dim bc.staticOverlay

  pure $ BrowserCanvas
       $ bc { dimensions = dim
            , track = track }

-- | Creates a `BrowserCanvas` and appends it to the provided element.
-- | Resizes the container element to fit.
browserCanvas :: Canvas.Dimensions
              -> TrackPadding
              -> Element
              -> Eff _ BrowserCanvas
browserCanvas dimensions trackPadding el = do

  setContainerStyle el dimensions

  let trackDim = subtractPadding dimensions trackPadding
  track   <- trackCanvas trackDim

  trackOverlay  <- createBufferedCanvas { width: trackDim.width
                                        , height: dimensions.height }

  staticOverlay <- createCanvas dimensions "staticOverlay"

  let trackEl = _.front  $ unwrap
                $ _.canvas $ unwrap $ track

      trackOverlayEl = _.front $ unwrap $ trackOverlay

  setCanvasZIndex trackEl 10
  setCanvasZIndex trackOverlayEl 20
  setCanvasZIndex staticOverlay 30

  -- TODO handle this nicer maybe idk
  let trackElPosition = { left: trackPadding.left - trackInnerPad
                        , top:  trackPadding.top  - trackInnerPad }

  setCanvasPosition trackElPosition trackEl
  setCanvasPosition { left: trackPadding.left, top: 0.0 } trackOverlayEl
  setCanvasPosition { left: 0.0, top: 0.0} staticOverlay

  appendCanvasElem el trackEl
  appendCanvasElem el trackOverlayEl
  appendCanvasElem el staticOverlay

  pure $ BrowserCanvas { dimensions
                       , track, trackPadding
                       , trackOverlay, staticOverlay
                       , container: el}

renderGlyphs :: TrackCanvas
             -> { drawing :: Drawing, points :: Array Point }
             -> Eff _ Unit
renderGlyphs (TrackCanvas tc) {drawing, points} = do
  glyphBfr <- Canvas.getContext2D tc.glyphBuffer
  ctx <- getBufferedContext tc.canvas

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphBfr glyphBufferSize

  Drawing.render glyphBfr
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies tc.glyphBuffer glyphBufferSize ctx points

type Label = { text :: String, point :: Point, gravity :: LabelPlace }

data LabelPlace = LLeft | LCenter | LRight

derive instance eqLabelPlace :: Eq LabelPlace

-- hardcoded global label font for now
-- can't use Drawing.Font because we need raw Canvas to measure the text size,
-- but we can at least use Drawing to generate the font string

labelFontSize :: Int
labelFontSize = 14

labelFont :: String
labelFont = Drawing.fontString $ Drawing.font sansSerif labelFontSize mempty

-- | Calculate the rectangle covered by a label when it'd be rendered
-- | to a provided canvas context
labelBox :: Context2D -> Label -> Eff _ Canvas.Rectangle
labelBox ctx {text, point, gravity} = do
  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx
    Canvas.measureText ctx text

  -- close enough height, actually calculating it is a nightmare
  let height = Int.toNumber labelFontSize
      pad = 14.0 + width / 2.0
      x = case gravity of
        LCenter -> point.x
        LLeft   -> point.x - pad
        LRight  -> point.x + pad

  pure $ { x
         , y: point.y - height
         , w: width, h: height }

-- | Returns `true` if the input rectangles overlap
isOverlapping :: Canvas.Rectangle
              -> Canvas.Rectangle
              -> Boolean
isOverlapping r1 r2 =
     r1.x < r2.x + r2.w
  && r1.x + r1.w > r2.x
  && r1.y < r2.y + r2.h
  && r1.h + r1.y > r2.y

eqRectangle :: Canvas.Rectangle
            -> Canvas.Rectangle
            -> Boolean
eqRectangle {x,y,w,h} r =
     x == r.x && y == r.y
  && w == r.w && h == r.h

appendBoxed :: ∀ r.
               Array {rect :: Canvas.Rectangle | r}
            -> {rect :: Canvas.Rectangle | r}
            -> Array {rect :: Canvas.Rectangle | r}
appendBoxed sofar next =
  let overlapsAny :: Boolean
      overlapsAny = any overlaps sofar
        where overlaps r' = (not $ eqRectangle next.rect r'.rect)
                            && next.rect `isOverlapping` r'.rect
  in if overlapsAny then sofar else sofar <> [next]

renderLabels :: Array Label -> Context2D -> Eff _ Unit
renderLabels ls ctx = do

  boxed <- traverse (\l -> {text: l.text, rect: _} <$> labelBox ctx l) ls

  let toRender = foldl appendBoxed [] boxed

  Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx

    for_ toRender \box ->
      Canvas.fillText ctx box.text
        (box.rect.x - (box.rect.w / 2.0))
        box.rect.y

type Renderable r = { drawings :: Array { drawing :: Drawing
                                        , points :: Array Point }
                    , labels :: Array Label | r }

renderBrowser :: ∀ a b c.
                 Milliseconds
              -> BrowserCanvas
              -> Number
              -> { tracks     :: { snps :: Renderable a
                                 , annotations :: Renderable b }
                 , relativeUI :: Drawing
                 , fixedUI :: Drawing }
             -> Aff _ Unit
renderBrowser d (BrowserCanvas bc) offset ui = do

  let
      labels = ui.tracks.snps.labels <> ui.tracks.annotations.labels

  -- Render the UI
  liftEff do
    staticOverlayCtx <- Canvas.getContext2D bc.staticOverlay

    clearCanvas staticOverlayCtx bc.dimensions
    Drawing.render staticOverlayCtx ui.fixedUI

    translateBuffer {x: zero, y: zero} bc.trackOverlay
    blankBuffer bc.trackOverlay

    translateBuffer {x: (-offset), y: zero} bc.trackOverlay
    trackOverlayCtx <- getBufferedContext bc.trackOverlay

    Drawing.render trackOverlayCtx ui.relativeUI

    translateBuffer {x: (-offset), y: bc.trackPadding.top} bc.trackOverlay
    renderLabels labels trackOverlayCtx

  -- Render the tracks
  let bfr = (unwrap bc.track).canvas
      cnv = (unwrap bfr).front

  -- TODO extract functions `clearTrack` and `translateTrack` that bake in padding
  ctx <- liftEff $ Canvas.getContext2D cnv
  liftEff do
    dim <- Canvas.getCanvasDimensions cnv

    translateBuffer {x: zero, y: zero} bfr
    clearCanvas ctx $ trackTotalDimensions dim

  liftEff $ translateBuffer { x: trackInnerPad - offset
                            , y: trackInnerPad } bfr

  let snpsTrack  = ui.tracks.snps.drawings
      annotTrack = ui.tracks.annotations.drawings

  for_ [snpsTrack, annotTrack] \t ->
    for_ t \s -> do
      liftEff $ renderGlyphs bc.track s
      delay d

data LayerContainer =
    LayerContainer LayerDimensions LayerCanvas

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_LayerCanvas :: Lens' LayerContainer LayerCanvas
_LayerCanvas = lens
         (\(LayerContainer _ ct)    -> ct)
         (\(LayerContainer ld _) ct -> LayerContainer ld ct)

_FrontCanvas :: Getter' LayerCanvas CanvasElement
_FrontCanvas = to case _ of
  Static c -> c
  Buffer c -> (unwrap c).front

_Buffer :: Prism' LayerCanvas BufferedCanvas
_Buffer = prism' Buffer from
  where from (Static _) = Nothing
        from (Buffer b) = Just b

_Static :: Prism' LayerCanvas CanvasElement
_Static = prism' Static $ case _ of
  Static el -> Just el
  Buffer _  -> Nothing

_LayerBuffer :: Traversal' LayerContainer BufferedCanvas
_LayerBuffer = _LayerCanvas <<< _Buffer

layerContainer :: ∀ a.
               Layer a -> LayerDimensions -> Eff _ LayerContainer
layerContainer (Layer lt _ c) lDim = do

  let slots = layerSlots lDim

  let {size, pos} = case c of
        Padded _ _ -> let p' = lDim.padding
                      in { size: slots.padded.size, pos: { left: p'.left, top: p'.top } }
        _        ->      { size: slots.full.size,   pos: { left: 0.0, top: 0.0 } }

  canvas <-
    case lt of
      Fixed     -> Static <$> createCanvas         size "fixed"
      Scrolling -> Buffer <$> createBufferedCanvas size

  setCanvasPosition pos (canvas ^. _FrontCanvas)

  pure $ unsafeCoerce unit

type LayerRenderable =
  Variant ( fixed    :: Drawing
          , drawings :: Array { drawing :: Drawing
                              , points :: Array Point }
          , labels   :: Array Label )

runLayer' :: ∀ m.
             Monoid m
          => Layer (ComponentSlot -> m)
          -> LayerContainer
          -> m
runLayer' layer@(Layer lt lm com) c@(LayerContainer ld ct) =
  let slots = layerSlots ld
  in case com of
      Full     f -> f slots.full
      Padded r f -> f slots.padded
      Outside  f -> fold [ f.top    slots.top
                         , f.right  slots.right
                         , f.bottom slots.bottom
                         , f.left   slots.left ]

layerContext :: ∀ a.
                Layer a
             -> LayerContainer
             -> Eff _ Context2D
layerContext (Layer _ _ com) (LayerContainer ld ct) = do
  ctx <- Canvas.getContext2D $ ct ^. _FrontCanvas
  _ <- Canvas.transform { m11: one,  m21: zero, m31: zero
                        , m12: zero, m22: one,  m32: zero } ctx
  case com of
    -- translate to 0.0, 0.0
    Full     _ -> pure ctx
    -- translate inward by the padding
    Padded r _ -> Canvas.translate { translateX: r, translateY: r } ctx
    Outside  _ -> do
      -- translate to 0.0, set mask to not draw on the padded canvas
      _ <- Canvas.beginPath ctx
      _ <- Canvas.moveTo ctx 0.0           0.0
      _ <- Canvas.lineTo ctx ld.size.width 0.0
      _ <- Canvas.lineTo ctx ld.size.width ld.size.height
      _ <- Canvas.lineTo ctx 0.0           ld.size.height
      _ <- Canvas.lineTo ctx 0.0           0.0
      Canvas.clip ctx

-- | This module provides a HTML5 canvas interface for the genetics browser,
-- | which wraps and optimizes all rendering calls

module Genetics.Browser.Canvas where

import Prelude

import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Uncurried (EffFn2, EffFn3, EffFn4, runEffFn2, runEffFn3, runEffFn4)
import DOM.Node.Types (Element)
import Data.Either (Either(..))
import Data.Foldable (any, foldl, for_)
import Data.Int as Int
import Data.Lens (Getter', Lens', iso, lens, re, to, view, (^.))
import Data.Lens.Iso (Iso')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (case_, onMatch)
import Genetics.Browser.Layer (Component(..), Layer(..), LayerDimensions, LayerType(..), layerSlots)
import Graphics.Canvas (CanvasElement, Context2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing (render, translate) as Drawing
import Graphics.Drawing.Font (font, fontString) as Drawing
import Graphics.Drawing.Font (sansSerif)
import Unsafe.Coerce (unsafeCoerce)

_Element :: Iso' CanvasElement Element
_Element = iso unsafeCoerce unsafeCoerce

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS class
foreign import createCanvas :: ∀ eff.
                               { width :: Number, height :: Number }
                            -> String
                            -> Eff eff CanvasElement

foreign import setElementStyleImpl :: ∀ e.
                                      EffFn3 e
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Eff _ Unit
setElementStyle = runEffFn3 setElementStyleImpl

setElementStyles :: Element -> Array (Tuple String String) -> Eff _ Unit
setElementStyles el =
  traverse_ (uncurry $ setElementStyle el)

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Eff _ Unit
setCanvasStyles = setElementStyles <<< view _Element

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Eff _ Unit
setCanvasStyle ce = setElementStyle (ce ^. _Element)

setCanvasZIndex :: CanvasElement -> Int -> Eff _ Unit
setCanvasZIndex ce i = setCanvasStyle ce "z-index" (show i)

setCanvasPosition :: ∀ r.
                     { left :: Number, top :: Number | r }
                  -> CanvasElement
                  -> Eff _ Unit
setCanvasPosition {left, top} ce =
  setCanvasStyles ce
    [ Tuple "position" "absolute"
    , Tuple "top"  (show top  <> "px")
    , Tuple "left" (show left <> "px") ]

foreign import appendCanvasElem :: ∀ e.
                                   Element
                                -> CanvasElement
                                -> Eff e Unit

-- | Sets some of the browser container's CSS to reasonable defaults
foreign import setContainerStyle :: ∀ e. Element -> Canvas.Dimensions -> Eff e Unit

foreign import drawCopies :: ∀ eff a.
                             EffFn4 eff
                             CanvasElement Canvas.Dimensions Context2D (Array Point)
                             Unit

foreign import setCanvasTranslation :: ∀ e.
                                       Point
                                    -> CanvasElement
                                    -> Eff e Unit

foreign import canvasClickImpl :: ∀ e.
                                  EffFn2 e
                                  CanvasElement (Point -> Eff e Unit)
                                  Unit

canvasClick :: CanvasElement -> (Point -> Eff _ Unit) -> Eff _ Unit
canvasClick = runEffFn2 canvasClickImpl

-- | Attaches two callbacks to the BrowserCanvas click event handler,
-- | provided with the track canvas and static overlay canvas' relative
-- | coordinates of the click, respectively.
browserOnClick :: BrowserCanvas
               -> { track   :: Point -> Eff _ Unit
                  , overlay :: Point -> Eff _ Unit }
               -> Eff _ Unit
browserOnClick (BrowserCanvas bc) {track, overlay} =
  canvasClick bc.staticOverlay \o -> do
    let t = { x: o.x - bc.trackPadding.left
            , y: o.y - bc.trackPadding.top }
    overlay o
    track t

foreign import scrollCanvasImpl :: ∀ e.
                                   EffFn3 e
                                   CanvasElement CanvasElement Point
                                   Unit

scrollCanvas :: BufferedCanvas
             -> Point
             -> Eff _ Unit
scrollCanvas (BufferedCanvas bc) = runEffFn3 scrollCanvasImpl bc.back bc.front

foreign import canvasDragImpl :: ∀ eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

foreign import canvasWheelCBImpl :: ∀ eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- | Takes a BrowserCanvas and a callback function that is called with the
-- | total dragged distance when a click & drag action is completed.
dragScroll :: BrowserCanvas
           -> (Point -> Eff _ Unit)
           -> Eff _ Unit
dragScroll (BrowserCanvas bc) cb = canvasDrag f bc.staticOverlay
  where f = case _ of
              Left  p     -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas (_.canvas $ unwrap bc.track) p'
                scrollCanvas bc.trackOverlay p'

-- | Takes a BrowserCanvas and a callback function that is called with each
-- | wheel scroll `deltaY`. Callback is provided with only the sign of `deltaY`
-- | as to be `deltaMode` agnostic.
wheelZoom :: BrowserCanvas
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom (BrowserCanvas bc) cb =
  canvasWheelCBImpl bc.staticOverlay cb

-- | Helper function for erasing the contents of a canvas context given its dimensions
clearCanvas :: Context2D -> Canvas.Dimensions -> Eff _ Unit
clearCanvas ctx {width, height} =
  void $ Canvas.clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

-- TODO browser background color shouldn't be hardcoded
backgroundColor :: String
backgroundColor = "white"

-- TODO the back canvas should have the option of being bigger than
-- the front, to minimize redrawing
-- needs adding the offset of the front canvas, and validating that back >= front
newtype BufferedCanvas =
  BufferedCanvas { back  :: CanvasElement
                 , front :: CanvasElement
                 }

derive instance newtypeBufferedCanvas :: Newtype BufferedCanvas _

createBufferedCanvas :: Canvas.Dimensions
                     -> Eff _ BufferedCanvas
createBufferedCanvas dim = do
  back  <- createCanvas dim "buffer"
  front <- createCanvas dim "front"
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

getBufferedContext :: BufferedCanvas
                   -> Eff _ Context2D
getBufferedContext = Canvas.getContext2D <$> _.front <<< unwrap

setBufferedCanvasSize :: Canvas.Dimensions
                      -> BufferedCanvas
                      -> Eff _ Unit
setBufferedCanvasSize dim bc@(BufferedCanvas {back, front}) = do
  _ <- Canvas.setCanvasDimensions dim back
  _ <- Canvas.setCanvasDimensions dim front
  blankBuffer bc
  pure unit

translateBuffer :: Point
                -> BufferedCanvas
                -> Eff _ Unit
translateBuffer p (BufferedCanvas bc) = do
  setCanvasTranslation p bc.back
  setCanvasTranslation p bc.front

drawToBuffer :: BufferedCanvas
             -> (Context2D -> Eff _ Unit)
             -> Eff _ Unit
drawToBuffer (BufferedCanvas {back}) f = do
  ctx <- Canvas.getContext2D back
  f ctx

blankBuffer :: BufferedCanvas
            -> Eff _ Unit
blankBuffer bc@(BufferedCanvas {back, front}) = do
  translateBuffer {x: zero, y: zero} bc

  dim <- Canvas.getCanvasDimensions back

  for_ [back, front]
    $ flip clearCanvas dim <=< Canvas.getContext2D

flipBuffer :: BufferedCanvas
           -> Eff _ Unit
flipBuffer (BufferedCanvas {back, front}) = do
-- NOTE this assumes back and front are the same size
  frontCtx <- Canvas.getContext2D front
  let imgSrc = Canvas.canvasElementToImageSource back

  dim <- Canvas.getCanvasDimensions front

  clearCanvas frontCtx dim
  _ <- Canvas.drawImage frontCtx imgSrc 0.0 0.0
  pure unit

-- | The `width` & `height` of the TrackCanvas is the area glyphs render to;
-- | the browser shows a `width` pixels slice of the whole coordinate system.
-- | `glyphBuffer` is what individual glyphs can be rendered to and copied from, for speed.
newtype TrackCanvas =
  TrackCanvas { canvas      :: BufferedCanvas
              , dimensions  :: Canvas.Dimensions
              , glyphBuffer :: CanvasElement
              }

-- | using hardcoded inner padding for now; makes it look a bit better
trackInnerPad :: Number
trackInnerPad = 5.0

derive instance newtypeTrackCanvas :: Newtype TrackCanvas _

_Dimensions :: ∀ n r1 r2.
               Newtype n { dimensions :: Canvas.Dimensions | r1 }
            => Lens' n Canvas.Dimensions
_Dimensions = _Newtype <<< Lens.prop (SProxy :: SProxy "dimensions")

trackTotalDimensions :: Canvas.Dimensions -> Canvas.Dimensions
trackTotalDimensions d = { width:  d.width  + extra
                         , height: d.height + extra }
  where extra = 2.0 * trackInnerPad

-- TODO calculate based on glyph bounding boxes
glyphBufferSize :: Canvas.Dimensions
glyphBufferSize = { width: 15.0, height: 300.0 }

trackCanvas :: Canvas.Dimensions
            -> Eff _ TrackCanvas
trackCanvas dim = do
  canvas <- createBufferedCanvas $ trackTotalDimensions dim
  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  pure $ TrackCanvas { dimensions: dim
                     , canvas, glyphBuffer }

setTrackCanvasSize :: Canvas.Dimensions
                   -> TrackCanvas
                   -> Eff _ TrackCanvas
setTrackCanvasSize dim (TrackCanvas tc) = do
  setBufferedCanvasSize (trackTotalDimensions dim) tc.canvas
  pure $ TrackCanvas
    $ tc { dimensions = dim }

-- TODO change name to BrowserPadding
type TrackPadding =
  { left :: Number, right :: Number
  , top :: Number, bottom :: Number }

-- | A `BrowserCanvas` consists of a double-buffered `track`
-- | which is what the genetics browser view is rendered onto,
-- | and a transparent `staticOverlay` canvas the UI is rendered onto,
-- | with a (also transparent) `trackOverlay` that scrolls with the track view.

-- | The `dimensions`, `trackPadding`, and track.width/height are
-- | related such that
-- | track.width + horizontal.left + horizontal.right = dimensions.width
-- | track.height + vertical.top + vertical.bottom = dimensions.height
newtype BrowserCanvas =
  BrowserCanvas { track         :: TrackCanvas
                , trackPadding  :: TrackPadding
                , dimensions    :: Canvas.Dimensions
                , staticOverlay :: CanvasElement
                , trackOverlay  :: BufferedCanvas
                , container :: Element
                }

derive instance newtypeBrowserCanvas :: Newtype BrowserCanvas _

_Track :: Lens' BrowserCanvas TrackCanvas
_Track = _Newtype <<< Lens.prop (SProxy :: SProxy "track")

foreign import debugBrowserCanvas :: ∀ e.
                                     String
                                  -> BrowserCanvas
                                  -> Eff e Unit

subtractPadding :: Canvas.Dimensions
                -> TrackPadding
                -> Canvas.Dimensions
subtractPadding {width, height} pad =
  { width:  width - pad.left - pad.right
  , height: height - pad.top - pad.bottom }

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

data UISlotGravity = UILeft | UIRight | UITop | UIBottom

derive instance eqUISlotGravity :: Eq UISlotGravity
derive instance ordUISlotGravity :: Ord UISlotGravity

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

uiSlots :: BrowserCanvas
        -> UISlots
uiSlots (BrowserCanvas bc) =
  let track   = subtractPadding bc.dimensions bc.trackPadding
      browser = bc.dimensions
      pad     = bc.trackPadding
  in { left:   { offset: { x: 0.0, y: pad.top }
               , size:   { height: track.height, width: pad.left }}
     , right:  { offset: { x: browser.width - pad.right, y: pad.top }
               , size:   { height: track.height, width: pad.right }}
     , top:    { offset: { x: pad.left, y: 0.0 }
               , size:   { height: pad.top, width: track.width }}
     , bottom: { offset: { x: browser.width  - pad.right
                         , y: browser.height - pad.bottom }
               , size:   { height: pad.bottom, width: track.width }}
    }

setBrowserCanvasSize :: Canvas.Dimensions
                     -> BrowserCanvas
                     -> Eff _ BrowserCanvas
setBrowserCanvasSize dim (BrowserCanvas bc) = do

  setContainerStyle bc.container dim
  let trackDim = subtractPadding dim bc.trackPadding

  track <- setTrackCanvasSize trackDim bc.track

  setBufferedCanvasSize dim bc.trackOverlay
  _ <- Canvas.setCanvasDimensions dim bc.staticOverlay

  pure $ BrowserCanvas
       $ bc { dimensions = dim
            , track = track }

-- | Creates a `BrowserCanvas` and appends it to the provided element.
-- | Resizes the container element to fit.
browserCanvas :: Canvas.Dimensions
              -> TrackPadding
              -> Element
              -> Eff _ BrowserCanvas
browserCanvas dimensions trackPadding el = do

  setContainerStyle el dimensions

  let trackDim = subtractPadding dimensions trackPadding
  track   <- trackCanvas trackDim

  trackOverlay  <- createBufferedCanvas { width: trackDim.width
                                        , height: dimensions.height }

  staticOverlay <- createCanvas dimensions "staticOverlay"

  let trackEl = _.front  $ unwrap
                $ _.canvas $ unwrap $ track

      trackOverlayEl = _.front $ unwrap $ trackOverlay

  setCanvasZIndex trackEl 10
  setCanvasZIndex trackOverlayEl 20
  setCanvasZIndex staticOverlay 30

  -- TODO handle this nicer maybe idk
  let trackElPosition = { left: trackPadding.left - trackInnerPad
                        , top:  trackPadding.top  - trackInnerPad }

  setCanvasPosition trackElPosition trackEl
  setCanvasPosition { left: trackPadding.left, top: 0.0 } trackOverlayEl
  setCanvasPosition { left: 0.0, top: 0.0} staticOverlay

  appendCanvasElem el trackEl
  appendCanvasElem el trackOverlayEl
  appendCanvasElem el staticOverlay

  pure $ BrowserCanvas { dimensions
                       , track, trackPadding
                       , trackOverlay, staticOverlay
                       , container: el}

renderGlyphs :: TrackCanvas
             -> { drawing :: Drawing, points :: Array Point }
             -> Eff _ Unit
renderGlyphs (TrackCanvas tc) {drawing, points} = do
  glyphBfr <- Canvas.getContext2D tc.glyphBuffer
  ctx <- getBufferedContext tc.canvas

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphBfr glyphBufferSize

  Drawing.render glyphBfr
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies tc.glyphBuffer glyphBufferSize ctx points

type Label = { text :: String, point :: Point, gravity :: LabelPlace }

data LabelPlace = LLeft | LCenter | LRight

derive instance eqLabelPlace :: Eq LabelPlace

-- hardcoded global label font for now
-- can't use Drawing.Font because we need raw Canvas to measure the text size,
-- but we can at least use Drawing to generate the font string

labelFontSize :: Int
labelFontSize = 14

labelFont :: String
labelFont = Drawing.fontString $ Drawing.font sansSerif labelFontSize mempty

-- | Calculate the rectangle covered by a label when it'd be rendered
-- | to a provided canvas context
labelBox :: Context2D -> Label -> Eff _ Canvas.Rectangle
labelBox ctx {text, point, gravity} = do
  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx
    Canvas.measureText ctx text

  -- close enough height, actually calculating it is a nightmare
  let height = Int.toNumber labelFontSize
      pad = 14.0 + width / 2.0
      x = case gravity of
        LCenter -> point.x
        LLeft   -> point.x - pad
        LRight  -> point.x + pad

  pure $ { x
         , y: point.y - height
         , w: width, h: height }

-- | Returns `true` if the input rectangles overlap
isOverlapping :: Canvas.Rectangle
              -> Canvas.Rectangle
              -> Boolean
isOverlapping r1 r2 =
     r1.x < r2.x + r2.w
  && r1.x + r1.w > r2.x
  && r1.y < r2.y + r2.h
  && r1.h + r1.y > r2.y

eqRectangle :: Canvas.Rectangle
            -> Canvas.Rectangle
            -> Boolean
eqRectangle {x,y,w,h} r =
     x == r.x && y == r.y
  && w == r.w && h == r.h

appendBoxed :: ∀ r.
               Array {rect :: Canvas.Rectangle | r}
            -> {rect :: Canvas.Rectangle | r}
            -> Array {rect :: Canvas.Rectangle | r}
appendBoxed sofar next =
  let overlapsAny :: Boolean
      overlapsAny = any overlaps sofar
        where overlaps r' = (not $ eqRectangle next.rect r'.rect)
                            && next.rect `isOverlapping` r'.rect
  in if overlapsAny then sofar else sofar <> [next]

renderLabels :: Array Label -> Context2D -> Eff _ Unit
renderLabels ls ctx = do

  boxed <- traverse (\l -> {text: l.text, rect: _} <$> labelBox ctx l) ls

  let toRender = foldl appendBoxed [] boxed

  Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx

    for_ toRender \box ->
      Canvas.fillText ctx box.text
        (box.rect.x - (box.rect.w / 2.0))
        box.rect.y

type Renderable r = { drawings :: Array { drawing :: Drawing
                                        , points :: Array Point }
                    , labels :: Array Label | r }

renderBrowser :: ∀ a b c.
                 Milliseconds
              -> BrowserCanvas
              -> Number
              -> { tracks     :: { snps :: Renderable a
                                 , annotations :: Renderable b }
                 , relativeUI :: Drawing
                 , fixedUI :: Drawing }
             -> Aff _ Unit
renderBrowser d (BrowserCanvas bc) offset ui = do

  let
      labels = ui.tracks.snps.labels <> ui.tracks.annotations.labels

  -- Render the UI
  liftEff do
    staticOverlayCtx <- Canvas.getContext2D bc.staticOverlay

    clearCanvas staticOverlayCtx bc.dimensions
    Drawing.render staticOverlayCtx ui.fixedUI

    translateBuffer {x: zero, y: zero} bc.trackOverlay
    blankBuffer bc.trackOverlay

    translateBuffer {x: (-offset), y: zero} bc.trackOverlay
    trackOverlayCtx <- getBufferedContext bc.trackOverlay

    Drawing.render trackOverlayCtx ui.relativeUI

    translateBuffer {x: (-offset), y: bc.trackPadding.top} bc.trackOverlay
    renderLabels labels trackOverlayCtx

  -- Render the tracks
  let bfr = (unwrap bc.track).canvas
      cnv = (unwrap bfr).front

  -- TODO extract functions `clearTrack` and `translateTrack` that bake in padding
  ctx <- liftEff $ Canvas.getContext2D cnv
  liftEff do
    dim <- Canvas.getCanvasDimensions cnv

    translateBuffer {x: zero, y: zero} bfr
    clearCanvas ctx $ trackTotalDimensions dim

  liftEff $ translateBuffer { x: trackInnerPad - offset
                            , y: trackInnerPad } bfr

  let snpsTrack  = ui.tracks.snps.drawings
      annotTrack = ui.tracks.annotations.drawings

  for_ [snpsTrack, annotTrack] \t ->
    for_ t \s -> do
      liftEff $ renderGlyphs bc.track s
      delay d

data LayerCanvas
  = Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_1Canvas :: Getter' LayerCanvas CanvasElement
_1Canvas = to case _ of
  Static c -> c
  Buffer c -> (unwrap c).front

-- _2Canvas :: Fold' LayerCanvas CanvasElement
-- _2Canvas =

layerCanvas :: ∀ a.
               Layer a -> LayerDimensions -> Eff _ LayerCanvas
layerCanvas (Layer lt _ c) lDim = do

  let slots = layerSlots lDim

  let {size, pos} = case c of
        Padded _ -> let p' = lDim.padding
                    in { size: slots.padded.size, pos: { left: p'.left, top: p'.top } }
        _        ->    { size: slots.full.size,   pos: { left: 0.0, top: 0.0 } }

  canvas <-
    case lt of
      Fixed     -> Static <$> createCanvas         size "fixed"
      Scrolling -> Buffer <$> createBufferedCanvas size

  setCanvasPosition pos (canvas ^. _1Canvas)

  pure $ unsafeCoerce unit

type LayerRenderable =
  Variant ( fixed    :: Drawing
          , drawings :: Array { drawing :: Drawing
                              , points :: Array Point }
          , labels   :: Array Label )

renderLayer :: Milliseconds
            -> LayerDimensions
            -> LayerCanvas
            -> Number
            -> Layer (ComponentSlot -> LayerRenderable)
            -> Aff _ Unit
renderLayer d ld lc offset layer@(Layer lt lm com) = do

  let slots = layerSlots ld

  let fixed :: Drawing -> _
      fixed = unsafeCoerce unit -- render the drawing to the Front canvas of the layer

      drawings :: Array _ -> _
      drawings = unsafeCoerce unit -- render, over time, copies of the drawings to the front canvas

      labels :: Array Label -> _
      labels = unsafeCoerce unit -- collide & render the labels of the drawings to the front canvas

      drawSlot :: LayerRenderable -> Aff _ Unit
      drawSlot =
        case_ # onMatch
          { fixed
          , drawings
          , labels
          }

  case com of
    Full    a -> unsafeCoerce unit
      -- run the contents on the full canvas
    Padded  a -> unsafeCoerce unit
      -- translate as necessary and run contents on canvas
    Outside a -> unsafeCoerce unit
      -- translate and mask as necessary and run each slot contents on the respective canvas

  pure unit