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

now in the command shell the primary type in the pipe is Expr not Tree. This makes the pt -compute and pt -typecheck more interesting

Browse Source
This commit is contained in:
krasimir
2009-05-23 21:33:52 +00:00
parent f9c877eec6
commit 0c46a129e6
10 changed files with 110 additions and 95 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/GF/Command/Abstract.hs
View File

@@ -25,7 +25,7 @@ data Value
deriving (Eq,Ord,Show)
data Argument
= ATree Tree
= AExpr Expr
| ANoArg
| AMacro Ident
deriving (Eq,Ord,Show)

47
src/GF/Command/Commands.hs
View File

@@ -39,10 +39,10 @@ import Text.PrettyPrint
import Debug.Trace
type CommandOutput = ([Tree],String) ---- errors, etc
type CommandOutput = ([Expr],String) ---- errors, etc
data CommandInfo = CommandInfo {
exec :: [Option] -> [Tree] -> IO CommandOutput,
exec :: [Option] -> [Expr] -> IO CommandOutput,
synopsis :: String,
syntax :: String,
explanation :: String,
@@ -117,8 +117,9 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"by the flag. The target format is postscript, unless overridden by the",
"flag -format."
],
exec = \opts ts -> do
let grph = if null ts then [] else alignLinearize pgf (head ts)
exec = \opts es -> do
let ts = toTrees es
grph = if null ts then [] else alignLinearize pgf (head ts)
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s
let view = optViewGraph opts ++ " "
@@ -261,7 +262,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
_ | isOpt "changes" opts -> changesMsg
_ | isOpt "coding" opts -> codingMsg
_ | isOpt "license" opts -> licenseMsg
[t] -> let co = getCommandOp (showTree t) in
[t] -> let co = getCommandOp (showExpr t) in
case lookCommand co (allCommands cod env) of ---- new map ??!!
Just info -> commandHelp True (co,info)
_ -> "command not found"
@@ -306,7 +307,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"gr -lang=LangHin -cat=Cl | l -table -to_devanagari -to_utf8 -- hindi table",
"l -unlexer=\"LangSwe=to_utf8 LangHin=to_devanagari,to_utf8\" -- different lexers"
],
exec = \opts -> return . fromStrings . map (optLin opts),
exec = \opts -> return . fromStrings . map (optLin opts) . toTrees,
options = [
("all","show all forms and variants"),
("bracket","show tree structure with brackets and paths to nodes"),
@@ -443,7 +444,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"pt -compute (plus one two) -- compute value",
"p \"foo\" | pt -typecheck -- type check parse results"
],
exec = \opts -> returnFromTrees . treeOps (map prOpt opts),
exec = \opts -> returnFromExprs . treeOps (map prOpt opts),
options = treeOpOptions pgf
}),
("q", emptyCommandInfo {
@@ -464,7 +465,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
("lines","return the list of lines, instead of the singleton of all contents"),
("tree","convert strings into trees")
],
exec = \opts arg -> do
exec = \opts _ -> do
let file = valStrOpts "file" "_gftmp" opts
s <- readFile file
return $ case opts of
@@ -524,7 +525,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
("ut", emptyCommandInfo {
longname = "unicode_table",
synopsis = "show a transliteration table for a unicode character set",
exec = \opts arg -> do
exec = \opts _ -> do
let t = concatMap prOpt (take 1 opts)
let out = maybe "no such transliteration" characterTable $ transliteration t
return $ fromString out,
@@ -548,8 +549,9 @@ allCommands cod env@(pgf, mos) = Map.fromList [
"by the flag. The target format is postscript, unless overridden by the",
"flag -format."
],
exec = \opts ts -> do
let funs = not (isOpt "nofun" opts)
exec = \opts es -> do
let ts = toTrees es
funs = not (isOpt "nofun" opts)
let cats = not (isOpt "nocat" opts)
let grph = visualizeTrees pgf (funs,cats) ts -- True=digraph
if isFlag "view" opts || isFlag "format" opts then do
@@ -599,13 +601,13 @@ allCommands cod env@(pgf, mos) = Map.fromList [
],
exec = \opts arg -> do
case arg of
[Fun id []] -> case Map.lookup id (funs (abstract pgf)) of
Just (ty,_,eqs) -> return $ fromString $
[EVar id] -> case Map.lookup id (funs (abstract pgf)) of
Just (ty,_,eqs) -> return $ fromString $
render (text "fun" <+> text (prCId id) <+> colon <+> ppType 0 ty $$
if null eqs
then empty
else text "def" <+> vcat [text (prCId id) <+> hsep (map (ppPatt 9) patts) <+> char '=' <+> ppExpr 0 res | Equ patts res <- eqs])
Nothing -> case Map.lookup id (cats (abstract pgf)) of
Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just hyps -> do return $ fromString $
render (text "cat" <+> text (prCId id) <+> hsep (map ppHypo hyps) $$
space $$
@@ -679,16 +681,21 @@ allCommands cod env@(pgf, mos) = Map.fromList [
optNum opts = valIntOpts "number" 1 opts
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
fromTrees ts = (ts,unlines (map showTree ts))
fromStrings ss = (map (Lit . LStr) ss, unlines ss)
fromString s = ([Lit (LStr s)], s)
fromTrees ts = (map tree2expr ts,unlines (map showTree ts))
fromStrings ss = (map (ELit . LStr) ss, unlines ss)
fromString s = ([ELit (LStr s)], s)
toTrees = map expr2tree
toStrings = map showAsString
toString = unwords . toStrings
returnFromTrees ts = return $ case ts of
[] -> (ts, "no trees found")
[] -> ([], "no trees found")
_ -> fromTrees ts
returnFromExprs es = return $ case es of
[] -> ([], "no trees found")
_ -> (es,unlines (map showExpr es))
prGrammar opts
| isOpt "cats" opts = return $ fromString $ unwords $ map showType $ categories pgf
| isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . morpho) $ optLangs opts
@@ -715,8 +722,8 @@ allCommands cod env@(pgf, mos) = Map.fromList [
app f = maybe id id (treeOp pgf f)
showAsString t = case t of
Lit (LStr s) -> s
_ -> "\n" ++ showTree t --- newline needed in other cases than the first
ELit (LStr s) -> s
_ -> "\n" ++ showExpr t --- newline needed in other cases than the first
stringOpOptions = [
("bind","bind tokens separated by Prelude.BIND, i.e. &+"),

22
src/GF/Command/Interpreter.hs
View File

@@ -27,7 +27,7 @@ data CommandEnv = CommandEnv {
morphos :: Map.Map Language Morpho,
commands :: Map.Map String CommandInfo,
commandmacros :: Map.Map String CommandLine,
expmacros :: Map.Map String Tree
expmacros :: Map.Map String Expr
}
mkCommandEnv :: Encoding -> PGF -> CommandEnv
@@ -72,18 +72,20 @@ interpretPipe enc env cs = do
appLine es = map (map (appCommand es))
-- macro definition applications: replace ?i by (exps !! i)
appCommand :: [Tree] -> Command -> Command
appCommand :: [Expr] -> Command -> Command
appCommand xs c@(Command i os arg) = case arg of
ATree e -> Command i os (ATree (app e))
AExpr e -> Command i os (AExpr (app e))
_ -> c
where
app e = case e of
Meta i -> xs !! i
Fun f as -> Fun f (map app as)
Abs x b -> Abs x (app b)
EAbs x e -> EAbs x (app e)
EApp e1 e2 -> EApp (app e1) (app e2)
ELit l -> ELit l
EMeta i -> xs !! i
EVar x -> EVar x
-- return the trees to be sent in pipe, and the output possibly printed
interpret :: (String -> String) -> CommandEnv -> [Tree] -> Command -> IO CommandOutput
interpret :: (String -> String) -> CommandEnv -> [Expr] -> Command -> IO CommandOutput
interpret enc env trees0 comm = case lookCommand co comms of
Just info -> do
checkOpts info
@@ -108,15 +110,15 @@ interpret enc env trees0 comm = case lookCommand co comms of
-- analyse command parse tree to a uniform datastructure, normalizing comm name
--- the env is needed for macro lookup
getCommand :: CommandEnv -> Command -> [Tree] -> (String,[Option],[Tree])
getCommand :: CommandEnv -> Command -> [Expr] -> (String,[Option],[Expr])
getCommand env co@(Command c opts arg) ts =
(getCommandOp c,opts,getCommandArg env arg ts)
getCommandArg :: CommandEnv -> Argument -> [Tree] -> [Tree]
getCommandArg :: CommandEnv -> Argument -> [Expr] -> [Expr]
getCommandArg env a ts = case a of
AMacro m -> case Map.lookup m (expmacros env) of
Just t -> [t]
_ -> []
ATree t -> [t] -- ignore piped
AExpr t -> [t] -- ignore piped
ANoArg -> ts -- use piped

2
src/GF/Command/Parse.hs
View File

@@ -51,7 +51,7 @@ pFilename = liftM2 (:) (RP.satisfy isFileFirst) (RP.munch (not . isSpace)) where
pArgument =
RP.option ANoArg
(fmap ATree (pTree False)
(fmap AExpr pExpr
RP.<++
(RP.munch isSpace >> RP.char '%' >> fmap AMacro pIdent))

16
src/GF/Command/TreeOperations.hs
View File

@@ -6,13 +6,9 @@ module GF.Command.TreeOperations (
import GF.Compile.TypeCheck
import PGF
--import GF.Compile.GrammarToGFCC (mkType,mkExp)
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.Macros as M
import Data.List
type TreeOp = [Tree] -> [Tree]
type TreeOp = [Expr] -> [Expr]
treeOp :: PGF -> String -> Maybe TreeOp
treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
@@ -20,20 +16,20 @@ treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
allTreeOps :: PGF -> [(String,(String,TreeOp))]
allTreeOps pgf = [
("compute",("compute by using semantic definitions (def)",
map (expr2tree pgf . tree2expr))),
map (compute pgf))),
("paraphrase",("paraphrase by using semantic definitions (def)",
nub . concatMap (paraphrase pgf))),
map tree2expr . nub . concatMap (paraphrase pgf . expr2tree))),
("smallest",("sort trees from smallest to largest, in number of nodes",
smallest)),
("typecheck",("type check and solve metavariables; reject if incorrect",
concatMap (typecheck pgf)))
]
smallest :: [Tree] -> [Tree]
smallest :: [Expr] -> [Expr]
smallest = sortBy (\t u -> compare (size t) (size u)) where
size t = case t of
Abs _ b -> size b + 1
Fun f ts -> sum (map size ts) + 1
EAbs _ e -> size e + 1
EApp e1 e2 -> size e1 + size e2 + 1
_ -> 1
{-

2
src/GFI.hs
View File

@@ -141,7 +141,7 @@ loop opts gfenv0 = do
_ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv
"dt":f:ws -> do
case readTree (unwords ws) of
case readExpr (unwords ws) of
Just exp -> loopNewCPU $ gfenv {
commandenv = env {
expmacros = Map.insert f exp (expmacros env)

11
src/PGF.hs
View File

@@ -48,7 +48,7 @@ module PGF(
parse, canParse, parseAllLang, parseAll,
-- ** Evaluation
tree2expr, PGF.expr2tree, paraphrase, typecheck,
tree2expr, expr2tree, PGF.compute, paraphrase, typecheck,
-- ** Word Completion (Incremental Parsing)
complete,
@@ -287,9 +287,6 @@ complete pgf from typ input =
| otherwise = (init ws, last ws)
where ws = words s
-- | Converts an expression to tree. The expression
-- is first reduced to beta-eta-alfa normal form and
-- after that converted to tree. The function definitions
-- are used in the computation.
expr2tree :: PGF -> Expr -> Tree
expr2tree pgf = PGF.Data.expr2tree (funs (abstract pgf))
-- | Converts an expression to normal form
compute :: PGF -> Expr -> Expr
compute pgf = PGF.Data.normalForm (funs (abstract pgf))

95
src/PGF/Expr.hs
View File

@@ -4,7 +4,7 @@ module PGF.Expr(Tree(..), Literal(..),
Expr(..), Patt(..), Equation(..),
readExpr, showExpr, pExpr, ppExpr, ppPatt,
tree2expr, expr2tree,
tree2expr, expr2tree, normalForm,
-- needed in the typechecker
Value(..), Env, eval, apply, eqValue,
@@ -42,9 +42,7 @@ data Tree =
deriving (Eq, Ord)
-- | An expression represents a potentially unevaluated expression
-- in the abstract syntax of the grammar. It can be evaluated with
-- the 'expr2tree' function and then linearized or it can be used
-- directly in the dependent types.
-- in the abstract syntax of the grammar.
data Expr =
EAbs CId Expr -- ^ lambda abstraction
| EApp Expr Expr -- ^ application
@@ -111,7 +109,7 @@ pTrees :: RP.ReadP [Tree]
pTrees = liftM2 (:) (pTree True) pTrees RP.<++ (RP.skipSpaces >> return [])
pTree :: Bool -> RP.ReadP Tree
pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Lit pLit RP.<++ pMeta)
pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Lit pLit RP.<++ fmap Meta pMeta)
where
pParen = RP.between (RP.char '(') (RP.char ')') (pTree False)
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
@@ -120,9 +118,6 @@ pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Li
pApp = do f <- pCId
ts <- (if isNested then return [] else pTrees)
return (Fun f ts)
pMeta = do RP.char '?'
n <- fmap read (RP.munch1 isDigit)
return (Meta n)
pExpr :: RP.ReadP Expr
pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm)
@@ -133,14 +128,16 @@ pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm)
e <- pExpr
return (foldr EAbs e xs)
pFactor = fmap EVar pCId
RP.<++ fmap ELit pLit
RP.<++ pMeta
pFactor = fmap EVar pCId
RP.<++ fmap ELit pLit
RP.<++ fmap EMeta pMeta
RP.<++ RP.between (RP.char '(') (RP.char ')') pExpr
where
pMeta = do RP.char '?'
n <- fmap read (RP.munch1 isDigit)
return (EMeta n)
pMeta = do RP.char '?'
cs <- RP.look
case cs of
(c:_) | isDigit c -> fmap read (RP.munch1 isDigit)
_ -> return 0
pLit :: RP.ReadP Literal
pLit = pNum RP.<++ liftM LStr pStr
@@ -166,7 +163,7 @@ ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<>
ppTree d (Fun f []) = PP.text (prCId f)
ppTree d (Fun f ts) = ppParens (d > 0) (PP.text (prCId f) PP.<+> PP.hsep (map (ppTree 1) ts))
ppTree d (Lit l) = ppLit l
ppTree d (Meta n) = PP.char '?' PP.<> PP.int n
ppTree d (Meta n) = ppMeta n
ppTree d (Var id) = PP.text (prCId id)
@@ -181,7 +178,7 @@ ppExpr d (EAbs x e) = let (xs,e1) = getVars (EAbs x e)
getVars e = ([],e)
ppExpr d (EApp e1 e2) = ppParens (d > 1) ((ppExpr 1 e1) PP.<+> (ppExpr 2 e2))
ppExpr d (ELit l) = ppLit l
ppExpr d (EMeta n) = PP.char '?' PP.<+> PP.int n
ppExpr d (EMeta n) = ppMeta n
ppExpr d (EVar f) = PP.text (prCId f)
ppPatt d (PApp f ps) = ppParens (d > 1) (PP.text (prCId f) PP.<+> PP.hsep (map (ppPatt 2) ps))
@@ -193,15 +190,20 @@ ppLit (LStr s) = PP.text (show s)
ppLit (LInt n) = PP.integer n
ppLit (LFlt d) = PP.double d
ppMeta n
| n == 0 = PP.char '?'
| otherwise = PP.char '?' PP.<> PP.int n
ppParens True = PP.parens
ppParens False = id
-----------------------------------------------------
-- Evaluation
-- Conversion Expr <-> Tree
-----------------------------------------------------
-- | Converts a tree to expression.
-- | Converts a tree to expression. The conversion
-- is always total, every tree is a valid expression.
tree2expr :: Tree -> Expr
tree2expr (Fun x ts) = foldl EApp (EVar x) (map tree2expr ts)
tree2expr (Lit l) = ELit l
@@ -209,29 +211,40 @@ tree2expr (Meta n) = EMeta n
tree2expr (Abs xs t) = foldr EAbs (tree2expr t) xs
tree2expr (Var x) = EVar x
-- | Converts an expression to tree. The expression
-- is first reduced to beta-eta-alfa normal form and
-- after that converted to tree.
expr2tree :: Funs -> Expr -> Tree
expr2tree funs e = value2tree [] (eval funs Map.empty e)
-- | Converts an expression to tree. The conversion is only partial.
-- Variables and meta variables of function type and beta redexes are not allowed.
expr2tree :: Expr -> Tree
expr2tree e = abs [] e
where
value2tree xs (VApp f vs) = case Map.lookup f funs of
Just (DTyp hyps _ _,_,_) -> -- eta conversion
let a1 = length hyps
a2 = length vs
a = a1 - a2
i = length xs
xs' = [var i | i <- [i..i+a-1]]
in ret (reverse xs'++xs)
(Fun f (map (value2tree []) vs++map Var xs'))
Nothing -> error ("unknown variable "++prCId f)
value2tree xs (VGen i vs) | null vs = ret xs (Var (var i))
| otherwise = error "variable of function type"
value2tree xs (VMeta n vs) | null vs = ret xs (Meta n)
| otherwise = error "meta variable of function type"
value2tree xs (VLit l) = ret xs (Lit l)
value2tree xs (VClosure env (EAbs x e)) = let i = length xs
in value2tree (var i:xs) (eval funs (Map.insert x (VGen i []) env) e)
abs xs (EAbs x e) = abs (x:xs) e
abs xs e = case xs of
[] -> app [] e
xs -> Abs (reverse xs) (app [] e)
app as (EApp e1 e2) = app ((abs [] e2) : as) e1
app as (ELit l)
| null as = Lit l
| otherwise = error "literal of function type encountered"
app as (EMeta n)
| null as = Meta n
| otherwise = error "meta variables of function type are not allowed in trees"
app as (EAbs x e) = error "beta redexes are not allowed in trees"
app as (EVar x) = Fun x as
-----------------------------------------------------
-- Computation
-----------------------------------------------------
-- | Compute an expression to normal form
normalForm :: Funs -> Expr -> Expr
normalForm funs e = value2expr 0 (eval funs Map.empty e)
where
value2expr i (VApp f vs) = foldl EApp (EVar f) (map (value2expr i) vs)
value2expr i (VGen j vs) = foldl EApp (EVar (var j)) (map (value2expr i) vs)
value2expr i (VMeta n vs) = foldl EApp (EMeta n) (map (value2expr i) vs)
value2expr i (VLit l) = ELit l
value2expr i (VClosure env (EAbs x e)) = EAbs (var i) (value2expr (i+1) (eval funs (Map.insert x (VGen i []) env) e))
var i = mkCId ('v':show i)

2
src/PGF/Paraphrase.hs
View File

@@ -49,7 +49,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where
[(ps,p) | (p,d@(Fun g ps)) <- equs, g==f,
isClosed d || (length equs == 1 && isLinear d)]
equss = [(f,[(Fun f (map patt2tree ps), expr2tree (funs (abstract pgf)) d) | (Equ ps d) <- eqs]) |
equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) |
(f,(_,_,eqs)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True

6
src/PGF/TypeCheck.hs
View File

@@ -26,9 +26,9 @@ import Data.List (partition,sort,groupBy)
import Debug.Trace
typecheck :: PGF -> Tree -> [Tree]
typecheck pgf t = case inferExpr pgf (newMetas (tree2expr t)) of
Ok t -> [expr2tree (funs (abstract pgf)) t]
typecheck :: PGF -> Expr -> [Expr]
typecheck pgf e = case inferExpr pgf (newMetas e) of
Ok e -> [e]
Bad s -> trace s []
inferExpr :: PGF -> Expr -> Err Expr