------------------------------------------------------------------------------
--- 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 August 2016
------------------------------------------------------------------------------

{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}

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

import FlatCurry.Types
import FlatCurry.Files
import SetRBT
import TableRBT
import Maybe
import List             (nub, union)
import FileGoodies
import FilePath         (takeFileName, (</>))
import Directory
import Sort             (cmpString, leqString)
import XML
import Distribution     (lookupModuleSourceInLoadPath, stripCurrySuffix)

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

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

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

--- (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
  done

--- 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 (emptyTableRBT leqQName)
                                      (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 insertRBT (emptySetRBT leqQName) initreqfuncs)
                    (emptySetRBT leqQName) (emptySetRBT leqQName)
                    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 `elemRBT` 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 :: SetRBT QName -> [TypeDecl] -> SetRBT QName
requiredDatatypes tcnames tdecls =
  let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls
   in if null newtcons
      then tcnames
      else requiredDatatypes (foldr insertRBT tcnames newtcons) tdecls

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

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

-- Extend function table (mapping from qualified names to function declarations)
-- by some new function declarations:
extendFuncTable :: TableRBT QName FuncDecl -> [FuncDecl]
                -> TableRBT QName FuncDecl
extendFuncTable ftable fdecls =
  foldr (\f t -> updateRBT (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],SetRBT String,[Prog])
requiredInCompactProg mainmod options
 | not (null initfuncs)
  = do impprogs <- mapIO readCurrentFlatCurry imports
       return (concat initfuncs, add2mainmodset imports, mainmod:impprogs)
 | Exports `elem` options
  = do impprogs <- mapIO 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 <- mapIO readCurrentFlatCurry imports
       return ([(mainmodname,func)], add2mainmodset imports, mainmod:impprogs)
     else error $ "CompactFlat: Cannot find main function \""++func++"\"!"
 | otherwise
  = do impprogs <- mapIO 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 = insertRBT mainmodname (emptySetRBT leqString)

   add2mainmodset mnames = foldr insertRBT 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] -> SetRBT String -> [Prog]
               -> TableRBT QName FuncDecl
               -> SetRBT QName -> SetRBT QName -> SetRBT QName
               -> [QName]
               -> IO ([Prog],[FuncDecl],SetRBT QName,SetRBT QName)
getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts)
getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames
               loadedtnames ((m,f):fs)
  | not (elemRBT m loadedmnames)
   = do newmod <- readCurrentFlatCurry m
        let reqnewfun = getRequiredInModule required m
        getCalledFuncs required (insertRBT m loadedmnames) (newmod:progs)
                       (extendFuncTable functable (moduleFuns newmod))
                       (foldr insertRBT loadedfnames reqnewfun) loadedcnames
                       loadedtnames ((m,f):fs ++ reqnewfun)
  | lookupRBT (m,f) functable == Nothing
   = -- 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 (lookupRBT (m,f) functable)
       funcCalls = allFuncCalls fdecl
       newFuncCalls = filter (\qn->not (elemRBT qn loadedfnames)) funcCalls
       newReqs = concatMap (getImplicitlyRequired required) newFuncCalls
       consCalls = allConstructorsOfFunc fdecl
       newConsCalls = filter (\qn->not (elemRBT qn loadedcnames)) consCalls
       newtcons = allTypesOfFunc fdecl
   (newprogs,newfuns,newcons, newtypes) <-
       getCalledFuncs required loadedmnames progs functable
                      (foldr insertRBT loadedfnames (newFuncCalls++newReqs))
                      (foldr insertRBT loadedcnames consCalls)
                      (foldr insertRBT 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)

unionMap :: (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 type name of a type declaration.
tconsName :: TypeDecl -> QName
tconsName (Type name _ _ _) = name
tconsName (TypeSyn 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 = cmpString m1 m2
                            in cm==LT || (cm==EQ && leqString 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 ++ ".prim_c2p")
  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) =
 let fname = lookup name trans in
 if fname==Nothing
 then [Func name ar vis tp rule]
 else let Just (lib,entry) = fname
       in if null entry
          then []
          else [Func name ar vis tp (External (lib++' ':entry))]


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 (XElem "primitives" [] primitives) = map xml2prim primitives
 where
   xml2prim (XElem "primitive" (("name",fname):_)
                   [XElem "library" [] xlib, XElem "entry" [] xfun]) =
       ((mod,fname),(textOfXml xlib,textOfXml xfun))
   xml2prim (XElem "ignore" (("name",fname):_) []) = ((mod,fname),("",""))


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