last-minute bug fixes

This commit is contained in:
aarne
2004-06-24 14:06:09 +00:00
parent d3db78ad31
commit 3b39607bba
20 changed files with 536 additions and 404 deletions

View File

@@ -104,6 +104,16 @@ defLinType = RecType [Lbg (L (A.identC "s")) TStr]
defLindef :: Term defLindef :: Term
defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))] defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))]
isDiscontinuousCType :: CType -> Bool
isDiscontinuousCType t = case t of
RecType rs -> length [t | Lbg _ t <- rs, valTableType t == TStr] > 1
_ -> True --- does not occur; would not behave well in lin commands
valTableType :: CType -> CType
valTableType t = case t of
Table _ v -> valTableType v
_ -> t
strsFromTerm :: Term -> Err [Str] strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case t of strsFromTerm t = case t of
K (KS s) -> return [str s] K (KS s) -> return [str s]

View File

@@ -41,6 +41,7 @@ lookupLincat gr f = do
case info of case info of
CncCat t _ _ -> return t CncCat t _ _ -> return t
AnyInd _ n -> lookupLincat gr $ redirectIdent n f AnyInd _ n -> lookupLincat gr $ redirectIdent n f
_ -> prtBad "no lincat found for" f
lookupPrintname :: CanonGrammar -> CIdent -> Err Term lookupPrintname :: CanonGrammar -> CIdent -> Err Term
lookupPrintname gr f = do lookupPrintname gr f = do

View File

@@ -22,6 +22,7 @@ import EBNF
import ReadFiles ---- import ReadFiles ----
import Char (toUpper)
import List (nub) import List (nub)
import Monad (foldM) import Monad (foldM)
@@ -62,7 +63,7 @@ parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef])
parseOldGrammar file = do parseOldGrammar file = do
putStrE $ "reading old file" +++ file putStrE $ "reading old file" +++ file
s <- ioeIO $ readFileIf file s <- ioeIO $ readFileIf file
A.OldGr incl topdefs <- ioeErr $ {- err2err $ -} pOldGrammar $ oldLexer $ fixNewlines s A.OldGr incl topdefs <- ioeErr $ pOldGrammar $ oldLexer $ fixNewlines s
includes <- ioeErr $ transInclude incl includes <- ioeErr $ transInclude incl
return (includes, topdefs) return (includes, topdefs)
@@ -74,16 +75,16 @@ err2err (E.Bad s) = Bad s
ioeEErr = ioeErr . err2err ioeEErr = ioeErr . err2err
-- To resolve the new reserved words: change them by turning the final letter to Z. -- To resolve the new reserved words:
-- change them by turning the final letter to upper case.
--- There is a risk of clash. --- There is a risk of clash.
oldLexer :: String -> [L.Token] oldLexer :: String -> [L.Token]
oldLexer = map change . L.tokens where oldLexer = map change . L.tokens where
change t = case t of change t = case t of
(L.PT p (L.TS s)) | elem s new -> (L.PT p (L.TV (init s ++ "Z"))) (L.PT p (L.TS s)) | elem s newReservedWords ->
(L.PT p (L.TV (init s ++ [toUpper (last s)])))
_ -> t _ -> t
new = words $ "abstract concrete interface incomplete " ++
"instance out open resource reuse transfer union with where"
getCFGrammar :: Options -> FilePath -> IOE SourceGrammar getCFGrammar :: Options -> FilePath -> IOE SourceGrammar
getCFGrammar opts file = do getCFGrammar opts file = do

View File

@@ -313,12 +313,16 @@ firstGrammarST = stateGrammarST . firstStateGrammar
firstAbstractST = abstractOf . firstGrammarST firstAbstractST = abstractOf . firstGrammarST
firstConcreteST = concreteOf . firstGrammarST firstConcreteST = concreteOf . firstGrammarST
-} -}
-- command-line option -language=foo overrides the actual grammar in state -- command-line option -lang=foo overrides the actual grammar in state
grammarOfOptState :: Options -> ShellState -> StateGrammar grammarOfOptState :: Options -> ShellState -> StateGrammar
grammarOfOptState opts st = grammarOfOptState opts st =
maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $
getOptVal opts useLanguage getOptVal opts useLanguage
languageOfOptState :: Options -> ShellState -> Maybe Language
languageOfOptState opts st =
maybe (concrete st) (return . language) $ getOptVal opts useLanguage
-- command-line option -cat=foo overrides the possible start cat of a grammar -- command-line option -cat=foo overrides the possible start cat of a grammar
firstCatOpts :: Options -> StateGrammar -> CFCat firstCatOpts :: Options -> StateGrammar -> CFCat
firstCatOpts opts sgr = firstCatOpts opts sgr =

View File

@@ -79,6 +79,10 @@ type MCat = (Ident,Ident)
sortMCat :: String -> MCat sortMCat :: String -> MCat
sortMCat s = (zIdent "_", zIdent s) sortMCat s = (zIdent "_", zIdent s)
--- hack for Editing.actCat in empty state
errorCat :: MCat
errorCat = (zIdent "?", zIdent "?")
getMCat :: Term -> Err MCat getMCat :: Term -> Err MCat
getMCat t = case t of getMCat t = case t of
Q m c -> return (m,c) Q m c -> return (m,c)

View File

@@ -7,6 +7,9 @@ import qualified Ident as I
import qualified Compute as Co import qualified Compute as Co
import qualified Lookup as L import qualified Lookup as L
import qualified GFC import qualified GFC
import qualified Look
import qualified CMacros
import qualified GrammarToCanon
import Values import Values
import GetTree import GetTree
@@ -28,7 +31,7 @@ import HelpFile
import PrOld import PrOld
import PrGrammar import PrGrammar
import Monad (foldM) import Monad (foldM,liftM)
import System (system) import System (system)
import Random (newStdGen) ---- import Random (newStdGen) ----
import Zipper ---- import Zipper ----
@@ -112,12 +115,15 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa
-- good to have here for piping; eh and ec must be done on outer level -- good to have here for piping; eh and ec must be done on outer level
CLinearize [] -> changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa CLinearize [] ->
changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa
---- CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa ---- CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa
CParse -> case optParseArgErrMsg opts gro (prCommandArg a) of CParse -> do
Ok (ts,msg) -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa warnDiscont opts
Bad msg -> changeArg (const $ AError msg) sa case optParseArgErrMsg opts gro (prCommandArg a) of
Ok (ts,msg) -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa
Bad msg -> changeArg (const $ AError msg) sa
CTranslate il ol -> do CTranslate il ol -> do
let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a
@@ -175,13 +181,19 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
return . L.opersForType src))) sa return . L.opersForType src))) sa
CTranslationQuiz il ol -> justOutput (teachTranslation opts (sgr il) (sgr ol)) sa CTranslationQuiz il ol -> do
CTranslationList il ol n -> do warnDiscont opts
justOutput (teachTranslation opts (sgr il) (sgr ol)) sa
CTranslationList il ol n -> do
warnDiscont opts
qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n) qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n)
returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa
CMorphoQuiz -> justOutput (teachMorpho opts gro) sa CMorphoQuiz -> do
warnDiscont opts
justOutput (teachMorpho opts gro) sa
CMorphoList n -> do CMorphoList n -> do
warnDiscont opts
qs <- useIOE [] $ morphoTrainList opts gro (toInteger n) qs <- useIOE [] $ morphoTrainList opts gro (toInteger n)
returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa
@@ -201,8 +213,8 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
| oElem showAll opts -> returnArg (AString txtHelpFile) sa | oElem showAll opts -> returnArg (AString txtHelpFile) sa
| otherwise -> returnArg (AString txtHelpFileSummary) sa | otherwise -> returnArg (AString txtHelpFileSummary) sa
CPrintGrammar -> returnArg (AString (optPrintGrammar opts gro)) sa CPrintGrammar -> returnArg (AString (optPrintGrammar opts gro)) sa
CPrintGlobalOptions -> justOutput (putStrLn $ prShellStateInfo st) sa CPrintGlobalOptions -> justOutput (putStrLn $ prShellStateInfo st) sa
CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa
CPrintLanguages -> justOutput CPrintLanguages -> justOutput
(putStrLn $ unwords $ map prLanguage $ allLanguages st) sa (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa
@@ -226,6 +238,14 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
ASTrm s -> err AError (ATrms . return) $ string2treeErr gro s ASTrm s -> err AError (ATrms . return) $ string2treeErr gro s
_ -> a _ -> a
warnDiscont os = err putStrLn id $ do
let c0 = firstAbsCat os gro
c <- GrammarToCanon.redQIdent c0
lang <- maybeErr "no concrete" $ languageOfOptState os st
t <- Look.lookupLincat cgr $ CMacros.redirectIdent lang c
return $ if CMacros.isDiscontinuousCType t
then (putStrLn ("Warning: discontinuous category" +++ prt_ c))
else (return ())
-- commands either change the state or process the argument, but not both -- commands either change the state or process the argument, but not both
-- some commands just do output -- some commands just do output

View File

@@ -20,7 +20,7 @@ import UTF8
initEditLoop :: CEnv -> IO () -> IO () initEditLoop :: CEnv -> IO () -> IO ()
initEditLoop env resume = do initEditLoop env resume = do
let env' = addGlobalOptions (options [sizeDisplay "short"]) env let env' = startEditEnv env
putStrLnFlush $ initEditMsg env' putStrLnFlush $ initEditMsg env'
let state = initSStateEnv env' let state = initSStateEnv env'
putStrLnFlush $ showCurrentState env' state putStrLnFlush $ showCurrentState env' state
@@ -113,7 +113,9 @@ pCommand = pCommandWords . words where
-- well, this lists the commands of the line-based editor -- well, this lists the commands of the line-based editor
initEditMsg env = unlines $ initEditMsg env = unlines $
"State-dependent editing commands are given in the menu:" : "State-dependent editing commands are given in the menu:" :
" n = new, r = refine, w = wrap, d = delete, s = select." : " n [Cat] = new, r [Fun] = refine, w [Fun] [Int] = wrap,":
" ch [Fun] = change head, d = delete, s [Int] = select," :
" x [Var] [Var] = alpha convert." :
"Commands changing the environment:" : "Commands changing the environment:" :
" i [file] = import, e = empty." : " i [file] = import, e = empty." :
"Other commands:" : "Other commands:" :

View File

@@ -26,6 +26,7 @@ import Unicode
import CF import CF
import CFIdent (cat2CFCat, cfCat2Cat) import CFIdent (cat2CFCat, cfCat2Cat)
import PPrCF (prCFCat)
import Linear import Linear
import Randomized import Randomized
import Editing import Editing
@@ -130,10 +131,10 @@ execCommand env c s = case c of
CCEnvEmptyAndImport file -> useIOE (emptyShellState, initSState) $ do CCEnvEmptyAndImport file -> useIOE (emptyShellState, initSState) $ do
st <- shellStateFromFiles opts emptyShellState file st <- shellStateFromFiles opts emptyShellState file
return (st,s) return (startEditEnv st,s)
CCEnvEmpty -> do CCEnvEmpty -> do
return (emptyShellState, initSState) return (startEditEnv emptyShellState, initSState)
CCEnvGFShell command -> do CCEnvGFShell command -> do
let cs = PShell.pCommandLines command let cs = PShell.pCommandLines command
@@ -224,7 +225,7 @@ execECommand env c = case c of
let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s))) let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s)))
ts = parseAny agrs cat str ts = parseAny agrs cat str
in (if null ts ---- debug in (if null ts ---- debug
then withMsg [str, "parse failed in cat" +++ show cat] then withMsg [str, "parse failed in cat" +++ prCFCat cat]
else id) else id)
(refineByTrees der cgr ts) s (refineByTrees der cgr ts) s
@@ -270,6 +271,10 @@ string2varPair s = case words s of
x : y : [] -> liftM2 (,) (string2ident x) (string2ident y) x : y : [] -> liftM2 (,) (string2ident x) (string2ident y)
_ -> Bad "expected format 'x y'" _ -> Bad "expected format 'x y'"
startEditEnv env = addGlobalOptions (options [sizeDisplay "short"]) env
-- seen on display -- seen on display
cMenuDisplay :: String -> Command cMenuDisplay :: String -> Command

View File

@@ -136,7 +136,7 @@ optionsOfCommand co = case co of
CStripState -> none CStripState -> none
CTransformGrammar _ -> flags "printer" CTransformGrammar _ -> flags "printer"
CConvertLatex _ -> none CConvertLatex _ -> none
CLinearize _ -> both "table struct record all" "lang number unlexer" CLinearize _ -> both "utf8 table struct record all" "lang number unlexer"
CParse -> both "new n ign raw v" "cat lang lexer parser number rawtrees" CParse -> both "new n ign raw v" "cat lang lexer parser number rawtrees"
CTranslate _ _ -> opts "cat lexer parser" CTranslate _ _ -> opts "cat lexer parser"
CGenerateRandom -> flags "cat lang number depth" CGenerateRandom -> flags "cat lang number depth"
@@ -161,7 +161,8 @@ optionsOfCommand co = case co of
CShowTerm -> flags "printer" CShowTerm -> flags "printer"
CSystemCommand _ -> none CSystemCommand _ -> none
CPrintGrammar -> flags "printer" CPrintGrammar -> both "utf8" "printer"
CPrintMultiGrammar -> opts "utf8"
CHelp _ -> opts "all" CHelp _ -> opts "all"

View File

@@ -100,6 +100,9 @@ data TopDef =
| DefPrintOld [PrintDef] | DefPrintOld [PrintDef]
| DefLintype [Def] | DefLintype [Def]
| DefPattern [Def] | DefPattern [Def]
| DefPackage Ident [TopDef]
| DefVars [Def]
| DefTokenizer Ident
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data CatDef = data CatDef =

View File

@@ -270,7 +270,7 @@ separator DDecl "" ;
-- for backward compatibility -- for backward compatibility
OldGr. OldGrammar ::= Include [TopDef] ; OldGr. OldGrammar ::= Include [TopDef] ;
NoIncl. Include ::= ; NoIncl. Include ::= ;
Incl. Include ::= "include" [FileName] ; Incl. Include ::= "include" [FileName] ;
@@ -292,3 +292,10 @@ ELin. Exp2 ::= "Lin" Ident ;
DefPrintOld. TopDef ::= "printname" [PrintDef] ; DefPrintOld. TopDef ::= "printname" [PrintDef] ;
DefLintype. TopDef ::= "lintype" [Def] ; DefLintype. TopDef ::= "lintype" [Def] ;
DefPattern. TopDef ::= "pattern" [Def] ; DefPattern. TopDef ::= "pattern" [Def] ;
-- deprecated packages are attempted to be interpreted
DefPackage. TopDef ::= "package" Ident "=" "{" [TopDef] "}" ";" ;
-- these two are just ignored after parsing
DefVars. TopDef ::= "var" [Def] ;
DefTokenizer. TopDef ::= "tokenizer" Ident ";" ;

View File

@@ -35,13 +35,17 @@ tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file" tokenPos _ = "end of file"
posLineCol (Pn _ l c) = (l,c)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken t = case t of prToken t = case t of
PT _ (TS s) -> s PT _ (TS s) -> s
PT _ (TI s) -> s PT _ (TI s) -> s
PT _ (TV s) -> s PT _ (TV s) -> s
PT _ (TD s) -> s PT _ (TD s) -> s
PT _ (TC s) -> s PT _ (TC s) -> s
_ -> show t PT _ (T_LString s) -> s
tokens:: String -> [Token] tokens:: String -> [Token]
tokens inp = scan tokens_scan inp tokens inp = scan tokens_scan inp
@@ -55,7 +59,7 @@ tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx
eitherResIdent :: (String -> Tok) -> String -> Tok eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $ isResWord s = isInTree s $
B "let" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "in" (B "fn" (B "flags" (B "def" N N) N) (B "grammar" (B "fun" N N) N)) (B "instance" (B "incomplete" (B "include" N N) N) (B "interface" N N)))) (B "pre" (B "open" (B "lindef" (B "lincat" (B "lin" N N) N) (B "of" (B "lintype" N N) N)) (B "param" (B "out" (B "oper" N N) N) (B "pattern" N N))) (B "transfer" (B "reuse" (B "resource" (B "printname" N N) N) (B "table" (B "strs" N N) N)) (B "where" (B "variants" (B "union" N N) N) (B "with" N N)))) B "lincat" (B "def" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "data" (B "concrete" N N) N))) (B "include" (B "fun" (B "fn" (B "flags" N N) N) (B "in" (B "grammar" N N) N)) (B "interface" (B "instance" (B "incomplete" N N) N) (B "lin" (B "let" N N) N)))) (B "resource" (B "out" (B "of" (B "lintype" (B "lindef" N N) N) (B "oper" (B "open" N N) N)) (B "pattern" (B "param" (B "package" N N) N) (B "printname" (B "pre" N N) N))) (B "union" (B "table" (B "strs" (B "reuse" N N) N) (B "transfer" (B "tokenizer" N N) N)) (B "where" (B "variants" (B "var" N N) N) (B "with" N N))))
data BTree = N | B String BTree BTree deriving (Show) data BTree = N | B String BTree BTree deriving (Show)

File diff suppressed because one or more lines are too long

View File

@@ -210,6 +210,9 @@ instance Print TopDef where
DefPrintOld printdefs -> prPrec i 0 (concat [["printname"] , prt 0 printdefs]) DefPrintOld printdefs -> prPrec i 0 (concat [["printname"] , prt 0 printdefs])
DefLintype defs -> prPrec i 0 (concat [["lintype"] , prt 0 defs]) DefLintype defs -> prPrec i 0 (concat [["lintype"] , prt 0 defs])
DefPattern defs -> prPrec i 0 (concat [["pattern"] , prt 0 defs]) DefPattern defs -> prPrec i 0 (concat [["pattern"] , prt 0 defs])
DefPackage id topdefs -> prPrec i 0 (concat [["package"] , prt 0 id , ["="] , ["{"] , prt 0 topdefs , ["}"] , [";"]])
DefVars defs -> prPrec i 0 (concat [["var"] , prt 0 defs])
DefTokenizer id -> prPrec i 0 (concat [["tokenizer"] , prt 0 id , [";"]])
prtList es = case es of prtList es = case es of
[] -> (concat []) [] -> (concat [])

View File

@@ -128,6 +128,9 @@ transTopDef x = case x of
DefPrintOld printdefs -> failure x DefPrintOld printdefs -> failure x
DefLintype defs -> failure x DefLintype defs -> failure x
DefPattern defs -> failure x DefPattern defs -> failure x
DefPackage id topdefs -> failure x
DefVars defs -> failure x
DefTokenizer id -> failure x
transCatDef :: CatDef -> Result transCatDef :: CatDef -> Result

View File

@@ -505,28 +505,34 @@ transOldGrammar opts name0 x = case x of
g1 <- transGrammar $ Gr moddefs g1 <- transGrammar $ Gr moddefs
removeLiT g1 --- needed for bw compatibility with an obsolete feature removeLiT g1 --- needed for bw compatibility with an obsolete feature
where where
sortTopDefs ds = [mkAbs a,mkRes r,mkCnc c] sortTopDefs ds = [mkAbs a,mkRes ops r,mkCnc ops c] ++ map mkPack ps
where (a,r,c) = foldr srt ([],[],[]) ds where
srt d (a,r,c) = case d of ops = map fst ps
DefCat catdefs -> (d:a,r,c) (a,r,c,ps) = foldr srt ([],[],[],[]) ds
DefFun fundefs -> (d:a,r,c) srt d (a,r,c,ps) = case d of
DefDef defs -> (d:a,r,c) DefCat catdefs -> (d:a,r,c,ps)
DefData pardefs -> (d:a,r,c) DefFun fundefs -> (d:a,r,c,ps)
DefPar pardefs -> (a,d:r,c) DefDef defs -> (d:a,r,c,ps)
DefOper defs -> (a,d:r,c) DefData pardefs -> (d:a,r,c,ps)
DefLintype defs -> (a,d:r,c) DefPar pardefs -> (a,d:r,c,ps)
DefLincat defs -> (a,r,d:c) DefOper defs -> (a,d:r,c,ps)
DefLindef defs -> (a,r,d:c) DefLintype defs -> (a,d:r,c,ps)
DefLin defs -> (a,r,d:c) DefLincat defs -> (a,r,d:c,ps)
DefPattern defs -> (a,r,d:c) DefLindef defs -> (a,r,d:c,ps)
DefFlag defs -> (a,r,d:c) --- a guess DefLin defs -> (a,r,d:c,ps)
DefPrintCat printdefs -> (a,r,d:c) DefPattern defs -> (a,r,d:c,ps)
DefPrintFun printdefs -> (a,r,d:c) DefFlag defs -> (a,r,d:c,ps) --- a guess
DefPrintOld printdefs -> (a,r,d:c) DefPrintCat printdefs -> (a,r,d:c,ps)
mkAbs a = MModule q (MTAbstract absName) (MBody ne (Opens []) (topDefs a)) DefPrintFun printdefs -> (a,r,d:c,ps)
mkRes r = MModule q (MTResource resName) (MBody ne (Opens []) (topDefs r)) DefPrintOld printdefs -> (a,r,d:c,ps)
mkCnc r = MModule q (MTConcrete cncName absName) DefPackage m ds -> (a,r,c,(m,ds):ps)
(MBody ne (Opens [OName resName]) (topDefs r)) _ -> (a,r,c,ps)
mkAbs a = MModule q (MTAbstract absName) (MBody ne (Opens []) (topDefs a))
mkRes ps r = MModule q (MTResource resName) (MBody ne (Opens ops) (topDefs r))
where ops = map OName ps
mkCnc ps r = MModule q (MTConcrete cncName absName)
(MBody ne (Opens (map OName (resName:ps))) (topDefs r))
mkPack (m, ds) = MModule q (MTResource m) (MBody ne (Opens []) (topDefs ds))
topDefs t = t topDefs t = t
ne = NoExt ne = NoExt
q = CMCompl q = CMCompl
@@ -551,12 +557,18 @@ transInclude x = case x of
where where
trans f = case f of trans f = case f of
FString s -> s FString s -> s
FIdent (IC s) -> s FIdent (IC s) -> let s' = init s ++ [toLower (last s)] in
if elem s' newReservedWords then s' else s
--- unsafe hack ; cf. GetGrammar.oldLexer
FSlash filename -> '/' : trans filename FSlash filename -> '/' : trans filename
FDot filename -> '.' : trans filename FDot filename -> '.' : trans filename
FMinus filename -> '-' : trans filename FMinus filename -> '-' : trans filename
FAddId (IC s) filename -> s ++ trans filename FAddId (IC s) filename -> s ++ trans filename
newReservedWords =
words $ "abstract concrete interface incomplete " ++
"instance out open resource reuse transfer union with where"
termInPattern :: G.Term -> G.Term termInPattern :: G.Term -> G.Term
termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
toP t = case t of toP t = case t of

View File

@@ -1,5 +1,9 @@
-- automatically generated by BNF Converter -- automatically generated by BNF Converter
module TestGF where module Main where
import IO ( stdin, hGetContents )
import System ( getArgs, getProgName )
import LexGF import LexGF
import ParGF import ParGF
@@ -13,13 +17,21 @@ type ParseFun a = [Token] -> Err a
myLLexer = myLexer myLLexer = myLexer
runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO() runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO ()
runFile p f = readFile f >>= run p runFile p f = readFile f >>= run p
run :: (Print a, Show a) => ParseFun a -> String -> IO() run :: (Print a, Show a) => ParseFun a -> String -> IO ()
run p s = case (p (myLLexer s)) of run p s = case (p (myLLexer s)) of
Bad s -> do putStrLn "\nParse Failed...\n" Bad s -> do putStrLn "\nParse Failed...\n"
putStrLn s putStrLn s
Ok tree -> do putStrLn "\nParse Successful!" Ok tree -> do putStrLn "\nParse Successful!"
putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
main :: IO ()
main = do args <- getArgs
case args of
[] -> hGetContents stdin >>= run pGrammar
[f] -> runFile pGrammar f
_ -> do progName <- getProgName
putStrLn $ progName ++ ": excess arguments."

View File

@@ -5,6 +5,7 @@ import qualified GFC
import TypeCheck import TypeCheck
import LookAbs import LookAbs
import AbsCompute import AbsCompute
import Macros (errorCat)
import Operations import Operations
import Zipper import Zipper
@@ -35,7 +36,7 @@ actVal :: State -> Val
actVal = valNode . nodeTree . actTree actVal = valNode . nodeTree . actTree
actCat :: State -> Cat actCat :: State -> Cat
actCat = errVal undefined . val2cat . actVal ---- undef actCat = errVal errorCat . val2cat . actVal ---- undef
actAtom :: State -> Atom actAtom :: State -> Atom
actAtom = atomTree . actTree actAtom = atomTree . actTree

View File

@@ -5,6 +5,7 @@ GHMAKE=$(GHC) --make
GHCFLAGS=-package lang -package util -fglasgow-exts $(CPPFLAGS) $(LDFLAGS) GHCFLAGS=-package lang -package util -fglasgow-exts $(CPPFLAGS) $(LDFLAGS)
GHCOPTFLAGS=-O $(GHCFLAGS) GHCOPTFLAGS=-O $(GHCFLAGS)
GHCFUDFLAG=-package Fudgets GHCFUDFLAG=-package Fudgets
JAVAFLAGS=-target 1.4 -source 1.4
HUGSINCLUDE =.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile:newparsing:trace: HUGSINCLUDE =.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile:newparsing:trace:
BASICINCLUDE =-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -inewparsing -iparsers -inotrace BASICINCLUDE =-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -inewparsing -iparsers -inotrace
@@ -101,7 +102,7 @@ ghci-nofud:
today: today:
util/mktoday.sh util/mktoday.sh
javac: javac:
$(JAVAC) -target 1.4 -source 1.4 java/*.java $(JAVAC) $(JAVAFLAGS) java/*.java
jar: javac jar: javac
cd java; $(JAR) -cmf manifest.txt gf-java.jar *.class cd java; $(JAR) -cmf manifest.txt gf-java.jar *.class

View File

@@ -1,6 +1,6 @@
Procedure for making a GF release: Procedure for making a GF release:
1. Make sure everything the should be in the release has been 1. Make sure everything that should be in the release has been
checked in. checked in.
2. Go to the src/ dir. 2. Go to the src/ dir.
@@ -43,7 +43,7 @@ Procedure for making a GF release:
- Make sure that you have the directories neccessary to build - Make sure that you have the directories neccessary to build
RPMs: RPMs:
$ mkdir -p ~/rpm/{BUILD,RPMS/$ARCH,RPMS/noarch,SOURCES,SRPMS,SPECS,tmp} $ mkdir -p ~/rpm/{BUILD,RPMS/i586,RPMS/noarch,SOURCES,SRPMS,SPECS,tmp}
- Create ~/.rpmrc with the following contents: - Create ~/.rpmrc with the following contents: