forked from GitHub/gf-core
152 lines
5.1 KiB
Haskell
152 lines
5.1 KiB
Haskell
module LookAbs where
|
|
|
|
import Operations
|
|
import qualified GFC as C
|
|
import Abstract
|
|
import Ident
|
|
|
|
import Modules
|
|
|
|
import List (nub)
|
|
import Monad
|
|
|
|
type GFCGrammar = C.CanonGrammar
|
|
|
|
lookupAbsDef :: GFCGrammar -> Ident -> Ident -> Err (Maybe Term)
|
|
lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
|
|
mi <- lookupModule gr m
|
|
case mi of
|
|
ModMod mo -> do
|
|
info <- lookupInfo mo c
|
|
case info of
|
|
C.AbsFun _ t -> return $ return t
|
|
C.AnyInd _ n -> lookupAbsDef gr n c
|
|
_ -> return Nothing
|
|
_ -> Bad $ prt m +++ "is not an abstract module"
|
|
|
|
lookupFunType :: GFCGrammar -> Ident -> Ident -> Err Type
|
|
lookupFunType gr m c = errIn ("looking up funtype of" +++ prt c) $ do
|
|
mi <- lookupModule gr m
|
|
case mi of
|
|
ModMod mo -> do
|
|
info <- lookupInfo mo c
|
|
case info of
|
|
C.AbsFun t _ -> return t
|
|
C.AnyInd _ n -> lookupFunType gr n c
|
|
_ -> prtBad "cannot find type of" c
|
|
_ -> Bad $ prt m +++ "is not an abstract module"
|
|
|
|
lookupCatContext :: GFCGrammar -> Ident -> Ident -> Err Context
|
|
lookupCatContext gr m c = errIn ("looking up context of cat" +++ prt c) $ do
|
|
mi <- lookupModule gr m
|
|
case mi of
|
|
ModMod mo -> do
|
|
info <- lookupInfo mo c
|
|
case info of
|
|
C.AbsCat co _ -> return co
|
|
C.AnyInd _ n -> lookupCatContext gr n c
|
|
_ -> prtBad "unknown category" c
|
|
_ -> Bad $ prt m +++ "is not an abstract module"
|
|
|
|
-- lookup for transfer function: transfer-module-name, category name
|
|
|
|
lookupTransfer :: GFCGrammar -> Ident -> Ident -> Err Term
|
|
lookupTransfer gr m c = errIn ("looking up transfer of cat" +++ prt c) $ do
|
|
mi <- lookupModule gr m
|
|
case mi of
|
|
ModMod mo -> do
|
|
info <- lookupInfo mo c
|
|
case info of
|
|
C.AbsTrans t -> return t
|
|
C.AnyInd _ n -> lookupTransfer gr n c
|
|
_ -> prtBad "cannot transfer function for" c
|
|
_ -> Bad $ prt m +++ "is not a transfer module"
|
|
|
|
|
|
---- should be revised (20/9/2003)
|
|
isPrimitiveFun :: GFCGrammar -> Fun -> Bool
|
|
isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of
|
|
Ok (Just (Eqs [])) -> True -- is canonical
|
|
Ok (Just _) -> False -- has defining clauses
|
|
_ -> True -- has no definition
|
|
|
|
|
|
-- looking up refinement terms
|
|
|
|
lookupRef :: GFCGrammar -> Binds -> Term -> Err Val
|
|
lookupRef gr binds at = case at of
|
|
Q m f -> lookupFunType gr m f >>= return . vClos
|
|
Vr i -> maybeErr ("unknown variable" +++ prt at) $ lookup i binds
|
|
EInt _ -> return valAbsInt
|
|
K _ -> return valAbsString
|
|
_ -> prtBad "cannot refine with complex term" at ---
|
|
|
|
refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,Val)]
|
|
refsForType compat gr binds val =
|
|
-- bound variables
|
|
[(vr i, t) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
|
|
-- integer and string literals
|
|
[(EInt i, val) | val == valAbsInt, i <- [0,1,2,5,11,1978]] ++
|
|
[(K s, val) | val == valAbsString, s <- ["foo", "NN", "x"]] ++
|
|
-- functions defined in the current abstract syntax
|
|
[(qq f, vClos t) | (f,t) <- funsForType compat gr val]
|
|
|
|
|
|
funRulesOf :: GFCGrammar -> [(Fun,Type)]
|
|
funRulesOf gr =
|
|
---- funRulesForLiterals ++
|
|
[((i,f),typ) | (i, ModMod m) <- modules gr,
|
|
mtype m == MTAbstract,
|
|
(f, C.AbsFun typ _) <- tree2list (jments m)]
|
|
|
|
allCatsOf :: GFCGrammar -> [(Cat,Context)]
|
|
allCatsOf gr =
|
|
[((i,c),cont) | (i, ModMod m) <- modules gr,
|
|
isModAbs m,
|
|
(c, C.AbsCat cont _) <- tree2list (jments m)]
|
|
|
|
funsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [(Fun,Type)]
|
|
funsForType compat gr val = [(fun,typ) | (fun,typ) <- funRulesOf gr,
|
|
compat val typ]
|
|
|
|
funsOnType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [((Fun,Int),Type)]
|
|
funsOnType compat gr = funsOnTypeFs compat (funRulesOf gr)
|
|
|
|
funsOnTypeFs :: (Val -> Type -> Bool) -> [(Fun,Type)] -> Val -> [((Fun,Int),Type)]
|
|
funsOnTypeFs compat fs val = [((fun,i),typ) |
|
|
(fun,typ) <- fs,
|
|
Ok (args,_,_) <- [typeForm typ],
|
|
(i,arg) <- zip [0..] (map snd args),
|
|
compat val arg]
|
|
|
|
allDefs :: GFCGrammar -> [(Fun,Term)]
|
|
allDefs gr = [((i,c),d) | (i, ModMod m) <- modules gr,
|
|
isModAbs m,
|
|
(c, C.AbsFun _ d) <- tree2list (jments m)]
|
|
|
|
-- this is needed at compile time
|
|
|
|
lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type
|
|
lookupFunTypeSrc gr m c = do
|
|
mi <- lookupModule gr m
|
|
case mi of
|
|
ModMod mo -> do
|
|
info <- lookupInfo mo c
|
|
case info of
|
|
AbsFun (Yes t) _ -> return t
|
|
AnyInd _ n -> lookupFunTypeSrc gr n c
|
|
_ -> prtBad "cannot find type of" c
|
|
_ -> Bad $ prt m +++ "is not an abstract module"
|
|
|
|
lookupCatContextSrc :: Grammar -> Ident -> Ident -> Err Context
|
|
lookupCatContextSrc gr m c = do
|
|
mi <- lookupModule gr m
|
|
case mi of
|
|
ModMod mo -> do
|
|
info <- lookupInfo mo c
|
|
case info of
|
|
AbsCat (Yes co) _ -> return co
|
|
AnyInd _ n -> lookupCatContextSrc gr n c
|
|
_ -> prtBad "unknown category" c
|
|
_ -> Bad $ prt m +++ "is not an abstract module"
|