module ProjectM36.Relation.Parse.CSV where
--parse Relations from CSV
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.Relation
import ProjectM36.AtomType
import ProjectM36.DataTypes.Interval
import qualified ProjectM36.Attribute as A

import Data.Csv.Parser
import qualified Data.Vector as V
import Data.Char (ord, isUpper, isSpace)
import qualified Data.ByteString.Lazy as BS
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Set as S
import qualified Data.HashMap.Lazy as HM
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Attoparsec.ByteString.Lazy as APBL
import qualified Data.Attoparsec.Text as APT
import Control.Arrow
import Text.Read hiding (parens)
import Control.Applicative
import Data.Either
import Control.Monad (void)

data CsvImportError = CsvParseError String |
                      AttributeMappingError RelationalError |
                      HeaderAttributeMismatchError (S.Set AttributeName)
                    deriving (Show)

csvDecodeOptions :: DecodeOptions
csvDecodeOptions = DecodeOptions {decDelimiter = fromIntegral (ord ',')}

csvAsRelation :: Attributes -> TypeConstructorMapping -> BS.ByteString -> Either CsvImportError Relation
csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecodeOptions) inString of
  APBL.Fail _ _ err -> Left (CsvParseError err)
  APBL.Done _ (headerRaw,vecMapsRaw) -> do
    let strHeader = V.map decodeUtf8 headerRaw
        strMapRecords = V.map convertMap vecMapsRaw
        convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)
        attrNameSet = A.attributeNameSet attrs
        headerSet = S.fromList (V.toList strHeader)
        parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType takeToEndOfColumnData <* APT.endOfInput) textIn of
          Left err -> Left (ParseError (T.pack err))
          Right eAtom -> eAtom 
        makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]
        makeTupleList tupMap = V.toList $ V.map (\attr -> 
                                                  either (Left . AttributeMappingError) Right $ 
                                                  parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) (attributesVec attrs)
    if attrNameSet == headerSet then do
      tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)
      case mkRelationFromList attrs tupleList of
        Left err -> Left (AttributeMappingError err)
        Right rel -> Right rel
      else
      Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)


parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser T.Text -> APT.Parser (Either RelationalError Atom)
parseCSVAtomP _ _ IntegerAtomType _ = Right . IntegerAtom <$> APT.decimal
parseCSVAtomP _ _ IntAtomType _ = Right . IntAtom <$> APT.decimal
parseCSVAtomP _ _ ScientificAtomType _ = Right . ScientificAtom <$> APT.scientific
parseCSVAtomP _ _ DoubleAtomType _ = Right . DoubleAtom <$> APT.double
parseCSVAtomP _ _ TextAtomType takeToEndOfData = 
  Right . TextAtom <$> takeToEndOfData
parseCSVAtomP _ _ DayAtomType takeToEndOfData = do
  dString <- T.unpack <$> takeToEndOfData
  case readMaybe dString of
    Nothing -> fail ("invalid Day string: " ++ dString)
    Just date -> pure (Right (DayAtom date))
parseCSVAtomP _ _ DateTimeAtomType takeToEndOfData = do    
  dString <- T.unpack <$> takeToEndOfData
  case readMaybe dString of
    Nothing -> fail ("invalid Date string: " ++ dString)
    Just date -> pure (Right (DateTimeAtom date))
parseCSVAtomP _ _ ByteStringAtomType takeToEndOfData = do    
  bsString <- T.unpack <$> takeToEndOfData
  case readMaybe bsString of
    Nothing -> fail ("invalid ByteString string: " ++ bsString)
    Just bs -> pure (Right (ByteStringAtom bs))
parseCSVAtomP _ _ BoolAtomType takeToEndOfData = do
  bString <- T.unpack <$> takeToEndOfData
  case readMaybe bString of
    Nothing -> fail ("invalid BoolAtom string: " ++ bString)
    Just b -> pure (Right (BoolAtom b))
parseCSVAtomP _ _ UUIDAtomType takeToEndOfData = do
  uString <- T.unpack <$> takeToEndOfData
  case readMaybe uString of
    Nothing -> fail ("invalid UUIDAtom string: " ++ uString)
    Just u -> pure (Right (UUIDAtom u))
parseCSVAtomP _ _ RelationalExprAtomType takeToEndOfData = do
  reString <- T.unpack <$> takeToEndOfData      
  case readMaybe reString of
    Nothing -> fail ("invalid RelationalExprAtom string: " ++ reString)
    Just b -> pure (Right (RelationalExprAtom b))
parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) takeToEndOfData 
  | isIntervalAtomType typ = do
    begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)
    let iType = intervalSubType typ
    eBeginv <- parseCSVAtomP attrName tConsMap iType takeToEndOfIntervalBlock
    case eBeginv of
      Left err -> pure (Left err)
      Right beginv -> do
        _ <- APT.char ','
        eEndv <- parseCSVAtomP attrName tConsMap iType takeToEndOfIntervalBlock
        case eEndv of
          Left err -> pure (Left err)
          Right endv -> do
            end <- (APT.char ']' >> pure False) <|> 
                   (APT.char ')' >> pure True)
            pure (Right (ConstructedAtom "Interval" typ [beginv, endv, 
                                                         BoolAtom begin, BoolAtom end]))
  | otherwise = do
    dConsName <- capitalizedIdentifier
    APT.skipSpace
  --we need to look up the name right away in order to determine the types of the following arguments
  -- grab the data constructor
    case findDataConstructor dConsName tConsMap of
      Nothing -> pure (Left (NoSuchDataConstructorError dConsName))
      Just (_, dConsDef) -> 
      -- identify the data constructor's expected atom type args
        case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of
          Left err -> pure (Left err)
          Right argAtomTypes -> do
            let argMapper argTyp = let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp takeToEndOfData <* APT.skipSpace in
                                      case argTyp of
                                        TextAtomType -> pure . TextAtom <$> quotedString <* APT.skipSpace
                                        ConstructedAtomType _ _ -> 
                                          parens parseNextAtom <|>
                                          parseNextAtom
                                        _ -> parseNextAtom
            atomArgs <- mapM argMapper argAtomTypes
            case lefts atomArgs of
              [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs)))
              errs -> pure (Left (someErrors errs))
parseCSVAtomP attrName _ (RelationAtomType _) _ = pure (Left (RelationValuedAttributesNotSupportedError [attrName]))
parseCSVAtomP _ _ (TypeVariableType x) _ = pure (Left (TypeConstructorTypeVarMissing x))
      
capitalizedIdentifier :: APT.Parser T.Text
capitalizedIdentifier = do
  fletter <- APT.satisfy isUpper APT.<?> "capitalized data constructor letter"
  rest <- APT.takeWhile (\c -> not (isSpace c || c == ')')) APT.<?> "data constructor name"
  pure (fletter `T.cons` rest)
  
takeToEndOfColumnData :: APT.Parser T.Text
takeToEndOfColumnData = APT.takeWhile (APT.notInClass "")

--read data for Text.Read parser but be wary of end of interval blocks  
takeToEndOfIntervalBlock :: APT.Parser T.Text
takeToEndOfIntervalBlock = APT.takeWhile (APT.notInClass ",)]")
  
parens :: APT.Parser a -> APT.Parser a  
parens p = do
  void $ APT.char '('
  APT.skipSpace
  v <- p
  APT.skipSpace
  void $ APT.char ')'
  pure v
  
quotedString :: APT.Parser T.Text
quotedString = do
  let escapeMap = [('"','"'), ('n', '\n'), ('r', '\r')]
      doubleQuote = void $ APT.char '"'
  doubleQuote
  (_, s) <- APT.runScanner [] (\prevl nextChar -> case prevl of
                             [] -> Just [nextChar]
                             chars | last chars == '\\' ->
                                        case lookup nextChar escapeMap of 
                                          Nothing -> Just (chars ++ [nextChar]) --there is no escape sequence, so leave backslash + char
                                          Just escapeVal -> Just (init chars ++ [escapeVal]) -- nuke the backslash and add the escapeVal
                                   | nextChar == '"' -> Nothing
                                   | otherwise -> Just (chars ++ [nextChar]))
  doubleQuote
  pure (T.pack s)

parse Relations from CSV
we need to look up the name right away in order to determine the types of the following arguments
 grab the data constructor
 identify the data constructor's expected atom type args
read data for Text.Read parser but be wary of end of interval blocks  
there is no escape sequence, so leave backslash + char
 nuke the backslash and add the escapeVal
module ProjectM36.Relation.Parse.CSV where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.Relation
import ProjectM36.AtomType
import ProjectM36.DataTypes.Interval
import qualified ProjectM36.Attribute as A

import Data.Csv.Parser
import qualified Data.Vector as V
import Data.Char (ord, isUpper, isSpace)
import qualified Data.ByteString.Lazy as BS
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Set as S
import qualified Data.HashMap.Lazy as HM
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Attoparsec.ByteString.Lazy as APBL
import qualified Data.Attoparsec.Text as APT
import Control.Arrow
import Text.Read hiding (parens)
import Control.Applicative
import Data.Either
import Control.Monad (void)

data CsvImportError = CsvParseError String |
                      AttributeMappingError RelationalError |
                      HeaderAttributeMismatchError (S.Set AttributeName)
                    deriving (Show)

csvDecodeOptions :: DecodeOptions
csvDecodeOptions = DecodeOptions {decDelimiter = fromIntegral (ord ',')}

csvAsRelation :: Attributes -> TypeConstructorMapping -> BS.ByteString -> Either CsvImportError Relation
csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecodeOptions) inString of
  APBL.Fail _ _ err -> Left (CsvParseError err)
  APBL.Done _ (headerRaw,vecMapsRaw) -> do
    let strHeader = V.map decodeUtf8 headerRaw
        strMapRecords = V.map convertMap vecMapsRaw
        convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)
        attrNameSet = A.attributeNameSet attrs
        headerSet = S.fromList (V.toList strHeader)
        parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType takeToEndOfColumnData <* APT.endOfInput) textIn of
          Left err -> Left (ParseError (T.pack err))
          Right eAtom -> eAtom 
        makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]
        makeTupleList tupMap = V.toList $ V.map (\attr -> 
                                                  either (Left . AttributeMappingError) Right $ 
                                                  parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) (attributesVec attrs)
    if attrNameSet == headerSet then do
      tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)
      case mkRelationFromList attrs tupleList of
        Left err -> Left (AttributeMappingError err)
        Right rel -> Right rel
      else
      Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)


parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser T.Text -> APT.Parser (Either RelationalError Atom)
parseCSVAtomP _ _ IntegerAtomType _ = Right . IntegerAtom <$> APT.decimal
parseCSVAtomP _ _ IntAtomType _ = Right . IntAtom <$> APT.decimal
parseCSVAtomP _ _ ScientificAtomType _ = Right . ScientificAtom <$> APT.scientific
parseCSVAtomP _ _ DoubleAtomType _ = Right . DoubleAtom <$> APT.double
parseCSVAtomP _ _ TextAtomType takeToEndOfData = 
  Right . TextAtom <$> takeToEndOfData
parseCSVAtomP _ _ DayAtomType takeToEndOfData = do
  dString <- T.unpack <$> takeToEndOfData
  case readMaybe dString of
    Nothing -> fail ("invalid Day string: " ++ dString)
    Just date -> pure (Right (DayAtom date))
parseCSVAtomP _ _ DateTimeAtomType takeToEndOfData = do    
  dString <- T.unpack <$> takeToEndOfData
  case readMaybe dString of
    Nothing -> fail ("invalid Date string: " ++ dString)
    Just date -> pure (Right (DateTimeAtom date))
parseCSVAtomP _ _ ByteStringAtomType takeToEndOfData = do    
  bsString <- T.unpack <$> takeToEndOfData
  case readMaybe bsString of
    Nothing -> fail ("invalid ByteString string: " ++ bsString)
    Just bs -> pure (Right (ByteStringAtom bs))
parseCSVAtomP _ _ BoolAtomType takeToEndOfData = do
  bString <- T.unpack <$> takeToEndOfData
  case readMaybe bString of
    Nothing -> fail ("invalid BoolAtom string: " ++ bString)
    Just b -> pure (Right (BoolAtom b))
parseCSVAtomP _ _ UUIDAtomType takeToEndOfData = do
  uString <- T.unpack <$> takeToEndOfData
  case readMaybe uString of
    Nothing -> fail ("invalid UUIDAtom string: " ++ uString)
    Just u -> pure (Right (UUIDAtom u))
parseCSVAtomP _ _ RelationalExprAtomType takeToEndOfData = do
  reString <- T.unpack <$> takeToEndOfData      
  case readMaybe reString of
    Nothing -> fail ("invalid RelationalExprAtom string: " ++ reString)
    Just b -> pure (Right (RelationalExprAtom b))
parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) takeToEndOfData 
  | isIntervalAtomType typ = do
    begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)
    let iType = intervalSubType typ
    eBeginv <- parseCSVAtomP attrName tConsMap iType takeToEndOfIntervalBlock
    case eBeginv of
      Left err -> pure (Left err)
      Right beginv -> do
        _ <- APT.char ','
        eEndv <- parseCSVAtomP attrName tConsMap iType takeToEndOfIntervalBlock
        case eEndv of
          Left err -> pure (Left err)
          Right endv -> do
            end <- (APT.char ']' >> pure False) <|> 
                   (APT.char ')' >> pure True)
            pure (Right (ConstructedAtom "Interval" typ [beginv, endv, 
                                                         BoolAtom begin, BoolAtom end]))
  | otherwise = do
    dConsName <- capitalizedIdentifier
    APT.skipSpace
    case findDataConstructor dConsName tConsMap of
      Nothing -> pure (Left (NoSuchDataConstructorError dConsName))
      Just (_, dConsDef) -> 
        case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of
          Left err -> pure (Left err)
          Right argAtomTypes -> do
            let argMapper argTyp = let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp takeToEndOfData <* APT.skipSpace in
                                      case argTyp of
                                        TextAtomType -> pure . TextAtom <$> quotedString <* APT.skipSpace
                                        ConstructedAtomType _ _ -> 
                                          parens parseNextAtom <|>
                                          parseNextAtom
                                        _ -> parseNextAtom
            atomArgs <- mapM argMapper argAtomTypes
            case lefts atomArgs of
              [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs)))
              errs -> pure (Left (someErrors errs))
parseCSVAtomP attrName _ (RelationAtomType _) _ = pure (Left (RelationValuedAttributesNotSupportedError [attrName]))
parseCSVAtomP _ _ (TypeVariableType x) _ = pure (Left (TypeConstructorTypeVarMissing x))
      
capitalizedIdentifier :: APT.Parser T.Text
capitalizedIdentifier = do
  fletter <- APT.satisfy isUpper APT.<?> "capitalized data constructor letter"
  rest <- APT.takeWhile (\c -> not (isSpace c || c == ')')) APT.<?> "data constructor name"
  pure (fletter `T.cons` rest)
  
takeToEndOfColumnData :: APT.Parser T.Text
takeToEndOfColumnData = APT.takeWhile (APT.notInClass "")

takeToEndOfIntervalBlock :: APT.Parser T.Text
takeToEndOfIntervalBlock = APT.takeWhile (APT.notInClass ",)]")
  
parens :: APT.Parser a -> APT.Parser a  
parens p = do
  void $ APT.char '('
  APT.skipSpace
  v <- p
  APT.skipSpace
  void $ APT.char ')'
  pure v
  
quotedString :: APT.Parser T.Text
quotedString = do
  let escapeMap = [('"','"'), ('n', '\n'), ('r', '\r')]
      doubleQuote = void $ APT.char '"'
  doubleQuote
  (_, s) <- APT.runScanner [] (\prevl nextChar -> case prevl of
                             [] -> Just [nextChar]
                             chars | last chars == '\\' ->
                                        case lookup nextChar escapeMap of 
                                   | nextChar == '"' -> Nothing
                                   | otherwise -> Just (chars ++ [nextChar]))
  doubleQuote
  pure (T.pack s)
