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
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
------------------------------------------------------------------------------
--- This module contains various operations to show a FlatCurry program
--- in human-readable forms, e.g., only the interface or also the
--- complete program translated back into pattern-based rules.
--- These operations are used in the Curry Browser and they are
--- also the basis to implement the `:interface` command
--- of PAKCS or KiCS2.
---
--- The interface description contains the type declarations
--- for all entities defined and exported by this module.
---
--- The human-readable presentation is (almost) Curry source code
--- generated from a FlatCurry program.
---
--- @author Michael Hanus
--- @version August 2016
------------------------------------------------------------------------------

module ShowFlatCurry
 ( main, showInterface, showCurryModule, showCurryFuncDecl
 , showFlatCurry, showFuncDeclAsCurry, showFuncDeclAsFlatCurry
 , funcModule, leqFunc
 ) where

import Char         (isAlpha)
import Directory    (doesFileExist, getModificationTime)
import Distribution (stripCurrySuffix, modNameToPath
                    ,lookupModuleSourceInLoadPath)
import FilePath     (takeFileName, (</>))
import List         (intercalate)
import Pretty             (pPrint)
import Sort         (sortBy, leqString)
import System       (getArgs, getEnviron, system)

import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies (funcName)
import FlatCurry.Pretty  (Options (..), defaultOptions, ppProg, ppFuncDecl)
import FlatCurry.Show

main :: IO ()
main = do
  args <- getArgs
  case args of
    ["-mod",mod] -> printCurryMod (stripCurrySuffix mod)
    ["-int",mod] -> printInterface (stripCurrySuffix mod)
    ["-mod",mod,target] -> writeCurryMod target (stripCurrySuffix mod)
    ["-int",mod,target] -> writeInterface target (stripCurrySuffix mod)
    _ -> putStrLn $ "ERROR: Illegal arguments for genint: " ++
                    intercalate " " args ++ "\n" ++
                    "Usage: [-mod|-int] module_name [targetfile]"

-- print interface on stdout:
printInterface :: String -> IO ()
printInterface progname =
  do intstring <- genInt False progname
     putStrLn ("Interface of module \""++progname++"\":\n")
     putStrLn intstring

-- write interface into target file:
writeInterface :: String -> String -> IO ()
writeInterface targetfile progname =
  do intstring <- genInt True progname
     writeFile targetfile
               ("--Interface of module \""++progname++"\":\n\n"++
                intstring)
     putStrLn ("Interface written into file \""++targetfile++"\"")


-----------------------------------------------------------------------
-- Get a FlatCurry program (parse only if necessary):
getFlatProg :: String -> IO Prog
getFlatProg modname = do
  mbdirfn <- lookupModuleSourceInLoadPath modname
  let progname = maybe modname snd mbdirfn
  let fcyprogname = flatCurryFileName
                        (maybe modname (\ (d,_) -> d </> takeFileName modname)
                                       mbdirfn)
  fcyexists <- doesFileExist fcyprogname
  if not fcyexists
    then readFlatCurry modname
    else do ctime <- getModificationTime progname
            ftime <- getModificationTime fcyprogname
            if ctime>ftime
             then readFlatCurry modname
             else readFlatCurryFile fcyprogname

-----------------------------------------------------------------------
-- Generate interface description for a program:
-- If first argument is True, generate stubs (...external) for
-- all functions so that the resulting interface is a valid Curry program.
genInt :: Bool -> String -> IO String
genInt genstub progname = getFlatInt progname >>= return . showInterface genstub

-- Shows an interface description for a program:
-- If first argument is True, generate stubs (...external) for
-- all functions so that the resulting interface is a valid Curry program.
showInterface :: Bool -> Prog -> String
showInterface genstub (Prog mod imports types funcs ops) = unlines $
  ["module " ++ mod ++ " where\n"] ++
  concatMap showInterfaceImport imports ++ [""] ++
  map showInterfaceOpDecl (sortBy leqOp ops) ++
  (if null ops then [] else [""]) ++
  concatMap (showInterfaceType (showQNameInModule mod))
            (sortBy leqType types) ++ [""] ++
  concatMap (showInterfaceFunc (showQNameInModule mod) genstub)
            (sortBy leqFunc funcs)

-- Get a FlatCurry program (parse only if necessary):
getFlatInt :: String -> IO Prog
getFlatInt modname = do
  mbdirfn <- lookupModuleSourceInLoadPath modname
  let progname = maybe modname snd mbdirfn
  let fintprogname = flatCurryIntName
                        (maybe modname (\ (d,_) -> d </> takeFileName modname)
                                       mbdirfn)
  fintexists <- doesFileExist fintprogname
  if not fintexists
    then readFlatCurryInt modname
    else do ctime <- getModificationTime progname
            ftime <- getModificationTime fintprogname
            if ctime>ftime
             then readFlatCurryInt modname
             else readFlatCurryFile fintprogname

-- write import declaration
showInterfaceImport :: String -> [String]
showInterfaceImport impmod = if impmod=="Prelude"
                             then []
                             else ["import "++impmod]

-- show operator declaration
showInterfaceOpDecl :: OpDecl -> String
showInterfaceOpDecl (Op op InfixOp  prec) = "infix "++show prec++" "++showOp op
showInterfaceOpDecl (Op op InfixlOp prec) = "infixl "++show prec++" "++showOp op
showInterfaceOpDecl (Op op InfixrOp prec) = "infixr "++show prec++" "++showOp op

showOp :: (_,String) -> String
showOp (_,on) = if isAlpha (head on) then '`':on++"`"
                                     else on

-- show type declaration if it is not a dictionary
showInterfaceType :: (QName -> String) -> TypeDecl -> [String]
showInterfaceType tt (Type (_,tcons) vis tvars constrs) =
  if vis==Public && not (isDict tcons)
  then ["data " ++ tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
        (if null constxt then "" else " = " ++ constxt)]
  else []
 where
  isDict fn = take 6 fn == "_Dict#"

  constxt = intercalate " | "
              (map (showExportConsDecl tt)
                   (filter (\ (Cons _ _ cvis _)->cvis==Public) constrs))

showInterfaceType tt (TypeSyn (_,tcons) vis tvars texp) =
  if vis==Public
  then ["type " ++ tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
        " = " ++ showCurryType tt True texp]
  else []

showExportConsDecl :: (QName -> String) -> ConsDecl -> String
showExportConsDecl tt (Cons (_,cname) _ _ argtypes) =
  cname ++ concatMap (\t->" "++showCurryType tt True t) argtypes

-- show function type declaration if it is not an internal
-- operation to implement type classes
showInterfaceFunc :: (QName -> String) -> Bool -> FuncDecl -> [String]
showInterfaceFunc ttrans genstub (Func (_,fname) _ vis ftype _) =
  if vis==Public && not (classOperations fname)
  then [showCurryId fname ++ " :: " ++
        showCurryType ttrans False ftype ++
        (if genstub then "\n" ++ showCurryId fname ++ " external\n" else "")]
  else []
 where
  classOperations fn = take 6 fn `elem` ["_impl#","_inst#"]
                    || take 5 fn == "_def#" || take 7 fn == "_super#"

---------------------------------------------------------------------------
-- generate a human-readable representation of a Curry module:

-- show representation on stdout:
printCurryMod :: String -> IO ()
printCurryMod progname =
  do modstring <- genCurryMod progname
     putStrLn ("-- Program file: "++progname)
     putStrLn modstring

-- write representation into file:
writeCurryMod :: String -> String -> IO ()
writeCurryMod targetfile progname =
  do modstring <- genCurryMod progname
     writeFile targetfile
               ("--Program file: "++progname++"\n\n"++
                modstring)
     putStrLn ("Module written into file \""++targetfile++"\"")

-- generate a human-readable representation of a Curry module:
genCurryMod :: String -> IO String
genCurryMod progname = do
  prog <- readFlatCurryFile (flatCurryFileName progname)
  return $ showCurryModule prog

showCurryModule :: Prog -> String
showCurryModule (Prog mod imports types funcs ops) = unlines $
  ["module "++mod++"("++showTypeExports types ++
   showFuncExports funcs++") where\n"] ++
  concatMap showInterfaceImport imports ++ [""] ++
  map showInterfaceOpDecl ops ++
  (if null ops then [] else [""]) ++
  map (showCurryDataDecl (showQNameInModule mod)) types
  ++ [""] ++
  map (showCurryFuncDecl (showQNameInModule mod)
                         (showQNameInModule mod)) funcs

showTypeExports :: [TypeDecl] -> String
showTypeExports types = concatMap (++",") (concatMap exptype types)
 where
   exptype (Type tcons vis _ cdecls) =
     if vis==Public
     then [snd tcons++let cs = expcons cdecls in (if cs=="()" then "" else cs)]
     else []
   exptype (TypeSyn tcons vis _ _) = if vis==Public then [snd tcons] else []

   expcons cds = "(" ++ intercalate "," (concatMap expc cds) ++ ")"
   expc (Cons cname _ vis _) = if vis==Public then [snd cname] else []

showFuncExports :: [FuncDecl] -> String
showFuncExports funcs = intercalate "," (concatMap expfun funcs)
 where
   expfun (Func fname _ vis _ _) = if vis==Public then [snd fname] else []

showCurryDataDecl :: (QName -> String) -> TypeDecl -> String
showCurryDataDecl tt (Type tcons _ tvars constrs) =
  "data " ++ snd tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
  (if null constxt then "" else " = " ++ constxt)
 where constxt = intercalate " | " (map (showCurryConsDecl tt) constrs)
showCurryDataDecl tt (TypeSyn tcons _ tvars texp) =
  "type " ++ snd tcons ++ concatMap (\i->[' ',chr (97+i)]) tvars ++
  " = " ++ showCurryType tt True texp

showCurryConsDecl :: (QName -> String) -> ConsDecl -> String
showCurryConsDecl tt (Cons cname _ _ argtypes) =
  snd cname ++ concatMap (\t->" "++showCurryType tt True t) argtypes


-- generate function definitions:
showCurryFuncDecl :: (QName -> String) -> (QName -> String) -> FuncDecl -> String
showCurryFuncDecl tt tf (Func fname _ _ ftype frule) =
  showCurryId (snd fname) ++" :: "++ showCurryType tt False ftype ++ "\n" ++
  showCurryRule tf fname frule

-- format rule as set of pattern matching rules:
showCurryRule :: (QName -> String) -> QName -> Rule -> String
showCurryRule _  fname (External   _) = showCurryId (snd fname) ++ " external\n"
showCurryRule tf fname (Rule lhs rhs) =
  concatMap (\ (l,r) -> showCurryPatternRule tf l r)
            (rule2equations (shallowPattern2Expr fname lhs) rhs)

splitFreeVars :: Expr -> ([Int],Expr)
splitFreeVars exp = case exp of
  Free vars e -> (vars,e)
  _ -> ([],exp)

showCurryPatternRule :: (QName -> String) -> Expr -> Expr -> String
showCurryPatternRule tf l r = let (vars,e) = splitFreeVars r in
   showCurryExpr tf False 0 l ++
   showCurryCRHS tf e ++
   (if vars==[] then "" else
    " where " ++ intercalate "," (map showCurryVar vars) ++ " free")
   ++ "\n"

showCurryCRHS :: (QName -> String) -> Expr -> String
showCurryCRHS tf r = case r of
  Comb _ ("Prelude","cond") [e1, e2] -> " | " ++ showCurryCondRule e1 e2
  _                                  -> " = " ++ showCurryExpr tf False 2 r
 where
   showCurryCondRule e1 e2 = showCurryExpr tf False 2 e1 ++
                             " = " ++ showCurryExpr tf False 4 e2

-- transform a rule consisting of a left- and a right-hand side
-- (represented as expressions) into a set of pattern matching rules:
rule2equations :: Expr -> Expr -> [(Expr,Expr)]
rule2equations lhs rhs = case rhs of
  Case Flex (Var i) bs -> caseIntoLhs lhs i bs
  Or e1 e2 -> rule2equations lhs e1 ++ rule2equations lhs e2
  _        -> [(lhs,rhs)]

caseIntoLhs :: Expr -> Int -> [BranchExpr] -> [(Expr,Expr)]
caseIntoLhs _ _ [] = []
caseIntoLhs lhs vi (Branch (Pattern c vs) e : bs) =
  rule2equations (substitute [vi] [shallowPattern2Expr c vs] lhs) e
  ++ caseIntoLhs lhs vi bs
caseIntoLhs lhs vi (Branch (LPattern lit) e : bs) =
  rule2equations (substitute [vi] [Lit lit] lhs) e
  ++ caseIntoLhs lhs vi bs

shallowPattern2Expr :: QName -> [Int] -> Expr
shallowPattern2Expr name vars =
               Comb ConsCall name (map (\i->Var i) vars)


-- (substitute vars exps expr) = expr[vars/exps]
-- i.e., replace all occurrences of vars by corresponding exps in the
-- expression expr
substitute :: [Int] -> [Expr] -> Expr -> Expr
substitute vars exps expr = substituteAll vars exps 0 expr

-- (substituteAll vars exps base expr):
-- substitute all occurrences of variables by corresonding expressions:
-- * substitute all occurrences of var_i by exp_i in expr
--   (if vars=[var_1,...,var_n] and exps=[exp_1,...,exp_n])
-- * substitute all other variables (Var j) by (Var (base+j))
--
-- here we assume that the new variables in guards and case patterns
-- do not occur in the list "vars" of replaced variables!

substituteAll :: [Int] -> [Expr] -> Int -> Expr -> Expr
substituteAll vars exps b (Var i) = replaceVar vars exps i
  where replaceVar []     _      var = Var (b + var)
        replaceVar (_:_)  []     var = Var (b + var)
        replaceVar (v:vs) (e:es) var = if v == var then e
                                                   else replaceVar vs es var
substituteAll _  _  _ (Lit l) = Lit l
substituteAll vs es b (Comb combtype c exps) =
                 Comb combtype c (map (substituteAll vs es b) exps)
substituteAll vs es b (Let bindings exp) =
                 Let (map (\(x,e)->(x+b,substituteAll vs es b e)) bindings)
                     (substituteAll vs es b exp)
substituteAll vs es b (Free vars e) =
                 Free (map (+b) vars) (substituteAll vs es b e)
substituteAll vs es b (Or e1 e2) =
                 Or (substituteAll vs es b e1) (substituteAll vs es b e2)
substituteAll vs es b (Case ctype e cases) =
   Case ctype (substituteAll vs es b e) (map (substituteAllCase vs es b) cases)
substituteAll vs es b (Typed e t) = Typed (substituteAll vs es b e) t

substituteAllCase :: [Int] -> [Expr] -> Int -> BranchExpr -> BranchExpr
substituteAllCase vs es b (Branch (Pattern l pvs) e) =
                 Branch (Pattern l (map (+b) pvs)) (substituteAll vs es b e)
substituteAllCase vs es b (Branch (LPattern l) e) =
                 Branch (LPattern l) (substituteAll vs es b e)


-------- Definition of some orderings:
leqOp :: OpDecl -> OpDecl -> Bool
leqOp (Op (_,op1) _ p1) (Op (_,op2) _ p2) = p1>p2 || p1==p2 && op1<=op2

leqType :: TypeDecl -> TypeDecl -> Bool
leqType t1 t2 = (tname t1) <= (tname t2)
 where tname (Type    (_,tn) _ _ _) = tn
       tname (TypeSyn (_,tn) _ _ _) = tn

leqFunc :: FuncDecl -> FuncDecl -> Bool
leqFunc (Func (_,f1) _ _ _ _) (Func (_,f2) _ _ _ _) = f1 <= f2

---------------------------------------------------------------------------
--- Show FlatCurry module in pretty-printed form
showFlatCurry :: Prog -> String
showFlatCurry = pPrint . ppProg defaultOptions

-- Show individual functions:
showFuncDeclAsCurry :: FuncDecl -> String
showFuncDeclAsCurry fd =
  showCurryFuncDecl (showQNameInModule (funcModule fd))
                    (showQNameInModule (funcModule fd)) fd

showFuncDeclAsFlatCurry :: FuncDecl -> String
showFuncDeclAsFlatCurry fd = pPrint (ppFuncDecl opts fd)
  where opts = defaultOptions { currentModule = funcModule fd }

funcModule :: FuncDecl -> String
funcModule fd = fst (funcName fd)

-----------------------------------------------------------------------------