mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 11:42:49 -06:00
the sd -size command now shows the size of all code needed for defining an oper
This commit is contained in:
@@ -791,9 +791,11 @@ allCommands env@(pgf, mos) = Map.fromList [
|
|||||||
"This command must be a line of its own, and thus cannot be a part of a pipe."
|
"This command must be a line of its own, and thus cannot be a part of a pipe."
|
||||||
],
|
],
|
||||||
options = [
|
options = [
|
||||||
|
("size","show the size of the source code for each constants (number of constructors)")
|
||||||
],
|
],
|
||||||
examples = [
|
examples = [
|
||||||
"sd ParadigmsEng.mkV -- show all constants on which this one depends"
|
"sd ParadigmsEng.mkV -- show all constants on which this one depends",
|
||||||
|
"sd -size ParadigmsEng.mkV -- show all constants on which this one depends, together with size"
|
||||||
],
|
],
|
||||||
needsTypeCheck = False
|
needsTypeCheck = False
|
||||||
}),
|
}),
|
||||||
|
|||||||
@@ -2,6 +2,7 @@ module GF.Grammar.Analyse (
|
|||||||
stripSourceGrammar,
|
stripSourceGrammar,
|
||||||
constantDepsTerm,
|
constantDepsTerm,
|
||||||
sizeTerm,
|
sizeTerm,
|
||||||
|
sizeConstant,
|
||||||
sizesModule,
|
sizesModule,
|
||||||
sizesGrammar,
|
sizesGrammar,
|
||||||
printSizesGrammar
|
printSizesGrammar
|
||||||
@@ -45,7 +46,7 @@ constantsInTerm = nub . consts where
|
|||||||
constantDeps :: SourceGrammar -> QIdent -> Err [Term]
|
constantDeps :: SourceGrammar -> QIdent -> Err [Term]
|
||||||
constantDeps sgr f = do
|
constantDeps sgr f = do
|
||||||
ts <- deps f
|
ts <- deps f
|
||||||
let cs = [i | t <- ts, i <- getId t]
|
let cs = [i | t <- ts, Ok i <- [getIdTerm t]]
|
||||||
ds <- mapM deps cs
|
ds <- mapM deps cs
|
||||||
return $ nub $ concat $ ts:ds
|
return $ nub $ concat $ ts:ds
|
||||||
where
|
where
|
||||||
@@ -56,18 +57,25 @@ constantDeps sgr f = do
|
|||||||
ty <- lookupResType sgr c
|
ty <- lookupResType sgr c
|
||||||
tr <- lookupResDef sgr c
|
tr <- lookupResDef sgr c
|
||||||
return $ constantsInTerm ty ++ constantsInTerm tr
|
return $ constantsInTerm ty ++ constantsInTerm tr
|
||||||
getId t = case t of
|
|
||||||
Q i -> [i]
|
|
||||||
QC i -> [i]
|
|
||||||
_ -> []
|
|
||||||
|
|
||||||
constantDepsTerm :: SourceGrammar -> Term -> Err [Term]
|
getIdTerm :: Term -> Err QIdent
|
||||||
constantDepsTerm sgr t = case t of
|
getIdTerm t = case t of
|
||||||
Q i -> constantDeps sgr i
|
Q i -> return i
|
||||||
QC i -> constantDeps sgr i
|
QC i -> return i
|
||||||
P (Vr r) l -> constantDeps sgr $ (r,label2ident l) ---
|
P (Vr r) l -> return (r,label2ident l) --- needed if term is received from parser
|
||||||
_ -> Bad ("expected qualified constant, not " ++ show t)
|
_ -> Bad ("expected qualified constant, not " ++ show t)
|
||||||
|
|
||||||
|
constantDepsTerm :: SourceGrammar -> Term -> Err [Term]
|
||||||
|
constantDepsTerm sgr t = do
|
||||||
|
i <- getIdTerm t
|
||||||
|
constantDeps sgr i
|
||||||
|
|
||||||
|
sizeConstant :: SourceGrammar -> Term -> Int
|
||||||
|
sizeConstant sgr t = err (const 0) id $ do
|
||||||
|
c <- getIdTerm t
|
||||||
|
ty <- return $ err (const 0) sizeTerm $ lookupResType sgr c -- if no type sig, return 0
|
||||||
|
tr <- return $ err (const 0) sizeTerm $ lookupResDef sgr c
|
||||||
|
return $ ty + tr
|
||||||
|
|
||||||
-- the number of constructors in a term, ignoring position information and unnecessary types
|
-- the number of constructors in a term, ignoring position information and unnecessary types
|
||||||
-- ground terms count as 1, i.e. as "one work" each
|
-- ground terms count as 1, i.e. as "one work" each
|
||||||
|
|||||||
@@ -193,8 +193,15 @@ execute1 opts gfenv0 s0 =
|
|||||||
let Right t = runP pExp (encodeUnicode utf8 (unwords ts))
|
let Right t = runP pExp (encodeUnicode utf8 (unwords ts))
|
||||||
err error return $ constantDepsTerm sgr t
|
err error return $ constantDepsTerm sgr t
|
||||||
_ -> error "give a term as argument"
|
_ -> error "give a term as argument"
|
||||||
let printer = showTerm sgr TermPrintDefault Qualified
|
let prTerm = showTerm sgr TermPrintDefault Qualified
|
||||||
putStrLn $ unwords $ map printer ops
|
let size = sizeConstant sgr
|
||||||
|
let printed
|
||||||
|
| elem "-size" os =
|
||||||
|
let sz = map size ops in
|
||||||
|
unlines $ ("total: " ++ show (sum sz)) :
|
||||||
|
[prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz]
|
||||||
|
| otherwise = unwords $ map prTerm ops
|
||||||
|
putStrLn $ printed
|
||||||
continue gfenv
|
continue gfenv
|
||||||
|
|
||||||
show_operations ws =
|
show_operations ws =
|
||||||
|
|||||||
Reference in New Issue
Block a user