1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
------------------------------------------------------------------------------
--- 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)))