diff --git a/src/compiler/GF/Command/TreeOperations.hs b/src/compiler/GF/Command/TreeOperations.hs index 221881f44..d9c61ccdf 100644 --- a/src/compiler/GF/Command/TreeOperations.hs +++ b/src/compiler/GF/Command/TreeOperations.hs @@ -4,7 +4,7 @@ module GF.Command.TreeOperations ( treeChunks ) where -import PGF(PGF,CId,compute,unApp) +import PGF(PGF,CId,compute,unApp,mkApp,exprSize,exprFunctions) import PGF.Internal(Expr(..),unAppForm) import Data.List @@ -28,18 +28,14 @@ allTreeOps pgf = [ ("subtrees",("return all fully applied subtrees (stopping at abstractions), by default sorted from the largest", Left $ concatMap subtrees)), ("funs",("return all fun functions appearing in the tree, with duplications", - Left $ concatMap funNodes)) + Left $ \es -> [mkApp f [] | e <- es, f <- exprFunctions e])) ] largest :: [Expr] -> [Expr] largest = reverse . smallest smallest :: [Expr] -> [Expr] -smallest = sortBy (\t u -> compare (size t) (size u)) where - size t = case t of - EAbs _ _ e -> size e + 1 - EApp e1 e2 -> size e1 + size e2 + 1 - _ -> 1 +smallest = sortBy (\t u -> compare (exprSize t) (exprSize u)) treeChunks :: Expr -> [Expr] treeChunks = snd . cks where @@ -55,13 +51,6 @@ subtrees t = t : case unApp t of Just (f,ts) -> concatMap subtrees ts _ -> [] -- don't go under abstractions -funNodes :: Expr -> [Expr] -funNodes t = case t of - EAbs _ _ e -> funNodes e - EApp e1 e2 -> funNodes e1 ++ funNodes e2 - EFun _ -> [t] - _ -> [] -- not literals, metas, etc - --- simple-minded transfer; should use PGF.Expr.match transfer :: PGF -> CId -> Expr -> Expr diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 42519fb63..1c425a565 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -54,7 +54,7 @@ module PGF( mkFloat, unFloat, mkMeta, unMeta, -- extra - pExpr, + pExpr, exprSize, exprFunctions, -- * Operations -- ** Linearization @@ -314,6 +314,23 @@ functionType pgf fun = compute :: PGF -> Expr -> Expr compute pgf = PGF.Data.normalForm (funs (abstract pgf),const Nothing) 0 [] +exprSize :: Expr -> Int +exprSize (EAbs _ _ e) = exprSize e +exprSize (EApp e1 e2) = exprSize e1 + exprSize e2 +exprSize (ETyped e ty)= exprSize e +exprSize (EImplArg e) = exprSize e +exprSize _ = 1 + +exprFunctions :: Expr -> [CId] +exprFunctions (EAbs _ _ e) = exprFunctions e +exprFunctions (EApp e1 e2) = exprFunctions e1 ++ exprFunctions e2 +exprFunctions (ETyped e ty)= exprFunctions e +exprFunctions (EImplArg e) = exprFunctions e +exprFunctions (EFun f) = [f] +exprFunctions _ = [] + +--exprFunctions :: Expr -> [Fun] + browse :: PGF -> CId -> Maybe (String,[CId],[CId]) browse pgf id = fmap (\def -> (def,producers,consumers)) definition where