{-# LANGUAGE RankNTypes, FlexibleContexts #-}

module FTag.Data where

import Data.Typeable
import Data.Foldable
import Control.Monad
import Database.Persist
import Database.Persist.Sqlite
import Control.Monad.Reader
import Control.Monad.Logger
import Control.Monad.Trans.Resource
import Control.Exception
import Data.String (IsString)
import Data.Text
import Data.Int
import Env.Paths

-- ----------------------------------------------------------------------------
-- The Environment containing useful stuff for the functioning of FTag
-- ----------------------------------------------------------------------------

data FTEnv = FTEnv {
           envVerbose :: !Bool

           -- The absolute path of the DB file
         , envDBPath :: !Path

           -- The absolute path of the directory that contains the DB
         , envDBRoot :: !Path

           -- The absolute path of the current directory
           -- TODO: maybe having a quick way of telling if envDBPath and
           -- envCurrentPath are equal would help with the performance.
         , envCurrentPath :: !Path
         }


-- ----------------------------------------------------------------------------
-- The monad stack in which FTag runs
-- ----------------------------------------------------------------------------

type FTag a = forall m. (MonadIO m, MonadReader FTEnv m) => m a
type DBAction a = ReaderT SqlBackend (NoLoggingT IO) a


-- ----------------------------------------------------------------------------
-- The basic data FTag works with
-- ----------------------------------------------------------------------------

type TagN = Text

-- A filename can be of two sorts: either a 'storage' filename, used in the
-- database and internally, or a 'user' filename, as shown to and read from the
-- user. The distinction is that a 'storage' filename is either absolute or
-- relative to the database root, and a user filename is either absolute or
-- relative to the working directory. If the working directory is the database
-- root (which I expect to be a common case), then they are the same thing.
data StorFileN = StorFileN { unS :: !Text }
               deriving (Read, Eq, Ord)

instance Show StorFileN where
  show = show . unS


data UserFileN = UserFileN { unU :: !Text }
               deriving (Read, Eq, Ord)

instance Show UserFileN where
  show = show . unU


-- ----------------------------------------------------------------------------
-- State of tagging of a file.
-- ----------------------------------------------------------------------------

data FTTaggedState = FTNotTagged
                   | FTTaggedNoVal
                   | FTTaggedWithVal Text
                   deriving (Show, Read, Eq)

maybeVal :: FTTaggedState -> Maybe Text
maybeVal (FTTaggedWithVal v) = Just v
maybeVal _ = Nothing

-- ----------------------------------------------------------------------------
-- Exceptions thrown in FTag
-- ----------------------------------------------------------------------------

data FTException = FTTagAlreadyExists  TagN
                 | FTNoSuchTag         TagN
                 | FTNoSuchFile        StorFileN
                 | FTFileUnknown       StorFileN
                 | FTFileAlreadyKnown  StorFileN
                 | FTFileAlreadyTagged TagN StorFileN (Maybe Text)
                 | FTFileNotTagged     TagN StorFileN
                 | FTInvalidExpression Text
                 | FTNoDB
                 | FTDBAlreadyExists
                 deriving (Show, Eq, Typeable)

instance Exception FTException


-- ----------------------------------------------------------------------------
-- Internal representation of expressions
-- ----------------------------------------------------------------------------

class AtomicSet a where
  getFiles :: a -> FTag [StorFileN]
  getFilesPredicate :: a -> FTPredOp -> FTag [StorFileN]
  testFile :: a -> StorFileN -> FTag FTTaggedState

class ToStorFileN a where
  toStorFileN :: a -> FTag StorFileN

instance ToStorFileN StorFileN where
  toStorFileN = return

data StorAtomicSet = SASTag Int64
                   | SASPreset Int64
                   | SASSpecial Text
                   deriving (Show, Eq, Read)

type StorExpr = FTGExpr Int64 StorAtomicSet

data UserAtomicSet = UASByName Text
                   | UASTag Text
                   | UASPreset Text
                   | UASSpecial Text
                   deriving (Show, Read, Eq)

type UserExpr = FTGExpr UserFileN UserAtomicSet

type FTGExpr f t = FTree FTOp (FTSet f t)

data FTree n a = FTNode n (FTree n a) (FTree n a)
               | FTLeaf a
               deriving (Show, Read, Eq)

instance Functor (FTree n) where
  fmap f (FTNode n l r) = FTNode n (fmap f l) (fmap f r)
  fmap f (FTLeaf a)     = FTLeaf $ f a

data FTOp = FTUnion | FTDifference | FTIntersection
          deriving (Eq, Show, Read, Enum, Bounded)

data FTSet f t = FTAtomic    t
               | FTLitSet    [f]
               | FTPredicate t    FTPredOp
               deriving (Show, Read, Eq)

data FTPredOp = FTLesser      Text
              | FTLesserOrEq  Text
              | FTEqual       Text
              | FTNotEqual    Text
              | FTGreater     Text
              | FTGreaterOrEq Text
              | FTInSet       [Text]
              | FTNotInSet    [Text]
              | FTDefined
              | FTNotDefined
              deriving (Show, Read, Eq)





