------------------------------------------------------------------------------
--- This module contains a simple compiler from FlatCurry to ICurry programs.
---
--- To do in future work:
--- * compile also imported modules depending on their date
--- * remove declarations/assignments of unused variables in ICurry code
---
--- @author Michael Hanus
--- @version July 2021
------------------------------------------------------------------------------

module ICurry.Compiler
  ( icCompile, flatCurry2ICurry, flatCurry2ICurryWithProgs
  , flatCurry2ICurryWithProgsAndOptions
  , ICOptions(..), defaultICOptions
  , printStatus, printIntermediate ) where

import Control.Monad         ( when )
import Data.List             ( elemIndex, find, maximum )

import FlatCurry.ElimNewtype ( elimNewtype )
import FlatCurry.Files       ( readFlatCurryWithParseOptions
                             , readFlatCurryIntWithParseOptions )
import FlatCurry.Goodies     ( allVars, consName, funcName, funcVisibility
                             , progFuncs, progImports, progName, progTypes )
import FlatCurry.Pretty      ( defaultOptions, ppProg )
import FlatCurry.Types
import Text.Pretty           ( pPrint )

import FlatCurry.CaseCompletion
import FlatCurry.CaseLifting ( defaultLiftOpts, defaultNoLiftOpts, liftProg )

import ICurry.Files   ( iCurryFileName, writeICurryFile )
import ICurry.Options
import ICurry.Pretty  ( ppIProg )
import ICurry.Types

test :: String -> IO ()
test p = do
  iprog <- icCompile defaultICOptions { optVerb = 3 } p
  writeICurryFile (iCurryFileName p) iprog
  putStrLn $ "ICurry program written to '" ++ iCurryFileName p ++ "'"

------------------------------------------------------------------------------
--- Generates an ICurry program by reading a FlatCurry program and
--- compiling it to ICurry.
icCompile :: ICOptions -> String -> IO IProg
icCompile opts p = do
  printStatus opts $ "Reading FlatCurry program '" ++ p ++ "'..."
  prog <- readFlatCurryWithParseOptions p (optFrontendParams opts)
  flatCurry2ICurry opts prog

--- Translates a FlatCurry program into an ICurry program.
--- It also reads the imported modules in order to access their
--- data and function declarations.
flatCurry2ICurry :: ICOptions -> Prog -> IO IProg
flatCurry2ICurry opts prog0 = flatCurry2ICurryWithProgs opts [] prog0

--- Translates a FlatCurry program into an ICurry program where
--- some FlatCurry interfaces are provided.
--- It also reads the interfaces of imported modules, if not already
--- provided, in order to access their data and function declarations.
flatCurry2ICurryWithProgs :: ICOptions -> [Prog] -> Prog -> IO IProg
flatCurry2ICurryWithProgs opts impprogs prog =
  flatCurry2ICurryWithProgsAndOptions opts impprogs prog >>= return . snd

--- Translates a FlatCurry program into an ICurry program where
--- some FlatCurry interfaces are provided.
--- It also reads the interfaces of imported modules, if not already
--- provided, in order to access their data and function declarations.
--- The `ICOptions` after processing the program (containing the
--- constructor and function maps required for the translation)
--- are also returned.
flatCurry2ICurryWithProgsAndOptions :: ICOptions -> [Prog] -> Prog
                                    -> IO (ICOptions,IProg)
flatCurry2ICurryWithProgsAndOptions opts progs prog0 = do
  let impmods = progImports prog0
  impprogs <- mapM getInterface impmods
  let prog      = elimNewtype impprogs prog0
      datadecls = concatMap dataDeclsOf (prog : impprogs)
      ccprog    = completeProg (CaseOptions datadecls) prog
      clprog    = if optLift opts
                    then liftProg defaultLiftOpts ccprog
                    else liftProg defaultNoLiftOpts ccprog
  printDetails opts $
    textWithLines "Transformed FlatCurry program to be compiled:" ++
    pPrint (ppProg FlatCurry.Pretty.defaultOptions clprog)
  let consmap   = map consMapOfProg (prog : impprogs)
      impfunmap = map publicFunMapOfProg impprogs
      pubfunmap = snd (publicFunMapOfProg prog)
      funmap    = (progName prog,
                   pubfunmap ++ privateFunMapOfProg clprog pubfunmap) :
                  impfunmap
  let cmpopts = setConsFuns opts consmap funmap
      icprog  = flat2icurry cmpopts clprog
  printIntermediate opts $
    textWithLines "Generated ICurry program:" ++
    pPrint (ppIProg icprog)
  printDetails opts (textWithLines "Generated ICurry file:" ++ showIProg icprog)
  return (cmpopts,icprog)
 where
  getInterface p =
    maybe (do printStatus opts $ "Read FlatCurry interface of '" ++ p ++ "'"
              readFlatCurryIntWithParseOptions p (optFrontendParams opts))
          return
          (find (\fp -> progName fp == p) progs)

  consMapOfProg fcy =
    (progName fcy,
     concatMap (\ (_,cars) -> map (\ ((cname,car),pos) -> (cname,(car,pos)))
                                  (zip cars [0..]))
               (dataDeclsOf fcy))

  -- compute mapping of public function names to indices
  publicFunMapOfProg fcprog =
    (progName fcprog,
     zip (map funcName
              (filter (\f -> funcVisibility f == FlatCurry.Types.Public)
                      (progFuncs fcprog)))
         [0..])

  privateFunMapOfProg fcprog pubfunmap =
    zip (filter (\fn -> fn `notElem` map fst pubfunmap)
                (map funcName (progFuncs fcprog)))
        [(length pubfunmap) ..]

  textWithLines s = unlines [l, s, l]
   where l = take 78 (repeat '-')

------------------------------------------------------------------------------
--- Translation from FlatCurry to ICurry according to the transformation
--- specified in the ICurry paper.
flat2icurry :: ICOptions -> Prog -> IProg
flat2icurry opts (Prog modname imps types funs _) =
  IProg modname imps
        (concatMap trTypeDecl (zip [0..] types))
        (map (trFunc opts) funs)
 where
  trTypeDecl (_,  TypeSyn _ _ _ _)   = []
  trTypeDecl (_,  TypeNew _ _ _ _)   =
    error $ "ICurry.Compiler: newtype occurred!" -- should not occur...
  trTypeDecl (ti, Type (mn,tn) _ _ cdecl) =
    [IDataType (mn,tn,ti)
               (map (\ (i, Cons (cmn,cn) ar _ _) -> ((cmn,cn,i),ar))
                    (zip [0..] cdecl))]

trVis :: Visibility -> IVisibility
trVis FlatCurry.Types.Public  = ICurry.Types.Public
trVis FlatCurry.Types.Private = ICurry.Types.Private

trFunc :: ICOptions -> FuncDecl -> IFunction
trFunc opts (Func qn@(mn,fn) ar vis _ rule) =
  IFunction (mn, fn, posOfFun opts qn) ar (trVis vis) (demandOf rule)
            (trRule optsf rule)
 where
  optsf = opts { optFun = qn }

-- Computes (approximates) the arguments demanded by a rule.
demandOf :: Rule -> [Int]
demandOf (External _)    = [] -- TODO
demandOf (Rule args rhs) = case rhs of
  Case _ (Var v) _ -> maybe [] (: []) (elemIndex v args)
  _                -> []

trRule :: ICOptions -> Rule -> IFuncBody
trRule _    (External s)    = IExternal s
trRule opts (Rule args rhs) = IFuncBody (toIBlock opts args rhs 0)

toIBlock :: ICOptions -> [VarIndex] -> Expr -> Int -> IBlock
toIBlock opts vs e root =
  IBlock (if optVarDecls opts
            then varDecls
            else map IVarDecl (filter (`elem` evars) vs) ++ varDecls)
         (map (\ (p,i) -> IVarAssign i (IVarAccess root [p]))
              (filter ((`elem` evars) . snd) (zip [0..] vs)) ++
          fst varAssigns ++ map fst (snd varAssigns))
         (case e of
            Case _ ce brs@(Branch (Pattern _ _) _ : _) ->
              let carg = trCaseArg ce
              in ICaseCons carg (map (trPBranch carg) brs)
            Case _ ce brs@(Branch (LPattern _ ) _ : _) ->
              let carg = trCaseArg ce
              in ICaseLit carg (map (trLBranch carg) brs)
            Comb FuncCall fn [] | fn == pre "failed" -> IExempt
            _ -> IReturn (toIExpr opts e))
 where
  evars = allVars e

  varDecls = case e of
    Free fvs _       -> map IFreeDecl fvs
    Let bs   _       -> if optVarDecls opts
                          then map IVarDecl
                                   (filter (`elem` cyclicVars) (map fst bs))
                          else map (IVarDecl . fst) bs
    Case _ (Var _) _ -> []
    Case _ _       _ -> if optVarDecls opts then [] else [IVarDecl caseVar]
    _                -> []

  -- fresh variable to translate complex case arguments:
  caseVar = maximum (0 : evars) + 1

  -- the assignments for this block: a pair of direct assignments
  -- and subsequent assignments required for recursive lets
  -- (where the cyclic variables is returned)
  varAssigns = case e of
    Let bs _ ->
      let assigns = map (\ (v,b) -> (v, toIExpr opts b)) bs
      in (map (\ (v,be) -> IVarAssign v be) assigns,
          -- add assignments of recursive occurrences:
          recursiveAssigns assigns)
    Case _ (Var _) _ -> ([], [])
    Case _ ce      _ -> ([IVarAssign caseVar (toIExpr opts ce)], [])
    _                -> ([], [])
   where
    recursiveAssigns [] = []
    recursiveAssigns (ve:ves) =
      let vps = varPos [] (snd ve)
      in map (\ (v,p) -> (INodeAssign (fst ve) p (IVar v), v))
             (filter (\vp -> fst vp `elem` map fst (ve:ves)) vps) ++
         recursiveAssigns ves

  -- variables used to implement cyclic data structures
  cyclicVars = map snd (snd varAssigns)

  trCaseArg ce = case ce of
                   Var v -> v
                   _     -> caseVar

  trPBranch carg (Branch (Pattern qn@(mn,cn) pvs) be) =
    let (ar,pos) = arityPosOfCons opts qn
    in IConsBranch (mn, cn, pos) ar (toIBlock opts pvs be carg)
  trPBranch _ (Branch (LPattern _) _) = funError opts "trPBranch with LPattern"

  trLBranch carg (Branch (LPattern lit) be) =
    ILitBranch (trLit lit) (toIBlock opts [] be carg)
  trLBranch _ (Branch (Pattern _ _) _) = funError opts "trLBranch with Pattern"

toIExpr :: ICOptions -> Expr -> IExpr
toIExpr _ (Var v) = IVar v
toIExpr _ (Lit l) = ILit (trLit l)
toIExpr opts (Comb ct qn@(mn,fn) es)
 | qn == pre "?" && length es == 2
 = toIExpr opts (Or (es!!0) (es!!1))
 | otherwise
 = let icall = case ct of
                 FuncCall       -> IFCall  (mn, fn, posOfFun opts qn)
                 ConsCall       -> ICCall  (mn, fn, posOfCons opts qn)
                 FuncPartCall m -> IFPCall (mn, fn, posOfFun opts qn) m
                 ConsPartCall m -> ICPCall (mn, fn, posOfCons opts qn) m
   in icall (map (toIExpr opts) es)
toIExpr opts (Or e1 e2)   = IOr (toIExpr opts e1) (toIExpr opts e2)
toIExpr opts (Typed e _)  = toIExpr opts e
toIExpr opts (Let _ e)    = toIExpr opts e
toIExpr opts (Free _ e)   = toIExpr opts e
toIExpr opts (Case _ _ _) = funError opts "toIExpr: Case occurred"

trLit :: Literal -> ILiteral
trLit (Intc i)   = IInt i
trLit (Floatc f) = IFloat f
trLit (Charc c)  = IChar c

-- Extracts the variables and their positions occurring in an ICurry expression
varPos :: [Int] -> IExpr -> [(IVarIndex,[Int])]
varPos rpos (IVar v)            = [(v,rpos)]
varPos _    (IVarAccess _ _)    = []
varPos _    (ILit _)            = []
varPos rpos (IFCall _ args)     = concatMap (\ (i,e) -> varPos (rpos ++ [i]) e)
                                            (zip [0..] args)
varPos rpos (ICCall qn args)    = varPos rpos (IFCall qn args)
varPos rpos (IFPCall qn _ args) = varPos rpos (IFCall qn args)
varPos rpos (ICPCall qn _ args) = varPos rpos (IFCall qn args)
varPos rpos (IOr e1 e2) = varPos (rpos ++ [0]) e1 ++ varPos (rpos ++ [1]) e2

------------------------------------------------------------------------------
--- Simple show for ICurry programs.
showIProg :: IProg -> String
showIProg (IProg mn imps types funs) = unlines $
  unwords ["IProg", mn, show imps, show types] :
  "[" : map show funs ++ ["]"]

------------------------------------------------------------------------------
-- Auxiliaries:

pre :: String -> QName
pre s = ("Prelude", s)

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