msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

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

Browse Source
This commit is contained in:
aarne
2008-05-21 09:26:44 +00:00
parent 915a1de717
commit 055c0d0d5a
536 changed files with 0 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

166
src-3.0/GF/Devel/Grammar/AppPredefined.hs Normal file
View File

@@ -0,0 +1,166 @@
----------------------------------------------------------------------
-- |
-- Module : AppPredefined
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/06 14:21:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- Predefined function type signatures and definitions.
-----------------------------------------------------------------------------
module GF.Devel.Grammar.AppPredefined (
isInPredefined,
typPredefined,
appPredefined
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF (prt,prt_,prtBad)
import GF.Infra.Ident
import GF.Data.Operations
-- predefined function type signatures and definitions. AR 12/3/2003.
isInPredefined :: Ident -> Bool
isInPredefined = err (const True) (const False) . typPredefined
typPredefined :: Ident -> Err Type
typPredefined c@(IC f) = case f of
"Int" -> return typePType
"Float" -> return typePType
"Error" -> return typeType
"Ints" -> return $ mkFunType [cnPredef "Int"] typePType
"PBool" -> return typePType
"error" -> return $ mkFunType [typeStr] (cnPredef "Error") -- non-can. of empty set
"PFalse" -> return $ cnPredef "PBool"
"PTrue" -> return $ cnPredef "PBool"
"dp" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
"drop" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
"eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
"lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
"eqStr" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
"length" -> return $ mkFunType [typeStr] (cnPredef "Int")
"occur" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
"occurs" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
"plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
---- "read" -> (P : Type) -> Tok -> P
"show" -> return $ mkProds -- (P : PType) -> P -> Tok
([(identC "P",typePType),(wildIdent,Vr (identC "P"))],typeStr,[])
"toStr" -> return $ mkProds -- (L : Type) -> L -> Str
([(identC "L",typeType),(wildIdent,Vr (identC "L"))],typeStr,[])
"mapStr" ->
let ty = identC "L" in
return $ mkProds -- (L : Type) -> (Str -> Str) -> L -> L
([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[])
"take" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
"tk" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
_ -> prtBad "unknown in Predef:" c
typPredefined c = prtBad "unknown in Predef:" c
mkProds (cont,t,xx) = foldr (uncurry Prod) (mkApp t xx) cont
appPredefined :: Term -> Err (Term,Bool)
appPredefined t = case t of
App f x0 -> do
(x,_) <- appPredefined x0
case f of
-- one-place functions
Q (IC "Predef") (IC f) -> case (f, x) of
("length", K s) -> retb $ EInt $ toInteger $ length s
_ -> retb t ---- prtBad "cannot compute predefined" t
-- two-place functions
App (Q (IC "Predef") (IC f)) z0 -> do
(z,_) <- appPredefined z0
case (f, norm z, norm x) of
("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
("take", EInt i, K s) -> retb $ K (take (fi i) s)
("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse
("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse
("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse
("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse
("plus", EInt i, EInt j) -> retb $ EInt $ i+j
("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t
("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags
("toStr", _, t) -> trm2str t >>= retb
_ -> retb t ---- prtBad "cannot compute predefined" t
-- three-place functions
App (App (Q (IC "Predef") (IC f)) z0) y0 -> do
(y,_) <- appPredefined y0
(z,_) <- appPredefined z0
case (f, z, y, x) of
("mapStr",ty,op,t) -> retf $ mapStr ty op t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t
---- should really check the absence of arg variables
where
retb t = return (t,True) -- no further computing needed
retf t = return (t,False) -- must be computed further
norm t = case t of
Empty -> K []
_ -> t
fi = fromInteger
-- read makes variables into constants
str2tag :: String -> Term
str2tag s = case s of
---- '\'' : cs -> mkCn $ pTrm $ init cs
_ -> Con $ IC s ---
where
mkCn t = case t of
Vr i -> Con i
App c a -> App (mkCn c) (mkCn a)
_ -> t
predefTrue = Q (IC "Predef") (IC "PTrue")
predefFalse = Q (IC "Predef") (IC "PFalse")
substring :: String -> String -> Bool
substring s t = case (s,t) of
(c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
([],_) -> True
_ -> False
trm2str :: Term -> Err Term
trm2str t = case t of
R ((_,(_,s)):_) -> trm2str s
T _ ((_,s):_) -> trm2str s
V _ (s:_) -> trm2str s
C _ _ -> return $ t
K _ -> return $ t
S c _ -> trm2str c
Empty -> return $ t
_ -> prtBad "cannot get Str from term" t
-- simultaneous recursion on type and term: type arg is essential!
-- But simplify the task by assuming records are type-annotated
-- (this has been done in type checking)
mapStr :: Type -> Term -> Term -> Term
mapStr ty f t = case (ty,t) of
_ | elem ty [typeStr,typeStr] -> App f t
(_, R ts) -> R [(l,mapField v) | (l,v) <- ts]
(Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
_ -> t
where
mapField (mty,te) = case mty of
Just ty -> (mty,mapStr ty f te)
_ -> (mty,te)

380
src-3.0/GF/Devel/Grammar/Compute.hs Normal file
View File

@@ -0,0 +1,380 @@
----------------------------------------------------------------------
-- |
-- Module : Compute
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/01 15:39:12 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
-- Computation of source terms. Used in compilation and in @cc@ command.
-----------------------------------------------------------------------------
module GF.Devel.Grammar.Compute (
computeTerm,
computeTermCont,
computeTermRec
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Lookup
import GF.Devel.Grammar.PrGF
import GF.Devel.Grammar.PatternMatch
import GF.Devel.Grammar.AppPredefined
import GF.Infra.Ident
import GF.Infra.Option
--import GF.Grammar.Refresh
--import GF.Grammar.Lockfield (isLockLabel) ----
import GF.Data.Str ----
import GF.Data.Operations
import Data.List (nub,intersperse)
import Control.Monad (liftM2, liftM)
-- | computation of concrete syntax terms into normal form
-- used mainly for partial evaluation
computeTerm :: GF -> Term -> Err Term
computeTerm g t = {- refreshTerm t >>= -} computeTermCont g [] t
computeTermRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t
computeTermCont :: GF -> Substitution -> Term -> Err Term
computeTermCont = computeTermOpt False
-- rec=True is used if it cannot be assumed that looked-up constants
-- have already been computed (mainly with -optimize=noexpand in .gfr)
computeTermOpt :: Bool -> GF -> Substitution -> Term -> Err Term
computeTermOpt rec gr = comp where
comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
case t of
Q (IC "Predef") _ -> return t
Q p c -> look p c
-- if computed do nothing
---- Computed t' -> return $ unComputed t'
Vr x -> do
t' <- maybe (prtBad ("no value for variable") x) return $ lookup x g
case t' of
_ | t == t' -> return t
_ -> comp g t'
Abs x b -> do
b' <- comp (ext x (Vr x) g) b
return $ Abs x b'
Let (x,(_,a)) b -> do
a' <- comp g a
comp (ext x a' g) b
Prod x a b -> do
a' <- comp g a
b' <- comp (ext x (Vr x) g) b
return $ Prod x a' b'
-- beta-convert
App f a -> do
f' <- comp g f
a' <- comp g a
case (f',a') of
(Abs x b, FV as) ->
mapM (\c -> comp (ext x c g) b) as >>= return . variants
(_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants
(FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
(Abs x b,_) -> comp (ext x a' g) b
(QC _ _,_) -> returnC $ App f' a'
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e
(S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
_ -> do
(t',b) <- appPredefined (App f' a')
if b then return t' else comp g t'
P t l -> do
t' <- comp g t
case t' of
FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
R r -> maybe (prtBad "no value for label" l) (comp g . snd) $
lookup l $ reverse r
ExtR a (R b) ->
case comp g (P (R b) l) of
Ok v -> return v
_ -> comp g (P a l)
--- { - --- this is incorrect, since b can contain the proper value
ExtR (R a) b -> -- NOT POSSIBLE both a and b records!
case comp g (P (R a) l) of
Ok v -> return v
_ -> comp g (P b l)
--- - } ---
S (T i cs) e -> prawitz g i (flip P l) cs e
S (V i cs) e -> prawitzV g i (flip P l) cs e
_ -> returnC $ P t' l
PI t l i -> comp g $ P t l -----
S t@(T ti cc) v -> do
v' <- comp g v
case v' of
FV vs -> do
ts' <- mapM (comp g . S t) vs
return $ variants ts'
_ -> case ti of
{-
TComp _ -> do
case term2patt v' of
Ok p' -> case lookup p' cc of
Just u -> comp g u
_ -> do
t' <- comp g t
return $ S t' v' -- if v' is not canonical
_ -> do
t' <- comp g t
return $ S t' v'
-}
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
_ -> do
t' <- comp g t
return $ S t' v' -- if v' is not canonical
S t v -> do
t' <- case t of
---- why not? ResFin.Agr "has no values"
---- T (TComp _) _ -> return t
---- V _ _ -> return t
_ -> comp g t
v' <- comp g v
case v' of
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
_ -> case t' of
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
T _ [(PV IW,c)] -> comp g c --- an optimization
T _ [(PT _ (PV IW),c)] -> comp g c
T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
-- course-of-values table: look up by index, no pattern matching needed
V ptyp ts -> do
vs <- allParamValues gr ptyp
case lookup v' (zip vs [0 .. length vs - 1]) of
Just i -> comp g $ ts !! i
----- _ -> prtBad "selection" $ S t' v' -- debug
_ -> return $ S t' v' -- if v' is not canonical
T (TComp _) cs -> do
case term2patt v' of
Ok p' -> case lookup p' cs of
Just u -> comp g u
_ -> return $ S t' v' -- if v' is not canonical
_ -> return $ S t' v'
T _ cc -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
_ -> return $ S t' v' -- if v' is not canonical
S (T i cs) e -> prawitz g i (flip S v') cs e
S (V i cs) e -> prawitzV g i (flip S v') cs e
_ -> returnC $ S t' v'
-- normalize away empty tokens
K "" -> return Empty
-- glue if you can
Glue x0 y0 -> do
x <- comp g x0
y <- comp g y0
case (x,y) of
(FV ks,_) -> do
kys <- mapM (comp g . flip Glue y) ks
return $ variants kys
(_,FV ks) -> do
xks <- mapM (comp g . Glue x) ks
return $ variants xks
(S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
(s, S (T i cs) e) -> prawitz g i (Glue s) cs e
(S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e
(s, S (V i cs) e) -> prawitzV g i (Glue s) cs e
(_,Empty) -> return x
(Empty,_) -> return y
(K a, K b) -> return $ K (a ++ b)
(_, Alts (d,vs)) -> do
---- (K a, Alts (d,vs)) -> do
let glx = Glue x
comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
(Alts _, ka) -> checks [do
y' <- strsFromTerm ka
---- (Alts _, K a) -> checks [do
x' <- strsFromTerm x -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
,return $ Glue x y
]
(C u v,_) -> comp g $ C u (Glue v y)
_ -> do
mapM_ checkNoArgVars [x,y]
r <- composOp (comp g) t
returnC r
Alts _ -> do
r <- composOp (comp g) t
returnC r
-- remove empty
C a b -> do
a' <- comp g a
b' <- comp g b
case (a',b') of
(Alts _, K a) -> checks [do
as <- strsFromTerm a' -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
,
return $ C a' b'
]
(Empty,_) -> returnC b'
(_,Empty) -> returnC a'
_ -> returnC $ C a' b'
-- reduce free variation as much as you can
FV ts -> mapM (comp g) ts >>= returnC . variants
-- merge record extensions if you can
ExtR r s -> do
r' <- comp g r
s' <- comp g s
case (r',s') of
(R rs, R ss) -> plusRecord r' s'
(RecType rs, RecType ss) -> plusRecType r' s'
_ -> return $ ExtR r' s'
-- case-expand tables
-- if already expanded, don't expand again
T i@(TComp ty) cs -> do
-- if there are no variables, don't even go inside
cs' <- if (null g) then return cs else mapPairsM (comp g) cs
---- return $ V ty (map snd cs')
return $ T i cs'
T i cs -> do
pty0 <- errIn (prt t) $ getTableType i
ptyp <- comp g pty0
case allParamValues gr ptyp of
Ok vs -> do
cs' <- mapM (compBranchOpt g) cs ---- why is this needed??
sts <- mapM (matchPattern cs') vs
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
ps <- mapM term2patt vs
let ps' = ps --- PT ptyp (head ps) : tail ps
---- return $ V ptyp ts -- to save space ---- why doesn't this work??
return $ T (TComp ptyp) (zip ps' ts)
_ -> do
cs' <- mapM (compBranch g) cs
return $ T i cs' -- happens with variable types
-- otherwise go ahead
_ -> composOp (comp g) t >>= returnC
where
look p c
| rec = lookupOperDef gr p c >>= comp []
| otherwise = lookupOperDef gr p c
{-
look p c = case lookupResDefKind gr p c of
Ok (t,_) | noExpand p || rec -> comp [] t
Ok (t,_) -> return t
Bad s -> raise s
noExpand p = errVal False $ do
mo <- lookupModMod gr p
return $ case getOptVal (iOpts (flags mo)) useOptimizer of
Just "noexpand" -> True
_ -> False
-}
ext x a g = (x,a):g
returnC = return --- . computed
variants ts = case nub ts of
[t] -> t
ts -> FV ts
isCan v = case v of
Con _ -> True
QC _ _ -> True
App f a -> isCan f && isCan a
R rs -> all (isCan . snd . snd) rs
_ -> False
compBranch g (p,v) = do
let g' = contP p ++ g
v' <- comp g' v
return (p,v')
compBranchOpt g c@(p,v) = case contP p of
[] -> return c
_ -> err (const (return c)) return $ compBranch g c
contP p = case p of
PV x -> [(x,Vr x)]
PC _ ps -> concatMap contP ps
PP _ _ ps -> concatMap contP ps
PT _ p -> contP p
PR rs -> concatMap (contP . snd) rs
PAs x p -> (x,Vr x) : contP p
PSeq p q -> concatMap contP [p,q]
PAlt p q -> concatMap contP [p,q]
PRep p -> contP p
PNeg p -> contP p
_ -> []
prawitz g i f cs e = do
cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
return $ S (T i cs') e
prawitzV g i f cs e = do
cs' <- mapM (comp g) [(f v) | v <- cs]
return $ S (V i cs') e
-- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term
checkNoArgVars t = case t of
Vr (IA _) -> Bad $ glueErrorMsg $ prt t
Vr (IAV _) -> Bad $ glueErrorMsg $ prt t
_ -> composOp checkNoArgVars t
glueErrorMsg s =
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
"Use Prelude.bind instead."

221
src-3.0/GF/Devel/Grammar/Construct.hs Normal file
View File

@@ -0,0 +1,221 @@
module GF.Devel.Grammar.Construct where
import GF.Devel.Grammar.Grammar
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
import Data.Map
import Debug.Trace (trace)
------------------
-- abstractions on Grammar, constructing objects
------------------
-- abstractions on GF
emptyGF :: GF
emptyGF = GF Nothing [] empty empty
type SourceModule = (Ident,Module)
listModules :: GF -> [SourceModule]
listModules = assocs.gfmodules
addModule :: Ident -> Module -> GF -> GF
addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)}
gfModules :: [(Ident,Module)] -> GF
gfModules ms = emptyGF {gfmodules = fromList ms}
-- abstractions on Module
emptyModule :: Module
emptyModule = Module MTGrammar True [] [] [] [] empty empty
isCompleteModule :: Module -> Bool
isCompleteModule = miscomplete
isInterface :: Module -> Bool
isInterface m = case mtype m of
MTInterface -> True
MTAbstract -> True
_ -> False
interfaceName :: Module -> Maybe Ident
interfaceName mo = case mtype mo of
MTInstance i -> return i
MTConcrete i -> return i
_ -> Nothing
listJudgements :: Module -> [(Ident,Judgement)]
listJudgements = assocs . mjments
isInherited :: MInclude -> Ident -> Bool
isInherited mi i = case mi of
MIExcept is -> notElem i is
MIOnly is -> elem i is
_ -> True
-- abstractions on Judgement
isConstructor :: Judgement -> Bool
isConstructor j = jdef j == EData
isLink :: Judgement -> Bool
isLink j = jform j == JLink
-- constructing judgements from parse tree
emptyJudgement :: JudgementForm -> Judgement
emptyJudgement form = Judgement form meta meta meta (identC "#") 0 where
meta = Meta 0
addJType :: Type -> Judgement -> Judgement
addJType tr ju = ju {jtype = tr}
addJDef :: Term -> Judgement -> Judgement
addJDef tr ju = ju {jdef = tr}
addJPrintname :: Term -> Judgement -> Judgement
addJPrintname tr ju = ju {jprintname = tr}
linkInherited :: Bool -> Ident -> Judgement
linkInherited can mo = (emptyJudgement JLink){
jlink = mo,
jdef = if can then EData else Meta 0
}
absCat :: Context -> Judgement
absCat co = addJType (mkProd co typeType) (emptyJudgement JCat)
absFun :: Type -> Judgement
absFun ty = addJType ty (emptyJudgement JFun)
cncCat :: Type -> Judgement
cncCat ty = addJType ty (emptyJudgement JLincat)
cncFun :: Term -> Judgement
cncFun tr = addJDef tr (emptyJudgement JLin)
resOperType :: Type -> Judgement
resOperType ty = addJType ty (emptyJudgement JOper)
resOperDef :: Term -> Judgement
resOperDef tr = addJDef tr (emptyJudgement JOper)
resOper :: Type -> Term -> Judgement
resOper ty tr = addJDef tr (resOperType ty)
resOverload :: [(Type,Term)] -> Judgement
resOverload tts = resOperDef (Overload tts)
-- param p = ci gi is encoded as p : ((ci : gi) -> p) -> Type
-- we use EData instead of p to make circularity check easier
resParam :: Ident -> [(Ident,Context)] -> Judgement
resParam p cos = addJDef (EParam (Con p) cos) (addJType typePType (emptyJudgement JParam))
-- to enable constructor type lookup:
-- create an oper for each constructor p = c g, as c : g -> p = EData
paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)]
paramConstructors p cs = [(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs]
-- unifying contents of judgements
---- used in SourceToGF; make error-free and informative
unifyJudgements j k = case unifyJudgement j k of
Ok l -> l
Bad s -> error s
unifyJudgement :: Judgement -> Judgement -> Err Judgement
unifyJudgement old new = do
testErr (jform old == jform new) "different judment forms"
[jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname]
return $ old{jtype = jty, jdef = jde, jprintname = jpri}
where
unifyField field = unifyTerm (field old) (field new)
unifyTerm oterm nterm = case (oterm,nterm) of
(Meta _,t) -> return t
(t,Meta _) -> return t
_ -> do
if (nterm /= oterm)
then (trace (unwords ["illegal update of",show oterm,"to",show nterm])
(return ()))
else return () ---- to recover from spurious qualification conflicts
---- testErr (nterm == oterm)
---- (unwords ["illegal update of",prt oterm,"to",prt nterm])
return nterm
updateJudgement :: Ident -> Ident -> Judgement -> GF -> Err GF
updateJudgement m c ju gf = do
mo <- maybe (Bad (show m)) return $ Data.Map.lookup m $ gfmodules gf
let mo' = mo {mjments = insert c ju (mjments mo)}
return $ gf {gfmodules = insert m mo' (gfmodules gf)}
-- abstractions on Term
type Cat = QIdent
type Fun = QIdent
type QIdent = (Ident,Ident)
-- | branches à la Alfa
newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
type Con = Ident ---
varLabel :: Int -> Label
varLabel = LVar
wildPatt :: Patt
wildPatt = PW
type Trm = Term
mkProd :: Context -> Type -> Type
mkProd = flip (foldr (uncurry Prod))
-- type constants
typeType :: Type
typeType = Sort "Type"
typePType :: Type
typePType = Sort "PType"
typeStr :: Type
typeStr = Sort "Str"
typeTok :: Type ---- deprecated
typeTok = Sort "Tok"
cPredef :: Ident
cPredef = identC "Predef"
cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)
isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
App c _ -> c == constPredefRes "Ints"
_ -> False
cnPredef = constPredefRes
constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (identC s)
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q (IC "Predef") _ -> True
Q (IC "PredefAbs") _ -> True
_ -> False

223
src-3.0/GF/Devel/Grammar/GFtoSource.hs Normal file
View File

@@ -0,0 +1,223 @@
module GF.Devel.Grammar.GFtoSource (
trGrammar,
trModule,
trAnyDef,
trLabel,
trt,
tri,
trp
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros (contextOfType)
import qualified GF.Devel.Compile.AbsGF as P
import GF.Infra.Ident
import GF.Data.Operations
import qualified Data.Map as Map
-- From internal source syntax to BNFC-generated (used for printing).
-- | AR 13\/5\/2003
--
-- translate internal to parsable and printable source
trGrammar :: GF -> P.Grammar
trGrammar = P.Gr . map trModule . listModules -- no includes
trModule :: (Ident,Module) -> P.ModDef
trModule (i,mo) = P.MModule compl typ body where
compl = case isCompleteModule mo of
False -> P.CMIncompl
_ -> P.CMCompl
i' = tri i
typ = case mtype mo of
MTGrammar -> P.MGrammar i'
MTAbstract -> P.MAbstract i'
MTConcrete a -> P.MConcrete i' (tri a)
MTInterface -> P.MInterface i'
MTInstance a -> P.MInstance i' (tri a)
body = P.MBody
(trExtends (mextends mo))
(mkOpens (map trOpen (mopens mo)))
(concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++
map trFlag (Map.assocs (mflags mo)))
trExtends :: [(Ident,MInclude)] -> P.Extend
trExtends [] = P.NoExt
trExtends es = (P.Ext $ map tre es) where
tre (i,c) = case c of
MIAll -> P.IAll (tri i)
MIOnly is -> P.ISome (tri i) (map tri is)
MIExcept is -> P.IMinus (tri i) (map tri is)
trOpen :: (Ident,Ident) -> P.Open
trOpen (i,j) = P.OQual (tri i) (tri j)
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
trAnyDef :: (Ident,Judgement) -> [P.TopDef]
trAnyDef (i,ju) = let
i' = mkName i
i0 = tri i
in case jform ju of
JCat -> [P.DefCat [P.SimpleCatDef i0 []]] ---- (map trDecl co)]]
JFun -> [P.DefFun [P.FDecl [i'] (trt (jtype ju))]]
---- ++ case pt of
---- Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
---- _ -> []
---- JFun ty EData -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
JParam -> [P.DefPar [
P.ParDefDir i0 [
P.ParConstr (tri c) (map trDecl co) | let EParam _ cos = jdef ju, (c,co) <- cos]
]]
JOper -> case jdef ju of
Overload tysts ->
[P.DefOper [P.DDef [i'] (
P.EApp (P.EPIdent $ ppIdent "overload")
(P.ERecord [P.LDFull [i0] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
tr -> [P.DefOper [trDef i (jtype ju) tr]]
JLincat -> [P.DefLincat [P.DDef [i'] (trt (jtype ju))]]
---- CncCat pty ptr ppr ->
---- [P.DefLindef [trDef i' pty ptr]]
---- ++ [P.DefPrintCat [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
JLin ->
[P.DefLin [trDef i (Meta 0) (jdef ju)]]
---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
JLink -> []
trDef :: Ident -> Type -> Term -> P.Def
trDef i pty ptr = case (pty,ptr) of
(Meta _, Meta _) -> P.DDef [mkName i] (P.EMeta) ---
(_, Meta _) -> P.DDecl [mkName i] (trPerh pty)
(Meta _, _) -> P.DDef [mkName i] (trPerh ptr)
(_, _) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr)
trPerh p = case p of
Meta _ -> P.EMeta
_ -> trt p
trFlag :: (Ident,String) -> P.TopDef
trFlag (f,x) = P.DefFlag [P.DDef [mkName f] (P.EString x)]
trt :: Term -> P.Exp
trt trm = case trm of
Vr s -> P.EPIdent $ tri s
---- Cn s -> P.ECons $ tri s
Con s -> P.EConstr $ tri s
Sort s -> P.ESort $ case s of
"Type" -> P.Sort_Type
"PType" -> P.Sort_PType
"Tok" -> P.Sort_Tok
"Str" -> P.Sort_Str
"Strs" -> P.Sort_Strs
_ -> error $ "not yet sort " +++ show trm ----
App c a -> P.EApp (trt c) (trt a)
Abs x b -> P.EAbstr [trb x] (trt b)
Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
Meta m -> P.EMeta
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
Example t s -> P.EExample (trt t) s
R [] -> P.ETuple [] --- to get correct parsing when read back
R r -> P.ERecord $ map trAssign r
RecType r -> P.ERecord $ map trLabelling r
ExtR x y -> P.EExtend (trt x) (trt y)
P t l -> P.EProj (trt t) (trLabel l)
PI t l _ -> P.EProj (trt t) (trLabel l)
Q t l -> P.EQCons (tri t) (tri l)
QC t l -> P.EQConstr (tri t) (tri l)
T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
T _ cc -> P.ETable (map trCase cc)
V ty cc -> P.EVTable (trt ty) (map trt cc)
Typed tr ty -> P.ETyped (trt tr) (trt ty)
Table x v -> P.ETType (trt x) (trt v)
S f x -> P.ESelect (trt f) (trt x)
Let (x,(ma,b)) t ->
P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t)
where
b' = trt b
x' = [tri x]
Empty -> P.EEmpty
K [] -> P.EEmpty
K a -> P.EString a
C a b -> P.EConcat (trt a) (trt b)
EInt i -> P.EInt i
EFloat i -> P.EFloat i
EPatt p -> P.EPatt (trp p)
EPattType t -> P.EPattType (trt t)
Glue a b -> P.EGlue (trt a) (trt b)
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
FV ts -> P.EVariants $ map trt ts
EData -> P.EData
EParam t _ -> trt t
_ -> error $ "not yet" +++ show trm ----
trp :: Patt -> P.Patt
trp p = case p of
PChar -> P.PChar
PChars s -> P.PChars s
PM m c -> P.PM (tri m) (tri c)
PW -> P.PW
PV s | isWildIdent s -> P.PW
PV s -> P.PV $ tri s
PC c [] -> P.PCon $ tri c
PC c a -> P.PC (tri c) (map trp a)
PP p c [] -> P.PQ (tri p) (tri c)
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r]
PString s -> P.PStr s
PInt i -> P.PInt i
PFloat i -> P.PFloat i
PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
PAs x p -> P.PAs (tri x) (trp p)
PAlt p q -> P.PDisj (trp p) (trp q)
PSeq p q -> P.PSeq (trp p) (trp q)
PRep p -> P.PRep (trp p)
PNeg p -> P.PNeg (trp p)
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
where
t' = trt t
x = [trLabelIdent lab]
trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty)
trCase (patt, trm) = P.Case (trp patt) (trt trm)
trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
trDecl (x,ty) = P.DDDec [trb x] (trt ty)
tri :: Ident -> P.PIdent
tri i = ppIdent (prIdent i)
ppIdent i = P.PIdent ((0,0),i)
trb i = if isWildIdent i then P.BWild else P.BPIdent (tri i)
trLabel :: Label -> P.Label
trLabel i = case i of
LIdent s -> P.LPIdent $ ppIdent s
LVar i -> P.LVar $ toInteger i
trLabelIdent i = ppIdent $ case i of
LIdent s -> s
LVar i -> "v" ++ show i --- should not happen
mkName :: Ident -> P.Name
mkName = P.PIdentName . tri

172
src-3.0/GF/Devel/Grammar/Grammar.hs Normal file
View File

@@ -0,0 +1,172 @@
module GF.Devel.Grammar.Grammar where
import GF.Infra.Ident
import GF.Data.Operations
import Data.Map
------------------
-- definitions --
------------------
data GF = GF {
gfabsname :: Maybe Ident ,
gfcncnames :: [Ident] ,
gflags :: Map Ident String , -- value of a global flag
gfmodules :: Map Ident Module
}
data Module = Module {
mtype :: ModuleType,
miscomplete :: Bool,
minterfaces :: [(Ident,Ident)], -- non-empty for functors
minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for inst'ions
mextends :: [(Ident,MInclude)],
mopens :: [(Ident,Ident)], -- used name, original name
mflags :: Map Ident String,
mjments :: Map Ident Judgement
}
data ModuleType =
MTAbstract
| MTConcrete Ident
| MTInterface
| MTInstance Ident
| MTGrammar
deriving Eq
data MInclude =
MIAll
| MIExcept [Ident]
| MIOnly [Ident]
type Indirection = (Ident,Bool) -- module of origin, whether canonical
data Judgement = Judgement {
jform :: JudgementForm, -- cat fun lincat lin oper param
jtype :: Type, -- context type lincat - type PType
jdef :: Term, -- lindef def lindef lin def constrs
jprintname :: Term, -- - - prname prname - -
jlink :: Ident, -- if inherited, the supermodule name, else #
jposition :: Int -- line number where def begins
}
deriving Show
data JudgementForm =
JCat
| JFun
| JLincat
| JLin
| JOper
| JParam
| JLink
deriving (Eq,Show)
type Type = Term
data Term =
Vr Ident -- ^ variable
| Con Ident -- ^ constructor
| EData -- ^ to mark in definition that a fun is a constructor
| Sort String -- ^ predefined type
| EInt Integer -- ^ integer literal
| EFloat Double -- ^ floating point literal
| K String -- ^ string literal or token: @\"foo\"@
| Empty -- ^ the empty string @[]@
| App Term Term -- ^ application: @f a@
| Abs Ident Term -- ^ abstraction: @\x -> b@
| Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0)
| Prod Ident Term Term -- ^ function type: @(x : A) -> B@
| Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@
-- only used in internal representation
| Typed Term Term -- ^ type-annotated term
--
-- /below this, the constructors are only for concrete syntax/
| Example Term String -- ^ example-based term: @in M.C "foo"
| RecType [Labelling] -- ^ record type: @{ p : A ; ...}@
| R [Assign] -- ^ record: @{ p = a ; ...}@
| P Term Label -- ^ projection: @r.p@
| PI Term Label Int -- ^ index-annotated projection
| ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms)
| Table Term Term -- ^ table type: @P => A@
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@
| V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@
| S Term Term -- ^ selection: @t ! p@
| Val Type Int -- ^ parameter value number: @T # i#
| Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@
| Q Ident Ident -- ^ qualified constant from a module
| QC Ident Ident -- ^ qualified constructor from a module
| C Term Term -- ^ concatenation: @s ++ t@
| Glue Term Term -- ^ agglutination: @s + t@
| EPatt Patt
| EPattType Term
| EParam Term [(Ident,Context)] -- to encode parameter constructor sets
| FV [Term] -- ^ free variation: @variants { s ; ... }@
| Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@
| Overload [(Type,Term)]
deriving (Read, Show, Eq, Ord)
data Patt =
PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@
| PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@
| PV Ident -- ^ variable pattern: @x@
| PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@
| PString String -- ^ string literal pattern: @\"foo\"@
| PInt Integer -- ^ integer literal pattern: @12@
| PFloat Double -- ^ float literal pattern: @1.2@
| PT Type Patt -- ^ type-annotated pattern
| PAs Ident Patt -- ^ as-pattern: x@p
-- regular expression patterns
| PNeg Patt -- ^ negated pattern: -p
| PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2
| PSeq Patt Patt -- ^ sequence of token parts: p + q
| PRep Patt -- ^ repetition of token part: p*
| PChar -- ^ string of length one: ?
| PChars String -- ^ list of characters: ["aeiou"]
| PMacro Ident -- #p
| PM Ident Ident -- #m.p
deriving (Read, Show, Eq, Ord)
-- | to guide computation and type checking of tables
data TInfo =
TRaw -- ^ received from parser; can be anything
| TTyped Type -- ^ type annotated, but can be anything
| TComp Type -- ^ expanded
| TWild Type -- ^ just one wild card pattern, no need to expand
deriving (Read, Show, Eq, Ord)
-- | record label
data Label =
LIdent String
| LVar Int
deriving (Read, Show, Eq, Ord)
type MetaSymb = Int
type Decl = (Ident,Term) -- (x:A) (_:A) A
type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A)
type Substitution = [(Ident, Term)]
type Equation = ([Patt],Term)
type Labelling = (Label, Term)
type Assign = (Label, (Maybe Type, Term))
type Case = (Patt, Term)
type LocalDef = (Ident, (Maybe Type, Term))

168
src-3.0/GF/Devel/Grammar/Lookup.hs Normal file
View File

@@ -0,0 +1,168 @@
module GF.Devel.Grammar.Lookup where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad (liftM)
import Data.Map
import Data.List (sortBy) ----
-- look up fields for a constant in a grammar
lookupJField :: (Judgement -> a) -> GF -> Ident -> Ident -> Err a
lookupJField field gf m c = do
j <- lookupJudgement gf m c
return $ field j
lookupJForm :: GF -> Ident -> Ident -> Err JudgementForm
lookupJForm = lookupJField jform
-- the following don't (need to) check that the jment form is adequate
lookupCatContext :: GF -> Ident -> Ident -> Err Context
lookupCatContext gf m c = do
ty <- lookupJField jtype gf m c
return $ contextOfType ty
lookupFunType :: GF -> Ident -> Ident -> Err Term
lookupFunType = lookupJField jtype
lookupLin :: GF -> Ident -> Ident -> Err Term
lookupLin = lookupJField jdef
lookupLincat :: GF -> Ident -> Ident -> Err Term
lookupLincat = lookupJField jtype
lookupOperType :: GF -> Ident -> Ident -> Err Term
lookupOperType gr m c = do
ju <- lookupJudgement gr m c
case jform ju of
JParam -> return typePType
_ -> case jtype ju of
Meta _ -> fail ("no type given to " ++ prIdent m ++ "." ++ prIdent c)
ty -> return ty
---- can't be just lookupJField jtype
lookupOperDef :: GF -> Ident -> Ident -> Err Term
lookupOperDef = lookupJField jdef
lookupOverload :: GF -> Ident -> Ident -> Err [([Type],(Type,Term))]
lookupOverload gr m c = do
tr <- lookupJField jdef gr m c
case tr of
Overload tysts -> return
[(lmap snd args,(val,tr)) | (ty,tr) <- tysts, let (args,val) = prodForm ty]
_ -> Bad $ prt c +++ "is not an overloaded operation"
lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)]
lookupParams gf m c = do
EParam _ ty <- lookupJField jdef gf m c
return ty
lookupParamConstructor :: GF -> Ident -> Ident -> Err Type
lookupParamConstructor = lookupJField jtype
lookupParamValues :: GF -> Ident -> Ident -> Err [Term]
lookupParamValues gf m c = do
ps <- lookupParams gf m c
liftM concat $ mapM mkPar ps
where
mkPar (f,co) = do
vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co
return $ lmap (mkApp (QC m f)) vs
lookupFlags :: GF -> Ident -> [(Ident,String)]
lookupFlags gf m = errVal [] $ do
mo <- lookupModule gf m
return $ toList $ mflags mo
allParamValues :: GF -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
App (Q (IC "Predef") (IC "Ints")) (EInt n) ->
return [EInt i | i <- [0..n]]
QC p c -> lookupParamValues cnc p c
Q p c -> lookupParamValues cnc p c ----
RecType r -> do
let (ls,tys) = unzip $ sortByFst r
tss <- mapM allPV tys
return [R (zipAssign ls ts) | ts <- combinations tss]
_ -> prtBad "cannot find parameter values for" ptyp
where
allPV = allParamValues cnc
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
abstractOfConcrete :: GF -> Ident -> Err Ident
abstractOfConcrete gf m = do
mo <- lookupModule gf m
case mtype mo of
MTConcrete a -> return a
MTInstance a -> return a
MTGrammar -> return m
_ -> prtBad "not concrete module" m
allOrigJudgements :: GF -> Ident -> [(Ident,Judgement)]
allOrigJudgements gf m = errVal [] $ do
mo <- lookupModule gf m
return [ju | ju@(_,j) <- listJudgements mo, jform j /= JLink]
allConcretes :: GF -> Ident -> [Ident]
allConcretes gf m =
[c | (c,mo) <- toList (gfmodules gf), mtype mo == MTConcrete m]
-- | select just those modules that a given one depends on, including itself
partOfGrammar :: GF -> (Ident,Module) -> GF
partOfGrammar gr (i,mo) = gr {
gfmodules = fromList [m | m@(j,_) <- mos, elem j modsFor]
}
where
mos = toList $ gfmodules gr
modsFor = i : allDepsModule gr mo
allDepsModule :: GF -> Module -> [Ident]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
add os = [m | o <- os, Just n <- [llookup o mods], m <- depPathModule n]
mods = toList $ gfmodules gr
-- | initial dependency list
depPathModule :: Module -> [Ident]
depPathModule mo = fors ++ lmap fst (mextends mo) ++ lmap snd (mopens mo) where
fors = case mtype mo of
MTConcrete i -> [i]
MTInstance i -> [i]
_ -> []
-- infrastructure for lookup
lookupModule :: GF -> Ident -> Err Module
lookupModule gf m = do
maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf)
-- this finds the immediate definition, which can be a link
lookupIdent :: GF -> Ident -> Ident -> Err Judgement
lookupIdent gf m c = do
mo <- lookupModule gf m
maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo)
-- this follows the link
lookupJudgement :: GF -> Ident -> Ident -> Err Judgement
lookupJudgement gf m c = do
ju <- lookupIdent gf m c
case jform ju of
JLink -> lookupJudgement gf (jlink ju) c
_ -> return ju
mlookup = Data.Map.lookup
raiseIdent msg i = raise (msg +++ prIdent i)
lmap = Prelude.map
llookup = Prelude.lookup

434
src-3.0/GF/Devel/Grammar/Macros.hs Normal file
View File

@@ -0,0 +1,434 @@
module GF.Devel.Grammar.Macros where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Infra.Ident
import GF.Data.Str
import GF.Data.Operations
import qualified Data.Map as Map
import Control.Monad (liftM,liftM2)
-- analyse types and terms
contextOfType :: Type -> Context
contextOfType ty = co where (co,_,_) = typeForm ty
typeForm :: Type -> (Context,Term,[Term])
typeForm t = (co,f,a) where
(co,t2) = prodForm t
(f,a) = appForm t2
termForm :: Term -> ([Ident],Term,[Term])
termForm t = (co,f,a) where
(co,t2) = absForm t
(f,a) = appForm t2
prodForm :: Type -> (Context,Term)
prodForm t = case t of
Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val
_ -> ([],t)
absForm :: Term -> ([Ident],Term)
absForm t = case t of
Abs x val -> (x:co,t2) where (co,t2) = absForm val
_ -> ([],t)
appForm :: Term -> (Term,[Term])
appForm tr = (f,reverse xs) where
(f,xs) = apps tr
apps t = case t of
App f a -> (f2,a:a2) where (f2,a2) = appForm f
_ -> (t,[])
valCat :: Type -> Err (Ident,Ident)
valCat typ = case typeForm typ of
(_,Q m c,_) -> return (m,c)
typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
typeRawSkeleton typ = do
let (cont,typ) = prodForm typ
args <- mapM (typeRawSkeleton . snd) cont
return ([(length c, v) | (c,v) <- args], typ)
type MCat = (Ident,Ident)
sortMCat :: String -> MCat
sortMCat s = (identC "_", identC s)
--- hack for Editing.actCat in empty state
errorCat :: MCat
errorCat = (identC "?", identC "?")
getMCat :: Term -> Err MCat
getMCat t = case t of
Q m c -> return (m,c)
QC m c -> return (m,c)
Sort s -> return $ sortMCat s
App f _ -> getMCat f
_ -> error $ "no qualified constant" +++ show t
typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
typeSkeleton typ = do
(cont,val) <- typeRawSkeleton typ
cont' <- mapPairsM getMCat cont
val' <- getMCat val
return (cont',val')
-- construct types and terms
mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod
mkApp :: Term -> [Term] -> Term
mkApp = foldl App
mkAbs :: [Ident] -> Term -> Term
mkAbs xs t = foldr Abs t xs
mkCTable :: [Ident] -> Term -> Term
mkCTable ids v = foldr ccase v ids where
ccase x t = T TRaw [(PV x,t)]
appCons :: Ident -> [Term] -> Term
appCons = mkApp . Con
appc :: String -> [Term] -> Term
appc = appCons . identC
tuple2record :: [Term] -> [Assign]
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
tuple2recordType :: [Term] -> [Labelling]
tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
tuple2recordPatt :: [Patt] -> [(Label,Patt)]
tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
tupleLabel :: Int -> Label
tupleLabel i = LIdent $ "p" ++ show i
assign :: Label -> Term -> Assign
assign l t = (l,(Nothing,t))
assignT :: Label -> Type -> Term -> Assign
assignT l a t = (l,(Just a,t))
unzipR :: [Assign] -> ([Label],[Term])
unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
mkDecl :: Term -> Decl
mkDecl typ = (wildIdent, typ)
mkLet :: [LocalDef] -> Term -> Term
mkLet defs t = foldr Let t defs
mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
mkRecType :: (Int -> Label) -> [Type] -> Type
mkRecType = mkRecTypeN 0
plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
ls -> Bad $ "clashing labels" +++ unwords (map show ls)
_ -> Bad ("cannot add record types" +++ show t1 +++ "and" +++ show t2)
plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
case (t1,t2) of
(R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> Bad ("cannot add records" +++ show t1 +++ "and" +++ show t2)
zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
defLinType :: Type
defLinType = RecType [(LIdent "s", typeStr)]
meta0 :: Term
meta0 = Meta 0
ident2label :: Ident -> Label
ident2label c = LIdent (prIdent c)
label2ident :: Label -> Ident
label2ident (LIdent c) = identC c
----label2ident :: Label -> Ident
----label2ident = identC . prLabel
-- to apply a term operation to every term in a judgement, module, grammar
termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF
termOpGF f = moduleOpGF (termOpModule f)
moduleOpGF :: Monad m => (Module -> m Module) -> GF -> m GF
moduleOpGF f g = do
ms <- mapMapM f (gfmodules g)
return g {gfmodules = ms}
termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module
termOpModule f = judgementOpModule fj where
fj = termOpJudgement f
judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module
judgementOpModule f m = do
mjs <- mapMapM f (mjments m)
return m {mjments = mjs}
entryOpModule :: Monad m =>
(Ident -> Judgement -> m Judgement) -> Module -> m Module
entryOpModule f m = do
mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m
return $ m {mjments = mjs}
where
mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j))
termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement
termOpJudgement f j = do
jtyp <- f (jtype j)
jde <- f (jdef j)
jpri <- f (jprintname j)
return $ j {
jtype = jtyp,
jdef = jde,
jprintname = jpri
}
-- | to define compositional term functions
composSafeOp :: (Term -> Term) -> Term -> Term
composSafeOp op trm = case composOp (mkMonadic op) trm of
Ok t -> t
_ -> error "the operation is safe isn't it ?"
where
mkMonadic f = return . f
-- | to define compositional monadic term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm = case trm of
App c a ->
do c' <- co c
a' <- co a
return (App c' a')
Abs x b ->
do b' <- co b
return (Abs x b')
Prod x a b ->
do a' <- co a
b' <- co b
return (Prod x a' b')
S c a ->
do c' <- co c
a' <- co a
return (S c' a')
Table a c ->
do a' <- co a
c' <- co c
return (Table a' c')
R r ->
do r' <- mapAssignM co r
return (R r')
RecType r ->
do r' <- mapPairListM (co . snd) r
return (RecType r')
P t i ->
do t' <- co t
return (P t' i)
PI t i j ->
do t' <- co t
return (PI t' i j)
ExtR a c ->
do a' <- co a
c' <- co c
return (ExtR a' c')
T i cc ->
do cc' <- mapPairListM (co . snd) cc
i' <- changeTableType co i
return (T i' cc')
Eqs cc ->
do cc' <- mapPairListM (co . snd) cc
return (Eqs cc')
EParam ty cos ->
do ty' <- co ty
cos' <- mapPairListM (mapPairListM (co . snd) . snd) cos
return (EParam ty' cos')
V ty vs ->
do ty' <- co ty
vs' <- mapM co vs
return (V ty' vs')
Let (x,(mt,a)) b ->
do a' <- co a
mt' <- case mt of
Just t -> co t >>= (return . Just)
_ -> return mt
b' <- co b
return (Let (x,(mt',a')) b')
C s1 s2 ->
do v1 <- co s1
v2 <- co s2
return (C v1 v2)
Glue s1 s2 ->
do v1 <- co s1
v2 <- co s2
return (Glue v1 v2)
Alts (t,aa) ->
do t' <- co t
aa' <- mapM (pairM co) aa
return (Alts (t',aa'))
FV ts -> mapM co ts >>= return . FV
Overload tts -> do
tts' <- mapM (pairM co) tts
return $ Overload tts'
EPattType ty ->
do ty' <- co ty
return (EPattType ty')
_ -> return trm -- covers K, Vr, Cn, Sort
---- should redefine using composOp
collectOp :: (Term -> [a]) -> Term -> [a]
collectOp co trm = case trm of
App c a -> co c ++ co a
Abs _ b -> co b
Prod _ a b -> co a ++ co b
S c a -> co c ++ co a
Table a c -> co a ++ co c
ExtR a c -> co a ++ co c
R r -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r
RecType r -> concatMap (co . snd) r
P t i -> co t
T _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
V _ cc -> concatMap co cc --- nor from type annot
Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
C s1 s2 -> co s1 ++ co s2
Glue s1 s2 -> co s1 ++ co s2
Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
FV ts -> concatMap co ts
_ -> [] -- covers K, Vr, Cn, Sort, Ready
--- just aux to composOp?
mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
changeTableType co i = case i of
TTyped ty -> co ty >>= return . TTyped
TComp ty -> co ty >>= return . TComp
TWild ty -> co ty >>= return . TWild
_ -> return i
patt2term :: Patt -> Term
patt2term pt = case pt of
PV x -> Vr x
PW -> Vr wildIdent --- not parsable, should not occur
PC c pp -> mkApp (Con c) (map patt2term pp)
PP p c pp -> mkApp (QC p c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
PInt i -> EInt i
PFloat i -> EFloat i
PString s -> K s
PAs x p -> appc "@" [Vr x, patt2term p] --- an encoding
PSeq a b -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
PAlt a b -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
PRep a -> appc "*" [(patt2term a)] --- an encoding
PNeg a -> appc "-" [(patt2term a)] --- an encoding
term2patt :: Term -> Err Patt
term2patt trm = case Ok (termForm trm) of
Ok ([], Vr x, []) -> return (PV x)
Ok ([], QC p c, aa) -> do
aa' <- mapM term2patt aa
return (PP p c aa')
Ok ([], R r, []) -> do
let (ll,aa) = unzipR r
aa' <- mapM term2patt aa
return (PR (zip ll aa'))
Ok ([],EInt i,[]) -> return $ PInt i
Ok ([],EFloat i,[]) -> return $ PFloat i
Ok ([],K s, []) -> return $ PString s
--- encodings due to excessive use of term-patt convs. AR 7/1/2005
Ok ([], Con (IC "@"), [Vr a,b]) -> do
b' <- term2patt b
return (PAs a b')
Ok ([], Con (IC "-"), [a]) -> do
a' <- term2patt a
return (PNeg a')
Ok ([], Con (IC "*"), [a]) -> do
a' <- term2patt a
return (PRep a')
Ok ([], Con (IC "+"), [a,b]) -> do
a' <- term2patt a
b' <- term2patt b
return (PSeq a' b')
Ok ([], Con (IC "|"), [a,b]) -> do
a' <- term2patt a
b' <- term2patt b
return (PAlt a' b')
Ok ([], Con c, aa) -> do
aa' <- mapM term2patt aa
return (PC c aa')
_ -> Bad $ "no pattern corresponds to term" +++ show trm
getTableType :: TInfo -> Err Type
getTableType i = case i of
TTyped ty -> return ty
TComp ty -> return ty
TWild ty -> return ty
_ -> Bad "the table is untyped"
-- | to get a string from a term that represents a sequence of terminals
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case t of
K s -> return [str s]
Empty -> return [str []]
C s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [plusStr x y | x <- s', y <- t']
Glue s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [glueStr x y | x <- s', y <- t']
Alts (d,vs) -> do
d0 <- strsFromTerm d
v0 <- mapM (strsFromTerm . fst) vs
c0 <- mapM (strsFromTerm . snd) vs
let vs' = zip v0 c0
return [strTok (str2strings def) vars |
def <- d0,
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- combinations v0]
]
FV ts -> mapM strsFromTerm ts >>= return . concat
_ -> Bad $ "cannot get Str from term" +++ show t
---- given in lib?
mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map.Map k v -> m (Map.Map k v)
mapMapM f =
liftM Map.fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . Map.assocs

146
src-3.0/GF/Devel/Grammar/PatternMatch.hs Normal file
View File

@@ -0,0 +1,146 @@
----------------------------------------------------------------------
-- |
-- Module : PatternMatch
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/12 12:38:29 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.7 $
--
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
-----------------------------------------------------------------------------
module GF.Devel.Grammar.PatternMatch (matchPattern,
testOvershadow,
findMatch
) where
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF
import GF.Infra.Ident
import GF.Data.Operations
import Data.List
import Control.Monad
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
matchPattern pts term =
if not (isInConstantForm term)
then prtBad "variables occur in" term
else
errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
findMatch [([p],t) | (p,t) <- pts] [term]
testOvershadow :: [Patt] -> [Term] -> Err [Patt]
testOvershadow pts vs = do
let numpts = zip pts [0..]
let cases = [(p,EInt i) | (p,i) <- numpts]
ts <- mapM (liftM fst . matchPattern cases) vs
return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
(patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
_ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
tryMatch (p,t) = do
let t' = termForm t
trym p t'
where
isInConstantFormt = True -- tested already
trym p t' =
case (p,t') of
(_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
(PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
(PV x, _) | isInConstantFormt -> return [(x,t)]
(PString s, ([],K i,[])) | s==i -> return []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
(PC p pp, ([], Con f, tt)) |
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PP q p pp, ([], QC r f, tt)) |
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
---- hack for AppPredef bug
(PP q p pp, ([], Q r f, tt)) |
-- q `eqStrIdent` r && ---
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PR r, ([],R r',[])) |
all (`elem` map fst r') (map fst r) ->
do matches <- mapM tryMatch
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
return (concat matches)
(PT _ p',_) -> trym p' t'
-- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
(PAs x p',_) -> do
subst <- trym p' t'
return $ (x,t) : subst
(PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
(PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return []
_ -> prtBad "no match with negative pattern" p
(PSeq p1 p2, ([],K s, [])) -> do
let cuts = [splitAt n s | n <- [0 .. length s]]
matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
return (concat matches)
(PRep p1, ([],K s, [])) -> checks [
trym (foldr (const (PSeq p1)) (PString "")
[1..n]) t' | n <- [0 .. length s]
] >>
return []
(PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> prtBad "no match in case expr for" t
eqStrIdent = (==) ----
isInConstantForm :: Term -> Bool
isInConstantForm trm = case trm of
Con _ -> True
Q _ _ -> True
QC _ _ -> True
Abs _ _ -> True
App c a -> isInConstantForm c && isInConstantForm a
R r -> all (isInConstantForm . snd . snd) r
K _ -> True
Empty -> True
EInt _ -> True
_ -> False ---- isInArgVarForm trm
varsOfPatt :: Patt -> [Ident]
varsOfPatt p = case p of
PV x -> [x | not (isWildIdent x)]
PC _ ps -> concat $ map varsOfPatt ps
PP _ _ ps -> concat $ map varsOfPatt ps
PR r -> concat $ map (varsOfPatt . snd) r
PT _ q -> varsOfPatt q
_ -> []

246
src-3.0/GF/Devel/Grammar/PrGF.hs Normal file
View File

@@ -0,0 +1,246 @@
----------------------------------------------------------------------
-- |
-- Module : PrGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/04 11:45:38 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003 - 4/12/2007
--
-- printing and prettyprinting class for source grammar
--
-- 8\/1\/2004:
-- Usually followed principle: 'prt_' for displaying in the editor, 'prt'
-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree',
-- only the former is ever needed.
-----------------------------------------------------------------------------
module GF.Devel.Grammar.PrGF where
import qualified GF.Devel.Compile.PrintGF as P
import GF.Devel.Grammar.GFtoSource
import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
----import GF.Grammar.Values
----import GF.Infra.Option
import GF.Infra.Ident
import GF.Infra.CompactPrint
----import GF.Data.Str
import GF.Data.Operations
----import GF.Data.Zipper
import Data.List (intersperse)
class Print a where
prt :: a -> String
-- | printing with parentheses, if needed
prt2 :: a -> String
-- | pretty printing
prpr :: a -> [String]
-- | printing without ident qualifications
prt_ :: a -> String
prt2 = prt
prt_ = prt
prpr = return . prt
-- 8/1/2004
--- Usually followed principle: prt_ for displaying in the editor, prt
--- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
--- only the former is ever needed.
cprintTree :: P.Print a => a -> String
cprintTree = compactPrint . P.printTree
-- | to show terms etc in error messages
prtBad :: Print a => String -> a -> Err b
prtBad s a = Bad (s +++ prt a)
prGF :: GF -> String
prGF = cprintTree . trGrammar
instance Print GF where
prt = cprintTree . trGrammar
prModule :: SourceModule -> String
prModule = cprintTree . trModule
instance Print Judgement where
prt j = cprintTree $ trAnyDef (wildIdent, j)
---- prt_ = prExp
instance Print Term where
prt = cprintTree . trt
---- prt_ = prExp
instance Print Ident where
prt = cprintTree . tri
instance Print Patt where
prt = P.printTree . trp
instance Print Label where
prt = P.printTree . trLabel
{-
instance Print MetaSymb where
prt (MetaSymb i) = "?" ++ show i
prParam :: Param -> String
prParam (c,co) = prt c +++ prContext co
prContext :: Context -> String
prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
-- printing values and trees in editing
instance Print a => Print (Tr a) where
prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees)
prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t)
-- | we cannot define the method prt_ in this way
prt_Tree :: Tree -> String
prt_Tree = prt_ . tree2exp
instance Print TrNode where
prt (N (bi,at,vt,(cs,ms),_)) =
prBinds bi ++
prt at +++ ":" +++ prt vt
+++ prConstraints cs +++ prMetaSubst ms
prt_ (N (bi,at,vt,(cs,ms),_)) =
prBinds bi ++
prt_ at +++ ":" +++ prt_ vt
+++ prConstraints cs +++ prMetaSubst ms
prMarkedTree :: Tr (TrNode,Bool) -> [String]
prMarkedTree = prf 1 where
prf ind t@(Tr (node, trees)) =
prNode ind node : concatMap (prf (ind + 2)) trees
prNode ind node = case node of
(n, False) -> indent ind (prt_ n)
(n, _) -> '*' : indent (ind - 1) (prt_ n)
prTree :: Tree -> [String]
prTree = prMarkedTree . mapTr (\n -> (n,False))
-- | a pretty-printer for parsable output
tree2string :: Tree -> String
tree2string = unlines . prprTree
prprTree :: Tree -> [String]
prprTree = prf False where
prf par t@(Tr (node, trees)) =
parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
prb [] = ""
prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
parIf par (s:ss) = map (indent 2) $
if par
then ('(':s) : ss ++ [")"]
else s:ss
ifPar (Tr (N ([],_,_,_,_), [])) = False
ifPar _ = True
-- auxiliaries
prConstraints :: Constraints -> String
prConstraints = concat . prConstrs
prMetaSubst :: MetaSubst -> String
prMetaSubst = concat . prMSubst
prEnv :: Env -> String
---- prEnv [] = prCurly "" ---- for debugging
prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
prConstrs :: Constraints -> [String]
prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w))
prMSubst :: MetaSubst -> [String]
prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e))
prBinds bi = if null bi
then []
else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
where
prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
instance Print Val where
prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging
prt (VApp u v) = prt u +++ prv1 v
prt (VCn mc) = prQIdent_ mc
prt (VClos env e) = case e of
Meta _ -> prt_ e ++ prEnv env
_ -> prt_ e ---- ++ prEnv env ---- for debugging
prt VType = "Type"
prv1 v = case v of
VApp _ _ -> prParenth $ prt v
VClos _ _ -> prParenth $ prt v
_ -> prt v
instance Print Atom where
prt (AtC f) = prQIdent f
prt (AtM i) = prt i
prt (AtV i) = prt i
prt (AtL s) = prQuotedString s
prt (AtI i) = show i
prt (AtF i) = show i
prt_ (AtC (_,f)) = prt f
prt_ a = prt a
prQIdent :: QIdent -> String
prQIdent (m,f) = prt m ++ "." ++ prt f
prQIdent_ :: QIdent -> String
prQIdent_ (_,f) = prt f
-- | print terms without qualifications
prExp :: Term -> String
prExp e = case e of
App f a -> pr1 f +++ pr2 a
Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b
Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
Q _ c -> prt c
QC _ c -> prt c
_ -> prt e
where
pr1 e = case e of
Abs _ _ -> prParenth $ prExp e
Prod _ _ _ -> prParenth $ prExp e
_ -> prExp e
pr2 e = case e of
App _ _ -> prParenth $ prExp e
_ -> pr1 e
-- | option @-strip@ strips qualifications
prTermOpt :: Options -> Term -> String
prTermOpt opts = if oElem nostripQualif opts then prt else prExp
-- | to get rid of brackets in the editor
prRefinement :: Term -> String
prRefinement t = case t of
Q m c -> prQIdent (m,c)
QC m c -> prQIdent (m,c)
_ -> prt t
prOperSignature :: (QIdent,Type) -> String
prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
-- to look up a constant etc in a search tree
lookupIdent :: Ident -> BinTree Ident b -> Err b
lookupIdent c t = case lookupTree prt c t of
Ok v -> return v
_ -> prtBad "unknown identifier" c
lookupIdentInfo :: Module Ident f a -> Ident -> Err a
lookupIdentInfo mo i = lookupIdent i (jments mo)
-}