------------------------------------------------------------------------------
--- Translator from Curry with Integrated Code to Curry
--- ===================================================
---
--- Integrated Code can be used in Curry in the form
---
---   AccentGraves Langtag Whitespaces Code SingleQuotes
---
--- where AccentGraves is a number of ` greater than 2
---       SingleQuotes is the same number of '
---       Langtag is an arbitrary sequence of characters without
---         whitespaces, tabs and newlines,
---       Whitespaces is a combination of spaces, tabs and newlines,
---       and Code is code in the language Langtag.
--- Is is allowed to use ` and ' in the code, as long as they amount of
--- sequential ` or ' is smaller than their number in AccentGraves.
---
--- If there is a corresponding parser to the langtag, the expression can be
--- translated into type-safe Curry code.
---
--- Currently available Langtags:
--- format - see the FormatParser and Format library
--- regex  - see the RegexParser and Regex library
--- html   - see the MLParser and HTML library
--- xml    - see the MLParser and XML library
--- sql    - see the SQLConverter and CDBI-library
---
--- @author Jasper Sikorra (with changes by Michael Hanus)
--- @version January 2018
------------------------------------------------------------------------------

module CPP.ICode.TransICode where

import System.Directory ( getAbsolutePath, getDirectoryContents )
import System.FilePath  ( (</>), joinPath, splitDirectories, takeDirectory )
import System.IO        ( stderr, hPutStrLn )
import System.Process
import Data.List

import CPP.ICode.ParseTypes

import qualified CPP.ICode.ICodeParser

import CPP.ICode.Parser.DummyParser   as DummyParser
import CPP.ICode.Parser.FormatParser  as FormatParser
import CPP.ICode.Parser.RegexParser   as RegexParser
import CPP.ICode.Parser.ML.Translate  as MLTranslate
import CPP.ICode.Parser.SQL.Converter as SQLParser

-- Parser for Curry with Integrated Code
ciparser :: Filename -> String -> IO (PM [StandardToken])
ciparser = CPP.ICode.ICodeParser.parse

-- Selection of parsers for the conversion of Integrated Code expressions
-- to Curry
parsers :: Maybe Langtag -> Either String ParserInfo -> LangParser
parsers = maybe iden pars
  where
    iden _ _ s = return $ cleanPM s
    pars :: Langtag -> Either String ParserInfo -> LangParser
    pars l model p =
      case l of
        "sql"       -> case model of
                         Left err -> const (return $ throwPM p err)
                         _        -> SQLParser.parseSQL True model p
        "sql*"      -> case model of
                         Left err -> const (return $ throwPM p err)
                         _        -> SQLParser.parseSQL False model p
        "dummy"     -> DummyParser.parse p
        "format"    -> FormatParser.parse ""       p
        "printf"    -> FormatParser.parse "putStr" p
        "regex"     -> RegexParser.parse p
        "html"      -> fmap (mapWarnsPM (addRealFname (getFilename p))) .
                               MLTranslate.translate l p
        "xml"       -> fmap (mapWarnsPM (addRealFname (getFilename p))) .
                               MLTranslate.translate l p
        _           -> (\_ -> return $ throwPM p ("Bad langtag: " ++ l))

addRealFname :: Filename -> Warning -> Warning
addRealFname f w = setWarnPos w (setFilename (getWarnPos w) f)

-- Formatting and terminating with Errors
formatErrors :: [PError] -> IO _
formatErrors [] =
  error "Internal error in 'TransICode.formatErrors': No errors in list!"
formatErrors es@(e1:_) = do
  hPutStrLn stderr $ "\nERRORS in " ++ getFilename (getPErrorPos e1) ++ ":"
                                    ++ concatMap formatErr es
  error "Failure during preprocessing of Curry source file!"
 where
  formatErr :: PError -> String
  formatErr e = "\n" ++ "Line " ++ show (getLn (getPErrorPos e))
                     ++ " Col " ++ show (getCol (getPErrorPos e))
                     ++ ": "   ++ getPErrorMsg e

-- Formatting Warnings
formatWarnings :: [Warning] -> String
formatWarnings []              = ""
formatWarnings ws@((p,_):_) = "\nWARNINGS in " ++ getFilename p ++ ":"
                                             ++ foldr (++) "" (map formatW ws)
                                             ++ "\n\n"
  where
    formatW :: Warning -> String
    formatW w = "\n" ++ "Line " ++ show (getLn (getWarnPos w))
                     ++ " Col " ++ show (getCol (getWarnPos w))
                     ++ " | "   ++ getWarnMsg w

--- Translates a string containing a Curry program with Integrated Code
--- into a string with pure Curry code.
--- The second argument is, if non-empty, the name of an info file containing
--- information about the data model in case of integrated SQL code.
--- @param verb  - verbosity level
--- @param model - name of file containing information about the datamodel
---                in case of SQL,  an empty string otherwise
--- @param fname - The name of the original Curry file
--- @param s - The string that should be translated
--- @return The translated string
translateIntCode :: Int -> String -> String -> String -> IO String
translateIntCode verb model fname s = do
  pinfo <- tryReadParserInfoFile verb model fname
  stw <- concatAllIOPM $ applyLangParsers pinfo
                       $ ciparser fname s
  putStr (formatWarnings (getWarningsPM stw))
  escapePR (discardWarningsPM stw) formatErrors

--- Try to read parser info file for the SQL preprocessor.
tryReadParserInfoFile :: Int -> String -> String
                      -> IO (Either String ParserInfo)
tryReadParserInfoFile verb model orgfname = do
  if null model
   then do orgdir  <- getAbsolutePath (takeDirectory orgfname)
           fresult <- findParserInfoFile (splitDirectories orgdir)
           case fresult of
             Left err    -> return (Left err)
             Right fname -> readParserInfo verb (orgdir </> fname)
   else readParserInfo verb model

findParserInfoFile :: [String] -> IO (Either String String)
findParserInfoFile dirpath = do
  let dir = joinPath dirpath
  --putStrLn $ "Searching info file in: " ++ dir
  dirfiles <- getDirectoryContents dir
  case filter ("_SQLCode.info" `isSuffixOf`) dirfiles of
    []  -> let uppath = init dirpath
           in if null uppath
                then return (Left "No .info file provided or found!")
                else findParserInfoFile uppath
    [m] -> return (Right $ dir </> m)
    ms  -> return (Left $ "Multiple .info files found in directory '" ++ dir ++
                          "':\n" ++ unwords ms)

--- Handles the IO and PM monads around the StandardTokens for the
--- concatenation, so they will not disturb in the real concat function
--- concatAll
--- @param ioprpt - A list of StandardTokens wrapped in IO and a ParserMonad
concatAllIOPM :: IO (PM [StandardToken]) -> IO (PM String)
concatAllIOPM ioprpt =
  do prpt <- ioprpt
     return $ liftPM (\pt -> concatAll pt) prpt

{-
Problems with insertion of newlines:
The case that a Curry expression directly follows integrated expression,
without a newline is problematic, if the integrated expression has multiple
lines. This stems from the Curry layout rule.  The problem is depicted in the
example:
                  -- Ln. 1: isEmail s = s ``regex
                  -- Ln. 2:  a'' && True
                  -- Ln. 3:
                  -- Ln. 4:  || False
                  -- Result:
                  -- Ln. 1: isEmail s = s `match` [(Literal 'a')] && True
                  -- Ln. 2:
                  -- Ln. 3:
                  -- Ln. 4:  || False
For this line, wrong positions will be calculate in the Curry compiler, if an
error occurs. In the example: Ln 1 instead of Ln 2. All other lines have
the right positions.
-}



















--- Concatenates the result of the translation process, inserting newlines
--- and offsets if necessary
--- @param tks - A list of StandardTokens containing the results
--- @result    - The resulting program code
concatAll :: [StandardToken] -> String
concatAll []      = ""
concatAll (t1:tks) = getCode t1 ++ (concatAllHelper
                                   (getIdentPos t1)
                                   (containsDSL t1)
                                   tks)
  where
    concatAllHelper :: Pos -> Bool -> [StandardToken] -> String
    concatAllHelper _ _ []        = ""
    concatAllHelper op b (t:toks) =
      let s      = getCode t
          p      = getIdentPos t
         -- if generated dsl code was processed before
      in if b
        then
          let lnDiff = lnDifference op p
          in
            -- if the first word of s was in a newline after the dsl
            if (null s)
              then genLines lnDiff ++ concatAllHelper p (containsDSL t) toks
              else
                if (head s == '\n')
                      then (genLines lnDiff ++ s
                            ++ concatAllHelper p (containsDSL t) toks)
                  -- If the first word of s was in the last line of the dsl.
                      else
                        let (headLine,restOfCurry) = splitByLine s
                        in
                            headLine ++ genLines lnDiff ++ restOfCurry
                            ++ concatAllHelper p (containsDSL t) toks
        else (s ++ concatAllHelper p (containsDSL t) toks)

--- The function genLines generates lines
--- @param n - The number of line to be generated
--- @result  - A string containing n lines
genLines :: Int -> String
genLines = flip replicate '\n'

--- The function splitByLine splits a string at the first newline
--- @param s - The string
--- @result A pair of strings, one containg the string before the newline
---         with the newline, the other containing the string after the newline
splitByLine :: String -> (String,String)
splitByLine s = splitByLineIter "" s
  where
    splitByLineIter acc "" = (reverse acc,"")
    splitByLineIter acc (c:cs) | c == '\n' = (reverse ('\n':acc),cs)
                               | otherwise = splitByLineIter (c:acc) cs

--- Applies the corresponding translators of the DSL to Curry on the
--- StandardTokens
--- @param model - data model information (required in case of SQL code),
---                otherwise an error message
--- @param iotks - The input StandardTokens wrapped in IO and ParserMonad
--- @result      - The translated StandardTokens wrapped in IO and ParserMonad
applyLangParsers :: Either String ParserInfo
                 -> IO (PM [StandardToken])
                 -> IO (PM [StandardToken])
applyLangParsers model iotks = do
  prtks <- iotks
  prpr <- swapIOPM (liftPM (mapM (applyLangParser model)) prtks)
  return (crumplePM (liftPM (\prpt -> sequencePM prpt) prpr))

--- Select the right translator and apply it to a single StandardToken
--- @param model - data model information in case of SQL code,
---                error message otherwise
--- @param t - The input StandardToken
--- result   - The translated StandardToken wrapped in IO and ParserMonad
applyLangParser :: Either String ParserInfo
                -> StandardToken
                -> IO (PM StandardToken)
applyLangParser model (StTk p pexp l c) =
  do parsedStringNoIO <- (parsers l model) pexp c
     return (bindPM parsedStringNoIO (\s -> cleanPM (StTk p pexp l s)))