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
------------------------------------------------------------------------------
--- 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 April 2021
------------------------------------------------------------------------------

module FlatCurry.ShowIntMod
 ( showInterface, showCurryModule, showCurryFuncDecl
 , showFlatCurry, showFuncDeclAsCurry, showFuncDeclAsFlatCurry
 , funcModule, leqFunc
 ) where

import Data.Char          ( isAlpha )
import Data.List          ( intercalate, sortBy )

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

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

-- 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)

-- write import declaration
showInterfaceImport :: String -> [String]
showInterfaceImport impmod | impmod == "Prelude" = []
                           | otherwise           = ["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 []

showInterfaceType tt (TypeNew (_,tcons) vis tvars newconsdecl) =
  if vis==Public
    then ["newtype " ++ tcons ++
           concatMap (\ (i,_) -> [' ', chr (97+i)]) tvars ++
          " = " ++ showCurryNewConsDecl tt newconsdecl]
    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:

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 []
  exptype (TypeNew tcons vis _ (NewCons _ ncvis _)) =
    if vis == Public
      then [snd tcons ++ if ncvis == Public then "(..)" else ""]
      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
showCurryDataDecl tt (TypeNew tcons _ tvars newconsdecl) =
  "newtype " ++ snd tcons ++ concatMap (\(i,_) -> [' ',chr (97+i)]) tvars ++
  " = " ++ showCurryNewConsDecl tt newconsdecl

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

showCurryNewConsDecl :: (QName -> String) -> NewConsDecl -> String
showCurryNewConsDecl tt (NewCons cname _ texp) =
  snd cname ++ " " ++ showCurryType tt True texp


-- 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
       tname (TypeNew (_,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)

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