content: 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 attrName _ (SubrelationFoldAtomType _) _ =
    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)
  