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

split the Exp type to Tree and Expr

Browse Source
This commit is contained in:
krasimir
2008-06-19 12:48:29 +00:00
parent 0442d67e8c
commit c0d22bec2d
23 changed files with 613 additions and 477 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
GF.cabal
View File

@@ -37,7 +37,7 @@ library
PGF.Parsing.FCFG.Active
PGF.Parsing.FCFG.Incremental
PGF.Parsing.FCFG
PGF.ExprSyntax
PGF.Expr
PGF.Raw.Parse
PGF.Raw.Print
PGF.Raw.Convert

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

@@ -24,7 +24,7 @@ data Value
deriving (Eq,Ord,Show)
data Argument
= AExp Exp
= ATree Tree
| ANoArg
| AMacro Ident
deriving (Eq,Ord,Show)

26
src-3.0/GF/Command/Commands.hs
View File

@@ -20,7 +20,7 @@ import GF.Compile.Export
import GF.Infra.Option (noOptions)
import GF.Infra.UseIO
import GF.Data.ErrM ----
import PGF.ExprSyntax (readExp)
import PGF.Expr (readTree)
import GF.Command.Abstract
import GF.Text.Lexing
import GF.Text.Transliterations
@@ -29,12 +29,12 @@ import GF.Data.Operations
import Data.Maybe
import qualified Data.Map as Map
import System
import System.Cmd
type CommandOutput = ([Exp],String) ---- errors, etc
type CommandOutput = ([Tree],String) ---- errors, etc
data CommandInfo = CommandInfo {
exec :: [Option] -> [Exp] -> IO CommandOutput,
exec :: [Option] -> [Tree] -> IO CommandOutput,
synopsis :: String,
syntax :: String,
explanation :: String,
@@ -192,7 +192,7 @@ allCommands pgf = Map.fromList [
("full","give full information of the commands")
],
exec = \opts ts -> return ([], case ts of
[t] -> let co = showExp t in
[t] -> let co = showTree t in
case lookCommand co (allCommands pgf) of ---- new map ??!!
Just info -> commandHelp True (co,info)
_ -> "command not found"
@@ -381,9 +381,9 @@ allCommands pgf = Map.fromList [
s <- readFile file
return $ case opts of
_ | isOpt "lines" opts && isOpt "tree" opts ->
fromTrees [t | l <- lines s, Just t <- [readExp l]]
fromTrees [t | l <- lines s, Just t <- [readTree l]]
_ | isOpt "tree" opts ->
fromTrees [t | Just t <- [readExp s]]
fromTrees [t | Just t <- [readTree s]]
_ | isOpt "lines" opts -> fromStrings $ lines s
_ -> fromString s,
flags = [("file","the input file name")]
@@ -469,7 +469,7 @@ allCommands pgf = Map.fromList [
_ -> linearize pgf lang
treebank opts t = unlines $
(abstractName pgf ++ ": " ++ showExp t) :
(abstractName pgf ++ ": " ++ showTree t) :
[lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
optRestricted opts = restrictPGF (hasLin pgf (mkCId (optLang opts))) pgf
@@ -483,11 +483,11 @@ allCommands pgf = Map.fromList [
optNum opts = valIntOpts "number" 1 opts
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
fromTrees ts = (ts,unlines (map showExp ts))
fromStrings ss = (map EStr ss, unlines ss)
fromString s = ([EStr s], s)
toStrings ts = [s | EStr s <- ts]
toString ts = unwords [s | EStr s <- ts]
fromTrees ts = (ts,unlines (map showTree ts))
fromStrings ss = (map (Lit . LStr) ss, unlines ss)
fromString s = ([Lit (LStr s)], s)
toStrings ts = [s | Lit (LStr s) <- ts]
toString ts = unwords [s | Lit (LStr s) <- ts]
prGrammar opts = case opts of
_ | isOpt "cats" opts -> unwords $ categories pgf

24
src-3.0/GF/Command/Interpreter.hs
View File

@@ -24,7 +24,7 @@ data CommandEnv = CommandEnv {
multigrammar :: PGF,
commands :: Map.Map String CommandInfo,
commandmacros :: Map.Map String CommandLine,
expmacros :: Map.Map String Exp
expmacros :: Map.Map String Tree
}
mkCommandEnv :: PGF -> CommandEnv
@@ -64,18 +64,18 @@ interpretPipe env cs = do
appLine es = map (map (appCommand es))
-- macro definition applications: replace ?i by (exps !! i)
appCommand :: [Exp] -> Command -> Command
appCommand :: [Tree] -> Command -> Command
appCommand xs c@(Command i os arg) = case arg of
AExp e -> Command i os (AExp (app e))
_ -> c
ATree e -> Command i os (ATree (app e))
_ -> c
where
app e = case e of
EMeta i -> xs !! i
EApp f as -> EApp f (map app as)
EAbs x b -> EAbs x (app b)
Meta i -> xs !! i
Fun f as -> Fun f (map app as)
Abs x b -> Abs x (app b)
-- return the trees to be sent in pipe, and the output possibly printed
interpret :: CommandEnv -> [Exp] -> Command -> IO CommandOutput
interpret :: CommandEnv -> [Tree] -> Command -> IO CommandOutput
interpret env trees0 comm = case lookCommand co comms of
Just info -> do
checkOpts info
@@ -100,17 +100,17 @@ interpret 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 -> [Exp] -> (String,[Option],[Exp])
getCommand :: CommandEnv -> Command -> [Tree] -> (String,[Option],[Tree])
getCommand env co@(Command c opts arg) ts =
(getCommandOp c,opts,getCommandArg env arg ts)
getCommandArg :: CommandEnv -> Argument -> [Exp] -> [Exp]
getCommandArg :: CommandEnv -> Argument -> [Tree] -> [Tree]
getCommandArg env a ts = case a of
AMacro m -> case Map.lookup m (expmacros env) of
Just t -> [t]
_ -> []
AExp t -> [t] -- ignore piped
ANoArg -> ts -- use piped
ATree t -> [t] -- ignore piped
ANoArg -> ts -- use piped
-- abbreviation convention from gf commands
getCommandOp s = case break (=='_') s of

6
src-3.0/GF/Command/Parse.hs
View File

@@ -1,7 +1,7 @@
module GF.Command.Parse(readCommandLine, pCommand) where
import PGF.ExprSyntax
import PGF.Data(Exp)
import PGF.Expr
import PGF.Data(Tree)
import GF.Command.Abstract
import Data.Char
@@ -43,6 +43,6 @@ pFilename = liftM2 (:) (RP.satisfy isFileFirst) (RP.munch (not . isSpace)) where
pArgument =
RP.option ANoArg
(fmap AExp (pExp False)
(fmap ATree (pTree False)
RP.<++
(RP.munch isSpace >> RP.char '%' >> fmap AMacro pIdent))

2
src-3.0/GF/Compile/GFCCtoJS.hs
View File

@@ -31,7 +31,7 @@ pgf2js pgf =
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
absdef2js :: (CId,(Type,Exp)) -> JS.Property
absdef2js :: (CId,(Type,Expr)) -> JS.Property
absdef2js (f,(typ,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)])

6
src-3.0/GF/Compile/GenerateFCFG.hs
View File

@@ -42,7 +42,7 @@ convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats'
cats = lincats cnc
(abs_defs',conc',cats') = expandHOAS abs_defs conc cats
expandHOAS :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> ([(CId,(Type,Exp))],TermMap,TermMap)
expandHOAS :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ([(CId,(Type,Expr))],TermMap,TermMap)
expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
Map.unions [lins, hoLins, varLins],
Map.unions [lincats, hoLincats, varLincat])
@@ -97,7 +97,7 @@ fixHoasFuns (rs, cs) = ([FRule (fixName n) ps args cat lins | FRule n ps args ca
| BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
fixName n = n
convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar
convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> FGrammar
convert abs_defs cnc_defs cat_defs = getFGrammar (loop frulesEnv)
where
srules = [
@@ -193,7 +193,7 @@ convertTerm cnc_defs selector (K (KS str)) ((lbl_path,lin) : lins) =
return ((lbl_path,Right str : lin) : lins)
convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) =
do projectHead lbl_path
toks <- member (strs:[strs' | Var strs' _ <- vars])
toks <- member (strs:[strs' | Alt strs' _ <- vars])
return ((lbl_path, map Right toks ++ lin) : lins)
convertTerm cnc_defs selector (F id) lins = do term <- Map.lookup id cnc_defs
convertTerm cnc_defs selector term lins

6
src-3.0/GF/Compile/GeneratePMCFG.hs
View File

@@ -44,7 +44,7 @@ convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats'
cats = lincats cnc
(abs_defs',conc',cats') = expandHOAS abs_defs conc cats
expandHOAS :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> ([(CId,(Type,Exp))],TermMap,TermMap)
expandHOAS :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ([(CId,(Type,Expr))],TermMap,TermMap)
expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
Map.unions [lins, hoLins, varLins],
Map.unions [lincats, hoLincats, varLincat])
@@ -99,7 +99,7 @@ fixHoasFuns (!rs, !cs) = ([FRule (fixName n) ps args cat lins | FRule n ps args
| BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
fixName n = n
convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar
convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> FGrammar
convert abs_defs cnc_defs cat_defs = getFGrammar (List.foldl' (convertRule cnc_defs) emptyFRulesEnv srules)
where
srules = [
@@ -159,7 +159,7 @@ convertTerm cnc_defs sel ctype (FV vars) lins = do term <-
convertTerm cnc_defs sel ctype (S ts) ((lbl_path,lin) : lins) = foldM (\lins t -> convertTerm cnc_defs sel ctype t lins) ((lbl_path,lin) : lins) (reverse ts)
convertTerm cnc_defs sel ctype (K (KS str)) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok str : lin) : lins)
convertTerm cnc_defs sel ctype (K (KP strs vars))((lbl_path,lin) : lins) =
do toks <- member (strs:[strs' | Var strs' _ <- vars])
do toks <- member (strs:[strs' | Alt strs' _ <- vars])
return ((lbl_path, map FSymTok toks ++ lin) : lins)
convertTerm cnc_defs sel ctype (F id) lins = do term <- Map.lookup id cnc_defs
convertTerm cnc_defs sel ctype term lins

23
src-3.0/GF/Compile/GrammarToGFCC.hs
View File

@@ -119,28 +119,27 @@ mkType :: A.Type -> C.Type
mkType t = case GM.typeForm t of
Ok (hyps,(_,cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
mkExp :: A.Term -> C.Exp
mkExp :: A.Term -> C.Expr
mkExp t = case t of
A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
_ -> case GM.termForm t of
Ok (xs,c,args) -> mkAbs xs (mkApp c (map mkExp args))
where
mkAbs [] t = t
mkAbs xs t = C.EAbs [i2i x | x <- xs] t
mkApp c args = case c of
Q _ c -> C.EApp (i2i c) args
QC _ c -> C.EApp (i2i c) args
mkAbs xs t = foldr (C.EAbs . i2i) t xs
mkApp c args = case c of
Q _ c -> foldl C.EApp (C.EVar (i2i c)) args
QC _ c -> foldl C.EApp (C.EVar (i2i c)) args
Vr x -> C.EVar (i2i x)
EInt i -> C.EInt i
EFloat f -> C.EFloat f
K s -> C.EStr s
EInt i -> C.ELit (C.LInt i)
EFloat f -> C.ELit (C.LFlt f)
K s -> C.ELit (C.LStr s)
Meta (MetaSymb i) -> C.EMeta i
_ -> C.EMeta 0
mkPatt p = case p of
A.PP _ c ps -> C.EApp (i2i c) (map mkPatt ps)
A.PP _ c ps -> foldl C.EApp (C.EVar (i2i c)) (map mkPatt ps)
A.PV x -> C.EVar (i2i x)
A.PW -> C.EVar wildCId
A.PInt i -> C.EInt i
A.PInt i -> C.ELit (C.LInt i)
mkContext :: A.Context -> [C.Hypo]
mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
@@ -167,7 +166,7 @@ mkTerm tr = case tr of
App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
Abs _ t -> mkTerm t ---- only on toplevel
Alts (td,tvs) ->
C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs])
C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs])
_ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
where
mkLab (LIdent l) = case BS.unpack l of

494
src-3.0/GFI.hs
View File

@@ -1,257 +1,237 @@
module GFI (mainGFI) where
import GF.Command.Interpreter
import GF.Command.Importing
import GF.Command.Commands
import GF.Command.Abstract
import GF.Command.Parse
import GF.Data.ErrM
import GF.Grammar.API -- for cc command
import GF.Infra.UseIO
import GF.Infra.Option
import GF.System.Readline
import PGF
import PGF.Data
import PGF.Macros
import PGF.ExprSyntax (readExp)
import Data.Char
import Data.List(isPrefixOf)
import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP
import System.Cmd
import System.CPUTime
import Control.Exception
import Data.Version
import Paths_gf
mainGFI :: Options -> [FilePath] -> IO ()
mainGFI opts files = do
putStrLn welcome
gfenv <- importInEnv emptyGFEnv opts files
loop opts gfenv
return ()
loop :: Options -> GFEnv -> IO GFEnv
loop opts gfenv0 = do
let env = commandenv gfenv0
let sgr = sourcegrammar gfenv0
setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))
s <- fetchCommand (prompt env)
let gfenv = gfenv0 {history = s : history gfenv0}
let loopNewCPU gfenv' = do
cpu' <- getCPUTime
putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
loop opts $ gfenv' {cputime = cpu'}
let
pwords = case words s of
w:ws -> getCommandOp w :ws
ws -> ws
case pwords of
-- special commands, requiring source grammar in env
"!":ws -> do
system $ unwords ws
loopNewCPU gfenv
"cc":ws -> do
let
(style,term) = case ws of
('-':w):ws2 -> (pTermPrintStyle w, ws2)
_ -> (TermPrintDefault, ws)
case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of ---- pipe!
Ok x -> putStrLnFlush (showTerm style x)
Bad s -> putStrLnFlush s
loopNewCPU gfenv
"i":args -> do
gfenv' <- case parseOptions args of
Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files
Bad err -> do
putStrLn $ "Command parse error: " ++ err
return gfenv
loopNewCPU gfenv'
-- other special commands, working on GFEnv
"e":_ -> loopNewCPU $ gfenv {
commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar
}
"dc":f:ws -> do
case readCommandLine (unwords ws) of
Just comm -> loopNewCPU $ gfenv {
commandenv = env {
commandmacros = Map.insert f comm (commandmacros env)
}
}
_ -> putStrLnFlush "command definition not parsed" >> loopNewCPU gfenv
"dt":f:"<":ws -> do
case readCommandLine (unwords ws) of
Just [pip] -> do
ip <- interpretPipe env pip
case ip of
(exp:es,_) -> do
if null es then return () else
putStrLnFlush $ "ambiguous definition, selected the first one"
loopNewCPU $ gfenv {
commandenv = env {
expmacros = Map.insert f exp (expmacros env)
}
}
_ -> putStrLnFlush "no value given in definition" >> loopNewCPU gfenv
_ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv
"dt":f:ws -> do
case readExp (unwords ws) of
Just exp -> loopNewCPU $ gfenv {
commandenv = env {
expmacros = Map.insert f exp (expmacros env)
}
}
_ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv
"ph":_ -> mapM_ putStrLnFlush (reverse (history gfenv0)) >> loopNewCPU gfenv
"q":_ -> putStrLnFlush "See you." >> return gfenv
-- ordinary commands, working on CommandEnv
_ -> do
interpretCommandLine env s
loopNewCPU gfenv
importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv
importInEnv gfenv opts files
| flag optRetainResource opts =
do src <- importSource (sourcegrammar gfenv) opts files
return $ gfenv {sourcegrammar = src}
| otherwise =
do let opts' = addOptions (setOptimization OptCSE False) opts
cenv0 = commandenv gfenv
pgf0 = multigrammar cenv0
pgf1 <- importGrammar pgf0 opts' files
putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1
return $ gfenv { commandenv = (mkCommandEnv pgf1)
{commandmacros = commandmacros cenv0, expmacros = expmacros cenv0}}
--- return $ gfenv { commandenv = cenv0 {multigrammar = pgf1} } -- WHY NOT
welcome = unlines [
" ",
" * * * ",
" * * ",
" * * ",
" * ",
" * ",
" * * * * * * * ",
" * * * ",
" * * * * * * ",
" * * * ",
" * * * ",
" ",
"This is GF version "++showVersion version++". ",
"Some things may work. "
]
prompt env = absname ++ "> " where
absname = case abstractName (multigrammar env) of
"_" -> "" --- created by new Ident handling 22/5/2008
n -> n
data GFEnv = GFEnv {
sourcegrammar :: Grammar, -- gfo grammar -retain
commandenv :: CommandEnv,
history :: [String],
cputime :: Integer
}
emptyGFEnv :: GFEnv
emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0
wordCompletion cmdEnv line prefix p =
case wc_type (take p line) of
CmplCmd pref
-> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
CmplStr (Just (Command _ opts _)) s
-> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat opts)))
case mb_state0 of
Right state0 -> let ws = words (take (length s - length prefix) s)
state = foldl nextState state0 ws
compls = getCompletions state prefix
in ret ' ' (Map.keys compls)
Left _ -> ret ' ' []
CmplOpt (Just (Command n _ _)) pref
-> case Map.lookup n (commands cmdEnv) of
Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags inf, isPrefixOf pref flg]
opt_compls = ['-':opt | (opt,_) <- options inf, isPrefixOf pref opt]
ret (if null flg_compls then ' ' else '=')
(flg_compls++opt_compls)
Nothing -> ret ' ' []
CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i
-> filenameCompletionFunction prefix
CmplIdent _ pref
-> do mb_abs <- try (evaluate (abstract pgf))
case mb_abs of
Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]
Left _ -> ret ' ' []
_ -> ret ' ' []
where
pgf = multigrammar cmdEnv
optLang opts = valIdOpts "lang" (head (languages pgf)) opts
optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
ret c [x] = return [x++[c]]
ret _ xs = return xs
data CompletionType
= CmplCmd Ident
| CmplStr (Maybe Command) String
| CmplOpt (Maybe Command) Ident
| CmplIdent (Maybe Command) Ident
deriving Show
wc_type :: String -> CompletionType
wc_type = cmd_name
where
cmd_name cs =
let cs1 = dropWhile isSpace cs
in go cs1 cs1
where
go x [] = CmplCmd x
go x (c:cs)
| isIdent c = go x cs
| otherwise = cmd x cs
cmd x [] = ret CmplIdent x "" 0
cmd _ ('|':cs) = cmd_name cs
cmd _ (';':cs) = cmd_name cs
cmd x ('"':cs) = str x cs cs
cmd x ('-':cs) = option x cs cs
cmd x (c :cs)
| isIdent c = ident x (c:cs) cs
| otherwise = cmd x cs
option x y [] = ret CmplOpt x y 1
option x y (c:cs)
| isIdent c = option x y cs
| otherwise = cmd x cs
ident x y [] = ret CmplIdent x y 0
ident x y (c:cs)
| isIdent c = ident x y cs
| otherwise = cmd x cs
str x y [] = ret CmplStr x y 1
str x y ('\"':cs) = cmd x cs
str x y ('\\':c:cs) = str x y cs
str x y (c:cs) = str x y cs
ret f x y d = f cmd y
where
x1 = take (length x - length y - d) x
x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1
cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
[x] -> Just x
_ -> Nothing
isIdent c = c == '_' || c == '\'' || isAlphaNum c
module GFI (mainGFI) where
import GF.Command.Interpreter
import GF.Command.Importing
import GF.Command.Commands
import GF.Command.Abstract
import GF.Command.Parse
import GF.Data.ErrM
import GF.Grammar.API -- for cc command
import GF.Infra.UseIO
import GF.Infra.Option
import GF.System.Readline
import PGF
import PGF.Data
import PGF.Macros
import PGF.Expr (readTree)
import Data.Char
import Data.List(isPrefixOf)
import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP
import System.Cmd
import System.CPUTime
import Control.Exception
import Data.Version
import Paths_gf
mainGFI :: Options -> [FilePath] -> IO ()
mainGFI opts files = do
putStrLn welcome
gfenv <- importInEnv emptyGFEnv opts files
loop opts gfenv
return ()
loop :: Options -> GFEnv -> IO GFEnv
loop opts gfenv0 = do
let env = commandenv gfenv0
let sgr = sourcegrammar gfenv0
setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))
s <- fetchCommand (prompt env)
let gfenv = gfenv0 {history = s : history gfenv0}
let loopNewCPU gfenv' = do
cpu' <- getCPUTime
putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
loop opts $ gfenv' {cputime = cpu'}
let
pwords = case words s of
w:ws -> getCommandOp w :ws
ws -> ws
case pwords of
-- special commands, requiring source grammar in env
"!":ws -> do
system $ unwords ws
loopNewCPU gfenv
"cc":ws -> do
let
(style,term) = case ws of
('-':w):ws2 -> (pTermPrintStyle w, ws2)
_ -> (TermPrintDefault, ws)
case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of ---- pipe!
Ok x -> putStrLn (showTerm style x)
Bad s -> putStrLn s
loopNewCPU gfenv
"i":args -> do
gfenv' <- case parseOptions args of
Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files
Bad err -> do putStrLn $ "Command parse error: " ++ err
return gfenv
loopNewCPU gfenv'
-- other special commands, working on GFEnv
"e":_ -> loopNewCPU $ gfenv {
commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar
}
"dc":f:ws -> do
case readCommandLine (unwords ws) of
Just comm -> loopNewCPU $ gfenv {
commandenv = env {
commandmacros = Map.insert f comm (commandmacros env)
}
}
_ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv
"dt":f:ws -> do
case readTree (unwords ws) of
Just exp -> loopNewCPU $ gfenv {
commandenv = env {
expmacros = Map.insert f exp (expmacros env)
}
}
_ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv
"ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
"q":_ -> putStrLn "See you." >> return gfenv
-- ordinary commands, working on CommandEnv
_ -> do
interpretCommandLine env s
loopNewCPU gfenv
importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv
importInEnv gfenv opts files
| flag optRetainResource opts =
do src <- importSource (sourcegrammar gfenv) opts files
return $ gfenv {sourcegrammar = src}
| otherwise =
do let opts' = addOptions (setOptimization OptCSE False) opts
pgf0 = multigrammar (commandenv gfenv)
pgf1 <- importGrammar pgf0 opts' files
putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1
return $ gfenv { commandenv = mkCommandEnv pgf1 }
welcome = unlines [
" ",
" * * * ",
" * * ",
" * * ",
" * ",
" * ",
" * * * * * * * ",
" * * * ",
" * * * * * * ",
" * * * ",
" * * * ",
" ",
"This is GF version "++showVersion version++". ",
"Some things may work. "
]
prompt env = absname ++ "> " where
absname = case abstractName (multigrammar env) of
"_" -> "" --- created by new Ident handling 22/5/2008
n -> n
data GFEnv = GFEnv {
sourcegrammar :: Grammar, -- gfo grammar -retain
commandenv :: CommandEnv,
history :: [String],
cputime :: Integer
}
emptyGFEnv :: GFEnv
emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0
wordCompletion cmdEnv line prefix p =
case wc_type (take p line) of
CmplCmd pref
-> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
CmplStr (Just (Command _ opts _)) s
-> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat opts)))
case mb_state0 of
Right state0 -> let ws = words (take (length s - length prefix) s)
state = foldl nextState state0 ws
compls = getCompletions state prefix
in ret ' ' (Map.keys compls)
Left _ -> ret ' ' []
CmplOpt (Just (Command n _ _)) pref
-> case Map.lookup n (commands cmdEnv) of
Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags inf, isPrefixOf pref flg]
opt_compls = ['-':opt | (opt,_) <- options inf, isPrefixOf pref opt]
ret (if null flg_compls then ' ' else '=')
(flg_compls++opt_compls)
Nothing -> ret ' ' []
CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i
-> filenameCompletionFunction prefix
CmplIdent _ pref
-> do mb_abs <- try (evaluate (abstract pgf))
case mb_abs of
Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]
Left _ -> ret ' ' []
_ -> ret ' ' []
where
pgf = multigrammar cmdEnv
optLang opts = valIdOpts "lang" (head (languages pgf)) opts
optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
ret c [x] = return [x++[c]]
ret _ xs = return xs
data CompletionType
= CmplCmd Ident
| CmplStr (Maybe Command) String
| CmplOpt (Maybe Command) Ident
| CmplIdent (Maybe Command) Ident
deriving Show
wc_type :: String -> CompletionType
wc_type = cmd_name
where
cmd_name cs =
let cs1 = dropWhile isSpace cs
in go cs1 cs1
where
go x [] = CmplCmd x
go x (c:cs)
| isIdent c = go x cs
| otherwise = cmd x cs
cmd x [] = ret CmplIdent x "" 0
cmd _ ('|':cs) = cmd_name cs
cmd _ (';':cs) = cmd_name cs
cmd x ('"':cs) = str x cs cs
cmd x ('-':cs) = option x cs cs
cmd x (c :cs)
| isIdent c = ident x (c:cs) cs
| otherwise = cmd x cs
option x y [] = ret CmplOpt x y 1
option x y (c:cs)
| isIdent c = option x y cs
| otherwise = cmd x cs
ident x y [] = ret CmplIdent x y 0
ident x y (c:cs)
| isIdent c = ident x y cs
| otherwise = cmd x cs
str x y [] = ret CmplStr x y 1
str x y ('\"':cs) = cmd x cs
str x y ('\\':c:cs) = str x y cs
str x y (c:cs) = str x y cs
ret f x y d = f cmd y
where
x1 = take (length x - length y - d) x
x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1
cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
[x] -> Just x
_ -> Nothing
isIdent c = c == '_' || c == '\'' || isAlphaNum c

34
src-3.0/PGF.hs
View File

@@ -28,8 +28,13 @@ module PGF(
Category, categories, startCat,
-- * Expressions
Exp(..), Equation(..),
showExp, readExp,
-- ** Tree
Tree(..),
showTree, readTree,
-- ** Expr
Expr(..), Equation(..),
showExpr, readExpr,
-- * Operations
-- ** Linearization
@@ -38,6 +43,9 @@ module PGF(
-- ** Parsing
parse, parseAllLang, parseAll,
-- ** Evaluation
tree2expr, expr2tree,
-- ** Word Completion (Incremental Parsing)
Incremental.ParseState,
initState, Incremental.nextState, Incremental.getCompletions, extractExps,
@@ -52,7 +60,7 @@ import qualified PGF.Linearize (linearize)
import PGF.Generate
import PGF.Macros
import PGF.Data
import PGF.ExprSyntax
import PGF.Expr
import PGF.Raw.Convert
import PGF.Raw.Parse
import PGF.Raw.Print (printTree)
@@ -90,25 +98,25 @@ type Category = String
readPGF :: FilePath -> IO PGF
-- | Linearizes given expression as string in the language
linearize :: PGF -> Language -> Exp -> String
linearize :: PGF -> Language -> Tree -> String
-- | Tries to parse the given string in the specified language
-- and to produce abstract syntax expression. An empty
-- list is returned if the parsing is not successful. The list may also
-- contain more than one element if the grammar is ambiguous.
parse :: PGF -> Language -> Category -> String -> [Exp]
parse :: PGF -> Language -> Category -> String -> [Tree]
-- | The same as 'linearizeAllLang' but does not return
-- the language.
linearizeAll :: PGF -> Exp -> [String]
linearizeAll :: PGF -> Tree -> [String]
-- | Linearizes given expression as string in all languages
-- available in the grammar.
linearizeAllLang :: PGF -> Exp -> [(Language,String)]
linearizeAllLang :: PGF -> Tree -> [(Language,String)]
-- | The same as 'parseAllLang' but does not return
-- the language.
parseAll :: PGF -> Category -> String -> [[Exp]]
parseAll :: PGF -> Category -> String -> [[Tree]]
-- | Tries to parse the given string with every language
-- available in the grammar and to produce abstract syntax
@@ -117,7 +125,7 @@ parseAll :: PGF -> Category -> String -> [[Exp]]
-- for which at least one parsing is possible are listed.
-- More than one abstract syntax expressions are possible
-- if the grammar is ambiguous.
parseAllLang :: PGF -> Category -> String -> [(Language,[Exp])]
parseAllLang :: PGF -> Category -> String -> [(Language,[Tree])]
-- | Creates an initial parsing state for a given language and
-- startup category.
@@ -127,21 +135,21 @@ initState :: PGF -> Language -> Category -> Incremental.ParseState
-- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually
-- the same as the startup category.
extractExps :: Incremental.ParseState -> Category -> [Exp]
extractExps :: Incremental.ParseState -> Category -> [Tree]
-- | The same as 'generateAllDepth' but does not limit
-- the depth in the generation.
generateAll :: PGF -> Category -> [Exp]
generateAll :: PGF -> Category -> [Tree]
-- | Generates an infinite list of random abstract syntax expressions.
-- This is usefull for tree bank generation which after that can be used
-- for grammar testing.
generateRandom :: PGF -> Category -> IO [Exp]
generateRandom :: PGF -> Category -> IO [Tree]
-- | Generates an exhaustive possibly infinite list of
-- abstract syntax expressions. A depth can be specified
-- to limit the search space.
generateAllDepth :: PGF -> Category -> Maybe Int -> [Exp]
generateAllDepth :: PGF -> Category -> Maybe Int -> [Tree]
-- | List of all languages available in the given grammar.
languages :: PGF -> [Language]

62
src-3.0/PGF/Data.hs
View File

@@ -21,10 +21,10 @@ data PGF = PGF {
}
data Abstr = Abstr {
aflags :: Map.Map CId String, -- value of a flag
funs :: Map.Map CId (Type,Exp), -- type and def of a fun
cats :: Map.Map CId [Hypo], -- context of a cat
catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
aflags :: Map.Map CId String, -- value of a flag
funs :: Map.Map CId (Type,Expr), -- type and def of a fun
cats :: Map.Map CId [Hypo], -- context of a cat
catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
}
data Concr = Concr {
@@ -39,20 +39,40 @@ data Concr = Concr {
}
data Type =
DTyp [Hypo] CId [Exp]
DTyp [Hypo] CId [Expr]
deriving (Eq,Ord,Show)
-- | An expression representing the abstract syntax tree
-- in PGF. The same expression is used in the dependent
-- types.
data Exp =
EAbs [CId] Exp -- ^ lambda abstraction. The list should contain at least one variable
| EApp CId [Exp] -- ^ application. Note that unevaluated lambda abstractions are not allowed
| EStr String -- ^ string constant
| EInt Integer -- ^ integer constant
| EFloat Double -- ^ floating point constant
data Literal =
LStr String -- ^ string constant
| LInt Integer -- ^ integer constant
| LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show)
-- | The tree is an evaluated expression in the abstract syntax
-- of the grammar. The type is especially restricted to not
-- allow unapplied lambda abstractions. The meta variables
-- also does not have indices because both the parser and
-- the linearizer consider all meta variable occurrences as
-- distinct. The tree is used directly from the linearizer
-- and is produced directly from the parser.
data Tree =
Abs [CId] Tree -- ^ lambda abstraction. The list of variables is non-empty
| Var CId -- ^ variable
| Fun CId [Tree] -- ^ function application
| Lit Literal -- ^ literal
| Meta Int -- ^ meta variable. Each occurency of 'Meta' means a different metavariable
deriving (Show, 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.
data Expr =
EAbs CId Expr -- ^ lambda abstraction
| EApp Expr Expr -- ^ application
| ELit Literal -- ^ literal
| EMeta Int -- ^ meta variable
| EVar CId -- ^ variable reference
| EVar CId -- ^ variable or function reference
| EEq [Equation] -- ^ lambda function defined as a set of equations with pattern matching
deriving (Eq,Ord,Show)
@@ -71,11 +91,11 @@ data Term =
data Tokn =
KS String
| KP [String] [Variant]
| KP [String] [Alternative]
deriving (Eq,Ord,Show)
data Variant =
Var [String] [String]
data Alternative =
Alt [String] [String]
deriving (Eq,Ord,Show)
data Hypo =
@@ -83,11 +103,11 @@ data Hypo =
deriving (Eq,Ord,Show)
-- | The equation is used to define lambda function as a sequence
-- of equations with pattern matching. The list of 'Exp' represents
-- the patterns and the second 'Exp' is the function body for this
-- of equations with pattern matching. The list of 'Expr' represents
-- the patterns and the second 'Expr' is the function body for this
-- equation.
data Equation =
Equ [Exp] Exp
Equ [Expr] Expr
deriving (Eq,Ord,Show)

202
src-3.0/PGF/Expr.hs Normal file
View File

@@ -0,0 +1,202 @@
module PGF.Expr(readTree, showTree, pTree, ppTree,
readExpr, showExpr, pExpr, ppExpr,
tree2expr, expr2tree,
-- needed in the typechecker
Value(..), Env, eval,
-- helpers
pIdent,pStr
) where
import PGF.CId
import PGF.Data
import Data.Char
import Data.Maybe
import Control.Monad
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
import qualified Data.Map as Map
-- | parses 'String' as an expression
readTree :: String -> Maybe Tree
readTree s = case [x | (x,cs) <- RP.readP_to_S (pTree False) s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | renders expression as 'String'
showTree :: Tree -> String
showTree = PP.render . ppTree 0
-- | parses 'String' as an expression
readExpr :: String -> Maybe Expr
readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | renders expression as 'String'
showExpr :: Expr -> String
showExpr = PP.render . ppExpr 0
-----------------------------------------------------
-- Parsing
-----------------------------------------------------
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)
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 ','))
t <- pTree False
return (Abs xs t)
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 RP.<++ pEqs)
where
pTerm = fmap (foldl1 EApp) (RP.sepBy1 pFactor RP.skipSpaces)
pFactor = fmap EVar pCId
RP.<++ fmap ELit pLit
RP.<++ pMeta
RP.<++ RP.between (RP.char '(') (RP.char ')') pExpr
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
e <- pExpr
return (foldr EAbs e xs)
pMeta = do RP.char '?'
n <- fmap read (RP.munch1 isDigit)
return (EMeta n)
pEqs = fmap EEq $
RP.between (RP.skipSpaces >> RP.char '{')
(RP.skipSpaces >> RP.char '}')
(RP.sepBy1 (RP.skipSpaces >> pEq)
(RP.skipSpaces >> RP.string ";"))
pEq = do pats <- (RP.sepBy1 pExpr RP.skipSpaces)
RP.skipSpaces >> RP.string "=>"
e <- pExpr
return (Equ pats e)
pLit :: RP.ReadP Literal
pLit = pNum RP.<++ liftM LStr pStr
pNum = do x <- RP.munch1 isDigit
((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (LFlt (read (x++"."++y))))
RP.<++
(return (LInt (read x))))
pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
where
pEsc = RP.char '\\' >> RP.get
pCId = fmap mkCId pIdent
pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
where
isIdentFirst c = c == '_' || isLetter c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
-----------------------------------------------------
-- Printing
-----------------------------------------------------
ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+>
PP.text "->" PP.<+>
ppTree 0 t)
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 (Var id) = PP.text (prCId id)
ppExpr d (EAbs x e) = let (xs,e1) = getVars (EAbs x e)
in ppParens (d > 0) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+>
PP.text "->" PP.<+>
ppExpr 0 e1)
where
getVars (EAbs x e) = let (xs,e1) = getVars e in (x:xs,e1)
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 (EVar f) = PP.text (prCId f)
ppExpr d (EEq eqs) = PP.braces (PP.sep (PP.punctuate PP.semi (map ppEquation eqs)))
ppEquation (Equ pats e) = PP.hsep (map (ppExpr 2) pats) PP.<+> PP.text "=>" PP.<+> ppExpr 0 e
ppLit (LStr s) = PP.text (show s)
ppLit (LInt n) = PP.integer n
ppLit (LFlt d) = PP.double d
ppParens True = PP.parens
ppParens False = id
-----------------------------------------------------
-- Evaluation
-----------------------------------------------------
-- | Converts a tree to expression.
tree2expr :: Tree -> Expr
tree2expr (Fun x ts) = foldl EApp (EVar x) (map tree2expr ts)
tree2expr (Lit l) = ELit l
tree2expr (Meta n) = EMeta n
tree2expr (Abs xs t) = foldr EAbs (tree2expr t) xs
tree2expr (Var x) = EVar x
-- | Converts an expression to tree. If the expression
-- contains unevaluated applications they will be applied.
expr2tree e = value2tree (eval Map.empty e) [] []
where
value2tree (VApp v1 v2) xs ts = value2tree v1 xs (value2tree v2 [] []:ts)
value2tree (VVar x) xs ts = ret xs (fun xs x ts)
value2tree (VMeta n) xs [] = ret xs (Meta n)
value2tree (VLit l) xs [] = ret xs (Lit l)
value2tree (VClosure env (EAbs x e)) xs [] = value2tree (eval (Map.insert x (VVar x) env) e) (x:xs) []
fun xs x ts
| x `elem` xs = Var x
| otherwise = Fun x ts
ret [] t = t
ret xs t = Abs (reverse xs) t
data Value
= VGen Int
| VApp Value Value
| VVar CId
| VMeta Int
| VLit Literal
| VClosure Env Expr
type Env = Map.Map CId Value
eval :: Env -> Expr -> Value
eval env (EVar x) = fromMaybe (VVar x) (Map.lookup x env)
eval env (EApp e1 e2) = apply (eval env e1) (eval env e2)
eval env (EAbs x e) = VClosure env (EAbs x e)
eval env (EMeta k) = VMeta k
eval env (ELit l) = VLit l
apply :: Value -> Value -> Value
apply (VClosure env (EAbs x e)) v = eval (Map.insert x v env) e
apply v0 v = VApp v0 v

73
src-3.0/PGF/ExprSyntax.hs
View File

@@ -1,73 +0,0 @@
module PGF.ExprSyntax(readExp, showExp,
pExp,ppExp,
-- helpers
pIdent,pStr
) where
import PGF.CId
import PGF.Data
import Data.Char
import Control.Monad
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
-- | parses 'String' as an expression
readExp :: String -> Maybe Exp
readExp s = case [x | (x,cs) <- RP.readP_to_S (pExp False) s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | renders expression as 'String'
showExp :: Exp -> String
showExp = PP.render . ppExp False
pExps :: RP.ReadP [Exp]
pExps = liftM2 (:) (pExp True) pExps RP.<++ (RP.skipSpaces >> return [])
pExp :: Bool -> RP.ReadP Exp
pExp isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ pNum RP.<++
liftM EStr pStr RP.<++ pMeta)
where
pParen = RP.between (RP.char '(') (RP.char ')') (pExp False)
pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
t <- pExp False
return (EAbs xs t)
pApp = do f <- pCId
ts <- (if isNested then return [] else pExps)
return (EApp f ts)
pMeta = do RP.char '?'
x <- RP.munch1 isDigit
return (EMeta (read x))
pNum = do x <- RP.munch1 isDigit
((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (EFloat (read (x++"."++y))))
RP.<++
(return (EInt (read x))))
pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
where
pEsc = RP.char '\\' >> RP.get
pCId = fmap mkCId pIdent
pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
where
isIdentFirst c = c == '_' || isLetter c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
ppExp isNested (EAbs xs t) = ppParens isNested (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+>
PP.text "->" PP.<+>
ppExp False t)
ppExp isNested (EApp f []) = PP.text (prCId f)
ppExp isNested (EApp f ts) = ppParens isNested (PP.text (prCId f) PP.<+> PP.hsep (map (ppExp True) ts))
ppExp isNested (EStr s) = PP.text (show s)
ppExp isNested (EInt n) = PP.integer n
ppExp isNested (EFloat d) = PP.double d
ppExp isNested (EMeta n) = PP.char '?' PP.<> PP.int n
ppExp isNested (EVar id) = PP.text (prCId id)
ppParens True = PP.parens
ppParens False = id

18
src-3.0/PGF/Generate.hs
View File

@@ -8,23 +8,23 @@ import qualified Data.Map as M
import System.Random
-- generate an infinite list of trees exhaustively
generate :: PGF -> CId -> Maybe Int -> [Exp]
generate :: PGF -> CId -> Maybe Int -> [Tree]
generate pgf cat dp = concatMap (\i -> gener i cat) depths
where
gener 0 c = [EApp f [] | (f, ([],_)) <- fns c]
gener 0 c = [Fun f [] | (f, ([],_)) <- fns c]
gener i c = [
tr |
(f, (cs,_)) <- fns c,
let alts = map (gener (i-1)) cs,
ts <- combinations alts,
let tr = EApp f ts,
let tr = Fun f ts,
depth tr >= i
]
fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c]
depths = maybe [0 ..] (\d -> [0..d]) dp
-- generate an infinite list of trees randomly
genRandom :: StdGen -> PGF -> CId -> [Exp]
genRandom :: StdGen -> PGF -> CId -> [Tree]
genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
timeout = 47 -- give up
@@ -36,16 +36,16 @@ genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
(genTrees ds2 cat) -- else (drop k ds)
genTree rs = gett rs where
gett ds cid | cid == mkCId "String" = (EStr "foo", 1)
gett ds cid | cid == mkCId "Int" = (EInt 12345, 1)
gett [] _ = (EStr "TIMEOUT", 1) ----
gett ds cid | cid == mkCId "String" = (Lit (LStr "foo"), 1)
gett ds cid | cid == mkCId "Int" = (Lit (LInt 12345), 1)
gett [] _ = (Lit (LStr "TIMEOUT"), 1) ----
gett ds cat = case fns cat of
[] -> (EMeta 0,1)
[] -> (Meta 0,1)
fs -> let
d:ds2 = ds
(f,args) = getf d fs
(ts,k) = getts ds2 args
in (EApp f ts, k+1)
in (Fun f ts, k+1)
getf d fs = let lg = (length fs) in
fs !! (floor (d * fromIntegral lg))
getts ds cats = case cats of

26
src-3.0/PGF/Linearize.hs
View File

@@ -10,8 +10,8 @@ import Debug.Trace
-- linearization and computation of concrete PGF Terms
linearize :: PGF -> CId -> Exp -> String
linearize pgf lang = realize . linExp pgf lang
linearize :: PGF -> CId -> Tree -> String
linearize pgf lang = realize . linTree pgf lang
realize :: Term -> String
realize trm = case trm of
@@ -25,18 +25,18 @@ realize trm = case trm of
TM s -> s
_ -> "ERROR " ++ show trm ---- debug
linExp :: PGF -> CId -> Exp -> Term
linExp pgf lang = lin
linTree :: PGF -> CId -> Tree -> Term
linTree pgf lang = lin
where
lin (EAbs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs)
lin (EApp fun es) = comp (map lin es) $ look fun
lin (EStr s ) = R [kks (show s)] -- quoted
lin (EInt i ) = R [kks (show i)]
lin (EFloat d ) = R [kks (show d)]
lin (EVar x ) = TM (prCId x)
lin (EMeta i ) = TM (show i)
lin (Abs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs)
lin (Fun fun es) = comp (map lin es) $ look fun
lin (Lit (LStr s)) = R [kks (show s)] -- quoted
lin (Lit (LInt i)) = R [kks (show i)]
lin (Lit (LFlt d)) = R [kks (show d)]
lin (Var x) = TM (prCId x)
lin (Meta i) = TM (show i)
comp = compute pgf lang
look = lookLin pgf lang

10
src-3.0/PGF/Macros.hs
View File

@@ -87,10 +87,10 @@ restrictPGF cond pgf = pgf {
restrict = Map.filterWithKey (\c _ -> cond c)
abstr = abstract pgf
depth :: Exp -> Int
depth (EAbs _ t) = depth t
depth (EApp _ ts) = maximum (0:map depth ts) + 1
depth _ = 1
depth :: Tree -> Int
depth (Abs _ t) = depth t
depth (Fun _ ts) = maximum (0:map depth ts) + 1
depth _ = 1
cftype :: [CId] -> CId -> Type
cftype args val = DTyp [Hyp wildCId (cftype [] arg) | arg <- args] val []
@@ -111,7 +111,7 @@ contextLength :: Type -> Int
contextLength ty = case ty of
DTyp hyps _ _ -> length hyps
primNotion :: Exp
primNotion :: Expr
primNotion = EEq []
term0 :: CId -> Term

4
src-3.0/PGF/Parsing/FCFG.hs
View File

@@ -29,11 +29,11 @@ import qualified Data.Map as Map
-- main parsing function
parseFCFG :: String -- ^ parsing strategy
parseFCFG :: String -- ^ parsing strategy
-> ParserInfo -- ^ compiled grammar (fcfg)
-> CId -- ^ starting category
-> [String] -- ^ input tokens
-> Err [Exp] -- ^ resulting GF terms
-> Err [Tree] -- ^ resulting GF terms
parseFCFG "bottomup" pinfo start toks = return $ Active.parse "b" pinfo start toks
parseFCFG "topdown" pinfo start toks = return $ Active.parse "t" pinfo start toks
parseFCFG "incremental" pinfo start toks = return $ Incremental.parse pinfo start toks

4
src-3.0/PGF/Parsing/FCFG/Active.hs
View File

@@ -32,8 +32,8 @@ makeFinalEdge cat 0 0 = (cat, [EmptyRange])
makeFinalEdge cat i j = (cat, [makeRange i j])
-- | the list of categories = possible starting categories
parse :: String -> ParserInfo -> CId -> [FToken] -> [Exp]
parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2exps
parse :: String -> ParserInfo -> CId -> [FToken] -> [Tree]
parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2trees
where
inTokens = input toks
starts = Map.findWithDefault [] start (startupCats pinfo)

6
src-3.0/PGF/Parsing/FCFG/Incremental.hs
View File

@@ -25,7 +25,7 @@ import PGF.Data
import PGF.Parsing.FCFG.Utilities
import Debug.Trace
parse :: ParserInfo -> CId -> [FToken] -> [Exp]
parse :: ParserInfo -> CId -> [FToken] -> [Tree]
parse pinfo start toks = extractExps (foldl' nextState (initState pinfo start) toks) start
initState :: ParserInfo -> CId -> ParseState
@@ -82,7 +82,7 @@ getCompletions (State pinfo chart items) w =
| isPrefixOf w tok = fromMaybe map (MM.insert' tok item map)
| otherwise = map
extractExps :: ParseState -> CId -> [Exp]
extractExps :: ParseState -> CId -> [Tree]
extractExps (State pinfo chart items) start = exps
where
(_,st) = process (\_ _ -> id) (allRules pinfo) (Set.toList items) ((),chart)
@@ -103,7 +103,7 @@ extractExps (State pinfo chart items) start = exps
if fn == wildCId
then go (Set.insert fid rec) (head args)
else do args <- mapM (go (Set.insert fid rec)) args
return (EApp fn args)
return (Fun fn args)
process fn !rules [] acc_chart = acc_chart
process fn !rules (item:items) acc_chart = univRule item acc_chart

12
src-3.0/PGF/Parsing/FCFG/Utilities.hs
View File

@@ -179,9 +179,9 @@ applyProfileToForest (FFloat f) = [FFloat f]
applyProfileToForest (FMeta) = [FMeta]
forest2exps :: SyntaxForest CId -> [Exp]
forest2exps (FNode n forests) = map (EApp n) $ forests >>= mapM forest2exps
forest2exps (FString s) = [EStr s]
forest2exps (FInt n) = [EInt n]
forest2exps (FFloat f) = [EFloat f]
forest2exps (FMeta) = [EMeta 0]
forest2trees :: SyntaxForest CId -> [Tree]
forest2trees (FNode n forests) = map (Fun n) $ forests >>= mapM forest2trees
forest2trees (FString s) = [Lit (LStr s)]
forest2trees (FInt n) = [Lit (LInt n)]
forest2trees (FFloat f) = [Lit (LFlt f)]
forest2trees (FMeta) = [Meta 0]

26
src-3.0/PGF/Raw/Convert.hs
View File

@@ -105,16 +105,16 @@ toHypo e = case e of
App x [typ] -> Hyp (mkCId x) (toType typ)
_ -> error $ "hypo " ++ show e
toExp :: RExp -> Exp
toExp :: RExp -> Expr
toExp e = case e of
App "Abs" [App "B" xs, exp] -> EAbs [mkCId x | App x [] <- xs] (toExp exp)
App "App" (App fun [] : exps) -> EApp (mkCId fun) (map toExp exps)
App "Abs" [App x [], exp] -> EAbs (mkCId x) (toExp exp)
App "App" [e1,e2] -> EApp (toExp e1) (toExp e2)
App "Eq" eqs -> EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
App "Var" [App i []] -> EVar (mkCId i)
AMet -> EMeta 0
AInt i -> EInt i
AFlt i -> EFloat i
AStr i -> EStr i
AInt i -> ELit (LInt i)
AFlt i -> ELit (LFlt i)
AStr i -> ELit (LStr i)
_ -> error $ "exp " ++ show e
toTerm :: RExp -> Term
@@ -170,14 +170,14 @@ fromHypo :: Hypo -> RExp
fromHypo e = case e of
Hyp x typ -> App (prCId x) [fromType typ]
fromExp :: Exp -> RExp
fromExp :: Expr -> RExp
fromExp e = case e of
EAbs xs exp -> App "Abs" [App "B" (map (flip App [] . prCId) xs), fromExp exp]
EApp fun exps -> App "App" (App (prCId fun) [] : map fromExp exps)
EAbs x exp -> App "Abs" [App (prCId x) [], fromExp exp]
EApp e1 e2 -> App "App" [fromExp e1, fromExp e2]
EVar x -> App "Var" [App (prCId x) []]
EStr s -> AStr s
EFloat d -> AFlt d
EInt i -> AInt (toInteger i)
ELit (LStr s) -> AStr s
ELit (LFlt d) -> AFlt d
ELit (LInt i) -> AInt (toInteger i)
EMeta _ -> AMet ----
EEq eqs ->
App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs]
@@ -194,7 +194,7 @@ fromTerm e = case e of
F f -> App (prCId f) []
V i -> App "A" [AInt (toInteger i)]
K (KS s) -> AStr s ----
K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ----
K (KP d vs) -> App "FV" (str d : [str v | Alt v _ <- vs]) ----
where
str v = App "S" (map AStr v)

22
src-3.0/PGF/ShowLinearize.hs
View File

@@ -53,17 +53,17 @@ mkRecord typ trm = case (typ,trm) of
str = realize
-- show all branches, without labels and params
allLinearize :: PGF -> CId -> Exp -> String
allLinearize :: PGF -> CId -> Tree -> String
allLinearize pgf lang = concat . map pr . tabularLinearize pgf lang where
pr (p,vs) = unlines vs
-- show all branches, with labels and params
tableLinearize :: PGF -> CId -> Exp -> String
tableLinearize :: PGF -> CId -> Tree -> String
tableLinearize pgf lang = unlines . map pr . tabularLinearize pgf lang where
pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" vs)
-- create a table from labels+params to variants
tabularLinearize :: PGF -> CId -> Exp -> [(String,[String])]
tabularLinearize :: PGF -> CId -> Tree -> [(String,[String])]
tabularLinearize pgf lang = branches . recLinearize pgf lang where
branches r = case r of
RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
@@ -73,18 +73,18 @@ tabularLinearize pgf lang = branches . recLinearize pgf lang where
RCon _ -> []
-- show record in GF-source-like syntax
recordLinearize :: PGF -> CId -> Exp -> String
recordLinearize :: PGF -> CId -> Tree -> String
recordLinearize pgf lang = prRecord . recLinearize pgf lang
-- create a GF-like record, forming the basis of all functions above
recLinearize :: PGF -> CId -> Exp -> Record
recLinearize pgf lang exp = mkRecord typ $ linExp pgf lang exp where
typ = case exp of
EApp f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
recLinearize :: PGF -> CId -> Tree -> Record
recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where
typ = case tree of
Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
-- show PGF term
termLinearize :: PGF -> CId -> Exp -> String
termLinearize pgf lang = show . linExp pgf lang
termLinearize :: PGF -> CId -> Tree -> String
termLinearize pgf lang = show . linTree pgf lang
-- for Morphology: word, lemma, tags
@@ -94,7 +94,7 @@ collectWords pgf lang =
[(f,c,0) | (f,(DTyp [] c _,_)) <- Map.toList $ funs $ abstract pgf]
where
collOne (f,c,i) =
fromRec f [prCId c] (recLinearize pgf lang (EApp f (replicate i (EMeta 888))))
fromRec f [prCId c] (recLinearize pgf lang (Fun f (replicate i (Meta 888))))
fromRec f v r = case r of
RR rs -> concat [fromRec f v t | (_,t) <- rs]
RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs]