Adds missing effect type to `getCollection`.

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, class ToDBObject
	, toDBObject
	, class FromDBObject
	, fromDBObject
	, class IsDBObject
	, Collection
	, Pagination
	, limit
	, skip
	, SortOrder
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
	, clause
	, LogicConnector
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, Entity
	, class Database
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, zero
	, ($)
	, (&&)
	, (<>)
	, (==)
	, (>=>)
	, (<<<)
	, (>>>)
	)

import Control.Alt           (class Alt, (<|>))
import Control.Monad.Eff     (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Except  (mapExcept)
import Data.Array            (length, range, zipWith)
import Data.Foreign
	( F
	, Foreign
	, ForeignError(ErrorAtIndex)
	, readArray
	, toForeign
	)
import Data.Bifunctor        (lmap)
import Data.Foreign.Class    (read, write)
import Data.Foreign.Null     (Null(Null), readNull, writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	, readNullOrUndefined
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	, readUndefined
	, writeUndefined
	)
import Data.Either           (Either(Left, Right))
import Data.List             (List, singleton, uncons)
import Data.Maybe            (Maybe(Just, Nothing), maybe)
import Data.Monoid           (class Monoid, mempty)
import Data.Traversable      (sequence)
import Unsafe.Coerce         (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

class FromDBObject a where
	fromDBObject :: Foreign -> F a

instance booleanFromDBObject :: FromDBObject Boolean where
	fromDBObject = read

instance intFromDBObject :: FromDBObject Int where
	fromDBObject = read

instance numberFromDBObject :: FromDBObject Number where
	fromDBObject = read

instance charFromDBObject :: FromDBObject Char where
	fromDBObject = read

instance stringFromDBObject :: FromDBObject String where
	fromDBObject = read

instance foreignFromDBObject :: FromDBObject Foreign where
	fromDBObject = read

instance nullFromDBObject :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject = readNull fromDBObject

instance undefinedFromDBObject :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject = readUndefined fromDBObject

instance nullOrUndefinedFromDBObject :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject = readNullOrUndefined fromDBObject

instance arrayFromDBObject :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject = readArray >=> fromDBObjectElements
		where
			fromDBObjectWith f          = mapExcept (lmap f) <<< fromDBObject
			fromDBObjectElement i value = fromDBObjectWith (map (ErrorAtIndex i)) value
			fromDBObjectElements arr    = sequence (zipWith fromDBObjectElement (range zero (length arr)) arr)

class ToDBObject a where
	toDBObject :: a -> Foreign

instance booleanToDBObject :: ToDBObject Boolean where
	toDBObject = write

instance intToDBObject :: ToDBObject Int where
	toDBObject = write

instance numberToDBObject :: ToDBObject Number where
	toDBObject = write

instance charToDBObject :: ToDBObject Char where
	toDBObject = write

instance stringToDBObject :: ToDBObject String where
	toDBObject = write

instance foreignToDBObject :: ToDBObject Foreign where
	toDBObject = write

instance nullToDBObject :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = maybe writeNull toDBObject a

instance undefinedToDBObject :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = maybe writeUndefined toDBObject a

instance nullOrUndefinedToDBObject :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = toDBObject (Null a)

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

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

instance booleanIsDBObject :: IsDBObject Boolean

instance intIsDBObject :: IsDBObject Int

instance numberIsDBObject :: IsDBObject Number

instance charIsDBObject :: IsDBObject Char

instance stringIsDBObject :: IsDBObject String

instance foreignIsDBObject :: IsDBObject Foreign

instance nullIsDBObject :: IsDBObject a => IsDBObject (Null a)

instance undefinedIsDBObject :: IsDBObject a => IsDBObject (Undefined a)

instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)

instance arrayIsDBObject :: IsDBObject a => IsDBObject (Array a)

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy { sortOrder :: SortOrder }
	    | Custom { name      :: String    }
	    | Negate { clause    :: Clause    }

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          =
		"SortBy ({ sortOrder: " <> show s.sortOrder <> " })"
	show (Custom n)          = "Custom ({ name: " <> show n.name <> " })"
	show (Negate c)          =
		"Negate ({ clause: " <> show c.clause <> " })"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy { sortOrder: desc }
	, custom             : getClauseType $ Custom { name: mempty }
	, negate             : getClauseType $ Negate { clause: Equals }
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(Foreign)"
	<> ", predicate: "      <> "(t -> Foreign)"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (ToDBObject a) =>
		 Clause                               ->
		 a                                    ->
		 String                               ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (ToDBObject a) =>
		  Clause                               ->
		  a                                    ->
		  (t -> a)                             ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Right (fn >>> toDBObject)
	}

equals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		  String                           ->
		  e                                ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (ToDBObject e, Eq e) =>
	  e                                ->
	  (t -> e)                         ->
	  Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		 (t -> e)                         ->
		 e                                ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		     String                           ->
		     e                                ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (ToDBObject e, Eq e) =>
	     e                                ->
	     (t -> e)                         ->
	     Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		    (t -> e)                         ->
		    e                                ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (ToDBObject o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		    String                            ->
		    o                                 ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (ToDBObject o, Ord o) =>
	    o                                 ->
	    (t -> o)                          ->
	    Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		   (t -> o)                          ->
		   o                                 ->
		   Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
		     o                                 ->
		     String                            ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			    String                            ->
			    o                                 ->
			    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		    o                                 ->
		    (t -> o)                          ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			   (t -> o)                          ->
			   o                                 ->
			   Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (ToDBObject o, Ord o) =>
		o                                 ->
		String                            ->
		Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		       String                            ->
		       o                                 ->
		       Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (ToDBObject o, Ord o) =>
	       o                                 ->
	       (t -> o)                          ->
	       Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		     (t -> o)                           ->
		     o                                  ->
		     Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
			o                                 ->
			String                            ->
			Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			       String                            ->
			       o                                 ->
			       Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		       o                                 ->
		       (t -> o)                          ->
		       Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			      (t -> o)                          ->
			      o                                 ->
			      Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. SortOrder ->
	  (t -> Ordering)               ->
	  Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> toDBObject)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> toDBObject)
	}

data Entity key a = Entity key a | Entity' a

instance showEntity :: (Show key, Show a) => Show (Entity key a) where
	show (Entity key a) = "(Entity"
		<> " (" <> show key <> ")"
		<> " (" <> show a   <> ")"
		<> ")"
	show (Entity' a)     = "(Entity' (" <> show a <> "))"

instance eqEntity :: (Eq key, Eq a) => Eq (Entity key a) where
	eq (Entity k1 a1) (Entity k2 a2) = k1 == k2 && a1 == a2
	eq (Entity'   a1) (Entity'   a2) = a1 == a2
	eq              _              _ = false

instance ordEntity :: (Ord key, Ord a) => Ord (Entity key a) where
	compare (Entity k1 a1) (Entity k2 a2) = compare k1 k2 <> compare a1 a2
	compare (Entity'   a1) (Entity'   a2) = compare a1 a2
	-- I'm not entirely sure how an Entity with a key can be 'greater' than
	-- one without, but I've just decided to choose this implementation and
	-- stick with it.
	compare (Entity'    _) (Entity _   _) = LT
	compare (Entity _   _) (Entity'    _) = GT

class Database d datastore where
	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE, ref :: REF | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

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

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

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

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

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

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

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, class ToDBObject
	, toDBObject
	, class FromDBObject
	, fromDBObject
	, class IsDBObject
	, Collection
	, Pagination
	, limit
	, skip
	, SortOrder
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
	, clause
	, LogicConnector
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, Entity
	, class Database
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, zero
	, ($)
	, (&&)
	, (<>)
	, (==)
	, (>=>)
	, (<<<)
	, (>>>)
	)

import Control.Alt           (class Alt, (<|>))
import Control.Monad.Eff     (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Except  (mapExcept)
import Data.Array            (length, range, zipWith)
import Data.Foreign
	( F
	, Foreign
	, ForeignError(ErrorAtIndex)
	, readArray
	, toForeign
	)
import Data.Bifunctor        (lmap)
import Data.Foreign.Class    (read, write)
import Data.Foreign.Null     (Null(Null), readNull, writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	, readNullOrUndefined
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	, readUndefined
	, writeUndefined
	)
import Data.Either           (Either(Left, Right))
import Data.List             (List, singleton, uncons)
import Data.Maybe            (Maybe(Just, Nothing), maybe)
import Data.Monoid           (class Monoid, mempty)
import Data.Traversable      (sequence)
import Unsafe.Coerce         (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

class FromDBObject a where
	fromDBObject :: Foreign -> F a

instance booleanFromDBObject :: FromDBObject Boolean where
	fromDBObject = read

instance intFromDBObject :: FromDBObject Int where
	fromDBObject = read

instance numberFromDBObject :: FromDBObject Number where
	fromDBObject = read

instance charFromDBObject :: FromDBObject Char where
	fromDBObject = read

instance stringFromDBObject :: FromDBObject String where
	fromDBObject = read

instance foreignFromDBObject :: FromDBObject Foreign where
	fromDBObject = read

instance nullFromDBObject :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject = readNull fromDBObject

instance undefinedFromDBObject :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject = readUndefined fromDBObject

instance nullOrUndefinedFromDBObject :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject = readNullOrUndefined fromDBObject

instance arrayFromDBObject :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject = readArray >=> fromDBObjectElements
		where
			fromDBObjectWith f          = mapExcept (lmap f) <<< fromDBObject
			fromDBObjectElement i value = fromDBObjectWith (map (ErrorAtIndex i)) value
			fromDBObjectElements arr    = sequence (zipWith fromDBObjectElement (range zero (length arr)) arr)

class ToDBObject a where
	toDBObject :: a -> Foreign

instance booleanToDBObject :: ToDBObject Boolean where
	toDBObject = write

instance intToDBObject :: ToDBObject Int where
	toDBObject = write

instance numberToDBObject :: ToDBObject Number where
	toDBObject = write

instance charToDBObject :: ToDBObject Char where
	toDBObject = write

instance stringToDBObject :: ToDBObject String where
	toDBObject = write

instance foreignToDBObject :: ToDBObject Foreign where
	toDBObject = write

instance nullToDBObject :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = maybe writeNull toDBObject a

instance undefinedToDBObject :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = maybe writeUndefined toDBObject a

instance nullOrUndefinedToDBObject :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = toDBObject (Null a)

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

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

instance booleanIsDBObject :: IsDBObject Boolean

instance intIsDBObject :: IsDBObject Int

instance numberIsDBObject :: IsDBObject Number

instance charIsDBObject :: IsDBObject Char

instance stringIsDBObject :: IsDBObject String

instance foreignIsDBObject :: IsDBObject Foreign

instance nullIsDBObject :: IsDBObject a => IsDBObject (Null a)

instance undefinedIsDBObject :: IsDBObject a => IsDBObject (Undefined a)

instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)

instance arrayIsDBObject :: IsDBObject a => IsDBObject (Array a)

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy { sortOrder :: SortOrder }
	    | Custom { name      :: String    }
	    | Negate { clause    :: Clause    }

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          =
		"SortBy ({ sortOrder: " <> show s.sortOrder <> " })"
	show (Custom n)          = "Custom ({ name: " <> show n.name <> " })"
	show (Negate c)          =
		"Negate ({ clause: " <> show c.clause <> " })"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy { sortOrder: desc }
	, custom             : getClauseType $ Custom { name: mempty }
	, negate             : getClauseType $ Negate { clause: Equals }
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(Foreign)"
	<> ", predicate: "      <> "(t -> Foreign)"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (ToDBObject a) =>
		 Clause                               ->
		 a                                    ->
		 String                               ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (ToDBObject a) =>
		  Clause                               ->
		  a                                    ->
		  (t -> a)                             ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Right (fn >>> toDBObject)
	}

equals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		  String                           ->
		  e                                ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (ToDBObject e, Eq e) =>
	  e                                ->
	  (t -> e)                         ->
	  Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		 (t -> e)                         ->
		 e                                ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		     String                           ->
		     e                                ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (ToDBObject e, Eq e) =>
	     e                                ->
	     (t -> e)                         ->
	     Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		    (t -> e)                         ->
		    e                                ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (ToDBObject o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		    String                            ->
		    o                                 ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (ToDBObject o, Ord o) =>
	    o                                 ->
	    (t -> o)                          ->
	    Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		   (t -> o)                          ->
		   o                                 ->
		   Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
		     o                                 ->
		     String                            ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			    String                            ->
			    o                                 ->
			    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		    o                                 ->
		    (t -> o)                          ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			   (t -> o)                          ->
			   o                                 ->
			   Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (ToDBObject o, Ord o) =>
		o                                 ->
		String                            ->
		Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		       String                            ->
		       o                                 ->
		       Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (ToDBObject o, Ord o) =>
	       o                                 ->
	       (t -> o)                          ->
	       Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		     (t -> o)                           ->
		     o                                  ->
		     Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
			o                                 ->
			String                            ->
			Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			       String                            ->
			       o                                 ->
			       Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		       o                                 ->
		       (t -> o)                          ->
		       Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			      (t -> o)                          ->
			      o                                 ->
			      Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. SortOrder ->
	  (t -> Ordering)               ->
	  Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> toDBObject)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> toDBObject)
	}

data Entity key a = Entity key a | Entity' a

instance showEntity :: (Show key, Show a) => Show (Entity key a) where
	show (Entity key a) = "(Entity"
		<> " (" <> show key <> ")"
		<> " (" <> show a   <> ")"
		<> ")"
	show (Entity' a)     = "(Entity' (" <> show a <> "))"

instance eqEntity :: (Eq key, Eq a) => Eq (Entity key a) where
	eq (Entity k1 a1) (Entity k2 a2) = k1 == k2 && a1 == a2
	eq (Entity'   a1) (Entity'   a2) = a1 == a2
	eq              _              _ = false

instance ordEntity :: (Ord key, Ord a) => Ord (Entity key a) where
	compare (Entity k1 a1) (Entity k2 a2) = compare k1 k2 <> compare a1 a2
	compare (Entity'   a1) (Entity'   a2) = compare a1 a2
	-- I'm not entirely sure how an Entity with a key can be 'greater' than
	-- one without, but I've just decided to choose this implementation and
	-- stick with it.
	compare (Entity'    _) (Entity _   _) = LT
	compare (Entity _   _) (Entity'    _) = GT

class Database d datastore where
	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

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

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

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

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

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

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


Allow saving definitions without an input

module Components.Controls
  ( component
  ) where

import Lambda.Prelude

import Lambda.Language.Pretty (Rep, select)
import Lambda.Machine (Machine)
import React.Basic (JSX)
import React.Basic.DOM as R
import React.Basic.Events (EventHandler, handler_)

type Props =
  { machine :: Maybe Machine
  , onStep :: Machine -> Effect Unit
  , onClear :: Effect Unit
  , onShare :: Effect Unit
  , onSave :: Effect Unit
  , onSugar :: Effect Unit
  , rep :: Rep
  }

component :: Props -> JSX
component {machine, onStep, onClear, onShare, onSave, onSugar, rep} =
  R.div
    { className: "add-margin-medium btn-group pull-right"
    , children:
      [ button (running =<< machine)
        { className: "btn btn-default"
        , onClick: onStep
        , label: "Step"
        }
      , button machine
        { className: "btn btn-default"
        , onClick: const onClear
        , label: "Clear"
        }
      , button enabled
        { className: "btn btn-default"
        , onClick: const onShare
        , label: "Share"
        }
      , button enabled
        { className: "btn btn-default"
        , onClick: const onSave
        , label: "Save"
        }
      , button enabled
        { className: select rep
          { sugar: "btn btn-danger"
          , raw: "btn btn-success"
          }
        , onClick: const onSugar
        , label: select rep
            { sugar: "Raw"
            , raw: "Sugar"
            }
        }
      ]
    }
 where
  enabled = pure unit

-- | Create a button element enabled based on the presence of the first
-- | argument.
button
  :: forall a
   . Maybe a
  ->
    { className :: String
    , onClick :: a -> Effect Unit
    , label :: String
    }
  -> JSX
button m {className, onClick, label} =
  R.button
    { className: maybeEnable className m
    , onClick: maybeHandle onClick m
    , children: [R.text label]
    }

-- | Build handler if second argument is present.
maybeHandle :: forall a. (a -> Effect Unit) -> Maybe a -> EventHandler
maybeHandle handle =
  handler_ <<< maybe (pure unit) handle

-- | Enable element if second argument is present.
maybeEnable :: forall a. String -> Maybe a -> String
maybeEnable className =
  maybe
    (className <> " disabled")
    (const className)

-- | A machine that hasn't halted
running :: Machine -> Maybe Machine
running machine = machine <$ guard (not $ machine.halted)

module Components.Controls
  ( component
  ) where

import Lambda.Prelude

import Lambda.Language.Pretty (Rep, select)
import Lambda.Machine (Machine)
import React.Basic (JSX)
import React.Basic.DOM as R
import React.Basic.Events (EventHandler, handler_)

type Props =
  { machine :: Maybe Machine
  , onStep :: Machine -> Effect Unit
  , onClear :: Effect Unit
  , onShare :: Effect Unit
  , onSave :: Effect Unit
  , onSugar :: Effect Unit
  , rep :: Rep
  }

component :: Props -> JSX
component {machine, onStep, onClear, onShare, onSave, onSugar, rep} =
  R.div
    { className: "add-margin-medium btn-group pull-right"
    , children:
      [ button (running =<< machine)
        { className: "btn btn-default"
        , onClick: onStep
        , label: "Step"
        }
      , button machine
        { className: "btn btn-default"
        , onClick: const onClear
        , label: "Clear"
        }
      , button (Just unit)
        { className: "btn btn-default"
        , onClick: const onShare
        , label: "Share"
        }
      , button machine
        { className: "btn btn-default"
        , onClick: const onSave
        , label: "Save"
        }
      , button (pure unit)
        { className: select rep
          { sugar: "btn btn-danger"
          , raw: "btn btn-success"
          }
        , onClick: const onSugar
        , label: select rep
            { sugar: "Raw"
            , raw: "Sugar"
            }
        }
      ]
    }

-- | Create a button element enabled based on the presence of the first
-- | argument.
button
  :: forall a
   . Maybe a
  ->
    { className :: String
    , onClick :: a -> Effect Unit
    , label :: String
    }
  -> JSX
button m {className, onClick, label} =
  R.button
    { className: maybeEnable className m
    , onClick: maybeHandle onClick m
    , children: [R.text label]
    }

-- | Build handler if second argument is present.
maybeHandle :: forall a. (a -> Effect Unit) -> Maybe a -> EventHandler
maybeHandle handle =
  handler_ <<< maybe (pure unit) handle

-- | Enable element if second argument is present.
maybeEnable :: forall a. String -> Maybe a -> String
maybeEnable className =
  maybe
    (className <> " disabled")
    (const className)

-- | A machine that hasn't halted
running :: Machine -> Maybe Machine
running machine = machine <$ guard (not $ machine.halted)


added rudimentary UI for consumer's style Sheet customization

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Dialog.Export.Component where

import SlamData.Prelude
import Clipboard as C
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Exception as Exception
import Data.Foldable as F
import Data.Map as Map
import Data.Path.Pathy as Pathy
import Data.StrMap as SM
import Data.String as Str
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import OIDC.Crypt as OIDC
import Quasar.Advanced.Types as QTA
import SlamData.Config as Config
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Security as Q
import SlamData.Render.CSS as Rc
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Deck.DeckId as DID
import Utils.DOM as DOM
import Utils.Path as UP
import Control.Bind ((=<<))
import Control.UI.Browser (select, locationString)
import DOM.Classy.Element (toElement)
import DOM.HTML.Types (readHTMLElement)
import Data.Argonaut (encodeJson)
import Data.Foreign (toForeign)
import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Deck.DeckPath (deckPath')
import SlamData.Workspace.Deck.Dialog.Share.Model (sharingActions, ShareResume(..), SharingInput)
import SlamData.Workspace.Routing (mkWorkspaceHash, varMapsForURL)
import Utils (hush, prettyJson)

data PresentAs = IFrame | URI

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Message Slam

type State =
  { presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  , sharingInput ∷ SharingInput
  , permToken ∷ Maybe QTA.TokenR
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLoggedIn ∷ Boolean
  , copyVal ∷ String
  , errored ∷ Boolean
  , warning ∷ Maybe String
  , presentStyleURLInput :: Boolean
  , styleURL :: String
  , submitting ∷ Boolean
  , loading ∷ Boolean
  , clipboard ∷ Maybe C.Clipboard
  }

initialState ∷ Input → State
initialState input =
  { presentingAs: input.presentingAs
  , varMaps: input.varMaps
  , sharingInput: input.sharingInput
  , permToken: Nothing
  , canRevoke: false
  , shouldGenerateToken: false
  , hovered: false
  , isLoggedIn: false
  , copyVal: ""
  , errored: false
  , warning: Nothing
  , presentStyleURLInput: false
  , styleURL: ""
  , submitting: false
  , loading: true
  , clipboard: Nothing
  }

toggleStyleURLInput :: State -> State
toggleStyleURLInput state =
   state {presentStyleURLInput = not state.presentStyleURLInput}

updateStyleURL :: String -> State -> State
updateStyleURL styleURL state =
  state { styleURL = styleURL }

type Input =
  { sharingInput ∷ SharingInput
  , presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  }

data Query a
  = SelectElement DOM.Event a
  | Init a
  | Revoke a
  | ToggleShouldGenerateToken a
  | ToggleStyleURLInput a
  | UpdateStyleURL String a
  | PreventDefault DOM.Event a
  | HandleCancel a

data Message = Dismiss

copyButtonRef ∷ H.RefLabel
copyButtonRef = H.RefLabel "copy"

component ∷ H.Component HH.HTML Query Input Message Slam
component =
  H.lifecycleComponent
    { initialState
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishURI state
  | otherwise = renderPublishIFrame state

renderPublishURI ∷ State → H.ComponentHTML Query
renderPublishURI state =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text "Publish deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.p_ message
        , HH.form
            [ HE.onSubmit (HE.input PreventDefault) ]
            [ HH.div
                [ HP.classes [ B.inputGroup ] ]
                $ [ HH.input
                    [ HP.classes [ B.formControl ]
                    , HP.value state.copyVal
                    , HP.readOnly true
                    , HP.disabled state.submitting
                    , HP.title "Published deck URL"
                    , ARIA.label "Published deck URL"
                    , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
                    ]
                  , HH.span
                      [ HP.classes [ B.inputGroupBtn ] ]
                      [ HH.button
                        [ HP.classes [ B.btn, B.btnDefault ]
                        , HE.onClick (HE.input_ HandleCancel)
                        , HP.ref copyButtonRef
                        , HP.id_ "copy-button"
                        , HP.type_ HP.ButtonButton
                        , HP.disabled state.submitting
                        ]
                        [ glyph B.glyphiconCopy ]
                      ]
                  ]
              , HH.div_
                  [ HH.a
                    [ HE.onClick (HE.input_ ToggleStyleURLInput) ]
                    [ HH.text "Provide a URL with the CSS to customize look/feel"]
                    ]
              , HH.div_
                  [ if state.presentStyleURLInput
                      then HH.input
                            [ HP.classes [ B.formControl ]
                            , HE.onValueInput (HE.input UpdateStyleURL)
                            ]
                      else HH.text ""
                  ]
            ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.errored then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $>  HH.button
                 [ HP.classes [ B.btn, B.btnInfo ]
                 , HE.onClick (HE.input_ Revoke)
                 , ARIA.label "Revoke access to this deck"
                 , HP.title "Revoke access to this deck"
                 , HP.type_ HP.ButtonButton
                 , HP.enabled $ state.canRevoke ∧ not state.submitting
                 ]
                 [ HH.text "Revoke" ])
        ⊕ [ HH.a
              ( [ HP.classes
                    $ [ B.btn, B.btnPrimary ]
                    ⊕ if state.submitting then [ B.disabled ] else [ ]
                , HP.target "_blank"
                ]
                ⊕ if state.submitting then [ ] else [ HP.href state.copyVal ]
              )
              [ HH.text "Preview" ]
          ]
      ]
  where
  message
    | state.isLoggedIn =
        [ HH.text
          $ "Anyone has access to the following link "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this link may be able to view this deck. "
            ⊕ "They may also be able to modify the link to view or edit any deck "
            ⊕ "in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target  "_blank"
               ]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

renderPublishIFrame ∷ State → H.ComponentHTML Query
renderPublishIFrame state =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text  "Embed deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.form
          [ HE.onSubmit (HE.input PreventDefault) ]
          [ HH.div
              [ HP.classes [ B.formGroup ] ]
                [ HH.textarea
                  [ HP.classes [ B.formControl, Rc.embedBox ]
                  , HP.readOnly true
                  , HP.value state.copyVal
                  , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
                  ]
                , HH.button
                  [ HP.id_ "copy-button"
                  , HP.classes
                      $ [ B.btn, B.btnDefault, B.btnXs ]
                      ⊕ [ HH.ClassName "textarea-copy-button" ]
                  , HP.ref copyButtonRef
                  , HP.type_ HP.ButtonButton
                  , HP.disabled state.submitting
                  ]
                  [ glyph B.glyphiconCopy ]
                , HH.div [ HP.classes [ B.checkbox ] ]
                  [ (if state.isLoggedIn then HH.label_ else HH.p_)
                    $ ((guard state.isLoggedIn)
                       $> HH.input
                           [ HP.type_ HP.InputCheckbox
                           , HP.checked state.shouldGenerateToken
                           , HP.disabled state.submitting
                           , HE.onChecked (HE.input_ ToggleShouldGenerateToken)
                           ])
                    ⊕ message
                  ]
                ]
          ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.errored then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $> HH.button
                [ HP.classes [ B.btn, B.btnInfo ]
                , HE.onClick (HE.input_ Revoke)
                , HP.title "Revoke access to this deck"
                , ARIA.label "Revoke access to this deck"
                , HP.type_ HP.ButtonButton
                , HP.enabled $ state.canRevoke ∧ not state.submitting
                ]
                [ HH.text "Revoke" ])

        ]
  where
  message
    | state.isLoggedIn =
        [ HH.text
            $ "Include a permission token so the deck "
            ⊕ "can be accessed by anyone who has the access to this script. "
            ⊕ "You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this script may be able to view this deck. "
            ⊕ "They may also be able to modify the script to view or edit any "
            ⊕ "deck in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target "_blank"]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

eval ∷ Query ~> DSL
eval (Init next) = next <$ do
  state ← H.get
  -- To know if user is authed
  mbAuthToken ← H.lift Auth.getIdToken
  case mbAuthToken of
    Nothing →
      H.modify _{ permToken = Nothing
                , canRevoke = false
                , isLoggedIn = false
                , loading = false
                }
    Just oidcToken → do
      H.modify _{isLoggedIn = true, canRevoke = true}
      tokensRes ← Q.tokenList
      H.modify _{loading = false}
      case tokensRes of
        Left _ → H.modify _{errored = true}
        Right tokens →
          let
            tokenName =
              Just $ workspaceTokenName state.sharingInput.workspacePath oidcToken
            oldToken =
              F.find (\x → x.name ≡ tokenName) tokens
          in case oldToken of
            Just token → do
              H.modify _{ permToken = Just token
                        , errored = false
                        }
            Nothing → do
              isURI ← (_ ≡ URI) <$> H.gets _.presentingAs
              when (state.shouldGenerateToken ∨ isURI) do
                H.modify _{submitting = true}
                createdRes ←
                  Q.createToken
                    tokenName
                    (sharingActions state.sharingInput View)
                H.modify _{submitting = false}
                H.modify case createdRes of
                  Left _ →  _{errored = true}
                  Right newToken →
                     _{ errored = false
                      , permToken = Just newToken
                      }
  updateCopyVal

eval (SelectElement ev next) = do
  st ← H.get
  H.liftEff do
    DOM.stopPropagation ev
    when (not st.submitting) do
      DOM.currentTarget ev
        # readHTMLElement ∘ toForeign
        # runExcept
        # traverse_ select
  pure next

eval (Revoke next) = do
  mbPermToken ← H.gets _.permToken
  for_ mbPermToken \tok → do
    H.modify _{submitting = true}
    deleteRes ← Q.deleteToken tok.id
    H.modify _{submitting = false}
    case deleteRes of
      Left _ → H.modify _{ errored = true }
      Right _ → H.raise Dismiss
  pure next

eval (ToggleShouldGenerateToken next) = next <$ do
  state ← H.get
  case state.permToken of
    Nothing →
      unless state.shouldGenerateToken do
        mbOIDC ← H.lift Auth.getIdToken
        workspacePath ← H.gets (_.workspacePath ∘ _.sharingInput)
        for_ mbOIDC \oidc → do
          let
            actions = sharingActions state.sharingInput View
            tokenName = Just $ workspaceTokenName workspacePath oidc
          H.modify _{submitting = true}
          recreatedRes ← Q.createToken tokenName actions
          H.modify _{submitting = false}
          H.modify case recreatedRes of
            Left _ →
              _ { permToken = Nothing
                , errored = true
                }
            Right token →
              _ { permToken = Just token
                , errored = false
                }
    Just tok → do
      H.modify _{submitting = true}
      deleteRes ← Q.deleteToken tok.id
      H.modify _{submitting = false}
      H.modify case deleteRes of
        Left _ → _ { errored = true }
        Right _ → _ { errored = false, permToken = Nothing }
  H.modify _{shouldGenerateToken = not state.shouldGenerateToken}
  updateCopyVal

eval (ToggleStyleURLInput next) =
  H.modify toggleStyleURLInput $> next

eval (UpdateStyleURL styleURL next) =
  H.modify (updateStyleURL styleURL) *> updateCopyVal $> next

eval (PreventDefault ev next) =
  H.liftEff (DOM.preventDefault ev) $> next
eval (HandleCancel next) =
  H.raise Dismiss $> next

workspaceTokenName ∷ UP.DirPath → OIDC.IdToken → QTA.TokenName
workspaceTokenName workspacePath idToken =
  let
    payload =
      hush $ Eff.runPure $ Exception.try $ OIDC.readPayload idToken
    email =
      fromMaybe "unknown user" $ unwrap <$> (OIDC.pluckEmail =<< payload)
    workspace =
      Pathy.printPath workspacePath
  in
    QTA.TokenName
      $ "publish permission granted by "
      ⊕ email
      ⊕ " for "
      ⊕ workspace

updateCopyVal ∷ DSL Unit
updateCopyVal = do
  locString ← H.liftEff locationString
  state ← H.get
  let
    copyVal = renderCopyVal locString state

  H.modify _{ copyVal = copyVal }
  clipboard ← H.gets _.clipboard
  case clipboard of
    Just c -> H.liftEff $ C.destroy c
    Nothing -> pure unit
  H.getHTMLElementRef copyButtonRef >>= traverse_ \htmlEl → do
    newClipboard ← H.liftEff $ C.fromElement (toElement htmlEl) (pure copyVal)
    H.modify _{ clipboard = Just newClipboard }

renderCopyVal ∷ String → State → String
renderCopyVal locString state
  | state.presentingAs ≡ URI =
    renderURL locString state
  | otherwise
      = Str.joinWith "\n"
          [ """<!-- This is the DOM element that the deck will be inserted into. -->"""
          , """<!-- You can change the width and height and use a stylesheet to apply styling. -->"""
          , """<iframe frameborder="0" width="100%" height="800" id=""" ⊕ quoted deckDOMId ⊕ """></iframe>"""
          , """"""
          , """<!-- To change a deck's variables after it has been inserted please use window.slamDataDeckUrl to create an new URL then update the deck iframe's src parameter. -->"""
          , """<script type="text/javascript">"""
          , """  window.slamDataDeckUrl = function (options) {"""
          , """    var queryParts = function () {"""
          , """      var parts = [];"""
          , """      if (options.echartTheme) {"""
          , """        parts.push("echartTheme=" + encodeURIComponent(options.echartTheme));"""
          , """      }"""
          , """      if (options.permissionTokens && options.permissionTokens.length) {"""
          , """        parts.push("permissionTokens=" + options.permissionTokens.join(","));"""
          , """      }"""
          , """      if (options.stylesheetUrls && options.stylesheetUrls.length) {"""
          , """        parts.push("stylesheets=" + options.stylesheetUrls.map(encodeURIComponent).join(","));"""
          , """      }"""
          , """      return parts;"""
          , """    };"""
          , """    var queryString = "?" + queryParts().join("&");"""
          , """    var varsParam = options.vars ? "/?vars=" + encodeURIComponent(JSON.stringify(options.vars)) : "";"""
          , """    return options.slamDataUrl + queryString + "#" + options.deckPath + options.deckId + "/view" + varsParam;"""
          , """  };"""
          , """</script>"""
          , """"""
          , """<!-- This is the script which performs SlamData deck insertion. -->"""
          , """<script type="text/javascript">"""
          , """  (function () {"""
          , """    var options = {"""
          , """      slamDataUrl: """ ⊕ quoted workspaceURL ⊕ ""","""
          , """      deckPath: """ ⊕ quoted deckPath ⊕ ""","""
          , """      deckId: """ ⊕ quoted deckId ⊕ ""","""
          , """      permissionTokens: [""" ⊕ maybe "" quoted token ⊕ """],"""
          , """      stylesheetUrls: [], // An array of custom stylesheet URLs."""
          , """      echartTheme: undefined,"""
          , """      vars: """ ⊕ renderVarMaps state.varMaps
          , """    };"""
          , """"""
          , """    var deckSelector = "iframe#sd-deck-" + options.deckId;"""
          , """    var deckElement = document.querySelector(deckSelector);"""
          , """"""
          , """    if (deckElement) {"""
          , """      deckElement.src = window.slamDataDeckUrl(options);"""
          , """    } else {"""
          , """      throw("SlamData: Couldn't locate " + deckSelector);"""
          , """    }"""
          , """  })();"""
          , """</script>"""
          ]
    where
    line = (_ ⊕ "\n")
    quoted s = "\"" ⊕ s ⊕ "\""
    workspaceURL = locString ⊕ "/" ⊕ Config.workspaceUrl
    deckId = DID.toString state.sharingInput.deckId
    deckDOMId = "sd-deck-" ⊕ deckId
    deckPath = UP.encodeURIPath (Pathy.printPath state.sharingInput.workspacePath)
    token = QTA.runTokenHash <<< _.secret <$> state.permToken

renderVarMaps ∷ Map.Map CID.CardId Port.VarMap → String
renderVarMaps = indent <<< prettyJson <<< encodeJson <<< varMapsForURL
  where
  indent = RX.replace (unsafePartial fromRight $ RX.regex "(\n\r?)" RXF.global) "$1      "

renderURL ∷ String → State → String
renderURL locationString state@{sharingInput, permToken, isLoggedIn, styleURL} =
  locationString
  ⊕ "/"
  ⊕ Config.workspaceUrl
  ⊕ foldMap
      (append "?permissionTokens=" ∘ QTA.runTokenHash)
      (do guard isLoggedIn
          token ← permToken
          pure token.secret)
  ⊕ if styleURL /= "" then "&stylesheets=" ⊕ styleURL else ""
  ⊕ mkWorkspaceHash (deckPath' sharingInput.workspacePath sharingInput.deckId) (WA.Load AT.ReadOnly) SM.empty

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Dialog.Export.Component where

import SlamData.Prelude

import Control.Monad.Eff as Eff
import Control.Monad.Eff.Exception as Exception
import Control.UI.Browser (select, locationString)

import Data.Argonaut (encodeJson)
import Data.Foldable as F
import Data.Foreign (toForeign)
import Data.Map as Map
import Data.Path.Pathy as Pathy
import Data.StrMap as SM
import Data.String as Str
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF

import DOM.HTML.Types (readHTMLElement)
import DOM.Classy.Element (toElement)
import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import OIDC.Crypt as OIDC

import SlamData.Config as Config
import SlamData.Monad (Slam)
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Security as Q
import SlamData.Render.CSS as Rc
import SlamData.Render.Common (glyph)
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Deck.DeckPath (deckPath')
import SlamData.Workspace.Deck.Dialog.Share.Model (sharingActions, ShareResume(..), SharingInput)
import SlamData.Workspace.Routing (mkWorkspaceHash, varMapsForURL)

import Quasar.Advanced.Types as QTA

import Utils.DOM as DOM
import Utils (hush, prettyJson)
import Utils.Path as UP

import Clipboard as C

data PresentAs = IFrame | URI

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Message Slam

type State =
  { presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  , sharingInput ∷ SharingInput
  , permToken ∷ Maybe QTA.TokenR
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLoggedIn ∷ Boolean
  , copyVal ∷ String
  , errored ∷ Boolean
  , submitting ∷ Boolean
  , loading ∷ Boolean
  , clipboard ∷ Maybe C.Clipboard
  }

initialState ∷ Input → State
initialState input =
  { presentingAs: input.presentingAs
  , varMaps: input.varMaps
  , sharingInput: input.sharingInput
  , permToken: Nothing
  , canRevoke: false
  , shouldGenerateToken: false
  , hovered: false
  , isLoggedIn: false
  , copyVal: ""
  , errored: false
  , submitting: false
  , loading: true
  , clipboard: Nothing
  }

type Input =
  { sharingInput ∷ SharingInput
  , presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  }

data Query a
  = SelectElement DOM.Event a
  | Init a
  | Revoke a
  | ToggleShouldGenerateToken a
  | PreventDefault DOM.Event a
  | HandleCancel a

data Message = Dismiss

copyButtonRef ∷ H.RefLabel
copyButtonRef = H.RefLabel "copy"

component ∷ H.Component HH.HTML Query Input Message Slam
component =
  H.lifecycleComponent
    { initialState
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishURI state
  | otherwise = renderPublishIFrame state

renderPublishURI ∷ State → H.ComponentHTML Query
renderPublishURI state =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text "Publish deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.p_ message
        , HH.form
            [ HE.onSubmit (HE.input PreventDefault) ]
            [ HH.div
                [ HP.classes [ B.inputGroup ] ]
                $ [ HH.input
                    [ HP.classes [ B.formControl ]
                    , HP.value state.copyVal
                    , HP.readOnly true
                    , HP.disabled state.submitting
                    , HP.title "Published deck URL"
                    , ARIA.label "Published deck URL"
                    , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
                    ]
                  , HH.span
                      [ HP.classes [ B.inputGroupBtn ] ]
                      [ HH.button
                        [ HP.classes [ B.btn, B.btnDefault ]
                        , HE.onClick (HE.input_ HandleCancel)
                        , HP.ref copyButtonRef
                        , HP.id_ "copy-button"
                        , HP.type_ HP.ButtonButton
                        , HP.disabled state.submitting
                        ]
                        [ glyph B.glyphiconCopy ]
                      ]
                  ]
            ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.errored then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $>  HH.button
                 [ HP.classes [ B.btn, B.btnInfo ]
                 , HE.onClick (HE.input_ Revoke)
                 , ARIA.label "Revoke access to this deck"
                 , HP.title "Revoke access to this deck"
                 , HP.type_ HP.ButtonButton
                 , HP.enabled $ state.canRevoke ∧ not state.submitting
                 ]
                 [ HH.text "Revoke" ])
        ⊕ [ HH.a
              ( [ HP.classes
                    $ [ B.btn, B.btnPrimary ]
                    ⊕ if state.submitting then [ B.disabled ] else [ ]
                , HP.target "_blank"
                ]
                ⊕ if state.submitting then [ ] else [ HP.href state.copyVal ]
              )
              [ HH.text "Preview" ]
          ]
      ]
  where
  message
    | state.isLoggedIn =
        [ HH.text
          $ "Anyone has access to the following link "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this link may be able to view this deck. "
            ⊕ "They may also be able to modify the link to view or edit any deck "
            ⊕ "in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target  "_blank"
               ]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

renderPublishIFrame ∷ State → H.ComponentHTML Query
renderPublishIFrame state =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text  "Embed deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.form
          [ HE.onSubmit (HE.input PreventDefault) ]
          [ HH.div
              [ HP.classes [ B.formGroup ] ]
                [ HH.textarea
                  [ HP.classes [ B.formControl, Rc.embedBox ]
                  , HP.readOnly true
                  , HP.value state.copyVal
                  , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
                  ]
                , HH.button
                  [ HP.id_ "copy-button"
                  , HP.classes
                      $ [ B.btn, B.btnDefault, B.btnXs ]
                      ⊕ [ HH.ClassName "textarea-copy-button" ]
                  , HP.ref copyButtonRef
                  , HP.type_ HP.ButtonButton
                  , HP.disabled state.submitting
                  ]
                  [ glyph B.glyphiconCopy ]
                , HH.div [ HP.classes [ B.checkbox ] ]
                  [ (if state.isLoggedIn then HH.label_ else HH.p_)
                    $ ((guard state.isLoggedIn)
                       $> HH.input
                           [ HP.type_ HP.InputCheckbox
                           , HP.checked state.shouldGenerateToken
                           , HP.disabled state.submitting
                           , HE.onChecked (HE.input_ ToggleShouldGenerateToken)
                           ])
                    ⊕ message
                  ]
                ]
          ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.errored then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $> HH.button
                [ HP.classes [ B.btn, B.btnInfo ]
                , HE.onClick (HE.input_ Revoke)
                , HP.title "Revoke access to this deck"
                , ARIA.label "Revoke access to this deck"
                , HP.type_ HP.ButtonButton
                , HP.enabled $ state.canRevoke ∧ not state.submitting
                ]
                [ HH.text "Revoke" ])

        ]
  where
  message
    | state.isLoggedIn =
        [ HH.text
            $ "Include a permission token so the deck "
            ⊕ "can be accessed by anyone who has the access to this script. "
            ⊕ "You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this script may be able to view this deck. "
            ⊕ "They may also be able to modify the script to view or edit any "
            ⊕ "deck in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target "_blank"]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

eval ∷ Query ~> DSL
eval (Init next) = next <$ do
  state ← H.get
  -- To know if user is authed
  mbAuthToken ← H.lift Auth.getIdToken
  case mbAuthToken of
    Nothing →
      H.modify _{ permToken = Nothing
                , canRevoke = false
                , isLoggedIn = false
                , loading = false
                }
    Just oidcToken → do
      H.modify _{isLoggedIn = true, canRevoke = true}
      tokensRes ← Q.tokenList
      H.modify _{loading = false}
      case tokensRes of
        Left _ → H.modify _{errored = true}
        Right tokens →
          let
            tokenName =
              Just $ workspaceTokenName state.sharingInput.workspacePath oidcToken
            oldToken =
              F.find (\x → x.name ≡ tokenName) tokens
          in case oldToken of
            Just token → do
              H.modify _{ permToken = Just token
                        , errored = false
                        }
            Nothing → do
              isURI ← (_ ≡ URI) <$> H.gets _.presentingAs
              when (state.shouldGenerateToken ∨ isURI) do
                H.modify _{submitting = true}
                createdRes ←
                  Q.createToken
                    tokenName
                    (sharingActions state.sharingInput View)
                H.modify _{submitting = false}
                H.modify case createdRes of
                  Left _ →  _{errored = true}
                  Right newToken →
                     _{ errored = false
                      , permToken = Just newToken
                      }
  updateCopyVal

eval (SelectElement ev next) = do
  st ← H.get
  H.liftEff do
    DOM.stopPropagation ev
    when (not st.submitting) do
      DOM.currentTarget ev
        # readHTMLElement ∘ toForeign
        # runExcept
        # traverse_ select
  pure next

eval (Revoke next) = do
  mbPermToken ← H.gets _.permToken
  for_ mbPermToken \tok → do
    H.modify _{submitting = true}
    deleteRes ← Q.deleteToken tok.id
    H.modify _{submitting = false}
    case deleteRes of
      Left _ → H.modify _{ errored = true }
      Right _ → H.raise Dismiss
  pure next

eval (ToggleShouldGenerateToken next) = next <$ do
  state ← H.get
  case state.permToken of
    Nothing →
      unless state.shouldGenerateToken do
        mbOIDC ← H.lift Auth.getIdToken
        workspacePath ← H.gets (_.workspacePath ∘ _.sharingInput)
        for_ mbOIDC \oidc → do
          let
            actions = sharingActions state.sharingInput View
            tokenName = Just $ workspaceTokenName workspacePath oidc
          H.modify _{submitting = true}
          recreatedRes ← Q.createToken tokenName actions
          H.modify _{submitting = false}
          H.modify case recreatedRes of
            Left _ →
              _ { permToken = Nothing
                , errored = true
                }
            Right token →
              _ { permToken = Just token
                , errored = false
                }
    Just tok → do
      H.modify _{submitting = true}
      deleteRes ← Q.deleteToken tok.id
      H.modify _{submitting = false}
      H.modify case deleteRes of
        Left _ → _ { errored = true }
        Right _ → _ { errored = false, permToken = Nothing }
  H.modify _{shouldGenerateToken = not state.shouldGenerateToken}
  updateCopyVal

eval (PreventDefault ev next) =
  H.liftEff (DOM.preventDefault ev) $> next
eval (HandleCancel next) =
  H.raise Dismiss $> next

workspaceTokenName ∷ UP.DirPath → OIDC.IdToken → QTA.TokenName
workspaceTokenName workspacePath idToken =
  let
    payload =
      hush $ Eff.runPure $ Exception.try $ OIDC.readPayload idToken
    email =
      fromMaybe "unknown user" $ unwrap <$> (OIDC.pluckEmail =<< payload)
    workspace =
      Pathy.printPath workspacePath
  in
    QTA.TokenName
      $ "publish permission granted by "
      ⊕ email
      ⊕ " for "
      ⊕ workspace

updateCopyVal ∷ DSL Unit
updateCopyVal = do
  locString ← H.liftEff locationString
  state ← H.get
  let
    copyVal = renderCopyVal locString state

  H.modify _{ copyVal = copyVal }
  clipboard ← H.gets _.clipboard
  case clipboard of
    Just c -> H.liftEff $ C.destroy c
    Nothing -> pure unit
  H.getHTMLElementRef copyButtonRef >>= traverse_ \htmlEl → do
    newClipboard ← H.liftEff $ C.fromElement (toElement htmlEl) (pure copyVal)
    H.modify _{ clipboard = Just newClipboard }

renderCopyVal ∷ String → State → String
renderCopyVal locString state
  | state.presentingAs ≡ URI =
    renderURL locString state
  | otherwise
      = Str.joinWith "\n"
          [ """<!-- This is the DOM element that the deck will be inserted into. -->"""
          , """<!-- You can change the width and height and use a stylesheet to apply styling. -->"""
          , """<iframe frameborder="0" width="100%" height="800" id=""" ⊕ quoted deckDOMId ⊕ """></iframe>"""
          , """"""
          , """<!-- To change a deck's variables after it has been inserted please use window.slamDataDeckUrl to create an new URL then update the deck iframe's src parameter. -->"""
          , """<script type="text/javascript">"""
          , """  window.slamDataDeckUrl = function (options) {"""
          , """    var queryParts = function () {"""
          , """      var parts = [];"""
          , """      if (options.echartTheme) {"""
          , """        parts.push("echartTheme=" + encodeURIComponent(options.echartTheme));"""
          , """      }"""
          , """      if (options.permissionTokens && options.permissionTokens.length) {"""
          , """        parts.push("permissionTokens=" + options.permissionTokens.join(","));"""
          , """      }"""
          , """      if (options.stylesheetUrls && options.stylesheetUrls.length) {"""
          , """        parts.push("stylesheets=" + options.stylesheetUrls.map(encodeURIComponent).join(","));"""
          , """      }"""
          , """      return parts;"""
          , """    };"""
          , """    var queryString = "?" + queryParts().join("&");"""
          , """    var varsParam = options.vars ? "/?vars=" + encodeURIComponent(JSON.stringify(options.vars)) : "";"""
          , """    return options.slamDataUrl + queryString + "#" + options.deckPath + options.deckId + "/view" + varsParam;"""
          , """  };"""
          , """</script>"""
          , """"""
          , """<!-- This is the script which performs SlamData deck insertion. -->"""
          , """<script type="text/javascript">"""
          , """  (function () {"""
          , """    var options = {"""
          , """      slamDataUrl: """ ⊕ quoted workspaceURL ⊕ ""","""
          , """      deckPath: """ ⊕ quoted deckPath ⊕ ""","""
          , """      deckId: """ ⊕ quoted deckId ⊕ ""","""
          , """      permissionTokens: [""" ⊕ maybe "" quoted token ⊕ """],"""
          , """      stylesheetUrls: [], // An array of custom stylesheet URLs."""
          , """      echartTheme: undefined,"""
          , """      vars: """ ⊕ renderVarMaps state.varMaps
          , """    };"""
          , """"""
          , """    var deckSelector = "iframe#sd-deck-" + options.deckId;"""
          , """    var deckElement = document.querySelector(deckSelector);"""
          , """"""
          , """    if (deckElement) {"""
          , """      deckElement.src = window.slamDataDeckUrl(options);"""
          , """    } else {"""
          , """      throw("SlamData: Couldn't locate " + deckSelector);"""
          , """    }"""
          , """  })();"""
          , """</script>"""
          ]
    where
    line = (_ ⊕ "\n")
    quoted s = "\"" ⊕ s ⊕ "\""
    workspaceURL = locString ⊕ "/" ⊕ Config.workspaceUrl
    deckId = DID.toString state.sharingInput.deckId
    deckDOMId = "sd-deck-" ⊕ deckId
    deckPath = UP.encodeURIPath (Pathy.printPath state.sharingInput.workspacePath)
    token = QTA.runTokenHash <<< _.secret <$> state.permToken

renderVarMaps ∷ Map.Map CID.CardId Port.VarMap → String
renderVarMaps = indent <<< prettyJson <<< encodeJson <<< varMapsForURL
  where
  indent = RX.replace (unsafePartial fromRight $ RX.regex "(\n\r?)" RXF.global) "$1      "

renderURL ∷ String → State → String
renderURL locationString state@{sharingInput, permToken, isLoggedIn} =
  locationString
  ⊕ "/"
  ⊕ Config.workspaceUrl
  ⊕ foldMap
      (append "?permissionTokens=" ∘ QTA.runTokenHash)
      (do guard isLoggedIn
          token ← permToken
          pure token.secret)
  ⊕ mkWorkspaceHash (deckPath' sharingInput.workspacePath sharingInput.deckId) (WA.Load AT.ReadOnly) SM.empty


Improve help message

Improve help message

-- | This module defines the interpreter for the Insect language.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.StrMap (lookup, insert, foldMap)
import Data.Bifunctor (lmap)

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, simplifyUnit)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..))
import Insect.Environment (Environment, initialEnvironment)

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) = { msg: Message Error (evalErrorMessage e), newEnv: env }
message env (Right q) = { msg: Message Value (prettyPrint q), newEnv: env }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (simplifyUnit <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (simplifyUnit value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "insect is a command-line scientific calculator."
  , ""
  , "It evaluates simple calculations like 1920/16·9 as"
  , "well as expressions involving physical quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "--> 1920/16*9"
  , ""
  , "--> 2min + 30s"
  , ""
  , "--> 60mph -> m/s"
  , ""
  , "--> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }

-- | This module defines the interpreter for the Insect language.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.StrMap (lookup, insert, foldMap)
import Data.Bifunctor (lmap)

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, simplifyUnit)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..))
import Insect.Environment (Environment, initialEnvironment)

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) = { msg: Message Error (evalErrorMessage e), newEnv: env }
message env (Right q) = { msg: Message Value (prettyPrint q), newEnv: env }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (simplifyUnit <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (simplifyUnit value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "INSECT is a command-line scientific calculator."
  , ""
  , "It understands simple calculations like 1920 / 16 · 9"
  , "as well as mathematical expressions involving physical"
  , "quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "> 1920/16·9"
  , "> 2min + 30s"
  , "> 60mph -> m/s"
  , "> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }