{-# LANGUAGE UndecidableInstances #-}

module Model.Types.Workflow
  ( WorkflowGraph(..), WorkflowGraphReference(..)
  , WorkflowGraphNodeLabel
  , WorkflowGraphNode(..)
  , WorkflowNodeView(..)
  , WorkflowNodeMessage(..)
  , WorkflowGraphEdgeLabel
  , WorkflowGraphEdge(..)
  , WorkflowEdgeMessage(..)
  , WorkflowGraphRestriction(..)
  , WorkflowGraphEdgeFormOrder
  , WorkflowGraphEdgeForm(..)
  , WorkflowRole(..)
  , WorkflowPayloadView(..)
  , WorkflowPayloadSpec(..), _WorkflowPayloadSpec
  , WorkflowPayloadFieldReference
  , WorkflowPayloadField(..)
  , WorkflowScope(..)
  , WorkflowScope'(..), classifyWorkflowScope
  , WorkflowPayloadLabel(..)
  , WorkflowStateIndex(..), workflowStateIndex, workflowStateSection
  , WorkflowState
  , WorkflowActionInfo(..), workflowActionInfos
  , WorkflowAction(..), _wpTo, _wpVia, _wpPayload, _wpUser, _wpTime
  , WorkflowFieldPayloadW(..), _WorkflowFieldPayloadW, IsWorkflowFieldPayload', IsWorkflowFieldPayload
  , workflowPayloadSort
  , WorkflowFieldPayload(..), _WorkflowFieldPayload
  , workflowStatePayload, workflowStateCurrentPayloads
  , WorkflowChildren
  ) where

import Import.NoModel

import Model.Types.Security (AuthDNF, PredDNF)
import Model.Types.File (FileContentReference, FileFieldUserOption, FileField, _fieldAdditionalFiles, FileReferenceTitleMapConvertible(..))

import Database.Persist.Sql (PersistFieldSql(..))
import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
import Data.ByteArray (ByteArrayAccess)

import Data.Maybe (fromJust)

import Data.Aeson (genericToJSON, genericParseJSON)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Aeson.Encoding as JSON
import Data.Aeson.Lens (_Null)
import Data.Aeson.Types (Parser)

import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.CaseInsensitive as CI

import Type.Reflection (eqTypeRep, typeRep, typeOf, (:~~:)(..))
import Data.Typeable (cast)

import Data.Generics.Product.Types

import Unsafe.Coerce

import Utils.Lens.TH

import Data.List (inits)

import Data.RFC5051 (compareUnicode)


-----  WORKFLOW GRAPH  -----

newtype WorkflowGraph fileid userid = WorkflowGraph
  { wgNodes       :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid)
  }
  deriving (Generic, Typeable)

deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraph fileid userid)
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid)

newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256)
  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
  deriving newtype ( PersistField
                   , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
                   , Hashable, NFData
                   , ByteArrayAccess
                   , Binary
                   )

instance PersistFieldSql WorkflowGraphReference where
  sqlType _ = sqlType $ Proxy @(Digest SHA3_256)

-----  WORKFLOW GRAPH: NODES  -----

newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
  deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
  deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)

instance PersistFieldSql WorkflowGraphNodeLabel where
  sqlType _ = sqlType $ Proxy @(CI Text)

data WorkflowGraphNode fileid userid = WGN
  { wgnFinal        :: Maybe Icon
  , wgnViewers      :: Maybe (WorkflowNodeView userid)
  , wgnMessages     :: Set (WorkflowNodeMessage userid)
  , wgnEdges        :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid)
  , wgnPayloadView  :: Map WorkflowPayloadLabel   (WorkflowPayloadView userid)
  }
  deriving (Generic, Typeable)

deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphNode fileid userid)
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphNode fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphNode fileid userid)

data WorkflowNodeView userid = WorkflowNodeView
  { wnvViewers :: NonNull (Set (WorkflowRole userid))
  , wnvDisplayLabel :: I18nText
  } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)

data WorkflowNodeMessage userid = WorkflowNodeMessage 
  { wnmViewers     :: NonNull (Set (WorkflowRole userid))
  , wnmRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
  , wnmStatus      :: MessageStatus
  , wnmContent     :: I18nHtml
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)

-----  WORKFLOW GRAPH: EDGES  -----

newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
  deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
  deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)

instance PersistFieldSql WorkflowGraphEdgeLabel where
  sqlType _ = sqlType $ Proxy @(CI Text)

data WorkflowGraphRestriction
  = WorkflowGraphRestrictionPayloadFilled { wgrPayloadFilled :: WorkflowPayloadLabel }
  | WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel }
  | WorkflowGraphRestrictionInitial
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

data WorkflowGraphEdge fileid userid
  = WorkflowGraphEdgeManual
    { wgeSource       :: WorkflowGraphNodeLabel
    , wgeActors       :: Set (WorkflowRole userid)
    , wgeForm         :: WorkflowGraphEdgeForm fileid userid
    , wgeDisplayLabel :: I18nText
    , wgeViewActor    :: Set (WorkflowRole userid)
    , wgeMessages     :: Set (WorkflowEdgeMessage userid)
    }
  | WorkflowGraphEdgeAutomatic
    { wgeSource      :: WorkflowGraphNodeLabel
    , wgeRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
    }
  | WorkflowGraphEdgeInitial
    { wgeActors       :: Set (WorkflowRole userid)
    , wgeForm         :: WorkflowGraphEdgeForm fileid userid
    , wgeDisplayLabel :: I18nText
    , wgeViewActor    :: Set (WorkflowRole userid)
    , wgeMessages     :: Set (WorkflowEdgeMessage userid)
    }
  deriving (Generic, Typeable)

deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdge fileid userid)
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdge fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdge fileid userid)

data WorkflowEdgeMessage userid = WorkflowEdgeMessage 
  { wemViewers     :: NonNull (Set (WorkflowRole userid))
  , wemRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
  , wemStatus      :: MessageStatus
  , wemContent     :: I18nHtml
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)

-- | A wrapped `Scientific`
--
-- Due to arbitrary precision this allows inserting new fields anywhere
newtype WorkflowGraphEdgeFormOrder = WorkflowGraphEdgeFormOrder { unWorkflowGraphEdgeFormOrder :: Maybe Scientific }
  deriving (Read, Show, Generic, Typeable)
  deriving (Eq, Ord) via (NTop (Maybe Scientific))
  deriving (Semigroup, Monoid) via (Maybe (Min Scientific))

newtype WorkflowGraphEdgeForm fileid userid
  = WorkflowGraphEdgeForm
    { wgefFields :: Map WorkflowPayloadLabel (NonNull (Set (NonNull (Map WorkflowGraphEdgeFormOrder (WorkflowPayloadSpec fileid userid)))))
      -- ^ field requirement forms a cnf:
      --
      -- - all labels must be filled
      -- - for each label any field must be filled
      -- - optional fields are always considered to be filled
      -- 
      -- since fields can reference other labels this allows arbitrary requirements to be encoded.
    } deriving (Generic, Typeable)

deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdgeForm fileid userid)
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdgeForm fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdgeForm fileid userid)

-----  WORKFLOW GRAPH: ROLES / ACTORS  -----

data WorkflowRole userid
  = WorkflowRoleUser             { workflowRoleUser         :: userid               }
  | WorkflowRolePayloadReference { workflowRolePayloadLabel :: WorkflowPayloadLabel }
  | WorkflowRoleAuthorized       { workflowRoleAuthorized   :: AuthDNF              }
  | WorkflowRoleInitiator
  deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)


-----  WORKFLOW GRAPH: PAYLOAD SPECIFICATION  -----

data WorkflowPayloadView userid = WorkflowPayloadView
  { wpvViewers :: NonNull (Set (WorkflowRole userid))
  , wpvDisplayLabel :: I18nText
  } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)

data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload)
  deriving (Typeable)

deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadSpec fileid userid)

data WorkflowPayloadFieldReference
  deriving (Typeable)

data WorkflowPayloadField fileid userid (payload :: Type) where
  WorkflowPayloadFieldText      :: { wpftLabel       :: I18nText
                                   , wpftPlaceholder :: Maybe I18nText
                                   , wpftTooltip     :: Maybe I18nHtml
                                   , wpftDefault     :: Maybe Text
                                   , wpftLarge       :: Bool
                                   , wpftOptional    :: Bool
                                   } -> WorkflowPayloadField fileid userid Text
  WorkflowPayloadFieldNumber    :: { wpfnLabel       :: I18nText
                                   , wpfnPlaceholder :: Maybe I18nText
                                   , wpfnTooltip     :: Maybe I18nHtml
                                   , wpfnDefault
                                   , wpfnMin
                                   , wpfnMax
                                   , wpfnStep        :: Maybe Scientific
                                   , wpfnOptional    :: Bool
                                   } -> WorkflowPayloadField fileid userid Scientific
  WorkflowPayloadFieldBool      :: { wpfbLabel       :: I18nText
                                   , wpfbTooltip     :: Maybe I18nHtml
                                   , wpfbDefault     :: Maybe Bool
                                   , wpfbOptional    :: Maybe I18nText -- ^ Optional if `Just`; encodes label of `Nothing`-Option
                                   } -> WorkflowPayloadField fileid userid Bool
  WorkflowPayloadFieldDay       :: { wpfdLabel       :: I18nText
                                   , wpfdTooltip     :: Maybe I18nHtml
                                   , wpfdDefault     :: Maybe Day
                                   , wpfdOptional    :: Bool
                                   } -> WorkflowPayloadField fileid userid Day
  WorkflowPayloadFieldFile      :: { wpffLabel       :: I18nText
                                   , wpffTooltip     :: Maybe I18nHtml
                                   , wpffConfig      :: FileField fileid
                                   , wpffOptional    :: Bool
                                   } -> WorkflowPayloadField fileid userid (Set fileid)
  WorkflowPayloadFieldUser      :: { wpfuLabel       :: I18nText
                                   , wpfuTooltip     :: Maybe I18nHtml
                                   , wpfuDefault     :: Maybe userid
                                   , wpfuOptional    :: Bool
                                   } -> WorkflowPayloadField fileid userid userid
  WorkflowPayloadFieldCaptureUser :: WorkflowPayloadField fileid userid userid
  WorkflowPayloadFieldReference :: { wpfrTarget      :: WorkflowPayloadLabel
                                   } -> WorkflowPayloadField fileid userid WorkflowPayloadFieldReference
  WorkflowPayloadFieldMultiple  :: { wpfmLabel       :: I18nText
                                   , wpfmTooltip     :: Maybe I18nHtml
                                   , wpfmDefault     :: Maybe (NonEmpty (WorkflowFieldPayloadW fileid userid))
                                   , wpfmSub         :: WorkflowPayloadSpec fileid userid
                                   , wpfmMin         :: Natural
                                   , wpfmRange       :: Maybe Natural -- ^ `wpfmMax = (+ wpfmMin) <$> wpfmRange
                                   } -> WorkflowPayloadField fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid))
  deriving (Typeable)

deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadField fileid userid payload)
deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid, Eq (FileField fileid)) => Eq (WorkflowPayloadField fileid userid payload)
deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid, Ord (FileField fileid)) => Ord (WorkflowPayloadField fileid userid payload)

instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowPayloadSpec fileid userid) where
  (WorkflowPayloadSpec a) == (WorkflowPayloadSpec b)
    = case typeOf a `eqTypeRep` typeOf b of
        Just HRefl -> a == b
        Nothing    -> False

instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowPayloadSpec fileid userid) where
  (WorkflowPayloadSpec a) `compare` (WorkflowPayloadSpec b)
    = case typeOf a `eqTypeRep` typeOf b of
        Just HRefl -> a `compare` b
        Nothing   -> case (a, b) of
          (WorkflowPayloadFieldText{}, _) -> LT
          (WorkflowPayloadFieldNumber{}, WorkflowPayloadFieldText{}) -> GT
          (WorkflowPayloadFieldNumber{}, _) -> LT
          (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldText{}) -> GT
          (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldNumber{}) -> GT
          (WorkflowPayloadFieldBool{}, _) -> LT
          (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldText{}) -> GT
          (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldNumber{}) -> GT
          (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldBool{}) -> GT
          (WorkflowPayloadFieldDay{}, _) -> LT
          (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldText{}) -> GT
          (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldNumber{}) -> GT
          (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldBool{}) -> GT
          (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldDay{}) -> GT
          (WorkflowPayloadFieldFile{}, _) -> LT
          (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldText{}) -> GT
          (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldNumber{}) -> GT
          (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldBool{}) -> GT
          (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldDay{}) -> GT
          (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldFile{}) -> GT
          (WorkflowPayloadFieldUser{}, _) -> LT
          (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldText{}) -> GT
          (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldNumber{}) -> GT
          (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldBool{}) -> GT
          (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldDay{}) -> GT
          (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldFile{}) -> GT
          (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldUser{}) -> GT
          (WorkflowPayloadFieldCaptureUser{}, _) -> LT
          (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldText{}) -> GT
          (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldNumber{}) -> GT
          (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldBool{}) -> GT
          (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldDay{}) -> GT
          (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldFile{}) -> GT
          (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldUser{}) -> GT
          (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldCaptureUser{}) -> GT
          (WorkflowPayloadFieldReference{}, _) -> LT
          (WorkflowPayloadFieldMultiple{}, _) -> GT

_WorkflowPayloadSpec :: forall payload fileid userid.
                        ( Typeable payload, Typeable fileid, Typeable userid )
                     => Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload)
_WorkflowPayloadSpec = prism' WorkflowPayloadSpec $ \(WorkflowPayloadSpec pF) -> cast pF
  
data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple'
  deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
  deriving anyclass (Universe, Finite)


-----  WORKFLOW INSTANCE  -----

data WorkflowScope termid schoolid courseid
  = WSGlobal
  | WSTerm   { wisTerm   :: termid   }
  | WSSchool { wisSchool :: schoolid }
  | WSTermSchool { wisTerm :: termid, wisSchool :: schoolid }
  | WSCourse { wisCourse :: courseid }
  deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)
  deriving anyclass (Hashable)

data WorkflowScope'
  = WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse'
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable)
  deriving anyclass (Universe, Finite)

classifyWorkflowScope :: WorkflowScope termid schoolid courseid -> WorkflowScope'
classifyWorkflowScope = \case
  WSGlobal       -> WSGlobal'
  WSTerm{}       -> WSTerm'
  WSSchool{}     -> WSSchool'
  WSTermSchool{} -> WSTermSchool'
  WSCourse{}     -> WSCourse'

-----  WORKFLOW: PAYLOAD  -----

newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text }
  deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
  deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)

instance PersistFieldSql WorkflowPayloadLabel where
  sqlType _ = sqlType $ Proxy @(CI Text)

newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 }
  deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
  deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary)

type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid))

workflowStateIndex :: Alternative m
                   => WorkflowStateIndex
                   -> WorkflowState fileid userid
                   -> m (WorkflowAction fileid userid)
workflowStateIndex (fromIntegral -> i) = maybe empty pure . flip index i . toNullable

workflowStateSection :: MonadPlus m
                     => WorkflowStateIndex
                     -> WorkflowState fileid userid
                     -> m (WorkflowState fileid userid)
workflowStateSection i wSt = maybe mzero return . fromNullable . Seq.fromList =<< traverse (`workflowStateIndex` wSt) [0..i]

data WorkflowAction fileid userid = WorkflowAction
  { wpTo      :: WorkflowGraphNodeLabel
  , wpVia     :: WorkflowGraphEdgeLabel
  , wpPayload :: Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW fileid userid))
  , wpUser    :: Maybe (Maybe userid) -- ^ Outer `Maybe` encodes automatic/manual, inner `Maybe` encodes whether user was authenticated
  , wpTime    :: UTCTime
  }
  deriving (Eq, Ord, Show, Generic, Typeable)

data WorkflowActionInfo fileid userid = WorkflowActionInfo
  { waiIx      :: WorkflowStateIndex
  , waiFrom    :: Maybe WorkflowGraphNodeLabel
  , waiHistory :: [WorkflowAction fileid userid]
  , waiAction  :: WorkflowAction fileid userid
  } deriving (Eq, Ord, Show, Generic, Typeable)

workflowActionInfos :: WorkflowState fileid userid -> [WorkflowActionInfo fileid userid]
workflowActionInfos wState
  = [ WorkflowActionInfo{..}
    | waiFrom <- Nothing : map (Just . wpTo) wState'
    | waiAction <- wState'
    | waiIx <- [minBound..]
    | waiHistory <- tailEx $ inits wState'
    ]
  where wState' = otoList wState

data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload)
  deriving (Typeable)

instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where
  (WorkflowFieldPayloadW a) == (WorkflowFieldPayloadW b)
    = case typeOf a `eqTypeRep` typeOf b of
        Just HRefl -> a == b
        Nothing    -> False

instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (WorkflowFieldPayloadW fileid userid) where
  (WorkflowFieldPayloadW a) `compare` (WorkflowFieldPayloadW b)
    = case typeOf a `eqTypeRep` typeOf b of
        Just HRefl -> a `compare` b
        Nothing   -> case (a, b) of
          (WFPText{}, _) -> LT
          (WFPNumber{}, WFPText{}) -> GT
          (WFPNumber{}, _) -> LT
          (WFPBool{}, WFPText{}) -> GT
          (WFPBool{}, WFPNumber{}) -> GT
          (WFPBool{}, _) -> LT
          (WFPDay{}, WFPText{}) -> GT
          (WFPDay{}, WFPNumber{}) -> GT
          (WFPDay{}, WFPDay{}) -> GT
          (WFPDay{}, _) -> LT
          (WFPFile{}, WFPText{}) -> GT
          (WFPFile{}, WFPNumber{}) -> GT
          (WFPFile{}, WFPBool{}) -> GT
          (WFPFile{}, WFPDay{}) -> GT
          (WFPFile{}, _) -> LT
          (WFPUser{}, _) -> GT

workflowPayloadSort
  :: forall fileid userid.
     (fileid -> fileid -> Ordering)
  -> (userid -> userid -> Ordering)
  -> (WorkflowFieldPayloadW fileid userid -> WorkflowFieldPayloadW fileid userid -> Ordering)
workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of
  (WFPText a',   WFPText b'  ) -> compareUnicode a' b'
  (WFPText{},    _           ) -> LT
  (WFPNumber a', WFPNumber b') -> compare a' b'
  (WFPNumber{},  WFPText{}   ) -> GT
  (WFPNumber{},  _           ) -> LT
  (WFPBool a',   WFPBool b'  ) -> compare a' b'
  (WFPBool{},    WFPText{}   ) -> GT
  (WFPBool{},    WFPNumber{} ) -> GT
  (WFPBool{},    _           ) -> LT
  (WFPDay a',    WFPDay b'   ) -> compare a' b'
  (WFPDay{},     WFPText{}   ) -> GT
  (WFPDay{},     WFPNumber{} ) -> GT
  (WFPDay{},     WFPBool{}   ) -> GT
  (WFPDay{},     _           ) -> LT
  (WFPFile a',   WFPFile b'  ) -> ordFiles a' b'
  (WFPFile{},    WFPText{}   ) -> GT
  (WFPFile{},    WFPNumber{} ) -> GT
  (WFPFile{},    WFPBool{}   ) -> GT
  (WFPFile{},    WFPDay{}    ) -> GT
  (WFPFile{},    _           ) -> LT
  (WFPUser a',   WFPUser b'  ) -> ordUsers a' b'
  (WFPUser{},    _           ) -> GT

instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where
  show (WorkflowFieldPayloadW payload) = show payload

data WorkflowFieldPayload fileid userid (payload :: Type) where
  WFPText     :: Text       -> WorkflowFieldPayload fileid userid Text
  WFPNumber   :: Scientific -> WorkflowFieldPayload fileid userid Scientific
  WFPBool     :: Bool       -> WorkflowFieldPayload fileid userid Bool
  WFPDay      :: Day        -> WorkflowFieldPayload fileid userid Day
  WFPFile     :: fileid     -> WorkflowFieldPayload fileid userid fileid
  WFPUser     :: userid     -> WorkflowFieldPayload fileid userid userid
  deriving (Typeable)

deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload)
deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload)
deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload)

_WorkflowFieldPayloadW :: forall payload fileid userid.
                          ( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid )
                       => Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload)
_WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW fp) -> cast fp

data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser'
  deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
  deriving anyclass (Universe, Finite)

type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload

class Typeable payload => IsWorkflowFieldPayload fileid fileid' userid userid' payload payload' where
  _WorkflowFieldPayload :: Prism (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload'

instance IsWorkflowFieldPayload fileid fileid userid userid Text Text where
  _WorkflowFieldPayload = prism' WFPText $ \case { WFPText x -> Just x; _other -> Nothing }
instance IsWorkflowFieldPayload fileid fileid userid userid Scientific Scientific where
  _WorkflowFieldPayload = prism' WFPNumber $ \case { WFPNumber x -> Just x; _other -> Nothing }
instance IsWorkflowFieldPayload fileid fileid userid userid Bool Bool where
  _WorkflowFieldPayload = prism' WFPBool $ \case { WFPBool x -> Just x; _other -> Nothing }
instance IsWorkflowFieldPayload fileid fileid userid userid Day Day where
  _WorkflowFieldPayload = prism' WFPDay $ \case { WFPDay x -> Just x; _other -> Nothing }
instance Typeable fileid => IsWorkflowFieldPayload fileid fileid' userid userid fileid fileid' where
  _WorkflowFieldPayload = prism WFPFile $ \case { WFPFile x -> Right x; other -> Left $ unsafeCoerce other }
instance Typeable userid => IsWorkflowFieldPayload fileid fileid userid userid' userid userid' where
  _WorkflowFieldPayload = prism WFPUser $ \case { WFPUser x -> Right x; other -> Left $ unsafeCoerce other }

-- workflowStatePayload :: forall fileid userid payload.
--                         ( IsWorkflowFieldPayload' fileid userid payload
--                         , Ord fileid, Ord userid, Ord payload
--                         , Typeable fileid, Typeable userid
--                         , Show userid, Show fileid
--                         )
--                      => WorkflowPayloadLabel -> WorkflowState fileid userid -> Seq (Maybe (Set payload))
-- workflowStatePayload label acts = flip ofoldMap acts $ \WorkflowAction{..} -> Seq.singleton . Map.lookup label $ fmap (Set.fromList . concatMap extractPayload . otoList) wpPayload
--   where
--     extractPayload :: WorkflowFieldPayloadW fileid userid -> [payload]
--     extractPayload = \case
--       WorkflowFieldPayloadW fieldPayload@(WFPMultiple ps) -> traceShow ("multiple", fieldPayload) . concatMap extractPayload $ otoList ps
--       WorkflowFieldPayloadW fieldPayload
--         | Just HRefl <- traceShow ("single", fieldPayload) $ typeOf fieldPayload `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload)
--           -> fieldPayload ^.. _WorkflowFieldPayload
--         | otherwise
--           -> traceShow ("none", fieldPayload) mempty

workflowStateCurrentPayloads :: forall fileid userid mono.
                                ( Element mono ~ WorkflowAction fileid userid
                                , MonoFoldable mono
                                )
                             => mono
                             -> Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW fileid userid))
workflowStateCurrentPayloads = Map.unionsWith (\_ v -> v) . map wpPayload . otoList

----- Lenses needed here -----
  
makeLenses_ ''WorkflowAction

----- Generic traversal -----

type family Concat as bs where
  Concat '[] bs = bs
  Concat as '[] = as
  Concat (a ': as) bs = a ': Concat as bs

data WorkflowChildren
type instance Children WorkflowChildren a = ChildrenWorkflowChildren a
type family ChildrenWorkflowChildren a where
  ChildrenWorkflowChildren (Map k v) = '[v]
  ChildrenWorkflowChildren (Set a) = '[a]
  ChildrenWorkflowChildren (Seq a) = '[a]
  ChildrenWorkflowChildren [a] = '[a]
  ChildrenWorkflowChildren (NonEmpty a) = '[a]
  ChildrenWorkflowChildren (NonNull mono) = '[Element mono]
  ChildrenWorkflowChildren (CI a) = '[a]
  ChildrenWorkflowChildren UUID = '[]
  ChildrenWorkflowChildren Html = '[]
  ChildrenWorkflowChildren Scientific = '[]
  ChildrenWorkflowChildren (BackendKey SqlBackend) = '[]
  ChildrenWorkflowChildren (Key record) = '[]
  ChildrenWorkflowChildren FileContentReference = '[]
  ChildrenWorkflowChildren UTCTime = '[]
  ChildrenWorkflowChildren Day = '[]
  ChildrenWorkflowChildren (WorkflowPayloadSpec fileid userid)
           = ChildrenWorkflowChildren I18nText
    `Concat` ChildrenWorkflowChildren (Maybe I18nText)
    `Concat` ChildrenWorkflowChildren (Maybe I18nHtml)
    `Concat` ChildrenWorkflowChildren (Maybe Text)
    `Concat` ChildrenWorkflowChildren (Maybe Scientific)
    `Concat` ChildrenWorkflowChildren (Maybe Bool)
    `Concat` ChildrenWorkflowChildren (Maybe Day)
    `Concat` ChildrenWorkflowChildren (Maybe fileid)
    `Concat` ChildrenWorkflowChildren (Maybe userid)
    `Concat` ChildrenWorkflowChildren Bool
    `Concat` ChildrenWorkflowChildren WorkflowPayloadLabel
  ChildrenWorkflowChildren (WorkflowFieldPayloadW fileid userid)
           = ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Text)
    `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Scientific)
    `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Bool)
    `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Day)
    `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid fileid)
    `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid userid)
  ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid payload)
           = ChildrenWorkflowChildren payload
  ChildrenWorkflowChildren a = Children ChGeneric a

instance HasTypesCustom WorkflowChildren a a a a where
  typesCustom = id

instance HasTypesCustom WorkflowChildren a' b' a b => HasTypesCustom WorkflowChildren (NonEmpty a') (NonEmpty b') a b where
  typesCustom = traverse . typesCustom @WorkflowChildren

instance HasTypesCustom WorkflowChildren v v' a a' => HasTypesCustom WorkflowChildren (Map k v) (Map k v') a a' where
  typesCustom = traverse . typesCustom @WorkflowChildren
  
instance (Ord b', HasTypesCustom WorkflowChildren a' b' a b) => HasTypesCustom WorkflowChildren (Set a') (Set b') a b where
  typesCustom = iso Set.toList Set.fromList . traverse . typesCustom @WorkflowChildren

instance (HasTypesCustom WorkflowChildren a' b' a b) => HasTypesCustom WorkflowChildren (Seq a') (Seq b') a b where
  typesCustom = traverse . typesCustom @WorkflowChildren

instance (HasTypesCustom WorkflowChildren mono mono' a a', MonoFoldable mono') => HasTypesCustom WorkflowChildren (NonNull mono) (NonNull mono') a a' where
  typesCustom = iso toNullable impureNonNull . typesCustom @WorkflowChildren

instance (HasTypesCustom WorkflowChildren a' b' a b, FoldCase b') => HasTypesCustom WorkflowChildren (CI a') (CI b') a b where
  typesCustom = iso CI.original CI.mk . typesCustom @WorkflowChildren

instance (Typeable userid, Typeable fileid, Typeable fileid', Ord fileid', userid ~ userid', FileReferenceTitleMapConvertible (FileFieldUserOption Bool) fileid fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') fileid fileid' where
  typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = traverseOf (_fieldAdditionalFiles . _FileReferenceTitleMap . _1) f wpffConfig <&> \wpffConfig' -> WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffConfig = wpffConfig', .. }
  typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldMultiple{ wpfmSub = sub, wpfmDefault = def', ..}) = (WorkflowPayloadSpec .) . toField <$> traverseOf (typesCustom @WorkflowChildren) f sub <*> traverseOf (traverse . traverse . typesCustom @WorkflowChildren) f def'
    where toField wpfmSub wpfmDefault = WorkflowPayloadFieldMultiple{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldDay{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}

instance (Typeable userid, Typeable userid', Typeable fileid, fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') userid userid' where
  typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid', .. }
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..}
  typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldMultiple{ wpfmSub = sub, wpfmDefault = def', ..}) = (WorkflowPayloadSpec .) . toField <$> typesCustom @WorkflowChildren f sub <*> (traverse . typesCustom @WorkflowChildren) f def'
    where toField wpfmSub wpfmDefault = WorkflowPayloadFieldMultiple{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldDay{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}

instance (Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') payload payload' where
  typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload) of
    Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid payload) @(WorkflowFieldPayload fileid' userid' payload') @payload @payload' f p
    Nothing    -> pure pw
  
instance {-# OVERLAPPING #-} (Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid userid, IsWorkflowFieldPayload' fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') userid userid' where
  typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid userid) of
    Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid userid) @(WorkflowFieldPayload fileid' userid' userid') @userid @userid' f p
    Nothing    -> pure $ unsafeCoerce @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid userid') pw -- We have proof that @p@ does not contain a value of type @userid@, therefor coercion is safe

instance {-# OVERLAPPING #-} (Typeable userid, Typeable fileid, IsWorkflowFieldPayload' fileid userid fileid, IsWorkflowFieldPayload' fileid' userid' fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') fileid fileid' where
  typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid fileid) of
    Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid fileid) @(WorkflowFieldPayload fileid' userid' fileid') @fileid @fileid' f p
    Nothing    -> pure $ unsafeCoerce @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid' userid) pw -- We have proof that @p@ does not contain a value of type @fileid@, therefor coercion is safe

instance (IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload') => HasTypesCustom WorkflowChildren (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload' where
  typesCustom f x = case x ^? _WorkflowFieldPayload of
    Just x' -> review _WorkflowFieldPayload <$> f x'
    Nothing -> error "@WorkflowFieldPayload fileid userid payload@ does not contain value of type @payload@; this means `IsWorkflowFieldPayload` is invalid"

instance (Ord userid, Ord fileid, Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') payload payload' where
  typesCustom = _wpPayload . typesCustom @WorkflowChildren
  
instance {-# OVERLAPPING #-} (Ord userid', Ord fileid, Typeable fileid, IsWorkflowFieldPayload' fileid userid userid, IsWorkflowFieldPayload' fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') userid userid' where
  typesCustom f WorkflowAction{..} = WorkflowAction wpTo wpVia
    <$> traverseOf (typesCustom @WorkflowChildren @_ @_ @userid @userid') f wpPayload
    <*> traverseOf (_Just . _Just) f wpUser
    <*> pure wpTime


workflowStatePayload :: forall fileid userid payload.
                        ( HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid userid) payload payload
                        , Ord payload
                        )
                     => WorkflowPayloadLabel -> WorkflowState fileid userid -> Seq (Maybe (Set payload))
workflowStatePayload label acts = flip ofoldMap acts $ \WorkflowAction{..} -> Seq.singleton . Map.lookup label $ fmap (setOf $ folded . typesCustom @WorkflowChildren @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid userid) @payload @payload) wpPayload


----- PathPiece instances -----

nullaryPathPiece ''WorkflowScope' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
nullaryPathPiece ''WorkflowFieldPayload' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
  
nullaryPathPiece ''WorkflowPayloadField' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"

derivePathPiece ''WorkflowScope (camelToPathPiece' 1) "--"

-----  ToJSON / FromJSON instances  -----

omitNothing :: [JSON.Pair] -> [JSON.Pair]
omitNothing = filter . hasn't $ _2 . _Null

  
deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
  , constructorTagModifier = camelToPathPiece' 2
  } ''WorkflowRole

deriveToJSON workflowNodeViewAesonOptions ''WorkflowNodeView
deriveToJSON workflowNodeMessageAesonOptions ''WorkflowNodeMessage
deriveToJSON workflowEdgeMessageAesonOptions ''WorkflowEdgeMessage
deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView
pathPieceJSON ''WorkflowFieldPayload'
pathPieceJSON ''WorkflowPayloadField'

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  , constructorTagModifier = camelToPathPiece' 3
  } ''WorkflowGraphRestriction

instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeMessage userid) where
  parseJSON = genericParseJSON workflowNodeMessageAesonOptions
instance (FromJSON userid, Ord userid) => FromJSON (WorkflowEdgeMessage userid) where
  parseJSON = genericParseJSON workflowEdgeMessageAesonOptions
instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeView userid) where
  parseJSON = genericParseJSON workflowNodeViewAesonOptions
instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where
  parseJSON = genericParseJSON workflowPayloadViewAesonOptions

instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraph fileid userid) where
  toJSON = toJSON . wgNodes
instance ( FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         , FromJSON (FileField fileid)
         , Ord (FileField fileid)
         ) => FromJSON (WorkflowGraph fileid userid) where
  parseJSON = fmap WorkflowGraph . parseJSON

instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphEdge fileid userid) where
  toJSON = genericToJSON workflowGraphEdgeAesonOptions
instance ( FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         , FromJSON (FileField fileid)
         , Ord (FileField fileid)
         ) => FromJSON (WorkflowGraphEdge fileid userid) where
  parseJSON = JSON.withObject "WorkflowGraphEdge" $ \o -> do
    mode <- o JSON..: "mode" :: JSON.Parser Text
    if | mode == "manual" -> do
           wgeSource <- o JSON..: "source"
           wgeActors <- o JSON..:? "actors" JSON..!= Set.empty
           wgeForm <- o JSON..:? "form" JSON..!= WorkflowGraphEdgeForm Map.empty
           wgeDisplayLabel <- o JSON..: "display-label"
           wgeViewActor <- o JSON..:? "view-actor" JSON..!= Set.empty
           wgeMessages <- o JSON..:? "messages" JSON..!= Set.empty
           return WorkflowGraphEdgeManual{..}
       | mode == "automatic" -> do
           wgeSource <- o JSON..: "source"
           wgeRestriction <- o JSON..:? "restriction"
           return WorkflowGraphEdgeAutomatic{..}
       | mode == "initial" -> do
           wgeActors <- o JSON..:? "actors" JSON..!= Set.empty
           wgeForm <- o JSON..:? "form" JSON..!= WorkflowGraphEdgeForm Map.empty
           wgeDisplayLabel <- o JSON..: "display-label"
           wgeViewActor <- o JSON..:? "view-actor" JSON..!= Set.empty
           wgeMessages <- o JSON..:? "messages" JSON..!= Set.empty
           return WorkflowGraphEdgeInitial{..}
       | otherwise -> fail "Could not parse WorkflowGraphEdge, expected mode to be one of: manual, automatic, initial"

instance ToJSON WorkflowGraphEdgeFormOrder where
  toJSON WorkflowGraphEdgeFormOrder{..} = case unWorkflowGraphEdgeFormOrder of
    Nothing  -> JSON.String "_"
    Just sci -> JSON.Number sci
instance FromJSON WorkflowGraphEdgeFormOrder where
  parseJSON v = fmap WorkflowGraphEdgeFormOrder $
        Just <$> parseJSON v
    <|> JSON.withText "WorkflowGraphEdgeFormOrder" (maybe (fail "WorkflowGraphEdgeFormOrder: could not parse String as Number") (return . Just) . readMay) v
    <|> JSON.withText "WorkflowGraphEdgeFormOrder" (bool (fail "WorkflowGraphEdgeFormOrder: unexpected String, expecting either number or \"_\"") (pure Nothing) . (== "_")) v

instance ToJSONKey WorkflowGraphEdgeFormOrder where
  toJSONKey = JSON.ToJSONKeyText (maybe "_" toText' . unWorkflowGraphEdgeFormOrder) (maybe (JSON.text "_") toEncoding' . unWorkflowGraphEdgeFormOrder)
    where toText' = decodeUtf8 . toStrict . JSON.encodingToLazyByteString . JSON.scientific
          toEncoding' = JSON.scientificText
instance FromJSONKey WorkflowGraphEdgeFormOrder where
  fromJSONKey = JSON.FromJSONKeyTextParser $ parseJSON . JSON.String

instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphEdgeForm fileid userid) where
  toJSON WorkflowGraphEdgeForm{..} = toJSON . flip map wgefFields $ \(toNullable -> disj) -> flip Set.map disj $ \(toNullable -> orderedFields) -> if
    | [(WorkflowGraphEdgeFormOrder Nothing, field)] <- Map.toList orderedFields
      -> toJSON field
    | otherwise
      -> toJSON orderedFields

instance ( FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         , FromJSON (FileField fileid), Ord (FileField fileid)
         ) => FromJSON (WorkflowGraphEdgeForm fileid userid) where
  parseJSON = JSON.withObject "WorkflowGraphEdgeForm" $ \o -> do
    o' <- parseJSON $ JSON.Object o :: JSON.Parser (Map WorkflowPayloadLabel (NonNull (Set JSON.Value)))
    fmap WorkflowGraphEdgeForm . for o' $ \(Set.toList . toNullable -> o'') -> fmap (impureNonNull . Set.fromList) . for o'' $ \o''' ->
          parseJSON o'''
      <|> impureNonNull . Map.singleton (WorkflowGraphEdgeFormOrder Nothing) <$> parseJSON o'''

instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowPayloadSpec fileid userid) where
  toJSON (WorkflowPayloadSpec f) = toJSON f

instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowPayloadField fileid userid payload) where
  toJSON WorkflowPayloadFieldText{..} = JSON.object $ omitNothing
    [ "tag"         JSON..=  WPFText'
    , "label"       JSON..=  wpftLabel
    , "placeholder" JSON..=  wpftPlaceholder
    , "tooltip"     JSON..=  wpftTooltip
    , "default"     JSON..=  wpftDefault
    , "large"       JSON..=  wpftLarge
    , "optional"    JSON..=  wpftOptional
    ]
  toJSON WorkflowPayloadFieldNumber{..} = JSON.object $ omitNothing
    [ "tag"         JSON..=  WPFNumber'
    , "label"       JSON..=  wpfnLabel
    , "placeholder" JSON..=  wpfnPlaceholder
    , "tooltip"     JSON..=  wpfnTooltip
    , "default"     JSON..=  wpfnDefault
    , "min"         JSON..=  wpfnMin
    , "max"         JSON..=  wpfnMax
    , "step"        JSON..=  wpfnStep
    , "optional"    JSON..=  wpfnOptional
    ]
  toJSON WorkflowPayloadFieldBool{..} = JSON.object $ omitNothing
    [ "tag"         JSON..=  WPFBool'
    , "label"       JSON..=  wpfbLabel
    , "tooltip"     JSON..=  wpfbTooltip
    , "default"     JSON..=  wpfbDefault
    , "optional"    JSON..=  wpfbOptional
    ]
  toJSON WorkflowPayloadFieldDay{..} = JSON.object $ omitNothing
    [ "tag"         JSON..=  WPFDay'
    , "label"       JSON..=  wpfdLabel
    , "tooltip"     JSON..=  wpfdTooltip
    , "default"     JSON..=  wpfdDefault
    , "optional"    JSON..=  wpfdOptional
    ]
  toJSON WorkflowPayloadFieldFile{..} = JSON.object $ omitNothing
    [ "tag"         JSON..=  WPFFile'
    , "label"       JSON..=  wpffLabel
    , "tooltip"     JSON..=  wpffTooltip
    , "config"      JSON..=  wpffConfig
    , "optional"    JSON..=  wpffOptional
    ]
  toJSON WorkflowPayloadFieldUser{..} = JSON.object $ omitNothing
    [ "tag"         JSON..=  WPFUser'
    , "label"       JSON..=  wpfuLabel
    , "tooltip"     JSON..=  wpfuTooltip
    , "default"     JSON..=  wpfuDefault
    , "optional"    JSON..=  wpfuOptional
    ]
  toJSON WorkflowPayloadFieldCaptureUser{} = JSON.object
    [ "tag"         JSON..=  WPFCaptureUser'
    ]
  toJSON WorkflowPayloadFieldReference{..} = JSON.object
    [ "tag"         JSON..=  WPFReference'
    , "target"      JSON..=  wpfrTarget
    ]
  toJSON WorkflowPayloadFieldMultiple{..} = JSON.object
    [ "tag"         JSON..=  WPFMultiple'
    , "label"       JSON..=  wpfmLabel
    , "tooltip"     JSON..=  wpfmTooltip
    , "default"     JSON..=  wpfmDefault
    , "sub"         JSON..=  wpfmSub
    , "min"         JSON..=  wpfmMin
    , "range"       JSON..=  wpfmRange
    ]

instance ( FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         , FromJSON (FileField fileid)
         ) => FromJSON (WorkflowPayloadSpec fileid userid) where
  parseJSON = JSON.withObject "WorkflowPayloadSpec" $ \o -> do
    fieldTag <- o JSON..: "tag"
    case fieldTag of
      WPFText' -> do
        wpftLabel       <-  o JSON..:  "label"
        wpftPlaceholder <-  o JSON..:? "placeholder"
        wpftTooltip     <-  o JSON..:? "tooltip"
        wpftDefault     <-  o JSON..:? "default"
        wpftLarge       <-  o JSON..:? "large" JSON..!= False
        wpftOptional    <-  o JSON..:  "optional"
        return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
      WPFNumber' -> do
        wpfnLabel       <-  o JSON..:  "label"
        wpfnPlaceholder <-  o JSON..:? "placeholder"
        wpfnTooltip     <-  o JSON..:? "tooltip"
        wpfnDefault     <- (o JSON..:? "default" :: Parser (Maybe Scientific))
        wpfnMin         <-  o JSON..:? "min"
        wpfnMax         <-  o JSON..:? "max"
        wpfnStep        <-  o JSON..:? "step"
        wpfnOptional    <-  o JSON..:  "optional"
        return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
      WPFBool' -> do
        wpfbLabel       <-  o JSON..:  "label"
        wpfbTooltip     <-  o JSON..:? "tooltip"
        wpfbOptional    <-  o JSON..:? "optional"
        wpfbDefault     <- (o JSON..:? "default" :: Parser (Maybe Bool))
        return $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
      WPFDay' -> do
        wpfdLabel       <-  o JSON..:  "label"
        wpfdTooltip     <-  o JSON..:? "tooltip"
        wpfdOptional    <-  o JSON..:  "optional"
        wpfdDefault     <- (o JSON..:? "default" :: Parser (Maybe Day))
        return $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
      WPFFile' -> do
        wpffLabel       <-  o JSON..:  "label"
        wpffTooltip     <-  o JSON..:? "tooltip"
        wpffConfig      <-  o JSON..:  "config"
        wpffOptional    <-  o JSON..:  "optional"
        return $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
      WPFUser' -> do
        wpfuLabel       <-  o JSON..:  "label"
        wpfuTooltip     <-  o JSON..:? "tooltip"
        wpfuDefault     <- (o JSON..:? "default" :: Parser (Maybe userid))
        wpfuOptional    <-  o JSON..:  "optional"
        return $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..}
      WPFCaptureUser' -> pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
      WPFReference' -> do
        wpfrTarget      <-  o JSON..:  "target"
        return $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}
      WPFMultiple' -> do
        wpfmLabel       <-  o JSON..:  "label"
        wpfmTooltip     <-  o JSON..:? "tooltip"
        wpfmDefault     <-  o JSON..:? "default"
        wpfmSub         <-  o JSON..:  "sub"
        wpfmMin         <-  o JSON..:  "min"
        wpfmRange       <-  o JSON..:? "range"
        return $ WorkflowPayloadSpec WorkflowPayloadFieldMultiple{..}

defaultFinalIcon :: Icon
defaultFinalIcon = IconOK

instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphNode fileid userid) where
  toJSON WGN{..} = JSON.object
    [ ("final" JSON..=) $ case wgnFinal of
        Nothing -> toJSON False
        Just icn | icn == defaultFinalIcon -> toJSON True
        other -> toJSON other
    , "viewers" JSON..= wgnViewers
    , "messages" JSON..= wgnMessages
    , "edges" JSON..= wgnEdges
    , "payload-view" JSON..= wgnPayloadView
    ]
instance ( FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         , FromJSON (FileField fileid)
         , Ord (FileField fileid)
         ) => FromJSON (WorkflowGraphNode fileid userid) where
  parseJSON = JSON.withObject "WorkflowGraphNode" $ \o -> do
    wgnFinal <- o JSON..:? "final"
            <|> fmap (bool Nothing $ Just defaultFinalIcon) (o JSON..: "final")
    wgnViewers <- o JSON..:? "viewers"
    wgnMessages <- o JSON..:? "messages" JSON..!= Set.empty
    wgnEdges <- o JSON..:? "edges" JSON..!= Map.empty
    wgnPayloadView <- o JSON..:? "payload-view" JSON..!= Map.empty
    return WGN{..}

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , fieldLabelModifier = camelToPathPiece' 1
  } ''WorkflowScope

pathPieceJSON ''WorkflowScope'

deriveToJSON workflowActionAesonOptions ''WorkflowAction

instance ( FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         ) => FromJSON (WorkflowAction fileid userid) where
  parseJSON = genericParseJSON workflowActionAesonOptions

instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid userid) where
  toJSON (WorkflowFieldPayloadW (WFPText   t)) = JSON.object
    [ "tag"    JSON..= WFPText'
    , toPathPiece WFPText' JSON..= t
    ]
  toJSON (WorkflowFieldPayloadW (WFPNumber n)) = JSON.object
    [ "tag"    JSON..= WFPNumber'
    , toPathPiece WFPNumber' JSON..= n
    ]
  toJSON (WorkflowFieldPayloadW (WFPBool   b)) = JSON.object
    [ "tag"    JSON..= WFPBool' 
    , toPathPiece WFPBool' JSON..= b
    ]
  toJSON (WorkflowFieldPayloadW (WFPDay    d)) = JSON.object
    [ "tag"    JSON..= WFPDay' 
    , toPathPiece WFPDay' JSON..= d
    ]
  toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object
    [ "tag"    JSON..= WFPFile'
    , toPathPiece WFPFile' JSON..= fid
    ]
  toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object
    [ "tag"    JSON..= WFPUser'
    , toPathPiece WFPUser' JSON..= uid
    ]
instance (Ord fileid, FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where
  parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do
    fieldTag <- o JSON..: "tag"
    case fieldTag of
      WFPText'   -> do
        t <- o JSON..: toPathPiece WFPText'
        return $ WorkflowFieldPayloadW $ WFPText t
      WFPNumber' -> do
        n <- o JSON..: toPathPiece WFPNumber'
        return $ WorkflowFieldPayloadW $ WFPNumber n
      WFPBool'   -> do
        b <- o JSON..: toPathPiece WFPBool'
        return $ WorkflowFieldPayloadW $ WFPBool b
      WFPDay'   -> do
        b <- o JSON..: toPathPiece WFPDay'
        return $ WorkflowFieldPayloadW $ WFPDay b
      WFPFile'  -> do
        fid <- o JSON..: toPathPiece WFPFile'
        return $ WorkflowFieldPayloadW $ WFPFile fid
      WFPUser'   -> do
        uid <- o JSON..: toPathPiece WFPUser'
        return $ WorkflowFieldPayloadW $ WFPUser uid



-----  PersistField / PersistFieldSql instances  -----

instance (   ToJSON fileid,   ToJSON userid
         , FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         , ToJSON (FileField fileid), FromJSON (FileField fileid)
         , Ord (FileField fileid)
         ) => PersistField (WorkflowGraph fileid userid) where
  toPersistValue   = toPersistValueJSON
  fromPersistValue = fromPersistValueJSON
instance (   ToJSON fileid,   ToJSON userid
         , FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         , ToJSON (FileField fileid), FromJSON (FileField fileid)
         , Ord (FileField fileid)
         ) => PersistFieldSql (WorkflowGraph fileid userid) where
  sqlType _ = sqlTypeJSON


instance (   ToJSON termid,   ToJSON schoolid,   ToJSON courseid
         , FromJSON termid, FromJSON schoolid, FromJSON courseid
         , Typeable termid, Typeable schoolid, Typeable courseid
         ) => PersistField (WorkflowScope termid schoolid courseid) where
  toPersistValue   = toPersistValueJSON
  fromPersistValue = fromPersistValueJSON
instance (   ToJSON termid,   ToJSON schoolid,   ToJSON courseid
         , FromJSON termid, FromJSON schoolid, FromJSON courseid
         , Typeable termid, Typeable schoolid, Typeable courseid
         ) => PersistFieldSql (WorkflowScope termid schoolid courseid) where
  sqlType _ = sqlTypeJSON

derivePersistFieldJSON ''WorkflowScope'

instance (   ToJSON fileid,   ToJSON userid
         , FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         ) => PersistField (WorkflowState fileid userid) where
  toPersistValue   = toPersistValueJSON
  fromPersistValue = fromPersistValueJSON
instance (   ToJSON fileid,   ToJSON userid
         , FromJSON fileid, FromJSON userid
         ,      Ord fileid,      Ord userid
         , Typeable fileid, Typeable userid
         ) => PersistFieldSql (WorkflowState fileid userid) where
  sqlType _ = sqlTypeJSON


-----  Binary instances  -----

instance Binary WorkflowScope'
instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowScope termid schoolid courseid)

instance Binary userid => Binary (WorkflowRole userid)

-----  TH Jail  -----

makeWrapped ''WorkflowGraphReference
