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
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
------------------------------------------------------------------------------
--- This module contains functions to reduce the size of FlatCurry programs
--- by combining the main module and all imports into a single program
--- that contains only the functions directly or indirectly called from
--- a set of main functions.
---
--- @author Michael Hanus, Carsten Heine
--- @version September 2021
------------------------------------------------------------------------------

module FlatCurry.Compact
  ( generateCompactFlatCurryFile, computeCompactFlatCurry
  , Option(..), RequiredSpec, requires, alwaysRequired
  , defaultRequired
  ) where

import FlatCurry.Types
import FlatCurry.Files
import qualified Data.Set.RBTree as RBS
import qualified Data.Table.RBTree as RBT
import Data.Maybe
import Data.List           ( nub, union )
import System.CurryPath    ( lookupModuleSourceInLoadPath, stripCurrySuffix)
import System.FilePath     ( takeFileName, (</>) )
import System.Directory
import XML

infix 0 `requires`

------------------------------------------------------------------------------
--- Options to guide the compactification process.
--- @cons Verbose  - for more output
--- @cons Main     - optimize for one main (unqualified!) function supplied here
--- @cons Exports  - optimize w.r.t. the exported functions of the module only
--- @cons InitFuncs - optimize w.r.t. given list of initially required functions
--- @cons Required - list of functions that are implicitly required and, thus,
---                  should not be deleted if the corresponding module
---                  is imported
--- @cons Import   - module that should always be imported
---                  (useful in combination with option InitFuncs)
data Option =
    Verbose
  | Main String
  | Exports
  | InitFuncs [QName]
  | Required [RequiredSpec]
  | Import String
  deriving Eq

isMainOption :: Option -> Bool
isMainOption o =
  case o of Main _ -> True
            _      -> False

getMainFuncFromOptions :: [Option] -> String
getMainFuncFromOptions (o:os) =
   case o of Main f -> f
             _      -> getMainFuncFromOptions os
getMainFuncFromOptions [] =
  error "FlatCurry.Compact.getMainFuncFromOptions: option missing"

getRequiredFromOptions :: [Option] -> [RequiredSpec]
getRequiredFromOptions options = concat [ fs | Required fs <- options ]

-- add Import for modules containing always required functions:
addImport2Options :: [Option] -> [Option]
addImport2Options options =
  options ++
  map Import (nub (concatMap alwaysReqMod (getRequiredFromOptions options)))
 where
  alwaysReqMod (AlwaysReq (m,_))  = [m]
  alwaysReqMod (Requires _ _) = []

------------------------------------------------------------------------------
--- Data type to specify requirements of functions.
data RequiredSpec = AlwaysReq QName | Requires QName QName
  deriving Eq

--- (fun `requires` reqfun) specifies that the use of the function "fun"
--- implies the application of function "reqfun".
requires :: QName -> QName -> RequiredSpec
requires fun reqfun = Requires fun reqfun

--- (alwaysRequired fun) specifies that the function "fun" should be
--- always present if the corresponding module is loaded.
alwaysRequired :: QName -> RequiredSpec
alwaysRequired fun = AlwaysReq fun

--- Functions that are implicitly required in a FlatCurry program
--- (since they might be generated by external functions like
--- "==" or "=:=" on the fly).
defaultRequired :: [RequiredSpec]
defaultRequired =
  [alwaysRequired (prelude,"apply"),
   alwaysRequired (prelude,"letrec"),
   alwaysRequired (prelude,"cond"),
   alwaysRequired (prelude,"failure"),
   (prelude,"==")    `requires` (prelude,"&&"),
   (prelude,"=:=")   `requires` (prelude,"&"),
   (prelude,"=:<=")  `requires` (prelude,"ifVar"),
   (prelude,"=:<=")  `requires` (prelude,"=:="),
   (prelude,"=:<=")  `requires` (prelude,"&>"),
   (prelude,"=:<<=") `requires` (prelude,"&"),
   (prelude,"$#")    `requires` (prelude,"ensureNotFree"),
   (prelude,"readFile") `requires` (prelude,"prim_readFileContents"),
   ("Ports","prim_openPortOnSocket") `requires` ("Ports","basicServerLoop"),
   ("Ports","prim_timeoutOnStream")  `requires` ("Ports","basicServerLoop"),
   ("Ports","prim_choiceSPEP")       `requires` ("Ports","basicServerLoop"),
   ("Dynamic","getDynamicKnowledge") `requires` ("Dynamic","isKnownAtTime") ]

prelude :: String
prelude = "Prelude"

--- Get functions that are required in a module w.r.t.
--- a requirement specification.
getRequiredInModule :: [RequiredSpec] -> String -> [QName]
getRequiredInModule reqspecs mod = concatMap getImpReq reqspecs
 where
  getImpReq (AlwaysReq (mf,f)) = if mf==mod then [(mf,f)] else []
  getImpReq (Requires _ _) = []

--- Get functions that are implicitly required by a function w.r.t.
--- a requirement specification.
getImplicitlyRequired :: [RequiredSpec] -> QName -> [QName]
getImplicitlyRequired reqspecs fun = concatMap getImpReq reqspecs
 where
  getImpReq (AlwaysReq _) = []
  getImpReq (Requires f reqf) = if f==fun then [reqf] else []

--- The basic types that are always required in a FlatCurry program.
defaultRequiredTypes :: [QName]
defaultRequiredTypes =
  [(prelude,"()"),(prelude,"Int"),(prelude,"Float"),(prelude,"Char"),
   (prelude,"Success"),(prelude,"IO")]


-------------------------------------------------------------------------------
-- Main functions:
-------------------------------------------------------------------------------

--- Computes a single FlatCurry program containing all functions potentially
--- called from a set of main functions and writes it into a FlatCurry file.
--- This is done by merging all imported FlatCurry modules and removing
--- the imported functions that are definitely not used.
--- @param options  - list of options
--- @param progname - name of the Curry program that should be compacted
--- @param target   - name of the target file where the compact program is saved
generateCompactFlatCurryFile :: [Option] -> String -> String -> IO ()
generateCompactFlatCurryFile options progname target = do
  optprog <- computeCompactFlatCurry options progname
  writeFCY target optprog

--- Computes a single FlatCurry program containing all functions potentially
--- called from a set of main functions.
--- This is done by merging all imported FlatCurry modules (these are loaded
--- demand-driven so that modules that contains no potentially called functions
--- are not loaded) and removing the imported functions that are definitely
--- not used.
--- @param options  - list of options
--- @param progname - name of the Curry program that should be compacted
--- @return the compact FlatCurry program
computeCompactFlatCurry :: [Option] -> String -> IO Prog
computeCompactFlatCurry orgoptions progname =
  let options = addImport2Options orgoptions in
  if (elem Exports options) && (any isMainOption options)
  then error
        "CompactFlat: Options 'Main' and 'Exports' can't be be used together!"
  else do
    putStr "CompactFlat: Searching relevant functions in module "
    prog <- readCurrentFlatCurry progname
    resultprog <- makeCompactFlatCurry prog options
    putStrLn $ "CompactFlat: Number of functions after optimization: " ++
               show (length (moduleFuns resultprog))
    return resultprog

--- Create the optimized program.
makeCompactFlatCurry :: Prog -> [Option] -> IO Prog
makeCompactFlatCurry mainmod options = do
  (initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options
  let initFuncTable = extendFuncTable (RBT.empty (<))
                                      (concatMap moduleFuns loadedmods)
      required = getRequiredFromOptions options
      loadedreqfuns = concatMap (getRequiredInModule required)
                                (map moduleName loadedmods)
      initreqfuncs = initfuncs ++ loadedreqfuns
  (finalmods,finalfuncs,finalcons,finaltcons) <-
     getCalledFuncs required
                    loadedmnames loadedmods initFuncTable
                    (foldr RBS.insert (RBS.empty (<)) initreqfuncs)
                    (RBS.empty (<)) (RBS.empty (<))
                    initreqfuncs
  putStrLn ("\nCompactFlat: Total number of functions (without unused imports): "
            ++ show (foldr (+) 0 (map (length . moduleFuns) finalmods)))
  let finalfnames  = map functionName finalfuncs
  return (Prog (moduleName mainmod)
               []
               (let allTDecls = concatMap moduleTypes finalmods
                    reqTCons  = extendTConsWithConsType finalcons finaltcons
                                                        allTDecls
                    allReqTCons = requiredDatatypes reqTCons allTDecls
                 in filter (\tdecl->tconsName tdecl `RBS.member` allReqTCons)
                           allTDecls)
               finalfuncs
               (filter (\ (Op oname _ _) -> oname `elem` finalfnames)
                       (concatMap moduleOps finalmods)))

-- compute the transitive closure of a set of type constructors w.r.t.
-- to a given list of type declaration so that the set contains
-- all type constructor names occurring in the type declarations:
requiredDatatypes :: RBS.SetRBT QName -> [TypeDecl] -> RBS.SetRBT QName
requiredDatatypes tcnames tdecls =
  let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls
   in if null newtcons
      then tcnames
      else requiredDatatypes (foldr RBS.insert tcnames newtcons) tdecls

-- Extract the new type constructors (w.r.t. a given set) contained in a
-- type declaration:
newTypeConsOfTDecl :: RBS.SetRBT QName -> TypeDecl -> [QName]
newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) =
  if tcons `RBS.member` tcnames
  then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp)
  else []
newTypeConsOfTDecl tcnames (TypeNew tcons _ _ (NewCons _ _ texp)) =
  if tcons `RBS.member` tcnames
  then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp)
  else []
newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) =
  if tcons `RBS.member` tcnames
  then filter (\tc -> not (tc `RBS.member` tcnames))
          (concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps)
                    cdecls)
  else []

-- Extend set of type constructor with type constructors of data declarations
-- contain some constructor.
extendTConsWithConsType :: RBS.SetRBT QName -> RBS.SetRBT QName -> [TypeDecl]
                        -> RBS.SetRBT QName
extendTConsWithConsType _ tcons [] = tcons
extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) =
  extendTConsWithConsType cnames (RBS.insert tname tcons) tds
extendTConsWithConsType cnames tcons (TypeNew tname _ _ cdecl : tds) =
  if newConsName cdecl `RBS.member` cnames
  then extendTConsWithConsType cnames (RBS.insert tname tcons) tds
  else extendTConsWithConsType cnames tcons tds
extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) =
  if tname `elem` defaultRequiredTypes ||
     any (\cdecl->consName cdecl `RBS.member` cnames) cdecls
  then extendTConsWithConsType cnames (RBS.insert tname tcons) tds
  else extendTConsWithConsType cnames tcons tds

-- Extend function table (mapping from qualified names to function declarations)
-- by some new function declarations:
extendFuncTable :: RBT.TableRBT QName FuncDecl -> [FuncDecl]
                -> RBT.TableRBT QName FuncDecl
extendFuncTable ftable fdecls =
  foldr (\f t -> RBT.update (functionName f) f t) ftable fdecls


-------------------------------------------------------------------------------
-- Generate the Prog to start with:
-------------------------------------------------------------------------------

-- Compute the initially required functions in the compact program
-- together with the set of module names and contents that are initially loaded:
requiredInCompactProg :: Prog -> [Option] -> IO ([QName],RBS.SetRBT String,[Prog])
requiredInCompactProg mainmod options
 | not (null initfuncs)
  = do impprogs <- mapM readCurrentFlatCurry imports
       return (concat initfuncs, add2mainmodset imports, mainmod:impprogs)
 | Exports `elem` options
  = do impprogs <- mapM readCurrentFlatCurry imports
       return (nub mainexports, add2mainmodset imports, mainmod:impprogs)
 | any isMainOption options
  = let func = getMainFuncFromOptions options in
     if (mainmodname,func) `elem` (map functionName (moduleFuns mainmod))
     then do
       impprogs <- mapM readCurrentFlatCurry imports
       return ([(mainmodname,func)], add2mainmodset imports, mainmod:impprogs)
     else error $ "CompactFlat: Cannot find main function \""++func++"\"!"
 | otherwise
  = do impprogs <- mapM readCurrentFlatCurry
                         (nub (imports ++ moduleImports mainmod))
       return (nub (mainexports ++
                    concatMap (exportedFuncNames . moduleFuns) impprogs),
               add2mainmodset (map moduleName impprogs),
               mainmod:impprogs)
 where
   imports = nub [ mname | Import mname <- options ]

   mainmodname = moduleName mainmod

   initfuncs = [ fs | InitFuncs fs <- options ]

   mainexports = exportedFuncNames (moduleFuns mainmod)

   mainmodset = RBS.insert mainmodname $ RBS.empty (<)

   add2mainmodset mnames = foldr RBS.insert mainmodset mnames


-- extract the names of all exported functions:
exportedFuncNames :: [FuncDecl] -> [QName]
exportedFuncNames funs =
   map (\(Func name _ _ _ _)->name)
       (filter (\(Func _ _ vis _ _)->vis==Public) funs)


-------------------------------------------------------------------------------
--- Adds all required functions to the program and load modules, if necessary.
--- @param required - list of potentially required functions
--- @param loadedmnames - set of already considered module names
--- @param progs - list of already loaded modules
--- @param functable - mapping from (loaded) function names to their definitions
--- @param loadedfnames - set of already loaded function names
--- @param loadedcnames - set of already required data constructors
--- @param loadedtnames - set of already required data constructors
--- @param fnames - list of function names to be analyzed for dependencies
--- @return (list of loaded modules, list of required function declarations,
---          set of required data constructors, set of required type names)
getCalledFuncs :: [RequiredSpec] -> RBS.SetRBT String -> [Prog]
               -> RBT.TableRBT QName FuncDecl
               -> RBS.SetRBT QName -> RBS.SetRBT QName -> RBS.SetRBT QName
               -> [QName]
               -> IO ([Prog],[FuncDecl],RBS.SetRBT QName,RBS.SetRBT QName)
getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts)
getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames
               loadedtnames ((m,f):fs)
  | not (m `RBS.member` loadedmnames)
   = do newmod <- readCurrentFlatCurry m
        let reqnewfun = getRequiredInModule required m
        getCalledFuncs required (RBS.insert m loadedmnames) (newmod:progs)
                       (extendFuncTable functable (moduleFuns newmod))
                       (foldr RBS.insert loadedfnames reqnewfun) loadedcnames
                       loadedtnames ((m,f):fs ++ reqnewfun)
  | isNothing (RBT.lookup (m,f) functable)
   = -- this must be a data constructor: ingore it since already considered
     getCalledFuncs required loadedmnames progs
                    functable loadedfnames loadedcnames loadedtnames fs
  | otherwise = do
   let fdecl = fromJust (RBT.lookup (m,f) functable)
       funcCalls = allFuncCalls fdecl
       newFuncCalls = filter (\qn->not (qn `RBS.member` loadedfnames)) funcCalls
       newReqs = concatMap (getImplicitlyRequired required) newFuncCalls
       consCalls = allConstructorsOfFunc fdecl
       newConsCalls = filter (\qn->not (qn `RBS.member` loadedcnames)) consCalls
       newtcons = allTypesOfFunc fdecl
   (newprogs,newfuns,newcons, newtypes) <-
       getCalledFuncs required loadedmnames progs functable
                      (foldr RBS.insert loadedfnames (newFuncCalls++newReqs))
                      (foldr RBS.insert loadedcnames consCalls)
                      (foldr RBS.insert loadedtnames newtcons)
                      (fs ++ newFuncCalls ++ newReqs ++ newConsCalls)
   return (newprogs, fdecl:newfuns, newcons, newtypes)


-------------------------------------------------------------------------------
-- Operations to get all function calls, types,... in a function declaration:
-------------------------------------------------------------------------------

--- Get all function calls in a function declaration and remove duplicates.
--- @param funcDecl - a function declaration in FlatCurry
--- @return a list of all function calls
allFuncCalls :: FuncDecl -> [QName]
allFuncCalls (Func _ _ _ _ (External _)) = []
allFuncCalls (Func _ _ _ _ (Rule _ expr)) = nub (allFuncCallsOfExpr expr)


--- Get all function calls in an expression.
--- @param expr - an expression
--- @return a list of all function calls
allFuncCallsOfExpr :: Expr -> [QName]
allFuncCallsOfExpr (Var _) = []
allFuncCallsOfExpr (Lit _) = []
allFuncCallsOfExpr (Comb ctype fname exprs) = case ctype of
  FuncCall       -> fname:fnames
  FuncPartCall _ -> fname:fnames
  _ -> fnames
 where
  fnames = concatMap allFuncCallsOfExpr exprs
allFuncCallsOfExpr (Free _ expr) =
    allFuncCallsOfExpr expr
allFuncCallsOfExpr (Let bs expr) =
    concatMap (allFuncCallsOfExpr . snd) bs ++ allFuncCallsOfExpr expr
allFuncCallsOfExpr (Or expr1 expr2) =
    allFuncCallsOfExpr expr1 ++ allFuncCallsOfExpr expr2
allFuncCallsOfExpr (Case _ expr branchExprs) =
    allFuncCallsOfExpr expr ++
    concatMap allFuncCallsOfBranchExpr branchExprs
allFuncCallsOfExpr (Typed expr _) = allFuncCallsOfExpr expr


--- Get all function calls in a branch expression in case expressions.
--- @param branchExpr - a branch expression
--- @return a list of all function calls
allFuncCallsOfBranchExpr :: BranchExpr -> [QName]
allFuncCallsOfBranchExpr (Branch _ expr) = allFuncCallsOfExpr expr



--- Get all data constructors in a function declaration.
allConstructorsOfFunc :: FuncDecl -> [QName]
allConstructorsOfFunc (Func _ _ _ _ (External _)) = []
allConstructorsOfFunc (Func _ _ _ _ (Rule _ expr)) = allConsOfExpr expr

--- Get all data constructors in an expression.
allConsOfExpr :: Expr -> [QName]
allConsOfExpr (Var _) = []
allConsOfExpr (Lit _) = []
allConsOfExpr (Comb ctype cname exprs) = case ctype of
  ConsCall       -> cname:cnames
  ConsPartCall _ -> cname:cnames
  _ -> cnames
 where
  cnames = unionMap allConsOfExpr exprs
allConsOfExpr (Free _ expr) =
   allConsOfExpr expr
allConsOfExpr (Let bs expr) =
   union (unionMap (allConsOfExpr . snd) bs) (allConsOfExpr expr)
allConsOfExpr (Or expr1 expr2) =
   union (allConsOfExpr expr1) (allConsOfExpr expr2)
allConsOfExpr (Case _ expr branchExprs) =
   union (allConsOfExpr expr) (unionMap consOfBranch branchExprs)
 where
  consOfBranch (Branch (LPattern _) e) = allConsOfExpr e
  consOfBranch (Branch (Pattern c _) e) = union [c] (allConsOfExpr e)
allConsOfExpr (Typed expr _) = allConsOfExpr expr


--- Get all type constructors in a function declaration.
allTypesOfFunc :: FuncDecl -> [QName]
allTypesOfFunc (Func _ _ _ texp _) = allTypesOfTExpr texp

--- Get all data constructors in an expression.
allTypesOfTExpr :: TypeExpr -> [QName]
allTypesOfTExpr (TVar _) = []
allTypesOfTExpr (FuncType texp1 texp2) =
   union (allTypesOfTExpr texp1) (allTypesOfTExpr texp2)
allTypesOfTExpr (TCons tcons args) =
  union [tcons] (unionMap allTypesOfTExpr args)
allTypesOfTExpr (ForallType _ texp) = allTypesOfTExpr texp

unionMap :: Eq b => (a -> [b]) -> [a] -> [b]
unionMap f = foldr union [] . map f


-------------------------------------------------------------------------------
-- Functions to get direct access to some data inside a datatype:
-------------------------------------------------------------------------------

--- Extracts the function name of a function declaration.
functionName :: FuncDecl -> QName
functionName (Func name _ _ _ _) = name

--- Extracts the constructor name of a constructor declaration.
consName :: ConsDecl -> QName
consName (Cons name _ _ _) = name

--- Extracts the constructor name of a newtype constructor declaration.
newConsName :: NewConsDecl -> QName
newConsName (NewCons name _ _) = name

--- Extracts the type name of a type declaration.
tconsName :: TypeDecl -> QName
tconsName (Type name _ _ _) = name
tconsName (TypeSyn name _ _ _) = name
tconsName (TypeNew name _ _ _) = name

--- Extracts the names of imported modules of a FlatCurry program.
moduleImports :: Prog -> [String]
moduleImports (Prog _ imports _ _ _) = imports


--- Extracts the types of a FlatCurry program.
moduleTypes :: Prog -> [TypeDecl]
moduleTypes (Prog _ _ types _ _) = types

--- Extracts the operators of a FlatCurry program.
moduleOps :: Prog -> [OpDecl]
moduleOps (Prog _ _ _ _ ops) = ops

--- Extracts the name of the Prog.
moduleName :: Prog -> String
moduleName (Prog name _ _ _ _) = name

--- Extracts the functions of the program.
moduleFuns :: Prog -> [FuncDecl]
moduleFuns (Prog _ _ _ funs _) = funs


-------------------------------------------------------------------------------
-- Functions for comparison:
-------------------------------------------------------------------------------

--- Compares two qualified names.
--- Returns True, if the first name is lexicographically smaller than
--- the second name using the leString function to compare String.
leqQName :: QName -> QName -> Bool
leqQName (m1,n1) (m2,n2) = let cm = compare m1 m2
                            in cm == LT || (cm == EQ && n1 <= n2)


-------------------------------------------------------------------------------
-- I/O functions:
-------------------------------------------------------------------------------

-- Read a FlatCurry program (parse only if necessary):
readCurrentFlatCurry :: String -> IO Prog
readCurrentFlatCurry modname = do
  putStr (modname++"...")
  mbsrc <- lookupModuleSourceInLoadPath modname
  case mbsrc of
    Nothing -> error ("Curry file for module \""++modname++"\" not found!")
    Just (moddir,progname) -> do
      let fcyname = flatCurryFileName (moddir </> takeFileName modname)
      fcyexists <- doesFileExist fcyname
      if not fcyexists
       then readFlatCurry modname >>= processPrimitives progname
       else do
         ctime <- getModificationTime progname
         ftime <- getModificationTime fcyname
         if ctime>ftime
          then readFlatCurry progname >>= processPrimitives progname
          else readFlatCurryFile fcyname >>= processPrimitives progname

-- read primitive specification and transform FlatCurry program accordingly:
processPrimitives :: String -> Prog -> IO Prog
processPrimitives progname prog = do
  pspecs <- readPrimSpec (moduleName prog)
                         (stripCurrySuffix progname ++ ".pakcs")
  return (mergePrimSpecIntoModule pspecs prog)

mergePrimSpecIntoModule :: [(QName,QName)] -> Prog -> Prog
mergePrimSpecIntoModule trans (Prog name imps types funcs ops) =
  Prog name imps types (concatMap (mergePrimSpecIntoFunc trans) funcs) ops

mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl]
mergePrimSpecIntoFunc trans (Func name ar vis tp rule) =
 maybe [Func name ar vis tp rule]
       (\ (lib,entry) ->
          if null entry
            then []
            else [Func name ar vis tp (External (lib++' ':entry))])
       (lookup name trans)

readPrimSpec :: String -> String -> IO [(QName,QName)]
readPrimSpec mod xmlfilename = do
  existsXml <- doesFileExist xmlfilename
  if existsXml
    then do --putStrLn $ "Reading specification '" ++ xmlfilename ++ "'..."
            xmldoc <- readXmlFile xmlfilename
            return (xml2primtrans mod xmldoc)
    else return []

xml2primtrans :: String -> XmlExp -> [(QName,QName)]
xml2primtrans mod xe = case xe of
  XElem "primitives" [] primitives -> map xml2prim primitives
  _ -> error $ "FlatCurry.Compact.xml2primtrans: unexpected document:\n" ++
               showXmlDoc xe
 where
   xml2prim xelem = case xelem of
     XElem "primitive" (("name",fname):_) [XElem "entry" [] xfun] ->
       ((mod,fname), (mod, textOfXml xfun))
     XElem "primitive" (("name",fname):_) -- old format
           [XElem "library" [] xlib, XElem "entry" [] xfun] ->
       ((mod,fname), (textOfXml xlib,textOfXml xfun))
     XElem "ignore" (("name",fname):_) [] -> ((mod,fname), ("",""))
     _ -> error $ "FlatCurry.Compact.xml2prim: unexpected document\n" ++
                  showXmlDoc xelem

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