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
------------------------------------------------------------------------------
--- A printf-like format expression parser
--- ======================================
--- A format expression is of the form
---
---     "(Specifier|NonSpecifier)*"(,Var)*
---
--- where `Var` can be any string without a comma.
---
--- A specifier is in the form
---
---     %[flags] [width] [.precision] type
---
--- Allowed Flags: '-' '+' '0' ' ' '#'
---
--- Width and Precision are either integers or '*'.
---
--- Types: 'c' 'd' 'i' 'o' 'x' 'X' 'e' 'E' 'f' 's'
---
--- For explanation on semantics see
--- <http://pubs.opengroup.org/onlinepubs/009695399/functions/fprintf.html>
---
--- __For further informations see the library `Data.Format` of package
--- `printf`. Not all parsable expressions are usable.__
---
--- @author Jasper Sikorra (with changes by Michael Hanus)
--- @version June 2021
------------------------------------------------------------------------------
module CPP.ICode.Parser.FormatParser ( parse ) where

import Prelude hiding       ( empty, (<*>) )

import Parser    -- from package fl-parser
import Data.Char
import Numeric              ( readNat )

import Control.AllValues    ( getOneSolution )

import CPP.ICode.ParseTypes

type Expression = ([Either String Specifier],[Variable])
data Specifier  = Spec (Maybe Flags) (Maybe Width) (Maybe Precision) Type
data SpecifierWVar =
  SpecV
    (Maybe Flags)
    (Maybe WidthV)
    (Maybe PrecisionV)
    Type
    Variable
type Flags = String
type Width = Either Int Char
type WidthV = Int
type Precision = Either Int Char
type PrecisionV = Int
type Type = Char
type Variable = String

--- Possible flags
flags :: String
flags      = ['-','+','0',' ','#']
--- Possible types
types :: String
types      = ['c','d','i','o','x','X','e','E','f','s']
--- Escapable characters
escapable :: String
escapable  = ['a','b','f','n','r','t','v','"' ,'\'','?','\\','0','x']
--- Possible starting letters for variables
isVarStartLetter :: Char -> Bool
isVarStartLetter c = c /= ','
--- Possible inner letters for variables
isVarInnerLetter :: Char -> Bool
isVarInnerLetter c = c /= ','

--- Map each type to a function in the `Data.Format` library
mapTypes :: Char -> String
mapTypes c = "Data.Format." ++ case c of
  'c' -> "showChar"
  'd' -> "showInt"
  'i' -> "showInt"
  'o' -> "showInt"
  'x' -> "showInt"
  'X' -> "showInt"
  'e' -> "showFloat"
  'E' -> "showFloat"
  'f' -> "showFloat"
  'g' -> "showFloat"
  'G' -> "showFloat"
  's' -> "showString"
  _   -> error "mapTypes: unknown character"

--- The function parses and converts a String that is in the format of a C-like
--- printf expression into a Curry Expression that makes use of the
--- `Data.Format` library.
--- @param showfun - The operation to be applied to the formatted string result
--- @param pos - The position of the expression in the original file
--- @param exp - The expression which should be converted
--- @return A String in Curry Syntax matching exp using the `Data.Format`
---         library
parse :: String -> LangParser
parse showfun p s = do
  x <- addVarsToSpecs p $ readExpression p s
  return (bindPM (liftPM genString x)
                 (\y -> cleanPM ((++) (showfun++" (") y)))

--- Generate the target code
genString :: [Either String SpecifierWVar] -> String
genString []     = []
genString [x]    = case x of
                    (Left stri) -> "\"" ++ stri ++ "\")"
                    (Right sp) -> specToString sp ++ ")"
genString (x1:x2:xs) = case x1 of
  (Left stri) -> "\"" ++ stri ++ "\" ++ " ++ genString (x2:xs)
  (Right sp) -> specToString sp ++ " ++ " ++ genString (x2:xs)

specToString :: SpecifierWVar -> String
specToString (SpecV f w p t v) =
  "("    ++ mapTypes t
  ++ " " ++ showBr t
  ++ " " ++ showBr f
  ++ " " ++ showBr w
  ++ " " ++ showBr p
  ++ " " ++ (if all isAlphaNum v then v else '(':v++")")
  ++ ")"
 where showBr x = '(' : show x ++ ")"

--- Assign variables to the specifiers
addVarsToSpecs :: Pos -> IO (PM Expression)
                  -> IO (PM [Either String SpecifierWVar])
addVarsToSpecs p ioprexp =
  do prexp <- ioprexp
     let prfs = fstPM prexp
         prsn = sndPM prexp
      in do return $ bindPM prfs $ \fs ->
                     bindPM prsn $ \sn ->
                      addVarsToSpecifiers p fs sn

addVarsToSpecifiers :: Pos -> [Either String Specifier] -> [Variable]
                       -> PM [Either String SpecifierWVar]
addVarsToSpecifiers _  [] []              = cleanPM []
addVarsToSpecifiers po [] (_:_)           =
  throwPM po "Too many variables in format expression"
addVarsToSpecifiers po ((Right _):_) []   =
  throwPM po "Too few variables in format expression"
addVarsToSpecifiers po ((Left x):xs) []   =
  liftPM ((:) (Left x)) (addVarsToSpecifiers po xs [])
addVarsToSpecifiers po (q:qs) varis@(v:vs) = case q of
  (Left stri)             -> liftPM ((:) (Left stri))
                                   (addVarsToSpecifiers po qs varis)
  (Right (Spec f w p t)) -> if isStar w
      then
        let iv = Just (Left (extractNat v))
        in addVarsToSpecifiers po (Right (Spec f iv p t):qs) vs
      else if isStar p
        then
          let iv = Just (Left (extractNat v))
          in  addVarsToSpecifiers po (Right (Spec f w iv t):qs) vs
        else liftPM ((:) (Right (SpecV f (eE w) (eE p) t v)))
                    (addVarsToSpecifiers po qs vs)
    where
      isStar :: Maybe (Either Int Char) -> Bool
      isStar = maybe
        False
        (\e -> case e of
          (Right '*') -> True
          _           -> False)
      eE :: Maybe (Either Int Char) -> Maybe Int
      eE = maybe Nothing (\x -> Just (either id failed x))

--- Parse a format string expression
readExpression :: Pos -> String -> IO (PM Expression)
readExpression p st =
  do x <- getOneSolution (\a -> expression a st =:= "")
     return $ maybe (throwPM p "Parse error in format expression.") cleanPM x

-- The whole expression
expression :: ([Either (String) Specifier],[String]) -> String -> String
expression   =  quoted q <*> vars v                                             >>> (q,v)                   where q,v free
-- The quote part of the expression
quoted :: [Either (String) Specifier] -> String -> String
quoted       = terminal '"'  <*> strsAndSpecs s <*> terminal '"'                >>> s                        where s free
strsAndSpecs :: [Either (String) Specifier] -> String -> String
strsAndSpecs = empty                                                            >>> []
          <||> str st                                                           >>> [Left st]
          <||> spec sp <*> strsAndSpecs stsps                                   >>> (Right sp:stsps)
          <||> str st <*> spec sp <*> strsAndSpecs stsps                        >>> (Left st:Right sp:stsps) where st,sp,stsps free
-- -- A normal string
str :: String -> String -> String
str          = noescp c <*> eorstr st                                           >>> (c:st)
          <||> terminal '\\' <*> escp e <*> eorstr st                           >>> ('\\':e:st)              where c,e,st free
eorstr :: String -> String -> String
eorstr       = empty                                                            >>> ""
          <||> str s                                                            >>> s                        where s free
noescp :: Char -> String -> String
noescp       = satisfy (\d -> d /= '\\' && d /= '%' && d /= '"' ) c             >>> c                        where c free
escp :: Char -> String -> String
escp         = satisfy (\c -> elem c escapable) e                               >>> e                        where e free
-- -- A format specification
spec :: Specifier -> String -> String
spec         = terminal '%' <*> flgs f <*> wid w <*> prc p <*> typ t            >>> (Spec f w p t)
          <||> terminal '%' <*> terminal '%'
            >>> (Spec Nothing Nothing Nothing '%')                                                           where f,w,p,t free
-- -- -- flags
flgs :: Maybe (String) -> String -> String
flgs         = empty                                                            >>> Nothing
   <||> flag f <*> someflags fl                                                 >>> (Just (f:fl))            where f,fl free
someflags :: String -> String -> String
someflags    = empty                                                            >>> ""
       <||> flag f <*> someflags fl                                             >>> (f:fl)                   where f,fl free
flag :: Char -> String -> String
flag         = satisfy (\x -> elem x flags) c                                   >>> c                        where c free
-- -- -- width
wid :: Maybe (Either Int Char) -> String -> String
wid          = empty                                                            >>> Nothing
          <||> posInt s                                                         >>> (Just (Left (extractNat s)))
          <||> terminal '*'                                                     >>> (Just (Right '*'))       where s free
posInt :: String -> String -> String
posInt       = nonzerodigit d <*> digits ds                                     >>> (d:ds)                   where d,ds free
nonzerodigit :: Char -> String -> String
nonzerodigit = satisfy (\c -> isDigit c && c /= '0') d                          >>> d                        where d free
digits :: String -> String -> String
digits       = empty                                                            >>> ""
          <||> digit d <*> digits ds                                            >>> (d:ds)                   where d,ds free
digit :: Char -> String -> String
digit        = satisfy (\c -> isDigit c) ch                                     >>> ch                       where ch free
-- -- -- precision
prc :: Maybe (Either Int Char) -> String -> String
prc          = empty                                                            >>> Nothing
          <||> terminal '.' <*> posZeroInt p                                    >>> (Just (Left (extractNat p)))
          <||> terminal '.'                                                     >>> (Just (Left 0))
          <||> terminal '*' <*> terminal '*'                                    >>> (Just (Right '*'))       where p free
posZeroInt :: String -> String -> String
posZeroInt   = digit d <*> digits ds                                            >>> (d:ds)                   where d,ds free
-- -- -- type
typ :: Char -> String -> String
typ          = satisfy (\c -> elem c types) t                                   >>> t                        where t free
-- The variables of the expression
vars :: [String] -> String -> String
vars         = empty                                                            >>> []
          <||> terminal ',' <*> var v <*> vars vs                               >>> (v:vs)                   where v,vs free
var :: String -> String -> String
var          = posInt i                                                         >>> i
          <||> varStart s <*> varInners i                                       >>> (s:i)                    where s,i free
varStart :: Char -> String -> String
varStart     = satisfy (\c -> isVarStartLetter c) s                             >>> s                        where s free
varInners :: String -> String -> String
varInners    = empty                                                            >>> ""
          <||> varInner v <*> varInners i                                       >>> (v:i)                    where v,i free
varInner :: Char -> String -> String
varInner     = satisfy (\c -> isVarInnerLetter c) i                             >>> i                        where i free

extractNat :: String -> Int
extractNat s = case readNat s of
  [(v,_)] -> v
  _       -> failed