mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 19:42:50 -06:00
last-minute bug fixes
This commit is contained in:
@@ -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]
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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 =
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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:" :
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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"
|
||||||
|
|
||||||
|
|||||||
@@ -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 =
|
||||||
|
|||||||
@@ -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 ";" ;
|
||||||
|
|||||||
@@ -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
@@ -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 [])
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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."
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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:
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user