IRNothing can be null

IRNothing can be null

IRNothing means anything, so it can also be
null.  See #56

Original commit 282339c84b4ff1aaa6bbe675c940f50356d27cf6

module IRGraph
    ( IRGraph(..)
    , Named(..)
    , namedValue
    , unifyNamed
    , mapToInferred
    , IRClassData(..)
    , IRType(..)
    , IRUnionRep(..)
    , irUnion_Nothing
    , irUnion_Null
    , irUnion_Integer
    , irUnion_Double
    , irUnion_Bool
    , irUnion_String
    , unionToSet
    , Entry(..)
    , makeClass
    , emptyGraph
    , followIndex
    , getClassFromGraph
    , nullifyNothing
    , nullableFromSet
    , canBeNull
    , isArray
    , isClass
    , isMap
    , matchingProperties
    , mapClasses
    , classesInGraph
    , regatherClassNames
    , regatherUnionNames
    , filterTypes
    , emptyUnion
    ) where

import Prelude

import Data.Foldable (all)
import Data.Int.Bits as Bits
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust, maybe, fromMaybe)
import Data.Sequence as Seq
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Data.Tuple as T
import Partial.Unsafe (unsafePartial)

data Entry
    = NoType
    | Class IRClassData
    | Redirect Int

newtype IRGraph = IRGraph { classes :: Seq.Seq Entry, toplevels :: Map String IRType }

-- Explicitly given names always take precedence over inferred ones.
data Named a
    = Given a
    | Inferred a

updateGiven :: forall a b. (Maybe a -> b) -> Named a -> Named b
updateGiven f (Given x) = Given $ f $ Just x
updateGiven f _ = Given $ f Nothing

updateInferred :: forall a. (a -> a) -> Named a -> Named a
updateInferred f (Inferred x) = Inferred $ f x
updateInferred _ given = given

namedValue :: forall a. Named a -> a
namedValue (Given x) = x
namedValue (Inferred x) = x

mapToInferred :: forall a b. (a -> b) -> Named a -> Named b
mapToInferred f n = Inferred $ f $ namedValue n

unifyNamed :: forall a. (a -> a -> a) -> Named a -> Named a -> Named a
unifyNamed f (Given ga) (Given gb) = Given $ f ga gb
unifyNamed f a@(Given _) _ = a
unifyNamed f _ b@(Given _) = b
unifyNamed f (Inferred ia) (Inferred ib) = Inferred $ f ia ib

instance functorNamed :: Functor Named where
    map f (Given x) = Given $ f x
    map f (Inferred x) = Inferred $ f x

newtype IRClassData = IRClassData { names :: Named (Set String), properties :: Map String IRType }

newtype IRUnionRep = IRUnionRep { names :: Named (Set String), primitives :: Int, arrayType :: Maybe IRType, classRef :: Maybe Int, mapType :: Maybe IRType }

irUnion_Nothing = 1
irUnion_Null = 2
irUnion_Integer = 4
irUnion_Double = 8
irUnion_Bool = 16
irUnion_String = 32

data IRType
    -- FIXME: IRNothing should never appear in proper types
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRMap IRType
    | IRUnion IRUnionRep

derive instance eqNamed :: Eq a => Eq (Named a)
derive instance ordNamed :: Ord a => Ord (Named a)
derive instance eqEntry :: Eq Entry
derive instance eqIRType :: Eq IRType
derive instance ordIRType :: Ord IRType
derive instance eqIRClassData :: Eq IRClassData
derive instance ordIRClassData :: Ord IRClassData
derive instance eqIRUnionRep :: Eq IRUnionRep
derive instance ordIRUnionRep :: Ord IRUnionRep
derive instance eqGraph :: Eq IRGraph

makeClass :: Named String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: map S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: Seq.empty, toplevels: M.empty }

followIndex :: IRGraph -> Int -> Tuple Int IRClassData
followIndex graph@(IRGraph { classes }) index =
    unsafePartial $
        case fromJust $ Seq.index index classes of
        Class cd -> Tuple index cd
        Redirect i -> followIndex graph i

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph index = T.snd $ followIndex graph index

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) = L.concat $ L.mapWithIndex mapper (L.fromFoldable classes)
    where
        mapper _ NoType = L.Nil
        mapper _ (Redirect _) = L.Nil
        mapper i (Class cd) = (f i cd) : L.Nil

mapClassesInSeq :: (Int -> IRClassData -> IRClassData) -> Seq.Seq Entry -> Seq.Seq Entry
mapClassesInSeq f entries =
    Seq.fromFoldable $ L.mapWithIndex entryMapper $ L.fromFoldable entries
    where
        entryMapper i (Class cd) = Class $ f i cd
        entryMapper _ x = x

classesInGraph :: IRGraph -> List (Tuple Int IRClassData)
classesInGraph = mapClasses Tuple

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

isMap :: IRType -> Boolean
isMap (IRMap _) = true
isMap _ = false

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

-- FIXME: This should take an IRUnionRep
nullableFromSet :: Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

canBeNull :: IRType -> Boolean
canBeNull =
    case _ of
    IRNothing -> true
    IRNull -> true
    IRUnion (IRUnionRep { primitives }) -> (Bits.and primitives irUnion_Null) /= 0
    _ -> false

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb = M.fromFoldable $ L.concatMap getFromB (M.toUnfoldable ma)
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb | va == vb -> Tuple k vb : L.Nil
                    | otherwise -> L.Nil
            Nothing -> L.Nil

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubclassOf :: IRGraph -> Int -> Int -> Boolean
isSubclassOf graph ia ib =
    let IRClassData { properties: pa } = getClassFromGraph graph ia
        IRClassData { properties: pb } = getClassFromGraph graph ib
    in propertiesAreSubset pa pb
    where
        propertiesAreSubset :: Map String IRType -> Map String IRType -> Boolean
        propertiesAreSubset ma mb = all (isInB mb) (M.toUnfoldable ma :: List _)
        isInB mb (Tuple n ta) = maybe false (isSubtypeOf graph ta) (M.lookup n mb)

-- FIXME: generalize with isMaybeSubtypeOfMaybe
isMaybeSubclassOfMaybe :: IRGraph -> Maybe Int -> Maybe Int -> Boolean
isMaybeSubclassOfMaybe _ Nothing Nothing = true
isMaybeSubclassOfMaybe graph (Just a) (Just b) = isSubclassOf graph a b
isMaybeSubclassOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion a) (IRUnion b) =
    let IRUnionRep { primitives: pa, arrayType: aa, classRef: ca, mapType: ma } = a
        IRUnionRep { primitives: pb, arrayType: ab, classRef: cb, mapType: mb } = a
    in
        (Bits.and pa pb) == pa &&
        isMaybeSubtypeOfMaybe graph aa ab &&
        isMaybeSubtypeOfMaybe graph ma mb &&
        isMaybeSubclassOfMaybe graph ca cb
isSubtypeOf graph (IRArray a) (IRArray b) = isSubtypeOf graph a b
isSubtypeOf graph (IRMap a) (IRMap b) = isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) = isSubclassOf graph ia ib
isSubtypeOf _ a b = a == b

regatherClassNames :: IRGraph -> IRGraph
regatherClassNames graph@(IRGraph { classes, toplevels }) =
    -- FIXME: gather names from top levels map, too
    IRGraph { classes: mapClassesInSeq classMapper classes, toplevels }
    where
        newNames = combine $ mapClasses gatherFromClassData graph
        classMapper :: Int -> IRClassData -> IRClassData
        classMapper i (IRClassData { names, properties }) =
            let newNamesForClass = updateInferred (\old -> fromMaybe old $ M.lookup i newNames) names
            in IRClassData { names: newNamesForClass, properties}
        gatherFromClassData :: Int -> IRClassData -> Map Int (Set String)
        gatherFromClassData _ (IRClassData { properties }) =
            combine $ map (\(Tuple n t) -> gatherFromType n t) (M.toUnfoldable properties :: List _)
        combine :: List (Map Int (Set String)) -> Map Int (Set String)
        combine =
            L.foldr (M.unionWith S.union) M.empty
        gatherFromType :: String -> IRType -> Map Int (Set String)
        gatherFromType name t =
            case t of
            IRClass i -> M.singleton i (S.singleton name)
            IRArray a -> gatherFromType (singular name) a
            IRMap m -> gatherFromType (singular name) m
            IRUnion (IRUnionRep { arrayType, classRef, mapType }) ->
                let fromArray = maybe M.empty (gatherFromType name) arrayType
                    fromMap = maybe M.empty (gatherFromType name) mapType
                    fromClass = maybe M.empty (\i -> gatherFromType name $ IRClass i) classRef
                in
                    combine $ (fromArray : fromMap : fromClass : L.Nil)
            _ -> M.empty

regatherUnionNames :: IRGraph -> IRGraph
regatherUnionNames graph@(IRGraph { classes, toplevels }) =
    let newClasses = mapClassesInSeq (const classMapper) classes
        newTopLevels = M.mapWithKey (updateType <<< Given) toplevels
    in
        IRGraph { classes: newClasses, toplevels: newTopLevels }
    where
        classMapper (IRClassData { names, properties }) =
            IRClassData { names, properties: M.mapWithKey (updateType <<< Inferred) properties }
        reassign name names =
            case name of
            Given g -> updateGiven (maybe (S.singleton g) (S.insert g)) names
            Inferred i -> updateInferred (const $ S.singleton i) names
        updateType :: Named String -> IRType -> IRType
        updateType name t =
            case t of
            IRArray a -> IRArray $ updateType name a
            IRMap m -> IRMap $ updateType name m
            IRUnion (IRUnionRep { names, primitives, arrayType, classRef, mapType}) ->
                let newNames = reassign name names
                    singularName = mapToInferred singular name
                    newArrayType = map (updateType singularName) arrayType
                    newMapType = map (updateType singularName) mapType
                in
                    IRUnion $ IRUnionRep { names: newNames, primitives, arrayType: newArrayType, classRef, mapType: newMapType }
            _ -> t

unionToSet :: IRUnionRep -> Set IRType
unionToSet (IRUnionRep { primitives, arrayType, classRef, mapType }) =
    let types1 = addIfSet irUnion_Nothing IRNothing L.Nil
        types2 = addIfSet irUnion_Null IRNull types1
        types3 = addIfSet irUnion_Integer IRInteger types2
        types4 = addIfSet irUnion_Double IRDouble types3
        types5 = addIfSet irUnion_Bool IRBool types4
        types6 = addIfSet irUnion_String IRString types5
        types7 = addIfJust IRArray arrayType types6
        types8 = addIfJust IRClass classRef types7
        types9 = addIfJust IRMap mapType types8
    in
        S.fromFoldable types9
    where
        addIfSet bit t l =
            if (Bits.and bit primitives) == 0 then l else t : l
        addIfJust :: forall a. (a -> IRType) -> Maybe a -> List IRType -> List IRType
        addIfJust c m l =
            case m of
            Just x -> c x : l
            Nothing -> l

filterTypes :: forall a. Ord a => (IRType -> Maybe a) -> IRGraph -> Set a
filterTypes predicate graph@(IRGraph { classes, toplevels }) =
    let fromTopLevels = S.unions $ map filterType $ M.values toplevels
        fromGraph = S.unions $ mapClasses (\_ cd -> filterClass cd) graph
    in
        S.union fromTopLevels fromGraph
    where
        filterClass :: IRClassData -> Set a
        filterClass (IRClassData { properties }) =
            S.unions $ map filterType $ M.values properties
        recurseType t =
            case t of
            IRArray t -> filterType t
            IRMap t -> filterType t
            IRUnion r ->
                S.unions $ S.map filterType $ unionToSet r
            _ -> S.empty
        filterType :: IRType -> Set a
        filterType t =
            let l = recurseType t
            in
                case predicate t of
                Nothing -> l
                Just x -> S.insert x l

emptyUnion :: IRUnionRep
emptyUnion =
    IRUnionRep { names: Inferred $ S.empty, primitives: 0, arrayType: Nothing, classRef: Nothing, mapType: Nothing }

module IRGraph
    ( IRGraph(..)
    , Named(..)
    , namedValue
    , unifyNamed
    , mapToInferred
    , IRClassData(..)
    , IRType(..)
    , IRUnionRep(..)
    , irUnion_Nothing
    , irUnion_Null
    , irUnion_Integer
    , irUnion_Double
    , irUnion_Bool
    , irUnion_String
    , unionToSet
    , Entry(..)
    , makeClass
    , emptyGraph
    , followIndex
    , getClassFromGraph
    , nullifyNothing
    , nullableFromSet
    , canBeNull
    , isArray
    , isClass
    , isMap
    , matchingProperties
    , mapClasses
    , classesInGraph
    , regatherClassNames
    , regatherUnionNames
    , filterTypes
    , emptyUnion
    ) where

import Prelude

import Data.Foldable (all)
import Data.Int.Bits as Bits
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust, maybe, fromMaybe)
import Data.Sequence as Seq
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Data.Tuple as T
import Partial.Unsafe (unsafePartial)

data Entry
    = NoType
    | Class IRClassData
    | Redirect Int

newtype IRGraph = IRGraph { classes :: Seq.Seq Entry, toplevels :: Map String IRType }

-- Explicitly given names always take precedence over inferred ones.
data Named a
    = Given a
    | Inferred a

updateGiven :: forall a b. (Maybe a -> b) -> Named a -> Named b
updateGiven f (Given x) = Given $ f $ Just x
updateGiven f _ = Given $ f Nothing

updateInferred :: forall a. (a -> a) -> Named a -> Named a
updateInferred f (Inferred x) = Inferred $ f x
updateInferred _ given = given

namedValue :: forall a. Named a -> a
namedValue (Given x) = x
namedValue (Inferred x) = x

mapToInferred :: forall a b. (a -> b) -> Named a -> Named b
mapToInferred f n = Inferred $ f $ namedValue n

unifyNamed :: forall a. (a -> a -> a) -> Named a -> Named a -> Named a
unifyNamed f (Given ga) (Given gb) = Given $ f ga gb
unifyNamed f a@(Given _) _ = a
unifyNamed f _ b@(Given _) = b
unifyNamed f (Inferred ia) (Inferred ib) = Inferred $ f ia ib

instance functorNamed :: Functor Named where
    map f (Given x) = Given $ f x
    map f (Inferred x) = Inferred $ f x

newtype IRClassData = IRClassData { names :: Named (Set String), properties :: Map String IRType }

newtype IRUnionRep = IRUnionRep { names :: Named (Set String), primitives :: Int, arrayType :: Maybe IRType, classRef :: Maybe Int, mapType :: Maybe IRType }

irUnion_Nothing = 1
irUnion_Null = 2
irUnion_Integer = 4
irUnion_Double = 8
irUnion_Bool = 16
irUnion_String = 32

data IRType
    -- FIXME: IRNothing should never appear in proper types
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRMap IRType
    | IRUnion IRUnionRep

derive instance eqNamed :: Eq a => Eq (Named a)
derive instance ordNamed :: Ord a => Ord (Named a)
derive instance eqEntry :: Eq Entry
derive instance eqIRType :: Eq IRType
derive instance ordIRType :: Ord IRType
derive instance eqIRClassData :: Eq IRClassData
derive instance ordIRClassData :: Ord IRClassData
derive instance eqIRUnionRep :: Eq IRUnionRep
derive instance ordIRUnionRep :: Ord IRUnionRep
derive instance eqGraph :: Eq IRGraph

makeClass :: Named String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: map S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: Seq.empty, toplevels: M.empty }

followIndex :: IRGraph -> Int -> Tuple Int IRClassData
followIndex graph@(IRGraph { classes }) index =
    unsafePartial $
        case fromJust $ Seq.index index classes of
        Class cd -> Tuple index cd
        Redirect i -> followIndex graph i

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph index = T.snd $ followIndex graph index

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) = L.concat $ L.mapWithIndex mapper (L.fromFoldable classes)
    where
        mapper _ NoType = L.Nil
        mapper _ (Redirect _) = L.Nil
        mapper i (Class cd) = (f i cd) : L.Nil

mapClassesInSeq :: (Int -> IRClassData -> IRClassData) -> Seq.Seq Entry -> Seq.Seq Entry
mapClassesInSeq f entries =
    Seq.fromFoldable $ L.mapWithIndex entryMapper $ L.fromFoldable entries
    where
        entryMapper i (Class cd) = Class $ f i cd
        entryMapper _ x = x

classesInGraph :: IRGraph -> List (Tuple Int IRClassData)
classesInGraph = mapClasses Tuple

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

isMap :: IRType -> Boolean
isMap (IRMap _) = true
isMap _ = false

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

-- FIXME: This should take an IRUnionRep
nullableFromSet :: Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

canBeNull :: IRType -> Boolean
canBeNull =
    case _ of
    IRNull -> true
    IRUnion (IRUnionRep { primitives }) -> (Bits.and primitives irUnion_Null) /= 0
    _ -> false

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb = M.fromFoldable $ L.concatMap getFromB (M.toUnfoldable ma)
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb | va == vb -> Tuple k vb : L.Nil
                    | otherwise -> L.Nil
            Nothing -> L.Nil

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubclassOf :: IRGraph -> Int -> Int -> Boolean
isSubclassOf graph ia ib =
    let IRClassData { properties: pa } = getClassFromGraph graph ia
        IRClassData { properties: pb } = getClassFromGraph graph ib
    in propertiesAreSubset pa pb
    where
        propertiesAreSubset :: Map String IRType -> Map String IRType -> Boolean
        propertiesAreSubset ma mb = all (isInB mb) (M.toUnfoldable ma :: List _)
        isInB mb (Tuple n ta) = maybe false (isSubtypeOf graph ta) (M.lookup n mb)

-- FIXME: generalize with isMaybeSubtypeOfMaybe
isMaybeSubclassOfMaybe :: IRGraph -> Maybe Int -> Maybe Int -> Boolean
isMaybeSubclassOfMaybe _ Nothing Nothing = true
isMaybeSubclassOfMaybe graph (Just a) (Just b) = isSubclassOf graph a b
isMaybeSubclassOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion a) (IRUnion b) =
    let IRUnionRep { primitives: pa, arrayType: aa, classRef: ca, mapType: ma } = a
        IRUnionRep { primitives: pb, arrayType: ab, classRef: cb, mapType: mb } = a
    in
        (Bits.and pa pb) == pa &&
        isMaybeSubtypeOfMaybe graph aa ab &&
        isMaybeSubtypeOfMaybe graph ma mb &&
        isMaybeSubclassOfMaybe graph ca cb
isSubtypeOf graph (IRArray a) (IRArray b) = isSubtypeOf graph a b
isSubtypeOf graph (IRMap a) (IRMap b) = isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) = isSubclassOf graph ia ib
isSubtypeOf _ a b = a == b

regatherClassNames :: IRGraph -> IRGraph
regatherClassNames graph@(IRGraph { classes, toplevels }) =
    -- FIXME: gather names from top levels map, too
    IRGraph { classes: mapClassesInSeq classMapper classes, toplevels }
    where
        newNames = combine $ mapClasses gatherFromClassData graph
        classMapper :: Int -> IRClassData -> IRClassData
        classMapper i (IRClassData { names, properties }) =
            let newNamesForClass = updateInferred (\old -> fromMaybe old $ M.lookup i newNames) names
            in IRClassData { names: newNamesForClass, properties}
        gatherFromClassData :: Int -> IRClassData -> Map Int (Set String)
        gatherFromClassData _ (IRClassData { properties }) =
            combine $ map (\(Tuple n t) -> gatherFromType n t) (M.toUnfoldable properties :: List _)
        combine :: List (Map Int (Set String)) -> Map Int (Set String)
        combine =
            L.foldr (M.unionWith S.union) M.empty
        gatherFromType :: String -> IRType -> Map Int (Set String)
        gatherFromType name t =
            case t of
            IRClass i -> M.singleton i (S.singleton name)
            IRArray a -> gatherFromType (singular name) a
            IRMap m -> gatherFromType (singular name) m
            IRUnion (IRUnionRep { arrayType, classRef, mapType }) ->
                let fromArray = maybe M.empty (gatherFromType name) arrayType
                    fromMap = maybe M.empty (gatherFromType name) mapType
                    fromClass = maybe M.empty (\i -> gatherFromType name $ IRClass i) classRef
                in
                    combine $ (fromArray : fromMap : fromClass : L.Nil)
            _ -> M.empty

regatherUnionNames :: IRGraph -> IRGraph
regatherUnionNames graph@(IRGraph { classes, toplevels }) =
    let newClasses = mapClassesInSeq (const classMapper) classes
        newTopLevels = M.mapWithKey (updateType <<< Given) toplevels
    in
        IRGraph { classes: newClasses, toplevels: newTopLevels }
    where
        classMapper (IRClassData { names, properties }) =
            IRClassData { names, properties: M.mapWithKey (updateType <<< Inferred) properties }
        reassign name names =
            case name of
            Given g -> updateGiven (maybe (S.singleton g) (S.insert g)) names
            Inferred i -> updateInferred (const $ S.singleton i) names
        updateType :: Named String -> IRType -> IRType
        updateType name t =
            case t of
            IRArray a -> IRArray $ updateType name a
            IRMap m -> IRMap $ updateType name m
            IRUnion (IRUnionRep { names, primitives, arrayType, classRef, mapType}) ->
                let newNames = reassign name names
                    singularName = mapToInferred singular name
                    newArrayType = map (updateType singularName) arrayType
                    newMapType = map (updateType singularName) mapType
                in
                    IRUnion $ IRUnionRep { names: newNames, primitives, arrayType: newArrayType, classRef, mapType: newMapType }
            _ -> t

unionToSet :: IRUnionRep -> Set IRType
unionToSet (IRUnionRep { primitives, arrayType, classRef, mapType }) =
    let types1 = addIfSet irUnion_Nothing IRNothing L.Nil
        types2 = addIfSet irUnion_Null IRNull types1
        types3 = addIfSet irUnion_Integer IRInteger types2
        types4 = addIfSet irUnion_Double IRDouble types3
        types5 = addIfSet irUnion_Bool IRBool types4
        types6 = addIfSet irUnion_String IRString types5
        types7 = addIfJust IRArray arrayType types6
        types8 = addIfJust IRClass classRef types7
        types9 = addIfJust IRMap mapType types8
    in
        S.fromFoldable types9
    where
        addIfSet bit t l =
            if (Bits.and bit primitives) == 0 then l else t : l
        addIfJust :: forall a. (a -> IRType) -> Maybe a -> List IRType -> List IRType
        addIfJust c m l =
            case m of
            Just x -> c x : l
            Nothing -> l

filterTypes :: forall a. Ord a => (IRType -> Maybe a) -> IRGraph -> Set a
filterTypes predicate graph@(IRGraph { classes, toplevels }) =
    let fromTopLevels = S.unions $ map filterType $ M.values toplevels
        fromGraph = S.unions $ mapClasses (\_ cd -> filterClass cd) graph
    in
        S.union fromTopLevels fromGraph
    where
        filterClass :: IRClassData -> Set a
        filterClass (IRClassData { properties }) =
            S.unions $ map filterType $ M.values properties
        recurseType t =
            case t of
            IRArray t -> filterType t
            IRMap t -> filterType t
            IRUnion r ->
                S.unions $ S.map filterType $ unionToSet r
            _ -> S.empty
        filterType :: IRType -> Set a
        filterType t =
            let l = recurseType t
            in
                case predicate t of
                Nothing -> l
                Just x -> S.insert x l

emptyUnion :: IRUnionRep
emptyUnion =
    IRUnionRep { names: Inferred $ S.empty, primitives: 0, arrayType: Nothing, classRef: Nothing, mapType: Nothing }


alternative implementation of itemized duration

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Int (fromNumber, toNumber)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Milliseconds(..), Minutes)
import Data.Tuple (Tuple(..))
import Math (floor, remainder)
import Partial.Unsafe (unsafePartial)

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
     in if startDatetime < now
        then Nothing
        else let difference :: ItemizedDuration
                 difference = diff startDatetime now
                 (Itemized itemized) = difference
                 formatTime t = if t < 10 then "0" <> show t else show t
                 dd = case itemized.days of
                        0 -> ""
                        1 -> "1 day and "
                        d -> show d <> " days and "
                 hh = formatTime itemized.hours
                 mm = formatTime itemized.minutes
                 ss = formatTime itemized.seconds
              in Just $ dd <> hh <> ":" <> mm <> ":" <> ss

data ItemizedDuration = Itemized { days :: Int
                                 , hours :: Int
                                 , minutes :: Int
                                 , seconds :: Int
                                 , ms :: Number
                                 }

instance durationItemized :: Duration ItemizedDuration where
  fromDuration (Itemized { days, hours, minutes, seconds, ms }) =
    Milliseconds (toNumber (days * msInDay + hours * msInHour + minutes * msInMinute + seconds * msInSecond) + ms)
    where msInSecond = 1000
          msInMinute = 60 * msInSecond
          msInHour = 60 * msInMinute
          msInDay = 24 * msInHour
  toDuration (Milliseconds ms') = Itemized { days, hours, minutes, seconds, ms }
    where toInt n = unsafePartial $ fromJust $ fromNumber n
          divMod x y = Tuple (floor $ div x y) (remainder x y)
          Tuple s' ms = divMod ms' 1000.0
          Tuple m' s  = divMod s' 60.0
          Tuple h' m  = divMod m' 60.0
          Tuple d  h  = divMod h' 24.0
          days    = toInt d  -- Number.MAX_SAFE_INTEGER / 86400000 is smaller than 2^31
          hours   = toInt h
          minutes = toInt m
          seconds = toInt s

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Hours(..), Milliseconds(..), Minutes(..), Seconds(..), convertDuration)
import Data.Tuple (Tuple(..))
import Math (remainder)

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
     in if startDatetime < now
        then Nothing
        else let timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
                 difference :: ItemizedDuration
                 difference = diff startDatetime now
              in case difference of
                (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) ->
                  let dd = show $ floor d
                      hh = format timeFormatter h
                      mm = format timeFormatter m
                      ss = format timeFormatter s
                  in Just $ (if d > 0.0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss

msInSecond :: Number
msInSecond = 1000.0
msInMinute :: Number
msInMinute = 60.0 * msInSecond
msInHour :: Number
msInHour = 60.0 * msInMinute
msInDay :: Number
msInDay = 24.0 * msInHour

data ItemizedDuration = Itemized Days Hours Minutes Seconds Milliseconds

instance durationItemized :: Duration ItemizedDuration where
  fromDuration (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) =
    Milliseconds (d * msInDay + h * msInHour + m * msInMinute + s * msInSecond + ms)
  toDuration (Milliseconds ms') = Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)
    where divMod x y = Tuple (div x y) (remainder x y)
          Tuple s' ms = divMod ms' 1000.0
          Tuple m' s  = divMod s' 60.0
          Tuple h' m  = divMod m' 60.0
          Tuple d  h  = divMod h' 24.0


Fix draftboard caching

Fix draftboard caching

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Component
  ( draftboardComponent
  , module SlamData.Workspace.Card.Draftboard.Component.Query
  , module SlamData.Workspace.Card.Draftboard.Component.State
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception as Exn
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)

import Data.Array as Array
import Data.Function (on)
import Data.Lens ((.~), (?~))
import Data.List as List
import Data.Map as Map
import CSS as CSS

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.Component.Opaque.Unsafe (opaqueState)
import Halogen.Component.Utils.Drag as Drag
import Halogen.Component.Utils (raise')
import Halogen.CustomEvents (mouseEventToPageEvent)
import Halogen.HTML.CSS.Indexed as HC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Math (round, floor)

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Quasar.Data as Quasar
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Common (deleteGraph)
import SlamData.Workspace.Card.Draftboard.Component.CSS as CCSS
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..), QueryP, QueryC)
import SlamData.Workspace.Card.Draftboard.Component.State (State, DeckPosition, initialState, encode, decode, _moving, _inserting, _grouping, modelFromState)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Deck.Common (wrappedDeck, defaultPosition)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString, freshDeckId)
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Wiring (putDeck)

import Utils.CSS (zIndex)
import Utils.DOM (elementEq, scrollTop, scrollLeft, getOffsetClientRect)
import Utils.Path (DirPath)

type DraftboardDSL = H.ParentDSL State DNS.State QueryC DNQ.QueryP Slam DeckId

type DraftboardHTML = H.ParentHTML DNS.State QueryC DNQ.QueryP Slam DeckId

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent opts = CC.makeCardComponent
  { cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render opts
      , eval: coproduct evalCard (evalBoard opts)
      , peek: Just (peek opts)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

render ∷ CardOptions → State → DraftboardHTML
render opts state =
  HH.div_
    [ HH.div [ HP.class_ CCSS.insetShadow ] []
    , HH.div
        [ HP.class_ CCSS.grid
        , HC.style bgSize
        , HP.ref (right ∘ H.action ∘ SetElement)
        , HE.onClick \e → pure $
            guard (AT.isEditable opts.deck.accessType && not state.inserting) $>
            right (H.action $ AddDeck e)
        ]
        $ map renderDeck (foldl Array.snoc [] $ Map.toList state.decks)
    ]

  where
  renderDeck (deckId × rect) =
    HH.div
      [ HP.key $ deckIdToString deckId
      , HP.classes $
          case state.grouping of
            Just deckId' | deckId == deckId' → [ HH.className "grouping" ]
            _ → []
      , HC.style $
          case state.moving of
            Just (deckId' × rect') | deckId == deckId' → zIndex 2 *> cssPos rect'
            _ → cssPos rect
      ]
      [ HH.slot deckId $ mkDeckComponent deckId ]

  mkDeckComponent id _ =
    { component: opts.deckComponent (opaqueState $ DCS.initialDeck opts.deck.path id)
    , initialState: DNS.initialState
    }

  cssPos rect = do
    CSS.position CSS.absolute
    CSS.top $ CSS.px $ gridToPx rect.y
    CSS.left $ CSS.px $ gridToPx rect.x
    CSS.width $ CSS.px $ gridToPx rect.width
    CSS.height $ CSS.px $ gridToPx rect.height

  bgSize = do
    let size = foldr maxSize { width: 0.0, height: 0.0 } state.decks
        size' = maybe size (flip maxSize size ∘ snd) state.moving
    CSS.width $ CSS.px $ gridToPx $ size'.width + 1.0
    CSS.height $ CSS.px $ gridToPx $ size'.height + 1.0

evalCard ∷ Natural CC.CardEvalQuery DraftboardDSL
evalCard = case _ of
  CC.EvalCard _ _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify _ { decks = model.decks }
        loadDecks
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Natural Query DraftboardDSL
evalBoard opts = case _ of
  Grabbing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        st ← H.get
        for_ (Map.lookup deckId (st.decks)) \rect →
        for_ st.canvas \el → do
          coords ← pageToGrid d el
          let
            cursorRect =
              { x: coords.x
              , y: coords.y
              , width: 1.0
              , height: 1.0
              }
            newRect = clampDeck rect
              { x = rect.x + (pxToGrid d.offsetX)
              , y = rect.y + (pxToGrid d.offsetY)
              }
            grouping =
              case overlapping cursorRect (Map.toList st.decks) of
                List.Cons (deckId' × _) _ | deckId ≠ deckId' → Just deckId'
                _ → Nothing
          H.modify
            $ (_moving ?~ Tuple deckId newRect)
            ∘ (_grouping .~ grouping)
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Resizing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
          let
            newRect = clampDeck rect
              { width = rect.width + (pxToGrid d.offsetX)
              , height = rect.height + (pxToGrid d.offsetY)
              }
          H.modify $ _moving ?~ Tuple deckId newRect
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  SetElement el next → do
    H.modify _ { canvas = el }
    pure next
  AddDeck e next → do
    let e' = mouseEventToPageEvent e
    H.gets _.canvas >>= traverse_ \el → do
      same ← H.fromEff (elementEq el e'.target)
      when same do
        coords ← pageToGrid { x: e'.pageX, y: e'.pageY } el
        addDeck opts DM.emptyDeck
          { x: floor $ coords.x + 1.0
          , y: floor $ coords.y
          }
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  LoadDeck deckId next → do
    queryDeck deckId
      $ H.action
      $ DCQ.Load opts.deck.path deckId (DL.succ opts.deck.level)
    pure next
  -- TODO: hopefully we can get rid of this later, as it's relatively expensive
  -- and will run quite frequently, as it's used to enable the `Unwrap` action.
  -- If we can add a real mechanism for handling card-specific actions on the
  -- deck backside we should be able to do something much more sensible, only
  -- building the decks' value here when we actually trigger an unwrap. -gb
  GetDecks k → do
    decks ← H.gets _.decks
    decks' ← runMaybeT $ for (Map.toList decks) \(deckId × position) -> do
      model ← MaybeT $ queryDeck deckId $ H.request DCQ.GetModel
      pure (deckId × (position × model))
    pure $ k $ maybe Map.empty Map.fromList decks'

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck = case _ of
    DCQ.GrabDeck ev _ → startDragging deckId ev Grabbing
    DCQ.ResizeDeck ev _ → startDragging deckId ev Resizing
    DCQ.DoAction DCQ.DeleteDeck _ → do
      deleteDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Wrap _ → do
      wrapDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction (DCQ.Unwrap decks) _ → do
      unwrapDeck opts deckId decks
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Mirror _ → do
      mirrorDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ → pure unit

  startDragging deckId ev tag =
    H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
      H.modify $ _moving ?~ Tuple deckId rect
      void
        $ Drag.subscribe' ev
        $ right ∘ H.action ∘ tag deckId

pageToGrid
  ∷ ∀ r
  . { x ∷ Number, y ∷ Number | r }
  → HTMLElement
  → DraftboardDSL { x ∷ Number, y ∷ Number }
pageToGrid e el = do
  rect ← H.fromEff $ getOffsetClientRect el
  scroll ←
    { top: _, left: _ }
    <$> H.fromEff (scrollTop el)
    <*> H.fromEff (scrollLeft el)
  pure
    { x: pxToGrid $ e.x - rect.left + scroll.left
    , y: pxToGrid $ e.y - rect.top + scroll.top
    }

pxToGrid ∷ Number → Number
pxToGrid = (_ / Config.gridPx)

gridToPx ∷ Number → Number
gridToPx = (_ * Config.gridPx)

stopDragging ∷ CardOptions → DraftboardDSL Unit
stopDragging opts = do
  st ← H.get
  for_ st.moving \(deckId × rect) → do
    let rect' = roundDeck rect
        decks = List.filter ((deckId /= _) ∘ fst) $ Map.toList st.decks
    case st.grouping of
      Just deckId' →
        groupDecks opts deckId deckId'
      Nothing →
        when (List.null $ overlapping rect' decks) do
          H.modify \s → s { decks = Map.insert deckId rect' s.decks }
  H.modify _
    { moving = Nothing
    , grouping = Nothing
    }

maxSize
  ∷ DeckPosition
  → { width ∷ Number, height ∷ Number }
  → { width ∷ Number, height ∷ Number }
maxSize deck size =
  { width: if x > size.width then x else size.width
  , height: if y > size.height then y else size.height
  }
  where
  x = deck.x + deck.width
  y = deck.y + deck.height

clampDeck ∷ DeckPosition → DeckPosition
clampDeck rect =
  { x: if rect.x < 0.0 then 0.0 else rect.x
  , y: if rect.y < 0.0 then 0.0 else rect.y
  , width: if rect.width < 10.0 then 10.0 else rect.width
  , height: if rect.height < 10.0 then 10.0 else rect.height
  }

roundDeck ∷ DeckPosition → DeckPosition
roundDeck rect =
  { x: round rect.x
  , y: round rect.y
  , width: round rect.width
  , height: round rect.height
  }

overlapping
  ∷ DeckPosition
  → List.List (DeckId × DeckPosition)
  → List.List (DeckId × DeckPosition)
overlapping a = List.filter go
  where
  go (_ × b) =
    not $ a.x + a.width <= b.x
       || b.x + b.width <= a.x
       || a.y + a.height <= b.y
       || b.y + b.height <= a.y

accomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → { x ∷ Number, y ∷ Number }
  → DeckPosition
  → Maybe DeckPosition
accomodateDeck bs = go List.Nil
  where
  go hist c a =
    case overlapping a bs of
      List.Nil →
        Just a
      bs' | not $ List.null $ List.intersectBy (eq `on` fst) hist bs' →
        Nothing
      List.Cons b _ →
        let a' = clampDeck $ reposition c a (snd b)
            c' = { x: a'.x + (floor (a'.width / 2.0)), y: a'.y }
        in  go (List.Cons b hist) c' a'

  reposition c a b
    | c.x >= b.x && c.x < b.x + b.width = a { y = b.y - a.height }
    | c.x >= b.x + b.width = a { x = b.x + b.width }
    | c.y < b.x = a { x = b.x - a.width }
    | otherwise = a

reallyAccomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → DeckPosition
  → DeckPosition
reallyAccomodateDeck decks deckPos =
  let deckPos' = deckPos { y = deckPos.y + deckPos.height }
      coords = { x: floor (deckPos'.x + deckPos'.x / 2.0), y: deckPos'.y }
  in
      case accomodateDeck decks coords deckPos of
        Nothing → reallyAccomodateDeck decks deckPos'
        Just a → a

loadDecks ∷ DraftboardDSL Unit
loadDecks =
  H.gets (Map.keys ∘ _.decks) >>=
    traverse_ (raise' ∘ right ∘ H.action ∘ LoadDeck)

addDeck ∷ CardOptions → DM.Deck → { x ∷ Number, y ∷ Number } → DraftboardDSL Unit
addDeck opts deck coords = do
  decks ← Map.toList <$> H.gets _.decks
  let
    deckPos = clampDeck $ defaultPosition
      { x = coords.x - 10.0
      , y = coords.y
      }
  for_ (accomodateDeck decks coords deckPos) $
    addDeckAt opts deck

addDeckAt ∷ CardOptions → DM.Deck → DeckPosition → DraftboardDSL Unit
addDeckAt { deck: opts, id: cardId } deck deckPos = do
  let
    parentId = opts.id
    deck' = deck { parent = Just (parentId × cardId) }
  H.modify $ _inserting .~ true
  deckId ← saveDeck opts.path deck'
  case deckId of
    Left err → do
      H.modify $ _inserting .~ false
      -- TODO: do something to notify the user saving failed
      pure unit
    Right deckId' → void do
      putDeck deckId' deck' opts.wiring.decks
      H.modify \s → s
        { decks = Map.insert deckId' deckPos s.decks
        , inserting = false
        }
      queryDeck deckId'
        $ H.action
        $ DCQ.Load opts.path deckId' (DL.succ opts.level)

saveDeck ∷ DirPath → DM.Deck → DraftboardDSL (Either Exn.Error DeckId)
saveDeck path model = runExceptT do
  i ← lift $ H.fromEff freshDeckId
  ExceptT $ Quasar.save (DM.deckIndex path i) $ DM.encode model
  pure i

deleteDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
deleteDeck { deck } deckId = do
  res ← deleteGraph deck.path deckId
  case res of
    Left err →
      -- TODO: do something to notify the user deleting failed
      pure unit
    Right _ →
      H.modify \s → s { decks = Map.delete deckId s.decks }

wrapDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
wrapDeck { id: cardId, deck } oldId = do
  H.gets (Map.lookup oldId ∘ _.decks) >>= traverse_ \deckPos → do
    let
      parentId = deck.id
      deckPos' = deckPos { x = 1.0, y = 1.0 }
      newDeck = (wrappedDeck deckPos' oldId) { parent = Just (parentId × cardId) }
    deckId ← saveDeck deck.path newDeck
    case deckId of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right newId → void do
        putDeck newId newDeck deck.wiring.decks
        traverse_ (queryDeck oldId ∘ H.action)
          [ DCQ.SetParent (newId × CID.CardId 0)
          , DCQ.Save Nothing
          ]
        H.modify \s → s
          { decks
              = Map.insert newId deckPos
              $ Map.delete oldId
              $ s.decks
          }
        queryDeck newId
          $ H.action
          $ DCQ.Load deck.path newId (DL.succ deck.level)

unwrapDeck
  ∷ CardOptions
  → DeckId
  → Map.Map DeckId (DeckPosition × DM.Deck)
  → DraftboardDSL Unit
unwrapDeck opts oldId decks = void $ runMaybeT do
  -- sort the decks here so they are ordered by position, this ensures that if
  -- decks need to be accomodated when broken out, the decks in the top left
  -- corner will maintain their position and the others will be accomodated.
  let deckList = List.sortBy (compare `on` toCoords) $ Map.toList decks
  let coord = opts.deck.id × opts.id
  let level' = DL.succ opts.deck.level
  offset ← MaybeT $ H.gets (Map.lookup oldId ∘ _.decks)
  lift do
    H.modify \s →
      s { decks = foldl (reinsert offset) (Map.delete oldId s.decks) deckList }
    for_ deckList \(deckId × (_ × deck)) → do
      let deck' = deck { parent = Just coord }
      queryDeck deckId $ H.action $ DCQ.SetModel deckId deck' level'
      queryDeck deckId $ H.action $ DCQ.Save Nothing
  where
  reinsert offset acc (deckId × (pos × deck)) =
    Map.insert deckId (updatePos (Map.toList acc) offset pos) acc
  updatePos currentDecks offset pos =
    reallyAccomodateDeck currentDecks $
      pos
        { x = pos.x + offset.x + 1.0
        , y = pos.y + offset.y + 1.0
        }
  toCoords (_ × (pos × _)) = Tuple pos.x pos.y

mirrorDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
mirrorDeck opts oldId = do
  queryDeck oldId (H.request DCQ.GetModelCards) >>= traverse_ \modelCards → do
    let modelCards' = Array.span (not ∘ eq oldId ∘ fst) modelCards
    if Array.null modelCards'.rest
      then insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'.init }
      else do
        res ←
          saveDeck opts.deck.path
            { parent: Nothing
            , mirror: map _.cardId <$> modelCards'.init
            , cards: snd <$> modelCards'.rest
            , name: ""
            }
        case res of
          Left _ →
            -- TODO: do something to notify the user saving failed
            pure unit
          Right newId → do
            let modelCards'' = modelCards'.init <> map (lmap (const newId)) modelCards'.rest
            queryDeck oldId $ H.action $ DCQ.SetModelCards modelCards''
            insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'' }
  where
  insertNewDeck deck = do
    st ← H.get
    for_ (Map.lookup oldId st.decks) \deckPos →
      addDeckAt opts deck $
        reallyAccomodateDeck (Map.toList st.decks) deckPos

groupDecks ∷ CardOptions → DeckId → DeckId → DraftboardDSL Unit
groupDecks { id: cardId, deck } deckFrom deckTo = do
  st ← H.get
  for_ (Map.lookup deckFrom st.decks) \rectFrom →
  for_ (Map.lookup deckTo st.decks) \rectTo → do
    let
      rectTo' = rectTo { x = 1.0, y = 1.0 }
      rectFrom' = rectFrom { x = 1.0, y = rectTo.height + 2.0 }
      newDeck = DM.emptyDeck
        { parent = Just (deck.id × cardId)
        , cards = pure
          { cardId: CID.CardId 0
          , model: Card.Draftboard
            { decks: Map.fromFoldable
              [ deckTo × rectTo'
              , deckFrom × rectFrom'
              ]
            }
          }
        }
    deckId ← saveDeck deck.path newDeck
    case deckId of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right newId → void do
        putDeck newId newDeck deck.wiring.decks
        H.modify \s → s
          { decks
              = Map.insert newId rectTo
              $ Map.delete deckFrom
              $ Map.delete deckTo
              $ s.decks
          }
        queryDeck newId
          $ H.action
          $ DCQ.Load deck.path newId (DL.succ deck.level)

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck deckId = H.query deckId ∘ right

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Component
  ( draftboardComponent
  , module SlamData.Workspace.Card.Draftboard.Component.Query
  , module SlamData.Workspace.Card.Draftboard.Component.State
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception as Exn
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)

import Data.Array as Array
import Data.Function (on)
import Data.Lens ((.~), (?~))
import Data.List as List
import Data.Map as Map
import CSS as CSS

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.Component.Opaque.Unsafe (opaqueState)
import Halogen.Component.Utils.Drag as Drag
import Halogen.Component.Utils (raise')
import Halogen.CustomEvents (mouseEventToPageEvent)
import Halogen.HTML.CSS.Indexed as HC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Math (round, floor)

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Quasar.Data as Quasar
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Common (deleteGraph)
import SlamData.Workspace.Card.Draftboard.Component.CSS as CCSS
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..), QueryP, QueryC)
import SlamData.Workspace.Card.Draftboard.Component.State (State, DeckPosition, initialState, encode, decode, _moving, _inserting, _grouping, modelFromState)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Deck.Common (wrappedDeck, defaultPosition)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString, freshDeckId)
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Wiring (putDeck)

import Utils.CSS (zIndex)
import Utils.DOM (elementEq, scrollTop, scrollLeft, getOffsetClientRect)
import Utils.Path (DirPath)

type DraftboardDSL = H.ParentDSL State DNS.State QueryC DNQ.QueryP Slam DeckId

type DraftboardHTML = H.ParentHTML DNS.State QueryC DNQ.QueryP Slam DeckId

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent opts = CC.makeCardComponent
  { cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render opts
      , eval: coproduct evalCard (evalBoard opts)
      , peek: Just (peek opts)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

render ∷ CardOptions → State → DraftboardHTML
render opts state =
  HH.div_
    [ HH.div [ HP.class_ CCSS.insetShadow ] []
    , HH.div
        [ HP.class_ CCSS.grid
        , HC.style bgSize
        , HP.ref (right ∘ H.action ∘ SetElement)
        , HE.onClick \e → pure $
            guard (AT.isEditable opts.deck.accessType && not state.inserting) $>
            right (H.action $ AddDeck e)
        ]
        $ map renderDeck (foldl Array.snoc [] $ Map.toList state.decks)
    ]

  where
  renderDeck (deckId × rect) =
    HH.div
      [ HP.key $ deckIdToString deckId
      , HP.classes $
          case state.grouping of
            Just deckId' | deckId == deckId' → [ HH.className "grouping" ]
            _ → []
      , HC.style $
          case state.moving of
            Just (deckId' × rect') | deckId == deckId' → zIndex 2 *> cssPos rect'
            _ → cssPos rect
      ]
      [ HH.slot deckId $ mkDeckComponent deckId ]

  mkDeckComponent id _ =
    { component: opts.deckComponent (opaqueState $ DCS.initialDeck opts.deck.path id)
    , initialState: DNS.initialState
    }

  cssPos rect = do
    CSS.position CSS.absolute
    CSS.top $ CSS.px $ gridToPx rect.y
    CSS.left $ CSS.px $ gridToPx rect.x
    CSS.width $ CSS.px $ gridToPx rect.width
    CSS.height $ CSS.px $ gridToPx rect.height

  bgSize = do
    let size = foldr maxSize { width: 0.0, height: 0.0 } state.decks
        size' = maybe size (flip maxSize size ∘ snd) state.moving
    CSS.width $ CSS.px $ gridToPx $ size'.width + 1.0
    CSS.height $ CSS.px $ gridToPx $ size'.height + 1.0

evalCard ∷ Natural CC.CardEvalQuery DraftboardDSL
evalCard = case _ of
  CC.EvalCard _ _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify _ { decks = model.decks }
        loadDecks
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Natural Query DraftboardDSL
evalBoard opts = case _ of
  Grabbing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        st ← H.get
        for_ (Map.lookup deckId (st.decks)) \rect →
        for_ st.canvas \el → do
          coords ← pageToGrid d el
          let
            cursorRect =
              { x: coords.x
              , y: coords.y
              , width: 1.0
              , height: 1.0
              }
            newRect = clampDeck rect
              { x = rect.x + (pxToGrid d.offsetX)
              , y = rect.y + (pxToGrid d.offsetY)
              }
            grouping =
              case overlapping cursorRect (Map.toList st.decks) of
                List.Cons (deckId' × _) _ | deckId ≠ deckId' → Just deckId'
                _ → Nothing
          H.modify
            $ (_moving ?~ Tuple deckId newRect)
            ∘ (_grouping .~ grouping)
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.StateOnlyUpdate
    pure next
  Resizing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
          let
            newRect = clampDeck rect
              { width = rect.width + (pxToGrid d.offsetX)
              , height = rect.height + (pxToGrid d.offsetY)
              }
          H.modify $ _moving ?~ Tuple deckId newRect
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.StateOnlyUpdate
    pure next
  SetElement el next → do
    H.modify _ { canvas = el }
    pure next
  AddDeck e next → do
    let e' = mouseEventToPageEvent e
    H.gets _.canvas >>= traverse_ \el → do
      same ← H.fromEff (elementEq el e'.target)
      when same do
        coords ← pageToGrid { x: e'.pageX, y: e'.pageY } el
        addDeck opts DM.emptyDeck
          { x: floor $ coords.x + 1.0
          , y: floor $ coords.y
          }
        CC.raiseUpdatedP' CC.StateOnlyUpdate
    pure next
  LoadDeck deckId next → do
    queryDeck deckId
      $ H.action
      $ DCQ.Load opts.deck.path deckId (DL.succ opts.deck.level)
    pure next
  -- TODO: hopefully we can get rid of this later, as it's relatively expensive
  -- and will run quite frequently, as it's used to enable the `Unwrap` action.
  -- If we can add a real mechanism for handling card-specific actions on the
  -- deck backside we should be able to do something much more sensible, only
  -- building the decks' value here when we actually trigger an unwrap. -gb
  GetDecks k → do
    decks ← H.gets _.decks
    decks' ← runMaybeT $ for (Map.toList decks) \(deckId × position) -> do
      model ← MaybeT $ queryDeck deckId $ H.request DCQ.GetModel
      pure (deckId × (position × model))
    pure $ k $ maybe Map.empty Map.fromList decks'

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck = case _ of
    DCQ.GrabDeck ev _ → startDragging deckId ev Grabbing
    DCQ.ResizeDeck ev _ → startDragging deckId ev Resizing
    DCQ.DoAction DCQ.DeleteDeck _ → do
      deleteDeck opts deckId
      CC.raiseUpdatedP' CC.StateOnlyUpdate
    DCQ.DoAction DCQ.Wrap _ → do
      wrapDeck opts deckId
      CC.raiseUpdatedP' CC.StateOnlyUpdate
    DCQ.DoAction (DCQ.Unwrap decks) _ → do
      unwrapDeck opts deckId decks
      CC.raiseUpdatedP' CC.StateOnlyUpdate
    DCQ.DoAction DCQ.Mirror _ → do
      mirrorDeck opts deckId
      CC.raiseUpdatedP' CC.StateOnlyUpdate
    _ → pure unit

  startDragging deckId ev tag =
    H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
      H.modify $ _moving ?~ Tuple deckId rect
      void
        $ Drag.subscribe' ev
        $ right ∘ H.action ∘ tag deckId

pageToGrid
  ∷ ∀ r
  . { x ∷ Number, y ∷ Number | r }
  → HTMLElement
  → DraftboardDSL { x ∷ Number, y ∷ Number }
pageToGrid e el = do
  rect ← H.fromEff $ getOffsetClientRect el
  scroll ←
    { top: _, left: _ }
    <$> H.fromEff (scrollTop el)
    <*> H.fromEff (scrollLeft el)
  pure
    { x: pxToGrid $ e.x - rect.left + scroll.left
    , y: pxToGrid $ e.y - rect.top + scroll.top
    }

pxToGrid ∷ Number → Number
pxToGrid = (_ / Config.gridPx)

gridToPx ∷ Number → Number
gridToPx = (_ * Config.gridPx)

stopDragging ∷ CardOptions → DraftboardDSL Unit
stopDragging opts = do
  st ← H.get
  for_ st.moving \(deckId × rect) → do
    let rect' = roundDeck rect
        decks = List.filter ((deckId /= _) ∘ fst) $ Map.toList st.decks
    case st.grouping of
      Just deckId' →
        groupDecks opts deckId deckId'
      Nothing →
        when (List.null $ overlapping rect' decks) do
          H.modify \s → s { decks = Map.insert deckId rect' s.decks }
  H.modify _
    { moving = Nothing
    , grouping = Nothing
    }

maxSize
  ∷ DeckPosition
  → { width ∷ Number, height ∷ Number }
  → { width ∷ Number, height ∷ Number }
maxSize deck size =
  { width: if x > size.width then x else size.width
  , height: if y > size.height then y else size.height
  }
  where
  x = deck.x + deck.width
  y = deck.y + deck.height

clampDeck ∷ DeckPosition → DeckPosition
clampDeck rect =
  { x: if rect.x < 0.0 then 0.0 else rect.x
  , y: if rect.y < 0.0 then 0.0 else rect.y
  , width: if rect.width < 10.0 then 10.0 else rect.width
  , height: if rect.height < 10.0 then 10.0 else rect.height
  }

roundDeck ∷ DeckPosition → DeckPosition
roundDeck rect =
  { x: round rect.x
  , y: round rect.y
  , width: round rect.width
  , height: round rect.height
  }

overlapping
  ∷ DeckPosition
  → List.List (DeckId × DeckPosition)
  → List.List (DeckId × DeckPosition)
overlapping a = List.filter go
  where
  go (_ × b) =
    not $ a.x + a.width <= b.x
       || b.x + b.width <= a.x
       || a.y + a.height <= b.y
       || b.y + b.height <= a.y

accomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → { x ∷ Number, y ∷ Number }
  → DeckPosition
  → Maybe DeckPosition
accomodateDeck bs = go List.Nil
  where
  go hist c a =
    case overlapping a bs of
      List.Nil →
        Just a
      bs' | not $ List.null $ List.intersectBy (eq `on` fst) hist bs' →
        Nothing
      List.Cons b _ →
        let a' = clampDeck $ reposition c a (snd b)
            c' = { x: a'.x + (floor (a'.width / 2.0)), y: a'.y }
        in  go (List.Cons b hist) c' a'

  reposition c a b
    | c.x >= b.x && c.x < b.x + b.width = a { y = b.y - a.height }
    | c.x >= b.x + b.width = a { x = b.x + b.width }
    | c.y < b.x = a { x = b.x - a.width }
    | otherwise = a

reallyAccomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → DeckPosition
  → DeckPosition
reallyAccomodateDeck decks deckPos =
  let deckPos' = deckPos { y = deckPos.y + deckPos.height }
      coords = { x: floor (deckPos'.x + deckPos'.x / 2.0), y: deckPos'.y }
  in
      case accomodateDeck decks coords deckPos of
        Nothing → reallyAccomodateDeck decks deckPos'
        Just a → a

loadDecks ∷ DraftboardDSL Unit
loadDecks =
  H.gets (Map.keys ∘ _.decks) >>=
    traverse_ (raise' ∘ right ∘ H.action ∘ LoadDeck)

addDeck ∷ CardOptions → DM.Deck → { x ∷ Number, y ∷ Number } → DraftboardDSL Unit
addDeck opts deck coords = do
  decks ← Map.toList <$> H.gets _.decks
  let
    deckPos = clampDeck $ defaultPosition
      { x = coords.x - 10.0
      , y = coords.y
      }
  for_ (accomodateDeck decks coords deckPos) $
    addDeckAt opts deck

addDeckAt ∷ CardOptions → DM.Deck → DeckPosition → DraftboardDSL Unit
addDeckAt { deck: opts, id: cardId } deck deckPos = do
  let
    parentId = opts.id
    deck' = deck { parent = Just (parentId × cardId) }
  H.modify $ _inserting .~ true
  deckId ← saveDeck opts.path deck'
  case deckId of
    Left err → do
      H.modify $ _inserting .~ false
      -- TODO: do something to notify the user saving failed
      pure unit
    Right deckId' → void do
      putDeck deckId' deck' opts.wiring.decks
      H.modify \s → s
        { decks = Map.insert deckId' deckPos s.decks
        , inserting = false
        }
      queryDeck deckId'
        $ H.action
        $ DCQ.Load opts.path deckId' (DL.succ opts.level)

saveDeck ∷ DirPath → DM.Deck → DraftboardDSL (Either Exn.Error DeckId)
saveDeck path model = runExceptT do
  i ← lift $ H.fromEff freshDeckId
  ExceptT $ Quasar.save (DM.deckIndex path i) $ DM.encode model
  pure i

deleteDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
deleteDeck { deck } deckId = do
  res ← deleteGraph deck.path deckId
  case res of
    Left err →
      -- TODO: do something to notify the user deleting failed
      pure unit
    Right _ →
      H.modify \s → s { decks = Map.delete deckId s.decks }

wrapDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
wrapDeck { id: cardId, deck } oldId = do
  H.gets (Map.lookup oldId ∘ _.decks) >>= traverse_ \deckPos → do
    let
      parentId = deck.id
      deckPos' = deckPos { x = 1.0, y = 1.0 }
      newDeck = (wrappedDeck deckPos' oldId) { parent = Just (parentId × cardId) }
    deckId ← saveDeck deck.path newDeck
    case deckId of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right newId → void do
        putDeck newId newDeck deck.wiring.decks
        traverse_ (queryDeck oldId ∘ H.action)
          [ DCQ.SetParent (newId × CID.CardId 0)
          , DCQ.Save Nothing
          ]
        H.modify \s → s
          { decks
              = Map.insert newId deckPos
              $ Map.delete oldId
              $ s.decks
          }
        queryDeck newId
          $ H.action
          $ DCQ.Load deck.path newId (DL.succ deck.level)

unwrapDeck
  ∷ CardOptions
  → DeckId
  → Map.Map DeckId (DeckPosition × DM.Deck)
  → DraftboardDSL Unit
unwrapDeck opts oldId decks = void $ runMaybeT do
  -- sort the decks here so they are ordered by position, this ensures that if
  -- decks need to be accomodated when broken out, the decks in the top left
  -- corner will maintain their position and the others will be accomodated.
  let deckList = List.sortBy (compare `on` toCoords) $ Map.toList decks
  let coord = opts.deck.id × opts.id
  let level' = DL.succ opts.deck.level
  offset ← MaybeT $ H.gets (Map.lookup oldId ∘ _.decks)
  lift do
    H.modify \s →
      s { decks = foldl (reinsert offset) (Map.delete oldId s.decks) deckList }
    for_ deckList \(deckId × (_ × deck)) → do
      let deck' = deck { parent = Just coord }
      queryDeck deckId $ H.action $ DCQ.SetModel deckId deck' level'
      queryDeck deckId $ H.action $ DCQ.Save Nothing
  where
  reinsert offset acc (deckId × (pos × deck)) =
    Map.insert deckId (updatePos (Map.toList acc) offset pos) acc
  updatePos currentDecks offset pos =
    reallyAccomodateDeck currentDecks $
      pos
        { x = pos.x + offset.x + 1.0
        , y = pos.y + offset.y + 1.0
        }
  toCoords (_ × (pos × _)) = Tuple pos.x pos.y

mirrorDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
mirrorDeck opts oldId = do
  queryDeck oldId (H.request DCQ.GetModelCards) >>= traverse_ \modelCards → do
    let modelCards' = Array.span (not ∘ eq oldId ∘ fst) modelCards
    if Array.null modelCards'.rest
      then insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'.init }
      else do
        res ←
          saveDeck opts.deck.path
            { parent: Nothing
            , mirror: map _.cardId <$> modelCards'.init
            , cards: snd <$> modelCards'.rest
            , name: ""
            }
        case res of
          Left _ →
            -- TODO: do something to notify the user saving failed
            pure unit
          Right newId → do
            let modelCards'' = modelCards'.init <> map (lmap (const newId)) modelCards'.rest
            queryDeck oldId $ H.action $ DCQ.SetModelCards modelCards''
            insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'' }
  where
  insertNewDeck deck = do
    st ← H.get
    for_ (Map.lookup oldId st.decks) \deckPos →
      addDeckAt opts deck $
        reallyAccomodateDeck (Map.toList st.decks) deckPos

groupDecks ∷ CardOptions → DeckId → DeckId → DraftboardDSL Unit
groupDecks { id: cardId, deck } deckFrom deckTo = do
  st ← H.get
  for_ (Map.lookup deckFrom st.decks) \rectFrom →
  for_ (Map.lookup deckTo st.decks) \rectTo → do
    let
      rectTo' = rectTo { x = 1.0, y = 1.0 }
      rectFrom' = rectFrom { x = 1.0, y = rectTo.height + 2.0 }
      newDeck = DM.emptyDeck
        { parent = Just (deck.id × cardId)
        , cards = pure
          { cardId: CID.CardId 0
          , model: Card.Draftboard
            { decks: Map.fromFoldable
              [ deckTo × rectTo'
              , deckFrom × rectFrom'
              ]
            }
          }
        }
    deckId ← saveDeck deck.path newDeck
    case deckId of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right newId → void do
        putDeck newId newDeck deck.wiring.decks
        H.modify \s → s
          { decks
              = Map.insert newId rectTo
              $ Map.delete deckFrom
              $ Map.delete deckTo
              $ s.decks
          }
        queryDeck newId
          $ H.action
          $ DCQ.Load deck.path newId (DL.succ deck.level)

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck deckId = H.query deckId ∘ right


Use the `aceConstructor`

Use the `aceConstructor`

module Main where

import Prelude

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceState (), AceQuery (TextChanged, GetText), aceConstructor)

import Control.Monad.Aff (Aff (), runAff)
import Control.Monad.Eff (Eff ())
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Eff.Exception (throwException)
import Control.Plus (Plus)

import Data.Functor.Coproduct (Coproduct())
import Data.Maybe (Maybe (..), fromMaybe)

import Halogen
import Halogen.Util (appendToBody, onLoad)
import qualified Halogen.HTML.Indexed as H

-- Effects
import Control.Monad.Eff.Random (RANDOM ())
import Control.Monad.Eff.Ref (REF ())
import Ace.Types (ACE (), Editor ())
import Data.Date (Now ())

data Query a
    = UpdateText a

type State =
    { text :: String
    }

initialState :: State
initialState =
    { text : "Name: Ace Editor"
    }

data AceSlot = AceSlot

instance eqAceSlot :: Eq AceSlot where
    eq AceSlot AceSlot = true

instance ordAceSlot :: Ord AceSlot where
    compare AceSlot AceSlot = EQ

type StateP g = InstalledState State AceState Query AceQuery g AceSlot
type QueryP = Coproduct Query (ChildF AceSlot AceQuery)
type MainHtml g = ParentHTML AceState Query AceQuery g AceSlot
type MainEffects = HalogenEffects (random :: RANDOM, now :: Now, ref :: REF, ace :: ACE)
type MainAff = Aff MainEffects

ui :: Component (StateP MainAff) QueryP MainAff
ui = parentComponent' render eval peek
    where

    render :: State -> MainHtml MainAff
    render state =
        H.div_
            [ H.Slot $ aceConstructor AceSlot (initEditor state) Nothing
            , H.div_
                [ H.text state.text ]
            ]

    initEditor :: State -> Editor -> MainAff Unit
    initEditor state editor = liftEff $ do
        session <- Editor.getSession editor
        Session.setMode "ace/mode/yaml" session
        Editor.setValue state.text Nothing editor
        pure unit

    eval :: EvalParent Query State AceState Query AceQuery MainAff AceSlot
    eval (UpdateText next) = do
        pure next

    peek :: Peek (ChildF AceSlot AceQuery) State AceState Query AceQuery MainAff AceSlot
    peek (ChildF p q) =
        case q of
            TextChanged _ -> do
                text <- query AceSlot $ request GetText
                modify (_ { text = fromMaybe "" text })
            _ ->
                pure unit

main :: Eff MainEffects Unit
main = runAff throwException (const (pure unit)) $ do
    app <- runUI ui (installedState initialState)
    onLoad $ appendToBody app.node

module Main where

import Prelude

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceState (), AceQuery (TextChanged, GetText), initialAceState)
import qualified Ace.Halogen.Component as Ace

import Control.Monad.Aff (Aff (), runAff)
import Control.Monad.Eff (Eff ())
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Eff.Exception (throwException)
import Control.Plus (Plus)

import Data.Functor.Coproduct (Coproduct())
import Data.Maybe (Maybe (..), fromMaybe)

import Halogen
import Halogen.Util (appendToBody, onLoad)
import qualified Halogen.HTML.Indexed as H

-- Effects
import Control.Monad.Eff.Random (RANDOM ())
import Control.Monad.Eff.Ref (REF ())
import Ace.Types (ACE ())
import Data.Date (Now ())

data Query a
    = UpdateText a

type State =
    { text :: String
    }

initialState :: State
initialState =
    { text : "Name: Ace Editor"
    }

data AceSlot = AceSlot

instance eqAceSlot :: Eq AceSlot where
    eq AceSlot AceSlot = true

instance ordAceSlot :: Ord AceSlot where
    compare AceSlot AceSlot = EQ

type StateP g = InstalledState State AceState Query AceQuery g AceSlot
type QueryP = Coproduct Query (ChildF AceSlot AceQuery)
type MainHtml g = ParentHTML AceState Query AceQuery g AceSlot
type MainEffects = HalogenEffects (random :: RANDOM, now :: Now, ref :: REF, ace :: ACE)
type MainAff = Aff MainEffects

ui :: Component (StateP MainAff) QueryP MainAff
ui = parentComponent' render eval peek
    where

    render :: State -> MainHtml MainAff
    render state =
        H.div_
            [ H.slot AceSlot \_ ->
                { component :
                    Ace.aceComponent
                        (\editor -> liftEff $ do
                            session <- Editor.getSession editor
                            Session.setMode "ace/mode/yaml" session
                            Editor.setValue state.text Nothing editor
                            pure unit
                        )
                        Nothing
                , initialState :
                    initialAceState
                }
            , H.div_
                [ H.text state.text ]
            ]

    eval :: EvalParent Query State AceState Query AceQuery MainAff AceSlot
    eval (UpdateText next) = do
        pure next

    peek :: Peek (ChildF AceSlot AceQuery) State AceState Query AceQuery MainAff AceSlot
    peek (ChildF p q) =
        case q of
            TextChanged _ -> do
                text <- query AceSlot $ request GetText
                modify (_ { text = fromMaybe "" text })
            _ ->
                pure unit

main :: Eff MainEffects Unit
main = runAff throwException (const (pure unit)) $ do
    app <- runUI ui (installedState initialState)
    onLoad $ appendToBody app.node