source-code-server-2010.9.1: src/CodeMushu/Type.hs

{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, BangPatterns #-}

module CodeMushu.Type where

import Rika.Type.Default

import Data.Map (Map)
import Control.Concurrent.STM

import MPS.Env
import Prelude ()

import Data.StateVar
import Rika.Data.Record.Label

import Text.JSON.Generic

import Data.ByteString.Char8 (ByteString)

data Code = Code
  {
    path :: String
  , parent :: String
  , depth :: Integer
  , filesize :: Integer
  , content :: String
  , is_directory :: Integer
  }
  deriving (Show, Eq)

instance Default Code where
  def = Code
    {
      path = def
    , parent = def
    , depth = 0
    , filesize = 0
    , content = def
    , is_directory = 0
    }


data UnpackStatus = 
    Unpacking 
  | UnpackComplete
  deriving (Show, Eq, Data, Typeable)

data DBJobStatus = 
    DBInit
  | DBAnalysing
  | DBImporting Int
  | DBIndexing
  | DBComplete
  deriving (Show, Eq, Data, Typeable)

data JobError =
    FailedToFetchRepo
  | Exception String
  deriving (Show, Eq, Data, Typeable)

data JobStatus =
    Initialized
  | UnpackStage UnpackStatus
  | DBStage DBJobStatus
  | Bouncing
  | Cleanup
  | Completed Project
  | Failed JobError
  deriving (Show, Eq, Data, Typeable)

instance Default JobStatus where
  def = Initialized

data FetchStatus =
    FetchInQueue Integer
  | Fetching JobStatus
  | FetchFailed String

type StatusCallback = JobStatus -> IO ()
type FetchCallback = FetchStatus -> IO ()
type FetchMonitorCallback = IO () -> IO ()

data Repo = Git | Darcs | SVN | Hg | Archive | Raw
  deriving (Show, Eq, Data, Typeable, Read)

instance Default Repo where
  def = Git

data Project = Project
  {
    project_id :: Integer
  , project_name :: String
  , repo :: Repo
  , project_url :: String
  }
  deriving (Show, Eq, Data, Typeable)

instance Default Project where
  def = Project
    {
      project_id = def
    , project_name = def
    , repo = def
    , project_url = def
    }

data RepoState = RepoState
  {
    states_map :: Map Integer (TVar JobStatus)
  }

instance Default RepoState where
  def = RepoState
    {
      states_map = def
    }

-- Datatypes

data JobQueryResponse =
    JobQueryFailed String
  | JobQuerySuccess JobStatus
  deriving (Eq, Show, Data, Typeable)

data JobCreateResponse = 
    JobCreateFailed String
  | JobCreateSuccess Integer
  deriving (Eq, Show, Data, Typeable)

instance HasGetter TVar where
  get = atomically < readTVar

instance HasSetter TVar where
  ($=) x = atomically < writeTVar x

data SourceCode = SourceCode
  {
    project_ref :: Project
  , fetch_status :: FetchStatus
  }

data ClientState = ClientState
  {
    source_codes :: [SourceCode]
  }

data RepoControlHandle = RepoControlHandle
  {
    set_ui_repo_status :: Integer -> LocalRepoStatus -> IO ()
  , set_global_error :: String -> IO ()
  }

data RepoControlInput = RepoControlInput
  {
    create_repo :: TaskID -> Repo -> String-> IO ()
  }

{-
instance Default (Event a) where
  def = NoEvent
-}

type TaskID = Int
type CallbackMap = Map Int RepoControlHandle

data FetchTask =
    CreateRepo !Repo !ByteString
  | MonitorRepo !Integer !Integer
  | DownloadRepo !Integer
  | NoTask
  deriving (Show, Eq)

instance Default FetchTask where
  def = NoTask

data ReactInput = ReactInput
  {
    input_id :: !TaskID
  , fetch_task :: !FetchTask
  }
  deriving (Show, Eq)

instance Default ReactInput where
  def = ReactInput
    {
      input_id = 0
    , fetch_task = def 
    }

data ReactState = ReactState
  {
    update_id :: !TaskID
  , fetch_update :: !FetchUpdate
  }
  deriving (Show, Eq)

instance Default ReactState where
  def = ReactState
    {
      update_id = 0
    , fetch_update = def
    }

data FetchUpdate =
    PerformCreateRepo !Repo !ByteString
  | PerformMonitorRepo !Integer !Integer
  | PerformDownloadRepo !Integer
  | SetRepoInQueue
  | NoUpdate
  deriving (Show, Eq)

instance Default FetchUpdate where
  def = NoUpdate

data LocalRepo = LocalRepo
  {
    repo_id :: Integer
  , repo_url :: String
  , repo_type :: Repo
  , repo_name :: String
  , repo_status :: LocalRepoStatus
  }
  deriving (Show, Eq, Data, Typeable)

instance Default LocalRepo where
  def = LocalRepo
    {
      repo_id = def
    , repo_url = def
    , repo_type = def
    , repo_name = def
    , repo_status = def
    }

data LocalRepoStatus =
    LocalInQueue
  | LocalUnpacking
  | LocalAnalysing
  | LocalImporting Double
  | LocalBouncing
  | LocalDownloading Double
  | LocalDone
  | LocalError String
  | LocalRefreshReachMaximumNumber
  deriving (Show, Eq, Data, Typeable)

instance Default LocalRepoStatus where
  def = LocalInQueue

type LocalRepoIndex = Integer


{-}
type FetchIn = Event ReactInput
type FetchOut = Event ReactState
type SenseRef = TVar [ReactInput]
type TaskRef = TVar CallbackMap
type LocalState = Map LocalRepoIndex LocalRepo
type LocalStateRef = TVar LocalState
-}

mkLabels 
  [ 
    ''RepoState
  ]