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)
------------------------------------------------------------------------
|
