1 files changed, 75 insertions, 0 deletions
diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs
new file mode 100644
index 000000000..8b3a01793
--- /dev/null
+++ b/src/GF/Compile/MkResource.hs
@@ -0,0 +1,75 @@
+module MkResource where
+
+import Grammar
+import Ident
+import Modules
+import Macros
+import PrGrammar
+
+import Operations
+
+import Monad
+
+-- extracting resource r from abstract + concrete syntax
+-- AR 21/8/2002 -- 22/6/2003 for GF with modules
+
+makeReuse :: SourceGrammar -> Ident -> Maybe Ident -> Ident -> Err SourceRes
+makeReuse gr r me c = do
+  mc <- lookupModule gr c
+
+  flags <- return [] --- no flags are passed: they would not make sense
+
+  (ops,jms) <- 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 r a me (extends m) jmsA (jments m)
+      _ -> prtBad "expected concrete to be the type of" c
+    _ -> prtBad "expected concrete to be the type of" c
+
+  return $ Module MTResource flags me ops jms
+
+mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident -> 
+             BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
+             Err (BinTree (Ident,Info))
+mkResDefs r a mext maext abs cnc = mapMTree mkOne abs where
+
+  mkOne (f,info) = case info of
+      AbsCat _ _ -> do
+        typ <- err (const (return defLinType)) return $ look f
+        return (f, ResOper (Yes typeType) (Yes typ))
+      AbsFun (Yes typ0) _ -> do
+        trm <- look f
+        typ <- redirTyp typ0 --- if isHardType typ0 then compute typ0 else ...
+        return (f, ResOper (Yes typ) (Yes trm))
+      AnyInd b _ -> case mext of
+        Just ext -> return (f,AnyInd b ext)
+        _ -> prtBad "no indirection possible in" r
+
+  look f = do
+     info <- lookupTree prt f cnc
+     case info of
+       CncCat (Yes ty) _ _ -> return ty
+       CncCat _ _ _        -> return defLinType
+       CncFun _ (Yes tr) _ -> return tr
+       _ -> prtBad "not enough information to reuse" f
+
+  -- type constant qualifications changed from abstract to resource
+  redirTyp ty = case ty of
+    Q n c | n == a -> return $ Q r c
+    Q n c | Just n == maext -> case mext of
+      Just ext -> return $ Q ext c
+      _ -> prtBad "no indirection of type possible in" r
+    _ -> composOp redirTyp ty
+
+{-
+-- for nicer printing of type signatures: preserves synonyms if not HO/dep type
+
+isHardType t = case t of
+  Prod x a b -> not (isWildIdent x) || isHardType a || isHardType b
+  App _ _    -> True
+  _          -> False  
+-}