forked from GitHub/gf-core
76 lines
2.4 KiB
Haskell
76 lines
2.4 KiB
Haskell
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 MSComplete 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
|
|
-}
|