1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

------------------------------------------------------------------------------
--- Set functions are intended to exist for every top-level function.
--- The operation `checkSetUse` detects unintended uses of set funtions.
--- Furthermore, the operation `checkBlacklistUse` checks whether
--- internal operations like `Prelude.=:<=` or `Prelude.prim_` are used
--- in a Curry program.
---
--- See programs `SetFuns.curry` and `NonStrictUniv.curry` in the
--- package directory `examples` for some examples.
---
--- @author Michael Hanus
--- @version February 2023
------------------------------------------------------------------------------

module Language.Curry.CheckOperations
  ( checkSetUse, checkBlacklistUse )
 where

import Data.Char ( isDigit )
import Numeric   ( readNat )

import qualified AbstractCurry.Types as AC
import AbstractCurry.Match
import FlatCurry.Types
import FlatCurry.Match

import Control.SetFunctions

------------------------------------------------------------------------------
--- Returns messages about unintended uses of set functions in a
--- FlatCurry program.
checkSetUse :: Prog -> IO [(QName,String)]
checkSetUse (Prog _ _ _ fdecls _) = do
  seterrors <- values2list (set1 setUse fdecls)
  return (map showSetError seterrors)
 where
  showSetError (qf,sar,reason) =
    (qf, "wrong use of set function `set" ++ sar ++ "': " ++ reason ++ "!")

--- 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 and a reason is returned.
--- Set functions are intended to be used only on top-level functions
--- with the correct arity.
---
--- To provide a simple implementation, we exploit functional patterns
--- with the function `funWithinExp`.
setUse :: [FuncDecl] -> (QName, String, String)
setUse (_ ++
        [funWithinExp qf _ _
                      (Comb ct ("Control.SetFunctions", "set" ++ n) args)]
        ++ _) =
  invalidSetFunCall qf ct n args

--- Checks whether an application of a set function `setn` is unintended.
invalidSetFunCall :: QName -> CombType -> String -> [Expr]
                 -> (QName,String,String)
invalidSetFunCall qf ct sar args
  | not (all isDigit sar)
  = (qf,sar,"suffix of set function is not a number")
  | ct==FuncCall && null args
  = (qf,sar,"missing function argument")
  | ct==FuncCall
  = if arity==0 then isFuncCall (head args)
                else isFuncPartCall arity (head args)
  | otherwise
  = (qf,sar,"partial application of set function")
 where
  arity = case readNat sar of
            [(i,"")] -> i
            _        -> error "UsageCheck.validSetFunCall: illegal number!"

  isFuncCall e = case e of
    Comb FuncCall (_,fn) [] -> checkTopLevelID fn
    _                       -> arityError 0

  isFuncPartCall n e = case e of
    Comb (FuncPartCall p) (_,fn) _ -> if p==n then checkTopLevelID fn
                                              else arityError n
    _                              -> arityError n

  checkTopLevelID fn
    | isID fn   = failed
    | otherwise = (qf,sar,"set function not applied to top-level name")

  -- Checks whether the name is a regular top-level name.
  isID fn = all (`elem` infixIDs) fn || '.' `notElem` fn
   where
    infixIDs :: String
    infixIDs =  "~!@#$%^&*+-=<>?./|\\:"

  arityError n =
    (qf, sar,
     "set function not applied to " ++ showArity n ++ " top-level function")

  showArity n | n == 0    = "0-ary"
              | n == 1    = "unary"
              | n == 2    = "binary"
              | otherwise = show n ++ "-ary"


------------------------------------------------------------------------------
--- Returns messages about uses of black-listed operations occurring
--- in an AbstractCurry program.
checkBlacklistUse :: AC.CurryProg -> IO [(QName,String)]
checkBlacklistUse (AC.CurryProg _ _ _ _ _ _ cfdecls _) = do
  blerrors <- values2list (set1 blacklistUsage cfdecls)
  return (map showBlacklistError blerrors)
 where
  showBlacklistError (qf,(q,f)) =
    (qf, "direct use of `" ++ q ++ "." ++ f ++ "' not allowed!")

--- 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 `cfunWithExp`.
---
--- 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 == AC.preludeName &&
  (take 5 f == "prim_" --no direct call to primitive ops
   || f `elem` ["=:<=", "=:<<="])

------------------------------------------------------------------------------