GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

remove some more old code

Browse Source
This commit is contained in:
krasimir
2015-03-05 14:47:36 +00:00
parent 9d85f53002
commit d408c7df9f
10 changed files with 37 additions and 354 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
gf.cabal
View File

@@ -217,7 +217,6 @@ Library
GF.Grammar.Lexer
GF.Grammar.Lockfield
GF.Grammar.Lookup
GF.Grammar.MMacros
GF.Grammar.Macros
GF.Grammar.Parser
GF.Grammar.PatternMatch

2
src/compiler/GF/Command/Importing.hs
View File

@@ -10,7 +10,7 @@ import GF.Grammar (SourceGrammar) -- for cc command
import GF.Grammar.CFG
import GF.Grammar.EBNF
import GF.Compile.CFGtoPGF
import GF.Infra.UseIO(die,tryIOE,useIOE)
import GF.Infra.UseIO(die,tryIOE)
import GF.Infra.Option
import GF.Data.ErrM

6
src/compiler/GF/Compile/Compute/Abstract.hs
View File

@@ -35,16 +35,16 @@ import GF.Text.Pretty
tracd m t = t
-- tracd = trace
compute :: SourceGrammar -> Exp -> Err Exp
compute :: SourceGrammar -> Term -> Err Term
compute = computeAbsTerm
computeAbsTerm :: SourceGrammar -> Exp -> Err Exp
computeAbsTerm :: SourceGrammar -> Term -> Err Term
computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
-- | a hack to make compute work on source grammar as well
type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
computeAbsTermIn :: LookDef -> [Ident] -> Term -> Err Term
computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where
compt vv t = case t of
-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)

4
src/compiler/GF/Compile/TypeCheck/Abstract.hs
View File

@@ -41,7 +41,7 @@ initTCEnv gamma =
type2val :: Type -> Val
type2val = VClos []
cont2exp :: Context -> Exp
cont2exp :: Context -> Term
cont2exp c = mkProd c eType [] -- to check a context
cont2val :: Context -> Val
@@ -49,7 +49,7 @@ cont2val = type2val . cont2exp
-- some top-level batch-mode checkers for the compiler
justTypeCheck :: SourceGrammar -> Exp -> Val -> Err Constraints
justTypeCheck :: SourceGrammar -> Term -> Val -> Err Constraints
justTypeCheck gr e v = do
(_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
(constrs1,_) <- unifyVal constrs0

16
src/compiler/GF/Compile/TypeCheck/TC.hs
View File

@@ -59,7 +59,7 @@ lookupConst :: Theory -> QIdent -> Err Val
lookupConst th f = th f
lookupVar :: Env -> Ident -> Err Val
lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,uVal):g)
lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,VClos [] (Meta 0)):g)
-- wild card IW: no error produced, ?0 instead.
type TCEnv = (Int,Env,Env)
@@ -82,7 +82,7 @@ app u v = case u of
VClos env (Abs _ x e) -> eval ((x,v):env) e
_ -> return $ VApp u v
eval :: Env -> Exp -> Err Val
eval :: Env -> Term -> Err Val
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
case e of
Vr x -> lookupVar env x
@@ -115,10 +115,10 @@ eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
_ -> return [(w1,w2) | w1 /= w2]
-- invariant: constraints are in whnf
checkType :: Theory -> TCEnv -> Exp -> Err (AExp,[(Val,Val)])
checkType :: Theory -> TCEnv -> Term -> Err (AExp,[(Val,Val)])
checkType th tenv e = checkExp th tenv e vType
checkExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
checkExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
checkExp th tenv@(k,rho,gamma) e ty = do
typ <- whnf ty
let v = VGen k
@@ -169,13 +169,13 @@ checkExp th tenv@(k,rho,gamma) e ty = do
return (AGlue x y,cs1++cs2++cs3)
_ -> checkInferExp th tenv e typ
checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
checkInferExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
checkInferExp th tenv@(k,_,_) e typ = do
(e',w,cs1) <- inferExp th tenv e
cs2 <- eqVal k w typ
return (e',cs1 ++ cs2)
inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
Q (m,c) | m == cPredefAbs && isPredefCat c
@@ -231,7 +231,7 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
Just val -> do (aexp,cs) <- checkExp th tenv exp val
return ((lbl,(val,aexp)),cs)
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Exp],AExp),[(Val,Val)])
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
chB tenv' ps' ty
where
@@ -276,7 +276,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)])
checkPatt :: Theory -> TCEnv -> Term -> Val -> Err (Binds,[(Val,Val)])
checkPatt th tenv exp val = do
(aexp,_,cs) <- checkExpP tenv exp val
let binds = extrBinds aexp

2
src/compiler/GF/Grammar.hs
View File

@@ -16,7 +16,6 @@ module GF.Grammar
( module GF.Grammar.Grammar,
module GF.Grammar.Values,
module GF.Grammar.Macros,
module GF.Grammar.MMacros,
module GF.Grammar.Printer,
module GF.Infra.Ident
) where
@@ -24,6 +23,5 @@ module GF.Grammar
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Macros
import GF.Grammar.MMacros
import GF.Grammar.Printer
import GF.Infra.Ident

280
src/compiler/GF/Grammar/MMacros.hs
View File

@@ -1,280 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MMacros
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/10 12:49:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.9 $
--
-- some more abstractions on grammars, esp. for Edit
-----------------------------------------------------------------------------
module GF.Grammar.MMacros where
import GF.Data.Operations
--import GF.Data.Zipper
import GF.Grammar.Grammar
import GF.Grammar.Printer
import GF.Infra.Ident
--import GF.Compile.Refresh
import GF.Grammar.Values
----import GrammarST
import GF.Grammar.Macros
import Control.Monad
import GF.Text.Pretty
-- ** Some more abstractions on grammars, esp. for Edit
{-
nodeTree :: Tree -> TrNode
argsTree :: Tree -> [Tree]
nodeTree (Tr (n,_)) = n
argsTree (Tr (_,ts)) = ts
isFocusNode :: TrNode -> Bool
bindsNode :: TrNode -> Binds
atomNode :: TrNode -> Atom
valNode :: TrNode -> Val
constrsNode :: TrNode -> Constraints
metaSubstsNode :: TrNode -> MetaSubst
isFocusNode (N (_,_,_,_,b)) = b
bindsNode (N (b,_,_,_,_)) = b
atomNode (N (_,a,_,_,_)) = a
valNode (N (_,_,v,_,_)) = v
constrsNode (N (_,_,_,(c,_),_)) = c
metaSubstsNode (N (_,_,_,(_,m),_)) = m
atomTree :: Tree -> Atom
valTree :: Tree -> Val
atomTree = atomNode . nodeTree
valTree = valNode . nodeTree
mkNode :: Binds -> Atom -> Val -> (Constraints, MetaSubst) -> TrNode
mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False)
metasTree :: Tree -> [MetaId]
metasTree = concatMap metasNode . scanTree where
metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n)
varsTree :: Tree -> [(Var,Val)]
varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t]
constrsTree :: Tree -> Constraints
constrsTree = constrsNode . nodeTree
allConstrsTree :: Tree -> Constraints
allConstrsTree = concatMap constrsNode . scanTree
changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode
changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x)
changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode
changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x)
changeAtom :: (Atom -> Atom) -> TrNode -> TrNode
changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x)
-- * on the way to Edit
uTree :: Tree
uTree = Tr (uNode, []) -- unknown tree
uNode :: TrNode
uNode = mkNode [] uAtom uVal ([],[])
uAtom :: Atom
uAtom = AtM meta0
mAtom :: Atom
mAtom = AtM meta0
-}
type Var = Ident
uVal :: Val
uVal = vClos uExp
vClos :: Exp -> Val
vClos = VClos []
uExp :: Exp
uExp = Meta meta0
mExp, mExp0 :: Exp
mExp = Meta meta0
mExp0 = mExp
meta2exp :: MetaId -> Exp
meta2exp = Meta
{-
atomC :: Fun -> Atom
atomC = AtC
funAtom :: Atom -> Err Fun
funAtom a = case a of
AtC f -> return f
_ -> prtBad "not function head" a
atomIsMeta :: Atom -> Bool
atomIsMeta atom = case atom of
AtM _ -> True
_ -> False
getMetaAtom :: Atom -> Err MetaId
getMetaAtom a = case a of
AtM m -> return m
_ -> Bad "the active node is not meta"
-}
cat2val :: Context -> Cat -> Val
cat2val cont cat = vClos $ mkApp (Q cat) [Meta i | i <- [1..length cont]]
val2cat :: Val -> Err Cat
val2cat v = liftM valCat (val2exp v)
substTerm :: [Ident] -> Substitution -> Term -> Term
substTerm ss g c = case c of
Vr x -> maybe c id $ lookup x g
App f a -> App (substTerm ss g f) (substTerm ss g a)
Abs b x t -> let y = mkFreshVarX ss x in
Abs b y (substTerm (y:ss) ((x, Vr y):g) t)
Prod b x a t -> let y = mkFreshVarX ss x in
Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t)
_ -> c
metaSubstExp :: MetaSubst -> [(MetaId,Exp)]
metaSubstExp msubst = [(m, fromErr (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
-- ** belong here rather than to computation
substitute :: [Var] -> Substitution -> Exp -> Err Exp
substitute v s = return . substTerm v s
alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp ---
alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')]
--alphaFresh :: [Var] -> Exp -> Err Exp
--alphaFresh vs = refreshTermN $ maxVarIndex vs
-- | done in a state monad
--alphaFreshAll :: [Var] -> [Exp] -> Err [Exp]
--alphaFreshAll vs = mapM $ alphaFresh vs
-- | for display
val2exp :: Val -> Err Exp
val2exp = val2expP False
-- | for type checking
val2expSafe :: Val -> Err Exp
val2expSafe = val2expP True
val2expP :: Bool -> Val -> Err Exp
val2expP safe v = case v of
VClos g@(_:_) e@(Meta _) -> if safe
then Bad (render ("unsafe value substitution" <+> ppValue Unqualified 0 v))
else substVal g e
VClos g e -> substVal g e
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
VCn c -> return $ Q c
VGen i x -> if safe
then Bad (render ("unsafe val2exp" <+> ppValue Unqualified 0 v))
else return $ Vr $ x --- in editing, no alpha conversions presentv
VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs
return (RecType xs)
VType -> return typeType
where
substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
isConstVal :: Val -> Bool
isConstVal v = case v of
VApp f c -> isConstVal f && isConstVal c
VCn _ -> True
VClos [] e -> null $ freeVarsExp e
_ -> False --- could be more liberal
mkProdVal :: Binds -> Val -> Err Val ---
mkProdVal bs v = do
bs' <- mapPairsM val2exp bs
v' <- val2exp v
return $ vClos $ foldr (uncurry (Prod Explicit)) v' bs'
freeVarsExp :: Exp -> [Ident]
freeVarsExp e = case e of
Vr x -> [x]
App f c -> freeVarsExp f ++ freeVarsExp c
Abs _ x b -> filter (/=x) (freeVarsExp b)
Prod _ x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
_ -> [] --- thus applies to abstract syntax only
int2var :: Int -> Ident
int2var = identS . ('$':) . show
meta0 :: MetaId
meta0 = 0
termMeta0 :: Term
termMeta0 = Meta meta0
identVar :: Term -> Err Ident
identVar (Vr x) = return x
identVar _ = Bad "not a variable"
-- | light-weight rename for user interaction; also change names of internal vars
qualifTerm :: ModuleName -> Term -> Term
qualifTerm m = qualif [] where
qualif xs t = case t of
Abs b x t -> let x' = chV x in Abs b x' $ qualif (x':xs) t
Prod b x a t -> Prod b x (qualif xs a) $ qualif (x:xs) t
Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q (m,x))
Cn c -> Q (m,c)
Con c -> QC (m,c)
_ -> composSafeOp (qualif xs) t
chV x = string2var $ ident2raw x
string2var :: RawIdent -> Ident
string2var s = case showRawIdent s of
c:'_':i -> identV (rawIdentS [c]) (readIntArg i) ---
_ -> identC s
-- | reindex variables so that they tell nesting depth level
reindexTerm :: Term -> Term
reindexTerm = qualif (0,[]) where
qualif dg@(d,g) t = case t of
Abs b x t -> let x' = ind x d in Abs b x' $ qualif (d+1, (x,x'):g) t
Prod b x a t -> let x' = ind x d in Prod b x' (qualif dg a) $ qualif (d+1, (x,x'):g) t
Vr x -> Vr $ look x g
_ -> composSafeOp (qualif dg) t
look x = maybe x id . lookup x --- if x is not in scope it is unchanged
ind x d = identC $ ident2raw x `prefixRawIdent` rawIdentS "_" `prefixRawIdent` rawIdentS (show d)
{-
-- this method works for context-free abstract syntax
-- and is meant to be used in simple embedded GF applications
exp2tree :: Exp -> Err Tree
exp2tree e = do
(bs,f,xs) <- termForm e
cont <- case bs of
[] -> return []
_ -> prtBad "cannot convert bindings in" e
at <- case f of
Q m c -> return $ AtC (m,c)
QC m c -> return $ AtC (m,c)
Meta m -> return $ AtM m
K s -> return $ AtL s
EInt n -> return $ AtI n
EFloat n -> return $ AtF n
_ -> prtBad "cannot convert to atom" f
ts <- mapM exp2tree xs
return $ Tr (N (cont,at,uVal,([],[]),True),ts)
-}

12
src/compiler/GF/Grammar/Macros.hs
View File

@@ -565,7 +565,6 @@ strsFromTerm t = case t of
stringFromTerm :: Term -> String
stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
getTableType :: TInfo -> Err Type
getTableType i = case i of
TTyped ty -> return ty
@@ -646,14 +645,3 @@ topoSortJments2 (m,mi) = do
(topoTest2 (allDependencies (==m) (jments mi)))
return
[[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]
{-
-- | Smart constructor for PSeq
pSeq p1 p2 =
case (p1,p2) of
(PString s1,PString s2) -> PString (s1++s2)
(PSeq p11 (PString s1),PString s2) -> PSeq p11 (PString (s1++s2))
(PString s1,PSeq (PString s2) p22) -> PSeq (PString (s1++s2)) p22
(PSeq p11 (PString s1),PSeq (PString s2) p22) ->
PSeq p11 (PSeq (PString (s1++s2)) p22)
_ -> PSeq p1 p2
-}

22
src/compiler/GF/Grammar/Unify.hs
View File

@@ -27,8 +27,8 @@ unifyVal :: Constraints -> Err (Constraints,MetaSubst)
unifyVal cs0 = do
let (cs1,cs2) = partition notSolvable cs0
let (us,vs) = unzip cs2
us' <- mapM val2exp us
vs' <- mapM val2exp vs
let us' = map val2term us
let vs' = map val2term vs
let (ms,cs) = unifyAll (zip us' vs') []
return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs],
[(m, VClos [] t) | (m,t) <- ms])
@@ -88,6 +88,16 @@ substMetas subst trm = case trm of
_ -> trm
_ -> composSafeOp (substMetas subst) trm
substTerm :: [Ident] -> Substitution -> Term -> Term
substTerm ss g c = case c of
Vr x -> maybe c id $ lookup x g
App f a -> App (substTerm ss g f) (substTerm ss g a)
Abs b x t -> let y = mkFreshVarX ss x in
Abs b y (substTerm (y:ss) ((x, Vr y):g) t)
Prod b x a t -> let y = mkFreshVarX ss x in
Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t)
_ -> c
occCheck :: MetaId -> Term -> Bool
occCheck s u = case u of
Meta v -> s == v
@@ -95,3 +105,11 @@ occCheck s u = case u of
Abs _ x b -> occCheck s b
_ -> False
val2term :: Val -> Term
val2term v = case v of
VClos g e -> substTerm [] (map (\(x,v) -> (x,val2term v)) g) e
VApp f c -> App (val2term f) (val2term c)
VCn c -> Q c
VGen i x -> Vr x
VRecType xs -> RecType (map (\(l,v) -> (l,val2term v)) xs)
VType -> typeType

46
src/compiler/GF/Grammar/Values.hs
View File

@@ -13,45 +13,26 @@
-----------------------------------------------------------------------------
module GF.Grammar.Values (-- ** Values used in TC type checking
Exp, Val(..), Env,
Val(..), Env,
-- ** Annotated tree used in editing
--Z Tree, TrNode(..), Atom(..),
Binds, Constraints, MetaSubst,
-- ** For TC
valAbsInt, valAbsFloat, valAbsString, vType,
isPredefCat,
eType,
--Z tree2exp, loc2treeFocus
) where
--import GF.Data.Operations
---Z import GF.Data.Zipper
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Predef
-- values used in TC type checking
type Exp = Term
data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | VType | VClos Env Exp
data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | VType | VClos Env Term
deriving (Eq,Show)
type Env = [(Ident,Val)]
{-
-- annotated tree used in editing
type Tree = Tr TrNode
newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool)
deriving (Eq,Show)
data Atom =
AtC Fun | AtM MetaId | AtV Ident | AtL String | AtI Integer | AtF Double
deriving (Eq,Show)
-}
type Binds = [(Ident,Val)]
type Constraints = [(Val,Val)]
type MetaSubst = [(MetaId,Val)]
@@ -71,26 +52,5 @@ valAbsString = VCn (cPredefAbs, cString)
vType :: Val
vType = VType
eType :: Exp
eType :: Term
eType = Sort cType
{-
tree2exp :: Tree -> Exp
tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
at' = case at of
AtC (m,c) -> Q m c
AtV i -> Vr i
AtM m -> Meta m
AtL s -> K s
AtI s -> EInt s
AtF s -> EFloat s
bi' = map fst bi
ts' = map tree2exp ts
loc2treeFocus :: Loc TrNode -> Tree
loc2treeFocus (Loc (Tr (a,ts),p)) =
loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p))
where
(mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True),
\(N (a,b,c,d,_)) -> N(a,b,c,d,False))
-}