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

------------------------------------------------------------------------
--- This module contains some operations to check and access
--- default rules in a Curry program.
---
--- @author Michael Hanus
--- @version May 2016
------------------------------------------------------------------------

module DefaultRuleUsage
  ( containsDefaultRules, checkDefaultRules
  , isDefaultFunc, isDefaultName, fromDefaultName
  )  where

import AbstractCurry.Types
import AbstractCurry.Select
import List

--- Does a program contains default rules?
containsDefaultRules :: CurryProg -> Bool
containsDefaultRules = not . null . filter isDefaultFunc . functions

--- Check correct usage of default rules and return function names and errors
--- for incorrect uses.
checkDefaultRules :: CurryProg -> [(QName,String)]
checkDefaultRules prog =
  let (defruledecls,fdecls) = partition isDefaultFunc (functions prog)
   in concatMap (checkDefaultRule fdecls) defruledecls

checkDefaultRule :: [CFuncDecl] -> CFuncDecl -> [(QName,String)]
checkDefaultRule funcs (CFunc defqn@(mn,deffn) ar _ _ rules)
  | null rules
  = [(defqn,"Default rule without right-hand side!")]
  | length rules > 1
  = [(defqn,"More than one default rule for function!")]
  | otherwise
  = maybe [(defqn,"Default rule given but no such function defined!")]
          (\fd -> if funcArity fd == ar
                  then []
                  else [(defqn,"Default rule has wrong arity!")])
          (find (\fd -> funcName fd == qn) funcs)
 where qn = (mn, fromDefaultName deffn)
checkDefaultRule funcs (CmtFunc _ qf ar vis texp rules) =
  checkDefaultRule funcs (CFunc qf ar vis texp rules)

--- Is this function a declaration of a default rule?
isDefaultFunc :: CFuncDecl -> Bool
isDefaultFunc = isDefaultName . snd . funcName

--- Is this the name of a specification?
isDefaultName :: String -> Bool
isDefaultName f = "'default" `isSuffixOf` f

--- Drop the default rule suffix "'default" from the name:
fromDefaultName :: String -> String
fromDefaultName f =
  let rf = reverse f
   in reverse (drop (if take 8 rf == "tluafed'" then 8 else 0) rf)

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