GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/Compile/MkResource.hs

@@ -0,0 +1,128 @@
+----------------------------------------------------------------------
+-- |
+-- 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