Commit 71e6ed20 authored by Michael Hanus's avatar Michael Hanus
Browse files

cusage tool added

parent 31c99e66
......@@ -9,13 +9,14 @@ browser/BrowserGUI
browser/SourceProgGUI
CASS/cass
CASS/cass_worker
createmakefile/CreateMakefile
curry2js/Curry2JS
currypp/Main
currypp/SequentialRules/Main
currypp/DefaultRules/Transform
currydoc/CurryDoc
currytest/CurryTest
createmakefile/CreateMakefile
cusage/CheckUsage
erd2cdbi/erd2cdbi
erd2curry/erd2curry
genint/GenInt
......
---------------------------------------------------------------------------
--- Some useful operations to support selection
--- of AbstractCurry expressions via deep pattern matching.
---------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-overlapping #-}
import AbstractCurry.Types
--- Returns (non-deterministically) some expression that contains
--- the given expression as a subexpression.
withExp :: CExpr -> CExpr
withExp e = e -- the subexpression is the entire expression
withExp e = CApply (withExp e) _
withExp e = CApply _ (withExp e)
withExp e = CLambda _ (withExp e)
withExp e = CLetDecl _ (withExp e)
withExp e = CLetDecl (_ ++ [ldeclWithExp e] ++ _) _
withExp e = CDoExpr (_ ++ [statWithExp e] ++ _)
withExp e = CListComp (withExp e) _
withExp e = CListComp _ (_ ++ [statWithExp e] ++ _)
withExp e = CCase _ (withExp e) _
withExp e = CCase _ _ (_ ++ [(_,rhsWithExp e)] ++ _)
withExp e = CTyped (withExp e) _
withExp e = CRecConstr _ (_ ++ [(_, withExp e)] ++ _)
withExp e = CRecUpdate _ (_ ++ [(_, withExp e)] ++ _)
ldeclWithExp :: CExpr -> CLocalDecl
ldeclWithExp e = CLocalPat _ (rhsWithExp e)
ldeclWithExp e = CLocalFunc (cfunWithExp _ e)
statWithExp :: CExpr -> CStatement
statWithExp e = CSExpr (withExp e)
statWithExp e = CSPat _ (withExp e)
statWithExp e = CSLet (_ ++ [ldeclWithExp e] ++ _)
rhsWithExp :: CExpr -> CRhs
rhsWithExp e = CSimpleRhs (withExp e) _
rhsWithExp e = CSimpleRhs _ (_ ++ [ldeclWithExp e] ++ _)
rhsWithExp e = CGuardedRhs (_ ++ [(withExp e,_)] ++ _) _
rhsWithExp e = CGuardedRhs (_ ++ [(_,withExp e)] ++ _) _
rhsWithExp e = CGuardedRhs _ (_ ++ [ldeclWithExp e] ++ _)
--- Returns (non-deterministically) a function declaration containing
--- the given expression in the right-hand side.
cfunWithExp :: QName -> CExpr -> CFuncDecl
cfunWithExp qf e = CFunc qf _ _ _ (_ ++ [CRule _ (rhsWithExp e)] ++ _)
cfunWithExp qf e = CmtFunc _ qf _ _ _ (_ ++ [CRule _ (rhsWithExp e)] ++ _)
---------------------------------------------------------------------------
---------------------------------------------------------------------------
--- Set functions are intended to exist for every top-level function.
--- This module checks whether there are unintended uses of set funtions
--- defined in the module `SetFunctions` in a module.
--- Furthermore, it checks whether internal operations like
--- `Prelude.=:<=` or `Prelude.prim_` are used.
---
--- See example module `TestUsage.curry` for some examples.
---
--- @author Michael Hanus
--- @version December 2015
---------------------------------------------------------------------------
import qualified AbstractCurry.Types as AC
import AbstractCurry.Files (readCurry)
import AbstractCurryMatch
import Char(isDigit)
import Distribution(stripCurrySuffix)
import FlatCurry.Types
import FlatCurry.Files
import FlatCurryMatch
import List(intercalate)
import Read(readNat)
import SetFunctions
import System(getArgs)
main :: IO ()
main = do
args <- getArgs
case args of
[modname] -> checkModule (stripCurrySuffix modname)
_ -> putStrLn $ unlines
[title
,"ERROR: Illegal arguments for cusage: " ++
intercalate " " args
,"Usage: cusage <module_name>"
]
title :: String
title = "cusage - A tool to check for intended uses of Curry features"
-------------------------------------------------------------------------
-- Main function to inspect a module for unintended uses of set functions.
-- Try: checkModule "TestUsage"
checkModule :: String -> IO ()
checkModule modname = do
AC.CurryProg _ _ _ cfdecls _ <- readCurry modname
blerrors <- values2list (set1 blacklistUsage cfdecls)
putStr (unlines (map showBlacklistError blerrors))
Prog _ _ _ fdecls _ <- readFlatCurry modname
seterrors <- values2list (set1 setUse fdecls)
putStr (unlines (map showSetError seterrors))
where
showBlacklistError ((_,n),(q,f)) =
"Function '" ++ n ++ "': usage of '" ++ q++"."++f ++ "' not allowed!"
showSetError ((_,n),sar) =
"Function '" ++ n ++ "': wrong use of set function 'set" ++ sar ++ "'"
---------------------------------------------------------------------
--- Returns some unintended use of a set function occurring in a list
--- of function declarations. The name of the function together with
--- the arity of the set function used is returned.
--- Set functions are intended to be used only on top-level functions
--- with the right arity.
---
--- To provide a simple implementation, we exploit functional patterns
--- with the function `funWithExp`.
setUse :: [FuncDecl] -> (QName, String)
--setUse (_ ++ [funWithExp qf (Comb ct ("SetFunctions","set"++n) args)] ++ _)
setUse (_++ [funWithinExp qf _ _ (Comb ct ("SetFunctions","set"++n) args)] ++_)
| not (validSetFunCall ct n args) = (qf,n)
--- Checks whether an application of a set function is as intended.
validSetFunCall :: CombType -> String -> [Expr] -> Bool
validSetFunCall ct n args
| ct==FuncCall && all isDigit n && not (null args)
= if arity==0 then isFuncCall (head args)
else isFuncPartCall arity (head args)
where
arity = readNat n
isFuncCall :: Expr -> Bool
isFuncCall e = case e of
Comb FuncCall qf [] -> isID qf
_ -> False
isFuncPartCall :: Int -> Expr -> Bool
isFuncPartCall n e = case e of
Comb (FuncPartCall p) qf _ -> p==n && isID qf
_ -> False
isID :: QName -> Bool
isID (_,n) = all (`elem` infixIDs) n || '.' `notElem` n
where
infixIDs :: String
infixIDs = "~!@#$%^&*+-=<>?./|\\:"
---------------------------------------------------------------------
---------------------------------------------------------------------
--- Returns some use of a black-listed operation occurring in a list
--- of function declarations. The name of the defined function together with
--- the black-listed operation is returned.
---
--- To provide a simple implementation, we exploit functional patterns
--- with the function `funWithExp`.
---
--- TODO: check also occurrences in functional patterns
blacklistUsage :: [AC.CFuncDecl] -> (AC.QName, AC.QName)
blacklistUsage (_ ++ [cfunWithExp qf (AC.CSymbol qop)] ++ _)
| isBlacklistedOperation qop
= (qf,qop)
isBlacklistedOperation :: AC.QName -> Bool
isBlacklistedOperation (q,f) =
(q == pre && take 5 f == "prim_") -- no direct call to primitive ops
|| (q,f) `elem` [(pre,"=:<="),(pre,"=:<<=")]
pre :: String
pre = "Prelude"
---------------------------------------------------------------------
---------------------------------------------------------------------------
--- Some useful operations to support selection
--- of FlatCurry expressions via deep pattern matching.
---------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-overlapping #-}
import FlatCurry.Types
--- Returns (non-deterministically) some expression that contains
--- the given expression as a subexpression.
withExp :: Expr -> Expr
withExp e = e -- the subexpression is the entire expression
withExp e = Comb _ _ (_++[withExp e]++_)
withExp e = Let _ (withExp e) ? Let (_++[(_,withExp e)]++_) _
withExp e = Free _ (withExp e)
withExp e = Or (withExp e) _ ? Or _ (withExp e)
withExp e = Case _ (withExp e) _ ? Case _ _ (_++[Branch _ (withExp e)]++_)
withExp e = Typed (withExp e) _
--- Returns (non-deterministically) a function declaration containing
--- the given expression in the right-hand side.
funWithExp :: QName -> Expr -> FuncDecl
funWithExp qf e = Func qf _ _ _ (Rule _ (withExp e))
-- Returns an expression that contains the given expression (third argument)
-- as a subexpression. Furthermore, the first argument is the complete
-- expression with a hole (free variable, second argument) at the position
-- of the given subexpression.
-- Hence, if e = inExp e' x s, then e = { x |-> s}(e').
inExp :: Expr -> Expr -> Expr -> Expr
inExp x x e = e -- the subexpression is the entire expression
inExp (Comb ct qf args) x e =
Comb ct qf (withElem (inExp se x e) se args)
where se free
inExp (Let bs se) x e = Let bs (inExp se x e)
inExp (Let bs le) x e = Let (withElem (lv,inExp se x e) (lv,se) bs) le
where lv,se free
inExp (Free vars se) x e = Free vars (inExp se x e)
inExp (Or se e2) x e = Or (inExp se x e) e2
inExp (Or e1 se) x e = Or e1 (inExp se x e)
inExp (Case ct se bs) x e = Case ct (inExp se x e) bs
inExp (Case ct ce bs) x e =
Case ct ce (withElem (Branch pat (inExp se x e)) (Branch pat se) bs)
where pat,se free
inExp (Typed se te) x e = Typed (inExp se x e) te
--- Returns a list containing the first argument as an element.
--- Furthermore, the third argument is the result list except for
--- the element which is replaced by the second argument. Hence,
--- if `withElem e x os` evaluates to `x1:...:xm:e:ys`,
--- where `os=x1:...:xm:x:ys`.
--- Note that this construction is necessary to achieve a finite search
--- space when matching against a finite expression with the operation
--- `inExp`.
withElem :: a -> a -> [a] -> [a]
withElem e x zs = prefix ++ e : (zs=:=prefix++(x:suffix) &> suffix)
where prefix,suffix free
--- Returns (non-deterministically) some function declaration for the
--- given function name where the right-hand side is the given
--- expression with a variable hole and a subexression.
---
--- @param qf - The qualified function name
--- @param e - The right-hand side with a hole containing `x`
--- @param x - The variable in the hole
--- @param se - The subexpression at the hole in the right-hand side
--- @return The function declaration with `e` as the right-hand side
funWithinExp :: QName -> Expr -> Expr -> Expr -> FuncDecl
funWithinExp qf e x se = Func qf _ _ _ (Rule _ (inExp e x se))
---------------------------------------------------------------------------
##############################################################################
# Makefile for Spicey Web Framework
##############################################################################
# Required:
# - installed Curry System (PAKCS or KiCS2) specified by variable REPL
# - root location of the Curry System specified by variable ROOT
# binaries
TOOL = $(ROOT)/bin/cusage
# Some modules required by the Spicey implementation:
DEPS = CheckUsage.curry AbstractCurryMatch.curry FlatCurryMatch.curry \
$(LIBDIR)/AbstractCurry/*.curry $(LIBDIR)/FlatCurry/*.curry
.PHONY: all compile install clean uninstall
all: install
compile: CheckUsage
install: compile
rm -f $(TOOL)
ln -s $(CURDIR)/CheckUsage $(TOOL)
clean:
$(CLEANCURRY) -r
rm -f CheckUsage
uninstall: clean
rm -f $(TOOL)
# generate executable for Spicey generator:
CheckUsage: $(DEPS)
$(REPL) $(REPL_OPTS) :load CheckUsage :save :quit
-- Examples for the cusage checker:
import SetFunctions
test1 x | 3 =:<= x = True -- not allowed!
test2 = set2 (++) [] [42] -- ok
test3 = set0 ([]++[42]) -- illegal!
test4 = set0 failed -- ok
test5 = set1 (\x->x) (1?2) -- unintended!
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment