mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 11:42:49 -06:00
fix the parsing for source commands
This commit is contained in:
@@ -28,7 +28,7 @@ pCommand = (do
|
|||||||
cmd <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
|
cmd <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
|
||||||
skipSpaces
|
skipSpaces
|
||||||
opts <- sepBy pOption skipSpaces
|
opts <- sepBy pOption skipSpaces
|
||||||
arg <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
|
arg <- if getCommandOp cmd `elem` ["cc","sd","so"] then pArgTerm else pArgument
|
||||||
return (Command cmd opts arg)
|
return (Command cmd opts arg)
|
||||||
)
|
)
|
||||||
<++ (do
|
<++ (do
|
||||||
|
|||||||
@@ -16,7 +16,6 @@ import GF.Data.Operations (chunks,err,raise)
|
|||||||
|
|
||||||
import GF.Grammar hiding (Ident,isPrefixOf)
|
import GF.Grammar hiding (Ident,isPrefixOf)
|
||||||
import GF.Grammar.Analyse
|
import GF.Grammar.Analyse
|
||||||
import GF.Grammar.Parser (runP, pExp)
|
|
||||||
import GF.Grammar.ShowTerm
|
import GF.Grammar.ShowTerm
|
||||||
import GF.Grammar.Lookup (allOpers,allOpersTo)
|
import GF.Grammar.Lookup (allOpers,allOpersTo)
|
||||||
import GF.Compile.Rename(renameSourceTerm)
|
import GF.Compile.Rename(renameSourceTerm)
|
||||||
@@ -54,7 +53,7 @@ sourceCommands = Map.fromList [
|
|||||||
("trace","trace computations")
|
("trace","trace computations")
|
||||||
],
|
],
|
||||||
needsTypeCheck = False, -- why not True?
|
needsTypeCheck = False, -- why not True?
|
||||||
exec = withStrings compute_concrete
|
exec = withTerm compute_concrete
|
||||||
}),
|
}),
|
||||||
("dg", emptyCommandInfo {
|
("dg", emptyCommandInfo {
|
||||||
longname = "dependency_graph",
|
longname = "dependency_graph",
|
||||||
@@ -101,7 +100,7 @@ sourceCommands = Map.fromList [
|
|||||||
mkEx "sd -size ParadigmsEng.mkV -- show all constants on which mkV depends, together with size"
|
mkEx "sd -size ParadigmsEng.mkV -- show all constants on which mkV depends, together with size"
|
||||||
],
|
],
|
||||||
needsTypeCheck = False,
|
needsTypeCheck = False,
|
||||||
exec = withStrings show_deps
|
exec = withTerm show_deps
|
||||||
}),
|
}),
|
||||||
|
|
||||||
("so", emptyCommandInfo {
|
("so", emptyCommandInfo {
|
||||||
@@ -130,7 +129,7 @@ sourceCommands = Map.fromList [
|
|||||||
mkEx "so | wf -file=/tmp/opers -- write the list of opers to a file"
|
mkEx "so | wf -file=/tmp/opers -- write the list of opers to a file"
|
||||||
],
|
],
|
||||||
needsTypeCheck = False,
|
needsTypeCheck = False,
|
||||||
exec = withStrings show_operations
|
exec = withTerm show_operations
|
||||||
}),
|
}),
|
||||||
|
|
||||||
("ss", emptyCommandInfo {
|
("ss", emptyCommandInfo {
|
||||||
@@ -163,14 +162,15 @@ sourceCommands = Map.fromList [
|
|||||||
do sgr <- getGrammar
|
do sgr <- getGrammar
|
||||||
liftSIO (exec opts (toStrings ts) sgr)
|
liftSIO (exec opts (toStrings ts) sgr)
|
||||||
|
|
||||||
compute_concrete opts ws sgr = fmap fst $ runCheck $
|
withTerm exec opts ts =
|
||||||
case runP pExp (UTF8.fromString s) of
|
do sgr <- getGrammar
|
||||||
Left (_,msg) -> return $ pipeMessage msg
|
liftSIO (exec opts (toTerm ts) sgr)
|
||||||
Right t -> do t <- checkComputeTerm opts sgr t
|
|
||||||
return (fromString (showTerm sgr style q t))
|
compute_concrete opts t sgr = fmap fst $ runCheck $ do
|
||||||
|
t <- checkComputeTerm opts sgr t
|
||||||
|
return (fromString (showTerm sgr style q t))
|
||||||
where
|
where
|
||||||
(style,q) = pOpts TermPrintDefault Qualified opts
|
(style,q) = pOpts TermPrintDefault Qualified opts
|
||||||
s = unwords ws
|
|
||||||
|
|
||||||
pOpts style q [] = (style,q)
|
pOpts style q [] = (style,q)
|
||||||
pOpts style q (o:os) =
|
pOpts style q (o:os) =
|
||||||
@@ -184,12 +184,8 @@ sourceCommands = Map.fromList [
|
|||||||
OOpt "qual" -> pOpts style Qualified os
|
OOpt "qual" -> pOpts style Qualified os
|
||||||
_ -> pOpts style q os
|
_ -> pOpts style q os
|
||||||
|
|
||||||
show_deps os xs sgr = do
|
show_deps os t sgr = do
|
||||||
ops <- case xs of
|
ops <- err error (return . nub) $ constantDepsTerm sgr t
|
||||||
_:_ -> do
|
|
||||||
let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
|
|
||||||
err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts
|
|
||||||
_ -> error "expected one or more qualified constants as argument"
|
|
||||||
let prTerm = showTerm sgr TermPrintDefault Qualified
|
let prTerm = showTerm sgr TermPrintDefault Qualified
|
||||||
let size = sizeConstant sgr
|
let size = sizeConstant sgr
|
||||||
let printed
|
let printed
|
||||||
@@ -200,13 +196,11 @@ sourceCommands = Map.fromList [
|
|||||||
| otherwise = unwords $ map prTerm ops
|
| otherwise = unwords $ map prTerm ops
|
||||||
return $ fromString printed
|
return $ fromString printed
|
||||||
|
|
||||||
show_operations os ts sgr = fmap fst $ runCheck $ do
|
show_operations os t sgr = fmap fst $ runCheck $ do
|
||||||
let greps = map valueString (listFlags "grep" os)
|
let greps = map valueString (listFlags "grep" os)
|
||||||
ops <- case ts of
|
ops <- do ty <- checkComputeTerm os sgr t
|
||||||
_:_ -> do let Right t = runP pExp (UTF8.fromString (unwords ts))
|
return $ allOpersTo sgr ty
|
||||||
ty <- checkComputeTerm os sgr t
|
-- _ -> return $ allOpers sgr
|
||||||
return $ allOpersTo sgr ty
|
|
||||||
_ -> return $ allOpers sgr
|
|
||||||
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
|
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
|
||||||
printer = showTerm sgr TermPrintDefault
|
printer = showTerm sgr TermPrintDefault
|
||||||
(if isOpt "raw" os then Qualified else Unqualified)
|
(if isOpt "raw" os then Qualified else Unqualified)
|
||||||
|
|||||||
@@ -6,7 +6,6 @@ module GF.Grammar.Parser
|
|||||||
, pModDef
|
, pModDef
|
||||||
, pModHeader
|
, pModHeader
|
||||||
, pTerm
|
, pTerm
|
||||||
, pExp
|
|
||||||
, pTopDef
|
, pTopDef
|
||||||
, pBNFCRules
|
, pBNFCRules
|
||||||
, pEBNFRules
|
, pEBNFRules
|
||||||
@@ -32,7 +31,6 @@ import qualified Data.Map as Map
|
|||||||
%name pTopDef TopDef
|
%name pTopDef TopDef
|
||||||
%partial pModHeader ModHeader
|
%partial pModHeader ModHeader
|
||||||
%partial pTerm Exp
|
%partial pTerm Exp
|
||||||
%name pExp Exp
|
|
||||||
%name pBNFCRules ListCFRule
|
%name pBNFCRules ListCFRule
|
||||||
%name pEBNFRules ListEBNFRule
|
%name pEBNFRules ListEBNFRule
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user