{-# Language DuplicateRecordFields,
    NoFieldSelectors,
    OverloadedRecordDot,
    OverloadedStrings,
    DeriveGeneric #-}

module Workflow where

  ----------------Imports----------------

  import Data.YAML hiding (Scalar, Mapping, Sequence, encode)
  import Data.Aeson(encode, ToJSON, ToJSONKey (toJSONKey))
  import Control.Applicative hiding (empty)
  import GHC.Generics (Generic)
  import Data.Map
  import Data.Maybe (fromMaybe, isNothing, fromJust)
  import Data.Text (Text, pack, unpack)
  import YamlParser
  import Data.Text.Encoding (decodeUtf8, encodeUtf8)
  import qualified Data.Text.Lazy.Encoding as TL
  import qualified Data.Text.Lazy as TL
  import Debug.Trace (trace)
  import Data.Yaml (ToJSON(toJSON))
  import Data.Aeson.Types (toJSONKeyText)
  
  ---------------------------------------


  ---------Data Types & Instances--------
  
  -- | Outer structure of a workflow, i.e. nodes and stages.
  data Workflow = Workflow {
    nodes  :: Map Text State,
    stages :: Maybe YAMLNode,
    anchor :: AnchorData,
    merge  :: [MergeData]
  } deriving Show

  instance FromYAML' Workflow where
    fromYAML (Mapping mapping _ anchor merge pos) = Workflow
                                                <$> mapping <|  "nodes"
                                                <*> mapping <|? "stages"
                                                <*> pure anchor
                                                <*> pure merge


  -- | Structure of a node.
  data State = State {
    viewers  :: Maybe StateViewers,
    payload  :: Maybe (Map Text YAMLNode),
    final    :: Maybe Final,
    edges    :: Maybe (Map Text Action),
    messages :: Maybe [Message],
    comment :: [Comment],
    anchor :: AnchorData,
    merge  :: [MergeData]
  } deriving Show

  instance FromYAML' State where
    fromYAML (Mapping mapping comment anchor merge _) = State
                                                        <$> mapping <|? "viewers"
                                                        <*> mapping <|? "payload-view"
                                                        <*> mapping <|? "final"
                                                        <*> mapping <|? "edges"
                                                        <*> mapping <|? "messages"
                                                        <*> pure comment
                                                        <*> pure anchor
                                                        <*> pure merge

  
  -- | Wrapper for the `final` value of any node.
  data Final =  Final {
    final :: Text,
    comment :: [Comment],
    anchor :: AnchorData
    } deriving Show

  instance FromYAML' Final where
    fromYAML (Scalar bytes comment anchor _) = Final
                                               <$> pure (decodeUtf8 bytes)
                                               <*> pure comment
                                               <*> pure anchor
      
      -- case scalar of
      --               SStr x  -> pure . Final $ show x
      --               SBool x -> pure . Final $ show x


  -- | Structure of the `viewers` object of any node.
  data StateViewers = StateViewers {
    name    :: Either Label Text,
    viewers :: Maybe Viewers,
    comment :: [Comment],
    anchor  :: AnchorData,
    merge  :: [MergeData]
  } deriving Show

  instance FromYAML' StateViewers where
    fromYAML (Mapping mapping comment anchor merge _) = StateViewers
                                                        <$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label"))
                                                        <*> mapping <|? "viewers"
                                                        <*> pure comment
                                                        <*> pure anchor
                                                        <*> pure merge

        
  data Viewers = Viewers {
    viewers :: [Map Text YAMLNode],
    comment :: [Comment],
    anchor  :: AnchorData
  } deriving Show

  newtype Actors = Actors Viewers deriving Show

  instance FromYAML' Viewers where
    fromYAML (Sequence seq comment anchor _) = Viewers
                                               <$> pure (Prelude.map (toV empty) seq)
                                               <*> pure comment
                                               <*> pure anchor where
                                                 toV :: Map Text YAMLNode -> YAMLNode -> Map Text YAMLNode
                                                 toV m (Mapping [] _ _ _ _) = m
                                                 toV m (Mapping ((Scalar b _ _ _,v):xs) c a md p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a md p)

  instance FromYAML' Actors where
    fromYAML x = Actors <$> fromYAML x

  instance ToJSON YAMLNode where
    toJSON (Scalar b _ _ _) = toJSON $ decodeUtf8 b
    toJSON (Mapping ct _ _ _ _) = toJSON $ fromList ct
    toJSON (Sequence ch _ _ _) = toJSON ch

  instance ToJSONKey YAMLNode where
    toJSONKey = toJSONKeyText display where
      display :: YAMLNode -> Text
      display (Scalar bytes _ _ _) = decodeUtf8 bytes


  
  -- | Structure of the @display-label@ object of any node or edge.
  data Label = Label {
    fallback :: Maybe Text,
    fallbackLang :: Maybe Text,
    translations :: Maybe YAMLNode,
    comment :: [Comment],
    anchor :: AnchorData,
    merge  :: [MergeData]
  } deriving Show

  instance FromYAML' Label where
    fromYAML (Mapping mapping comment anchor merge _) = Label
                                                        <$> mapping <|? "fallback"
                                                        <*> mapping <|? "fallback-lang"
                                                        <*> mapping <|? "translations"
                                                        <*> pure comment
                                                        <*> pure anchor
                                                        <*> pure merge
    fromYAML (Scalar bytes comment anchor _) = Label
                                               <$> pure (Just . decodeUtf8 $ bytes)
                                               <*> pure (Just . pack $ "de-de-formal")
                                               <*> pure Nothing
                                               <*> pure comment
                                               <*> pure anchor
                                               <*> pure []


  -- | Structure of an edge.
  data Action = Action {
    mode      :: Maybe Text,
    source    :: Maybe Text,
    name      :: Maybe Label,
    actors    :: Maybe Actors,
    viewActor :: Maybe Viewers,
    viewers   :: Maybe Viewers,
    messages  :: Maybe [Message],
    form      :: Maybe YAMLNode,
    comment   :: [Comment],
    anchor    :: AnchorData,
    merge     :: [MergeData]
  } deriving Show

  instance FromYAML' Action where
    fromYAML (Mapping mapping comment anchor merge _) = Action
                                                        <$> mapping <|? "mode"
                                                        <*> mapping <|? "source"
                                                        <*> mapping <|? "display-label"
                                                        <*> mapping <|? "actors"
                                                        <*> mapping <|? "view-actor"
                                                        <*> mapping <|? "viewers"
                                                        <*> mapping <|? "messages"
                                                        <*> mapping <|? "form"
                                                        <*> pure comment
                                                        <*> pure anchor
                                                        <*> pure merge

  data Message = Message {
    content :: Label,
    status  :: Maybe Text,
    viewers :: Maybe Viewers,
    comment :: [Comment],
    anchor  :: AnchorData,
    merge   :: [MergeData]
  } deriving Show

  instance FromYAML' Message where
    fromYAML (Mapping mapping comment anchor merge _) = Message
                                                        <$> mapping <|  "content"
                                                        <*> mapping <|? "status"
                                                        <*> mapping <|? "viewers"
                                                        <*> pure comment
                                                        <*> pure anchor
                                                        <*> pure merge


  data Entry = Single Text
             | Msg Message
             | Vie Viewers
             | Act Actors
             | Dict (Map Text YAMLNode)
             | List [Entry]
             | Val YAMLNode deriving Show
  
  
  -- | Data of all nodes prepared for JSON encoding.
  newtype NodeData  = NData (Map Text (Map Text Entry)) deriving (Show, Generic)
  -- | Data of all edges prepared for JSON encoding.
  newtype EdgeData  = EData (Map Text (Map Text Entry)) deriving (Show, Generic)
  -- | Data of the entire workflow prepared for JSON encoding.
  newtype GraphData = GData (NodeData , EdgeData) deriving (Show, Generic)

  ---------------------------------------

  
  ---------------Constants---------------
  
  -- | Name of the source of an initial action.
  initID = "@@INIT"

  ---------------------------------------


  ----------------Methods----------------

  buildData :: Workflow -> GraphData
  buildData wf = GData $ foldrWithKey analyse (NData empty, EData empty) nodes where
    nodes = insert initID (State {final = Just $ Final "False" [] NoAnchor,
                                  viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor [])) Nothing [] NoAnchor [],
                                  payload = Nothing,
                                  edges = Nothing,
                                  messages = Nothing,
                                  comment = [],
                                  anchor = NoAnchor,
                                  merge = []}) wf.nodes
    analyse :: Text -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData)
    analyse k s (NData n, ed@(EData e)) = (NData $ insert k (extract s) n, updateEdges k s.edges ed)
    extract :: State -> Map Text Entry
    extract s = fromList [("name",     Single name),
                          ("comment",  List $ Prelude.map Single s.comment),
                          ("anchor",   Single . pack . show $ s.anchor),
                          ("viewers",  Vie viewers),
                          ("final",    Single final),
                          ("messages", List $ Prelude.map Msg messages),
                          ("payload",  payload)] where
      (name, viewers) = case s.viewers of
                          Nothing -> ("", Viewers [] [] NoAnchor)
                          Just x -> case x.name of
                                      Left y  -> (fromMaybe "" y.fallback, fromMaybe (Viewers [] [] NoAnchor) x.viewers)
                                      Right y -> (y, fromMaybe (Viewers [] [] NoAnchor) x.viewers)
      final = case s.final of
                Nothing -> ""
                Just x  -> x.final
      messages = fromMaybe [] s.messages
      payload = maybe (Val (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0))) Dict s.payload
    updateEdges :: Text -> Maybe (Map Text Action) -> EdgeData -> EdgeData
    updateEdges _ Nothing e = e
    updateEdges targetID (Just edges) (EData e) = EData $ foldrWithKey (\ k action eData -> insert (pack $ unpack k ++ "_@_" ++ unpack targetID) (newData k action targetID) eData) e edges
    newData :: Text -> Action -> Text -> Map Text Entry
    newData ident a targetID = fromList [("name",       Single name),
                                         ("comment",    List $ Prelude.map Single a.comment),
                                         ("anchor",     Single . pack . show $ a.anchor),
                                         ("source",     Single source),
                                         ("target",     Single targetID),
                                         ("mode",       Single mode),
                                         ("actors",     Act actors),
                                         ("viewers",    Vie viewers),
                                         ("view-actor", Vie viewActor),
                                         ("messages",   List $ Prelude.map Msg messages),
                                         ("form",       Val form)] where
      name = if isNothing a.name
             then ident
             else case (fromJust a.name).fallback of
                  Nothing -> pack $ show a.name
                  Just x  -> x
      source = fromMaybe initID a.source
      mode = fromMaybe "" a.mode
      actors = fromMaybe (Actors $ Viewers [] [] NoAnchor) a.actors
      viewers = fromMaybe (Viewers [] [] NoAnchor) a.viewers
      viewActor = fromMaybe (Viewers [] [] NoAnchor) a.viewActor
      messages = fromMaybe [] a.messages
      form = fromMaybe (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0)) a.form

  ---------------------------------------