forked from GitHub/gf-core
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."
|
||||
],
|
||||
options = [
|
||||
("size","show the size of the source code for each constants (number of constructors)")
|
||||
],
|
||||
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
|
||||
}),
|
||||
|
||||
@@ -2,6 +2,7 @@ module GF.Grammar.Analyse (
|
||||
stripSourceGrammar,
|
||||
constantDepsTerm,
|
||||
sizeTerm,
|
||||
sizeConstant,
|
||||
sizesModule,
|
||||
sizesGrammar,
|
||||
printSizesGrammar
|
||||
@@ -45,7 +46,7 @@ constantsInTerm = nub . consts where
|
||||
constantDeps :: SourceGrammar -> QIdent -> Err [Term]
|
||||
constantDeps sgr f = do
|
||||
ts <- deps f
|
||||
let cs = [i | t <- ts, i <- getId t]
|
||||
let cs = [i | t <- ts, Ok i <- [getIdTerm t]]
|
||||
ds <- mapM deps cs
|
||||
return $ nub $ concat $ ts:ds
|
||||
where
|
||||
@@ -56,18 +57,25 @@ constantDeps sgr f = do
|
||||
ty <- lookupResType sgr c
|
||||
tr <- lookupResDef sgr c
|
||||
return $ constantsInTerm ty ++ constantsInTerm tr
|
||||
getId t = case t of
|
||||
Q i -> [i]
|
||||
QC i -> [i]
|
||||
_ -> []
|
||||
|
||||
constantDepsTerm :: SourceGrammar -> Term -> Err [Term]
|
||||
constantDepsTerm sgr t = case t of
|
||||
Q i -> constantDeps sgr i
|
||||
QC i -> constantDeps sgr i
|
||||
P (Vr r) l -> constantDeps sgr $ (r,label2ident l) ---
|
||||
getIdTerm :: Term -> Err QIdent
|
||||
getIdTerm t = case t of
|
||||
Q i -> return i
|
||||
QC i -> return i
|
||||
P (Vr r) l -> return (r,label2ident l) --- needed if term is received from parser
|
||||
_ -> 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
|
||||
-- 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))
|
||||
err error return $ constantDepsTerm sgr t
|
||||
_ -> error "give a term as argument"
|
||||
let printer = showTerm sgr TermPrintDefault Qualified
|
||||
putStrLn $ unwords $ map printer ops
|
||||
let prTerm = showTerm sgr TermPrintDefault Qualified
|
||||
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
|
||||
|
||||
show_operations ws =
|
||||
|
||||
Reference in New Issue
Block a user