module MkExternalCore (
        emitExternalCore
) where

#include "HsVersions.h"

import qualified ExternalCore as C
import Module
import CoreSyn
import HscTypes
import TyCon
import CoAxiom
-- import Class
import TypeRep
import Type
import Kind
import PprExternalCore () -- Instances
import DataCon
import Coercion
import Var
import IdInfo
import Literal
import Name
import Outputable
import Encoding
import ForeignCall
import DynFlags
import FastString
import Exception

import Control.Applicative (Applicative(..))
import Control.Monad
import qualified Data.ByteString as BS
import Data.Char
import System.IO

emitExternalCore :: DynFlags -> FilePath -> CgGuts -> IO ()
emitExternalCore dflags extCore_filename cg_guts
 | gopt Opt_EmitExternalCore dflags
 = (do handle <- openFile extCore_filename WriteMode
       hPutStrLn handle (show (mkExternalCore dflags cg_guts))
       hClose handle)
   `catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
                             (text extCore_filename))
emitExternalCore _ _ _
 | otherwise
 = return ()

-- Reinventing the Reader monad; whee.
newtype CoreM a = CoreM (CoreState -> (CoreState, a))
data CoreState = CoreState {
                     cs_dflags :: DynFlags,
                     cs_module :: Module
                 }

instance Functor CoreM where
    fmap = liftM

instance Applicative CoreM where
    pure = return
    (<*>) = ap

instance Monad CoreM where
  (CoreM m) >>= f = CoreM (\ s -> case m s of
                                    (s',r) -> case f r of
                                                CoreM f' -> f' s')
  return x = CoreM (\ s -> (s, x))
runCoreM :: CoreM a -> CoreState -> a
runCoreM (CoreM f) s = snd $ f s
ask :: CoreM CoreState
ask = CoreM (\ s -> (s,s))

instance HasDynFlags CoreM where
    getDynFlags = liftM cs_dflags ask

mkExternalCore :: DynFlags -> CgGuts -> C.Module
-- The ModGuts has been tidied, but the implicit bindings have
-- not been injected, so we have to add them manually here
-- We don't include the strange data-con *workers* because they are
-- implicit in the data type declaration itself
mkExternalCore dflags (CgGuts {cg_module=this_mod, cg_tycons = tycons,
                               cg_binds = binds})
{- Note that modules can be mutually recursive, but even so, we
   print out dependency information within each module. -}
  = C.Module (mname dflags) tdefs (runCoreM (mapM (make_vdef True) binds) initialState)
  where
    initialState = CoreState {
                       cs_dflags = dflags,
                       cs_module = this_mod
                   }
    mname dflags = make_mid dflags this_mod
    tdefs  = foldr (collect_tdefs dflags) [] tycons

collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs dflags tcon tdefs
  | isAlgTyCon tcon = tdef: tdefs
  where
    tdef | isNewTyCon tcon =
                C.Newtype (qtc dflags tcon)
                  (qcc dflags (newTyConCo tcon))
                  (map make_tbind tyvars)
                  (make_ty dflags (snd (newTyConRhs tcon)))
         | otherwise =
                C.Data (qtc dflags tcon) (map make_tbind tyvars)
                   (map (make_cdef dflags) (tyConDataCons tcon))
    tyvars = tyConTyVars tcon

collect_tdefs _ _ tdefs = tdefs

qtc :: DynFlags -> TyCon -> C.Qual C.Tcon
qtc dflags = make_con_qid dflags . tyConName

qcc :: DynFlags -> CoAxiom br -> C.Qual C.Tcon
qcc dflags = make_con_qid dflags . co_ax_name

make_cdef :: DynFlags -> DataCon -> C.Cdef
make_cdef dflags dcon =  C.Constr dcon_name existentials tys
  where
    dcon_name    = make_qid dflags False False (dataConName dcon)
    existentials = map make_tbind ex_tyvars
    ex_tyvars    = dataConExTyVars dcon
    tys          = map (make_ty dflags) (dataConRepArgTys dcon)

make_tbind :: TyVar -> C.Tbind
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))

make_vbind :: DynFlags -> Var -> C.Vbind
make_vbind dflags v = (make_var_id  (Var.varName v), make_ty dflags (varType v))

make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
make_vdef topLevel b =
  case b of
    NonRec v e -> f (v,e)     >>= (return . C.Nonrec)
    Rec ves    -> mapM f ves  >>= (return . C.Rec)
  where
  f :: (CoreBndr,CoreExpr) -> CoreM C.Vdef
  f (v,e) = do
          localN <- isALocal vName
          let local = not topLevel || localN
          rhs <- make_exp e
          -- use local flag to determine where to add the module name
          dflags <- getDynFlags
          return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs)
        where vName = Var.varName v

make_exp :: CoreExpr -> CoreM C.Exp
make_exp (Var v) = do
  let vName = Var.varName v
  isLocal <- isALocal vName
  dflags <- getDynFlags
  return $
     case idDetails v of
       FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _))
           -> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v))
       FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
           panic "make_exp: FFI values not supported"
       FCallId (CCall (CCallSpec DynamicTarget     callconv _))
           -> C.DynExternal            (showPpr dflags callconv) (make_ty dflags (varType v))
       -- Constructors are always exported, so make sure to declare them
       -- with qualified names
       DataConWorkId _ -> C.Var (make_var_qid dflags False vName)
       DataConWrapId _ -> C.Var (make_var_qid dflags False vName)
       _ -> C.Var (make_var_qid dflags isLocal vName)
make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
make_exp (Lit l) = do dflags <- getDynFlags
                      return $ C.Lit (make_lit dflags l)
make_exp (App e (Type t)) = do b <- make_exp e
                               dflags <- getDynFlags
                               return $ C.Appt b (make_ty dflags t)
make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))"    -- TODO
make_exp (App e1 e2) = do
   rator <- make_exp e1
   rand <- make_exp e2
   return $ C.App rator rand
make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
                                    return $ C.Lam (C.Tb (make_tbind v)) b)
make_exp (Lam v e) | otherwise = do b <- make_exp e
                                    dflags <- getDynFlags
                                    return $ C.Lam (C.Vb (make_vbind dflags v)) b
make_exp (Cast e co) = do b <- make_exp e
                          dflags <- getDynFlags
                          return $ C.Cast b (make_co dflags co)
make_exp (Let b e) = do
  vd   <- make_vdef False b
  body <- make_exp e
  return $ C.Let vd body
make_exp (Case e v ty alts) = do
  scrut <- make_exp e
  newAlts  <- mapM make_alt alts
  dflags <- getDynFlags
  return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts
make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary
make_exp _ = error "MkExternalCore died: make_exp"

make_alt :: CoreAlt -> CoreM C.Alt
make_alt (DataAlt dcon, vs, e) = do
    newE <- make_exp e
    dflags <- getDynFlags
    return $ C.Acon (make_con_qid dflags (dataConName dcon))
           (map make_tbind tbs)
           (map (make_vbind dflags) vbs)
           newE
        where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e)   = do x <- make_exp e
                               dflags <- getDynFlags
                               return $ C.Alit (make_lit dflags l) x
make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
-- This should never happen, as the DEFAULT alternative binds no variables,
-- but we might as well check for it:
make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
             ++ "alternative had a non-empty var list") (ppr a)


make_lit :: DynFlags -> Literal -> C.Lit
make_lit dflags l =
  case l of
    -- Note that we need to check whether the character is "big".
    -- External Core only allows character literals up to '\xff'.
    MachChar i | i <= chr 0xff -> C.Lchar i t
    -- For a character bigger than 0xff, we represent it in ext-core
    -- as an int lit with a char type.
    MachChar i             -> C.Lint (fromIntegral $ ord i) t
    MachStr s -> C.Lstring (BS.unpack s) t
    MachNullAddr -> C.Lint 0 t
    MachInt i -> C.Lint i t
    MachInt64 i -> C.Lint i t
    MachWord i -> C.Lint i t
    MachWord64 i -> C.Lint i t
    MachFloat r -> C.Lrational r t
    MachDouble r -> C.Lrational r t
    LitInteger i _ -> C.Lint i t
    _ -> pprPanic "MkExternalCore died: make_lit" (ppr l)
  where
    t = make_ty dflags (literalType l)

-- Expand type synonyms, then convert.
make_ty :: DynFlags -> Type -> C.Ty     -- Be sure to expand types recursively!
                                        -- example: FilePath ~> String ~> [Char]
make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded
make_ty dflags t = make_ty' dflags t

-- note calls to make_ty so as to expand types recursively
make_ty' :: DynFlags -> Type -> C.Ty
make_ty' _      (TyVarTy tv)     = C.Tvar (make_var_id (tyVarName tv))
make_ty' dflags (AppTy t1 t2)     = C.Tapp (make_ty dflags t1) (make_ty dflags t2)
make_ty' dflags (FunTy t1 t2)     = make_ty dflags (TyConApp funTyCon [t1,t2])
make_ty' dflags (ForAllTy tv t)  = C.Tforall (make_tbind tv) (make_ty dflags t)
make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts
make_ty' _      (LitTy {})       = panic "MkExernalCore can't do literal types yet"

-- Newtypes are treated just like any other type constructor; not expanded
-- Reason: predTypeRep does substitution and, while substitution deals
--         correctly with name capture, it's only correct if you see the uniques!
--         If you just see occurrence names, name capture may occur.
-- Example: newtype A a = A (forall b. b -> a)
--          test :: forall q b. q -> A b
--          test _ = undefined
--      Here the 'a' gets substituted by 'b', which is captured.
-- Another solution would be to expand newtypes before tidying; but that would
-- expose the representation in interface files, which definitely isn't right.
-- Maybe CoreTidy should know whether to expand newtypes or not?

make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty
make_tyConApp dflags tc ts =
  foldl C.Tapp (C.Tcon (qtc dflags tc))
            (map (make_ty dflags) ts)

make_kind :: Kind -> C.Kind
make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
make_kind k
  | isLiftedTypeKind k   = C.Klifted
  | isUnliftedTypeKind k = C.Kunlifted
  | isOpenTypeKind k     = C.Kopen
make_kind _ = error "MkExternalCore died: make_kind"

{- Id generation. -}

make_id :: Bool -> Name -> C.Id
-- include uniques for internal names in order to avoid name shadowing
make_id _is_var nm = ((occNameString . nameOccName) nm)
  ++ (if isInternalName nm then (show . nameUnique) nm else "")

make_var_id :: Name -> C.Id
make_var_id = make_id True

-- It's important to encode the module name here, because in External Core,
-- base:GHC.Base => base:GHCziBase
-- We don't do this in pprExternalCore because we
-- *do* want to keep the package name (we don't want baseZCGHCziBase,
-- because that would just be ugly.)
-- SIGH.
-- We encode the package name as well.
make_mid :: DynFlags -> Module -> C.Id
-- Super ugly code, but I can't find anything else that does quite what I
-- want (encodes the hierarchical module name without encoding the colon
-- that separates the package name from it.)
make_mid dflags m
            = showSDoc dflags $
              (text $ zEncodeString $ packageIdString $ modulePackageId m)
              <> text ":"
              <> (pprEncoded $ pprModuleName $ moduleName m)
     where pprEncoded = pprCode CStyle

make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id
make_qid dflags force_unqual is_var n = (mname,make_id is_var n)
    where mname =
           case nameModule_maybe n of
            Just m | not force_unqual -> make_mid dflags m
            _ -> ""

make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id
make_var_qid dflags force_unqual = make_qid dflags force_unqual True

make_con_qid :: DynFlags -> Name -> C.Qual C.Id
make_con_qid dflags = make_qid dflags False False

make_co :: DynFlags -> Coercion -> C.Coercion
make_co dflags (Refl r ty)           = C.ReflCoercion (make_role r) $ make_ty dflags ty
make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos)
make_co dflags (AppCo c1 c2)         = C.AppCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (ForAllCo tv co)      = C.ForAllCoercion (make_tbind tv) (make_co dflags co)
make_co _      (CoVarCo cv)          = C.CoVarCoercion (make_var_id (coVarName cv))
make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos)
make_co dflags (UnivCo r t1 t2)      = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2)
make_co dflags (SymCo co)            = C.SymCoercion (make_co dflags co)
make_co dflags (TransCo c1 c2)       = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (NthCo d co)          = C.NthCoercion d (make_co dflags co)
make_co dflags (LRCo lr co)          = C.LRCoercion (make_lr lr) (make_co dflags co)
make_co dflags (InstCo co ty)        = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
make_co dflags (SubCo co)            = C.SubCoercion (make_co dflags co)
make_co _ (AxiomRuleCo {})           = panic "make_co AxiomRuleCo: not yet implemented"


make_lr :: LeftOrRight -> C.LeftOrRight
make_lr CLeft  = C.CLeft
make_lr CRight = C.CRight

make_role :: Role -> C.Role
make_role Nominal          = C.Nominal
make_role Representational = C.Representational
make_role Phantom          = C.Phantom

-------
isALocal :: Name -> CoreM Bool
isALocal vName = do
  modName <- liftM cs_module ask
  return $ case nameModule_maybe vName of
             -- Not sure whether isInternalName corresponds to "local"ness
             -- in the External Core sense; need to re-read the spec.
             Just m | m == modName -> isInternalName vName
             _                     -> False