----------------------------------------------------------------------
-- |
-- Module      : MkResource
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 21:08:14 $ 
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.14 $
--
-- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
-----------------------------------------------------------------------------

module GF.Compile.MkResource (makeReuse) where

import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.Lockfield
import GF.Grammar.PrGrammar

import GF.Data.Operations

import Control.Monad

-- | extracting resource r from abstract + concrete syntax.
-- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules
makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] -> 
             MReuseType Ident -> Err SourceRes
makeReuse gr r me mrc = do
  flags <- return [] --- no flags are passed: they would not make sense
  case mrc of
    MRResource c -> do
      (ops,jms) <- mkFull True c
      return $ Module MTResource MSComplete flags me ops jms

    MRInstance c a -> do
      (ops,jms) <- mkFull False c
      return $ Module (MTInstance a) MSComplete flags me ops jms

    MRInterface c -> do
      mc <- lookupModule gr c

      (ops,jms) <- case mc of 
        ModMod m -> case mtype m of
          MTAbstract -> liftM ((,) (opens m)) $ 
                          mkResDefs True False gr r c me 
                            (extend m) (jments m) emptyBinTree
          _ -> prtBad "expected abstract to be the type of" c
        _ -> prtBad "expected abstract to be the type of" c

      return $ Module MTInterface MSIncomplete flags me ops jms

 where
    mkFull hasT c = do
      mc <- lookupModule gr c

      case mc of 
        ModMod m -> case mtype m of
          MTConcrete a -> do
            ma <- lookupModule gr a
            jmsA <- case ma of 
               ModMod m' -> return $ jments m'
               _ -> prtBad "expected abstract to be the type of" a
            liftM ((,) (opens m)) $ 
               mkResDefs hasT True gr r a me (extend m) jmsA (jments m)
          _ -> prtBad "expected concrete to be the type of" c
        _ -> prtBad "expected concrete to be the type of" c


-- | the first  Boolean indicates if the type needs be given
-- the second Boolean indicates if the definition needs be given
mkResDefs :: Bool -> Bool -> 
             SourceGrammar -> Ident -> Ident -> 
             [(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] -> 
             BinTree Ident Info -> BinTree Ident Info -> 
             Err (BinTree Ident Info)
mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where

  ifTyped  = yes --- if hasT then yes else const nope --- needed for TC
  ifCompl  = if isC  then yes else const nope
  doIf b t = if b then t else return typeType -- latter value not used

  mkOne a mae (f,info) = case info of
      AbsCat _ _ -> do
        typ  <- doIf isC $ err (const (return defLinType)) return $ look cnc f
        typ' <- doIf isC $ lockRecType f typ 
        return (f, ResOper (ifTyped typeType) (ifCompl typ'))
      AbsFun (Yes typ0) _ -> do
        trm <- doIf isC $ look cnc f
        testErr (not (isHardType typ0)) 
                ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0)
        typ <- redirTyp True a mae typ0
        cat <- valCat typ
        trm' <- doIf isC $ unlockRecord (snd cat) trm 
        return (f, ResOper (ifTyped typ) (ifCompl trm'))
      AnyInd b n -> do
        mo    <- lookupModMod gr n
        info' <- lookupInfo mo f
        mkOne n (extend mo) (f,info')

  look cnc f = do
     info <- lookupTree prt f cnc
     case info of
       CncCat (Yes ty) _ _ -> return ty
       CncCat _ _ _        -> return defLinType
       CncFun _ (Yes tr) _ -> return tr
       AnyInd _ n -> do 
         mo    <- lookupModMod gr n
         t <- look (jments mo) f
         redirTyp False n (extend mo) t
       _ -> prtBad "not enough information to reuse" f

  -- type constant qualifications changed from abstract to resource
  redirTyp always a mae ty = case ty of
    Q _ c | always -> return $ Q r c
    Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts
    _ -> composOp (redirTyp always a mae) ty

-- | no reuse for functions of HO\/dep types
isHardType t = case t of
  Prod x a b -> not (isWild x) || isHardType a || isHardType b
  App _ _    -> True
  _          -> False  
 where 
   isWild x = isWildIdent x || prt x == "h_" --- produced by transl from canon