------------------------------------------------------------------------------
--- 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 December 2018
------------------------------------------------------------------------------

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

import Char         ( isAlpha )
import Directory    ( doesFileExist, getModificationTime )
import FilePath     ( takeFileName, (</>) )
import List         ( intercalate )
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
import System.CurryPath  ( stripCurrySuffix, modNameToPath
                         , lookupModuleSourceInLoadPath )
import Text.Pretty       ( pPrint )


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)

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