Skip to content
Newer
Older
100644 101 lines (80 sloc) 4.42 KB
4d83dd0 @rhz first commit
authored May 3, 2012
1 {-# LANGUAGE TupleSections #-}
2
b78661c @rhz multisites -> sites
authored May 22, 2012
3 module Types where
4d83dd0 @rhz first commit
authored May 3, 2012
4
5 import qualified KappaParser as KP
b78661c @rhz multisites -> sites
authored May 22, 2012
6 import KappaParser
7 import PlainKappa (showAgent)
4d83dd0 @rhz first commit
authored May 3, 2012
8 import Utils
9 import Misc
10
11 import qualified Data.Set as Set
12 import qualified Data.Map as Map
13 import Data.Maybe (mapMaybe, fromJust)
14 import Control.Monad (mapM_)
15 import Data.List (find)
16
b78661c @rhz multisites -> sites
authored May 22, 2012
17 -- Checking
4d83dd0 @rhz first commit
authored May 3, 2012
18 data Error = LinkError Agent SiteName SiteName Agent
19 | StateError Agent SiteName String
20
21 check :: Module -> IO ()
22 check m@(Module{ contactMap = cm }) = mapM_ printErrors (ruleErrors ++ initErrors ++ varErrors)
23 where ruleErrors = map (uncurry errorInRule) (rules m)
24 errorInRule ruleName (Rule _ lhs rhs _) = ("rule '" ++ show ruleName ++ "'", checkExpr cm lhs ++ checkExpr cm rhs)
25
26 initErrors = zipWith errorInInit (inits m) [1..]
27 errorInInit (_, kexpr) n = ("init " ++ show n, checkExpr cm kexpr)
28
29 varErrors = map errorInVar (vars m)
30 errorInVar (name, Left kexpr) = ("var '" ++ name ++ "'", checkExpr cm kexpr)
31 errorInVar _ = ("", [])
32
33 printErrors (name, errors) = mapM_ printError errors
34 where printError (LinkError a i j b) =
35 putStrLn $ "Error in " ++ name ++ ": Link between agents '" ++ showAgent a ++ "' and '" ++ showAgent b ++ "' " ++
36 "is not allowed through sites '" ++ i ++ "' and '" ++ j ++ "', respectively"
37 printError (StateError a i state) =
38 putStrLn $ "Error in " ++ name ++ ": State '" ++ state ++ "' is not allowed on site '" ++ i ++ "' " ++
39 "in agent '" ++ showAgent a ++ "'"
40
41
42 checkExpr :: CM -> KExpr -> [Error]
f518062 @rhz bug fix in Graphviz.hs
authored May 24, 2012
43 checkExpr cm kexpr = concatMap stateErrors kexpr ++ Map.fold linkErrors [] lm -- TODO should be Map.foldr, but I'm leaving it as is for compatibility
4d83dd0 @rhz first commit
authored May 3, 2012
44 where stateErrors :: Agent -> [Error]
45 stateErrors a@(Agent name intf) = mapMaybe stateError intf
46 where stateError :: Site -> Maybe Error
47 stateError (Site sn state _) = if state == "" || Set.member (name, sn, state) allowedStates
48 then Nothing
49 else Just $ StateError a sn state
50
51 allowedStates = Set.fromList $ concatMap getStates4Agent cm
52 getStates4Agent (CMAgent name intf) = concatMap getStates4Site intf
53 where getStates4Site (CMSite sn iss _) = map (name, sn,) iss
54
55 lm = linkMap kexpr
56 linkErrors :: Link -> [Error] -> [Error]
57 linkErrors (a@(Agent aname aintf), i, j, b@(Agent bname bintf)) errors
58 | isLinkInCM = errors
59 | otherwise = LinkError a i j b : errors
60 where isLinkInCM = any (== CMBound bname j) bss
61 (CMAgent _ cmIntf) = getSig cm aname
62 (CMSite _ _ bss) = fromJust $ find isSite cmIntf
63 isSite (CMSite sn _ _) = sn == i
64
b78661c @rhz multisites -> sites
authored May 22, 2012
65 -- Inference
ded4d71 @rhz Types.inferCM doesn't stack-overflow when optimized now
authored May 25, 2012
66 -- TODO make this function stack-overflow-free when not optimized
b78661c @rhz multisites -> sites
authored May 22, 2012
67 inferCM :: [KExpr] -> CM
ded4d71 @rhz Types.inferCM doesn't stack-overflow when optimized now
authored May 25, 2012
68 inferCM kexprs = toCM $ foldl' addKExpr Map.empty kexprs
b78661c @rhz multisites -> sites
authored May 22, 2012
69 where
ded4d71 @rhz Types.inferCM doesn't stack-overflow when optimized now
authored May 25, 2012
70 addKExpr cm kexpr = foldl' addAgent cm kexpr
b78661c @rhz multisites -> sites
authored May 22, 2012
71 where
72 lm = linkMap kexpr
73
ded4d71 @rhz Types.inferCM doesn't stack-overflow when optimized now
authored May 25, 2012
74 addAgent cm (Agent agentName intf) = Map.insert agentName cmIntf' cm
b78661c @rhz multisites -> sites
authored May 22, 2012
75 where
76 cmIntf = Map.findWithDefault Map.empty agentName cm
ded4d71 @rhz Types.inferCM doesn't stack-overflow when optimized now
authored May 25, 2012
77 cmIntf' = foldl' addSite cmIntf intf
b78661c @rhz multisites -> sites
authored May 22, 2012
78
ded4d71 @rhz Types.inferCM doesn't stack-overflow when optimized now
authored May 25, 2012
79 addSite cmIntf (Site siteName int lnk) = Map.insert siteName cmSite' cmIntf
b78661c @rhz multisites -> sites
authored May 22, 2012
80 where
81 cmSite = Map.findWithDefault (CMSite siteName [] []) siteName cmIntf
82 cmSite' = addInt int $ addLnk lnk cmSite
83
84 addInt int (CMSite siteName ints lnks)
85 | int `elem` ints = CMSite siteName ints lnks
86 | otherwise = CMSite siteName (int:ints) lnks
87
88 addLnk (Bound bondLabel) (CMSite siteName ints lnks)
89 | lnk `elem` lnks = CMSite siteName ints lnks
90 | otherwise = CMSite siteName ints (lnk:lnks)
91 where
92 (Agent an1 _, sn1, sn2, Agent an2 _) = Map.lookup bondLabel lm ? "Types.inferCM: bond label " ++ show bondLabel ++ " not found"
93 lnk | agentName == an1 && siteName == sn1 = CMBound an2 sn2
94 | agentName == an2 && siteName == sn2 = CMBound an1 sn1
95
96 addLnk _ cmSite = cmSite
97
98 toCM cm = map toCMAgent $ Map.toList cm
99 toCMAgent (agentName, cmIntf) = CMAgent agentName (Map.elems cmIntf)
100
Something went wrong with that request. Please try again.