809616f9395bdaf499e2efceec30cb7beeebb08b
[barrelfish] / tools / sockeye / SockeyeChecker.hs
1 {-
2     SockeyeChecker.hs: AST checker for Sockeye
3
4     Part of Sockeye
5
6     Copyright (c) 2017, ETH Zurich.
7
8     All rights reserved.
9
10     This file is distributed under the terms in the attached LICENSE file.
11     If you do not find this file, copies can be found by writing to:
12     ETH Zurich D-INFK, CAB F.78, Universitaetstr. 6, CH-8092 Zurich,
13     Attn: Systems Group.
14 -}
15
16 {-# LANGUAGE MultiParamTypeClasses #-}
17 {-# LANGUAGE FlexibleInstances #-}
18 {-# LANGUAGE FlexibleContexts #-}
19
20 module SockeyeChecker
21 ( checkSockeye ) where
22
23 import Data.List (nub)
24 import qualified Data.Map as Map
25 import Data.Set (Set)
26 import qualified Data.Set as Set
27 import Data.Either
28
29 import qualified SockeyeASTParser as ParseAST
30 import qualified SockeyeAST as AST
31
32 data Context = Context
33     { spec       :: AST.SockeyeSpec
34     , moduleName :: !String
35     , vars       :: Set String
36     , instModule :: String
37     }
38
39 data FailedCheckType
40     = DuplicateModule String
41     | DuplicateParameter String
42     | DuplicateVariable String
43     | NoSuchModule String
44     | NoSuchParameter String
45     | NoSuchVariable String
46     | ParamTypeMismatch String AST.ModuleParamType AST.ModuleParamType
47     | ModuleSelfInst
48     | WrongNumberOfArgs Int Int
49     | ArgTypeMismatch String AST.ModuleParamType AST.ModuleParamType
50
51 instance Show FailedCheckType where
52     show (DuplicateModule name)          = concat ["Multiple definitions for module '", name, "'"]
53     show (DuplicateParameter name)       = concat ["Multiple parameters named '", name, "'"]
54     show (DuplicateVariable name)        = concat ["Multiple definitions for variable '", name, "'"]
55     show (NoSuchModule name)             = concat ["No definition for module '", name, "'"]
56     show (NoSuchParameter name)          = concat ["Parameter '", name, "' not in scope"]
57     show (NoSuchVariable name)           = concat ["Variable '", name, "' not in scope"]
58     show (ModuleSelfInst)                = "Module must not instantiate itself"
59     show (WrongNumberOfArgs takes given) =
60         let arg = if takes == 1
61             then "argument"
62             else "arguments"
63         in concat ["Module takes ", show takes, " ", arg, ", given ", show given]
64     show (ParamTypeMismatch name expected actual) =
65         concat ["Expected type '", show expected, "' but '", name, "' has type '", show actual, "'"]
66     show (ArgTypeMismatch name expected actual) =
67         concat ["Type mismatch for argument '", name, "': Expected '", show expected, "', given '", show actual, "'"]
68
69 data FailedCheck = FailedCheck
70     { failure  :: FailedCheckType
71     , inModule :: !String
72     }
73
74 newtype CheckFailure = CheckFailure
75     { failedChecks :: [FailedCheck] }
76
77 instance Show CheckFailure where
78     show (CheckFailure fs) = 
79         let
80             modules = nub $ map inModule fs
81         in unlines $ concat (map showFailsForModule modules)
82         where
83             showFailsForModule name =
84                 let
85                     title = "\nIn module '" ++ name ++ "':"
86                     fails = filter (\f -> name == inModule f) fs
87                 in if name == ""
88                     then "":showFails 0 fails
89                     else title:showFails 1 fails
90             showFails indentLevel fs =
91                 let
92                     indent = replicate (indentLevel * 4) ' '
93                 in map ((indent ++) . showFail) fs
94             showFail f = (show $ failure f)
95
96 checkFailure :: Context -> [FailedCheckType] -> CheckFailure
97 checkFailure context fs = CheckFailure $ map failCheck fs
98     where
99         failCheck f = FailedCheck
100             { failure  = f
101             , inModule = moduleName context
102             }
103
104 checkSockeye :: ParseAST.SockeyeSpec -> Either CheckFailure AST.SockeyeSpec
105 checkSockeye ast = do
106     let
107         emptySpec = AST.SockeyeSpec Map.empty
108         initContext = Context
109             { spec       = emptySpec
110             , moduleName = ""
111             , vars       = Set.empty
112             , instModule = ""
113             }
114     symbolTable <- buildSymbolTable initContext ast
115     let
116         context = initContext
117             { spec = symbolTable }
118     check context ast
119
120 --
121 -- Build Symbol table
122 --
123 class SymbolSource a b where
124     buildSymbolTable :: Context -> a -> Either CheckFailure b
125
126 instance SymbolSource ParseAST.SockeyeSpec AST.SockeyeSpec where
127     buildSymbolTable context ast = do
128         let
129             modules = (rootModule ast):(ParseAST.modules ast)
130             names = map ParseAST.name modules
131         checkDuplicates context names DuplicateModule
132         symbolTables <- buildSymbolTable context modules
133         let
134             moduleMap = Map.fromList $ zip names symbolTables
135         return AST.SockeyeSpec
136                 { AST.modules = moduleMap }
137
138 instance SymbolSource ParseAST.Module AST.Module where
139     buildSymbolTable context ast = do
140         let
141             name = ParseAST.name ast
142             paramNames = map ParseAST.paramName (ParseAST.parameters ast)
143             paramTypes = map ParseAST.paramType (ParseAST.parameters ast)
144             moduleContext = context
145                 { moduleName = name}
146         checkDuplicates moduleContext paramNames DuplicateParameter
147         let
148             paramTypeMap = Map.fromList $ zip paramNames paramTypes
149         return AST.Module
150             { AST.paramNames   = paramNames
151             , AST.paramTypeMap = paramTypeMap
152             , AST.inputPorts   = []
153             , AST.outputPorts  = []
154             , AST.nodeDecls    = []
155             , AST.moduleInsts  = []
156             }
157
158 instance SymbolSource a b => SymbolSource [a] [b] where
159     buildSymbolTable context as = forAll (buildSymbolTable context) as
160
161 --
162 -- Check module bodies
163 --
164 class Checkable a b where
165     check :: Context -> a -> Either CheckFailure b
166
167 instance Checkable ParseAST.SockeyeSpec AST.SockeyeSpec where
168     check context ast = do
169         let
170             modules = (rootModule ast):(ParseAST.modules ast)
171             names = map ParseAST.name modules
172         checked <- check context modules
173         let
174             sockeyeSpec = spec context
175             checkedMap = Map.fromList $ zip names checked
176         return sockeyeSpec
177             { AST.modules = checkedMap }
178
179 instance Checkable ParseAST.Module AST.Module where
180     check context ast = do
181         let
182             name = ParseAST.name ast
183             bodyContext = context
184                 { moduleName = name}
185             body = ParseAST.moduleBody ast
186             portDefs = ParseAST.ports body
187             netSpecs = ParseAST.moduleNet body
188         inputPorts  <- check bodyContext $ filter isInPort  portDefs
189         outputPorts <- check bodyContext $ filter isOutPort portDefs
190         checkedNetSpecs <- check bodyContext netSpecs
191         let
192             checkedNodeDecls = lefts checkedNetSpecs
193             checkedModuleInsts = rights checkedNetSpecs
194             mod = getCurrentModule bodyContext
195         return mod
196             { AST.inputPorts  = inputPorts
197             , AST.outputPorts = outputPorts
198             , AST.nodeDecls   = checkedNodeDecls
199             , AST.moduleInsts = checkedModuleInsts
200             }
201         where
202             isInPort (ParseAST.InputPortDef _) = True
203             isInPort (ParseAST.MultiPortDef for) = isInPort $ ParseAST.body for
204             isInPort _ = False
205             isOutPort = not . isInPort
206
207 instance Checkable ParseAST.PortDef AST.Port where
208     check context (ParseAST.MultiPortDef for) = do
209         checkedFor <- check context for
210         return $ AST.MultiPort checkedFor
211     check context portDef = do
212         checkedId <- check context (ParseAST.portId portDef)
213         return $ AST.Port checkedId
214
215 instance Checkable ParseAST.NetSpec (Either AST.NodeDecl AST.ModuleInst) where
216     check context (ParseAST.NodeDeclSpec decl) = do
217         checkedDecl <- check context decl
218         return $ Left checkedDecl
219     check context (ParseAST.ModuleInstSpec inst) = do
220         checkedInst <- check context inst
221         return $ Right checkedInst
222
223 instance Checkable ParseAST.ModuleInst AST.ModuleInst where
224     check context (ParseAST.MultiModuleInst for) = do
225         checkedFor <- check context for
226         return $ AST.MultiModuleInst checkedFor
227     check context ast = do
228         let
229             nameSpace = ParseAST.nameSpace ast
230             name = ParseAST.moduleName ast
231             arguments = ParseAST.arguments ast
232             portMaps = ParseAST.portMappings ast
233         mod <- getModule context name
234         let
235             paramNames = AST.paramNames mod
236             instContext = context
237                 { instModule = name }
238         checkSelfInst instContext
239         checkedArgs <- checkArgs instContext arguments
240         checkedNameSpace <- check instContext nameSpace
241         inPortMap  <- check instContext $ filter isInMap  portMaps
242         outPortMap <- check instContext $ filter isOutMap portMaps
243         let
244             argMap = Map.fromList $ zip paramNames checkedArgs
245         return AST.ModuleInst
246             { AST.nameSpace  = checkedNameSpace
247             , AST.moduleName = name
248             , AST.arguments  = argMap
249             , AST.inPortMap  = inPortMap
250             , AST.outPortMap = outPortMap
251             }
252         where
253             isInMap (ParseAST.InputPortMap {}) = True
254             isInMap (ParseAST.MultiPortMap for) = isInMap $ ParseAST.body for
255             isInMap _ = False
256             isOutMap = not . isInMap
257             checkSelfInst context = do
258                 let
259                     selfName = moduleName context
260                     instName = instModule context
261                 if instName == selfName
262                     then Left $ checkFailure context [ModuleSelfInst]
263                     else return ()
264             checkArgs context args = do
265                 mod <- getInstantiatedModule context
266                 let
267                     typeMap = AST.paramTypeMap mod
268                     paramNames = AST.paramNames mod
269                     paramTypes = map (typeMap Map.!) paramNames
270                     params = zip paramNames paramTypes
271                 checkArgCount paramNames args
272                 forAll id $ zipWith checkArgType params args
273                 where
274                     checkArgCount params args = do
275                         let
276                             paramc = length params
277                             argc = length args
278                         if argc == paramc
279                             then return ()
280                             else Left $ checkFailure context [WrongNumberOfArgs paramc argc]
281                     checkArgType (name, expected) arg = do
282                         case arg of
283                             ParseAST.AddressArg value -> do
284                                 if expected == AST.AddressParam
285                                     then return $ AST.AddressArg value
286                                     else Left $ mismatch AST.AddressParam
287                             ParseAST.NumberArg value -> do
288                                 if expected == AST.NumberParam
289                                     then return $ AST.NumberArg value
290                                     else Left $ mismatch AST.NumberParam
291                             ParseAST.ParamArg pName -> do
292                                 checkParamType context pName expected
293                                 return $ AST.ParamArg pName
294                         where
295                             mismatch t = checkFailure context [ArgTypeMismatch name expected t]
296
297 instance Checkable ParseAST.PortMap AST.PortMap where
298     check context (ParseAST.MultiPortMap for) = do
299         checkedFor <- check context for
300         return $ AST.MultiPortMap checkedFor
301     check context portMap = do
302         let
303             mappedId = ParseAST.mappedId portMap
304             mappedPort = ParseAST.mappedPort portMap
305         (checkedId, checkedPort) <- check context (mappedId, mappedPort)
306         return $ AST.PortMap
307             { AST.mappedId   = checkedId
308             , AST.mappedPort = checkedPort
309             }
310
311 instance Checkable ParseAST.NodeDecl AST.NodeDecl where
312     check context (ParseAST.MultiNodeDecl for) = do
313         checkedFor <- check context for
314         return $ AST.MultiNodeDecl checkedFor
315     check context ast = do
316         let
317             nodeId = ParseAST.nodeId ast
318             nodeSpec = ParseAST.nodeSpec ast
319         checkedId <- check context nodeId
320         checkedSpec <- check context nodeSpec
321         return AST.NodeDecl
322             { AST.nodeId   = checkedId
323             , AST.nodeSpec = checkedSpec
324             }
325
326 instance Checkable ParseAST.Identifier AST.Identifier where
327     check _ (ParseAST.SimpleIdent name) = return $ AST.SimpleIdent name
328     check context ast = do
329         let
330             prefix = ParseAST.prefix ast
331             varName = ParseAST.varName ast
332             suffix = ParseAST.suffix ast
333         checkVarInScope context varName
334         checkedSuffix <- case suffix of
335             Nothing    -> return Nothing
336             Just ident -> do
337                 checkedIdent <- check context ident
338                 return $ Just checkedIdent
339         return AST.TemplateIdent
340             { AST.prefix  = prefix
341             , AST.varName = varName
342             , AST.suffix  = checkedSuffix
343             }
344
345 instance Checkable ParseAST.NodeSpec AST.NodeSpec where
346     check context ast = do
347         let 
348             nodeType = ParseAST.nodeType ast
349             accept = ParseAST.accept ast
350             translate = ParseAST.translate ast
351             overlay = ParseAST.overlay ast
352         checkedAccept <- check context accept
353         checkedTranslate <- check context translate
354         checkedOverlay <- case overlay of
355             Nothing    -> return Nothing
356             Just ident -> do
357                 checkedIdent <- check context ident
358                 return $ Just checkedIdent
359         return AST.NodeSpec
360             { AST.nodeType  = nodeType
361             , AST.accept    = checkedAccept
362             , AST.translate = checkedTranslate
363             , AST.overlay   = checkedOverlay
364             }
365
366 instance Checkable ParseAST.BlockSpec AST.BlockSpec where
367     check context (ParseAST.SingletonBlock address) = do
368         checkedAddress <- check context address
369         return AST.SingletonBlock
370             { AST.address = checkedAddress }
371     check context (ParseAST.RangeBlock base limit) = do
372         (checkedBase, checkedLimit) <- check context (base, limit)
373         return AST.RangeBlock
374             { AST.base  = checkedBase
375             , AST.limit = checkedLimit
376             }
377     check context (ParseAST.LengthBlock base bits) = do
378         checkedBase <- check context base
379         return AST.LengthBlock
380             { AST.base = checkedBase
381             , AST.bits = bits
382             }
383
384 instance Checkable ParseAST.MapSpec AST.MapSpec where
385     check context ast = do
386         let
387             block = ParseAST.block ast
388             destNode = ParseAST.destNode ast
389             destBase = ParseAST.destBase ast
390         checkedBlock <- check context block
391         checkedDestNode <- check context destNode
392         checkedDestBase <- case destBase of
393             Nothing      -> return Nothing
394             Just address -> do
395                 checkedAddress <- check context address
396                 return $ Just checkedAddress
397         return AST.MapSpec
398             { AST.block    = checkedBlock
399             , AST.destNode = checkedDestNode
400             , AST.destBase = checkedDestBase
401             }
402
403 instance Checkable ParseAST.Address AST.Address where
404     check _ (ParseAST.NumberAddress value) = do
405         return $ AST.NumberAddress value
406     check context (ParseAST.ParamAddress name) = do
407         checkParamType context name AST.AddressParam
408         return $ AST.ParamAddress name
409
410 instance Checkable a b => Checkable (ParseAST.For a) (AST.For b) where
411     check context ast = do
412         let
413             varRanges = ParseAST.varRanges ast
414             varNames = map ParseAST.var varRanges
415             body = ParseAST.body ast
416         checkDuplicates context varNames DuplicateVariable
417         ranges <- check context varRanges
418         let
419             currentVars = vars context
420             bodyVars = currentVars `Set.union` (Set.fromList varNames)
421             bodyContext = context
422                 { vars = bodyVars }
423         checkedBody <- check bodyContext body
424         let
425             checkedVarRanges = Map.fromList $ zip varNames ranges
426         return AST.For
427                 { AST.varRanges = checkedVarRanges
428                 , AST.body      = checkedBody
429                 }
430
431 instance Checkable ParseAST.ForVarRange AST.ForRange where
432     check context ast = do
433         let 
434             start = ParseAST.start ast
435             end = ParseAST.end ast
436         (checkedStart, checkedEnd) <- check context (start, end)
437         return AST.ForRange
438             { AST.start = checkedStart
439             , AST.end   = checkedEnd
440             }
441
442 instance Checkable ParseAST.ForLimit AST.ForLimit where
443     check _ (ParseAST.NumberLimit value) = do
444         return $ AST.NumberLimit value
445     check context (ParseAST.ParamLimit name) = do
446         checkParamType context name AST.NumberParam
447         return $ AST.ParamLimit name
448
449 instance Checkable a b => Checkable [a] [b] where
450     check context as = forAll (check context) as
451
452 instance (Checkable a c, Checkable b d) => Checkable (a, b) (c, d) where
453     check context (a, b) =
454         let
455             eitherC = check context a
456             eitherD = check context b
457         in case (eitherC, eitherD) of
458             (Right c, Right d) -> return (c, d)
459             (Left e1, Left e2) -> Left $ CheckFailure (concat $ map failedChecks [e1, e2])
460             (Left e1, _)       -> Left $ e1
461             (_      , Left e2) -> Left $ e2
462 --
463 -- Helpers
464 --
465 rootModule :: ParseAST.SockeyeSpec -> ParseAST.Module
466 rootModule spec =
467     let
468         body = ParseAST.ModuleBody
469             { ParseAST.ports = []
470             , ParseAST.moduleNet = ParseAST.net spec
471             }
472     in ParseAST.Module
473         { ParseAST.name       = "@root"
474         , ParseAST.parameters = []
475         , ParseAST.moduleBody = body
476         }
477
478 getModule :: Context -> String -> Either CheckFailure AST.Module
479 getModule context name = do
480     let
481         modMap = AST.modules $ spec context
482     case Map.lookup name modMap of
483         Nothing -> Left $ checkFailure context [NoSuchModule name]
484         Just m  -> return m
485
486 getCurrentModule :: Context -> AST.Module
487 getCurrentModule context =
488     let
489         modMap = AST.modules $ spec context
490     in modMap Map.! (moduleName context)
491
492 getInstantiatedModule :: Context -> Either CheckFailure AST.Module
493 getInstantiatedModule context =
494     let
495         modName = instModule context
496     in getModule context modName
497
498 getParameterType :: Context -> String -> Either CheckFailure AST.ModuleParamType
499 getParameterType context name = do
500     let
501         mod = getCurrentModule context
502         paramMap = AST.paramTypeMap mod
503     case Map.lookup name paramMap of
504         Nothing -> Left $ checkFailure context [NoSuchParameter name]
505         Just t  -> return t
506
507 forAll :: (a -> Either CheckFailure b) -> [a] -> Either CheckFailure [b]
508 forAll f as = do
509     let
510         bs = map f as
511         es = concat $ map failedChecks (lefts bs)
512     case es of
513         [] -> return $ rights bs
514         _  -> Left $ CheckFailure es
515
516 checkDuplicates :: Context -> [String] -> (String -> FailedCheckType) -> Either CheckFailure ()
517 checkDuplicates context names failure = do
518     let
519         duplicates = duplicateNames names
520     case duplicates of
521         [] -> return ()
522         _  -> Left $ checkFailure context (map failure duplicates)
523     where
524         duplicateNames [] = []
525         duplicateNames (x:xs)
526             | x `elem` xs = nub $ [x] ++ duplicateNames xs
527             | otherwise = duplicateNames xs
528
529 checkVarInScope :: Context -> String -> Either CheckFailure ()
530 checkVarInScope context name = do
531     if name `Set.member` (vars context)
532         then return ()
533         else Left $ checkFailure context [NoSuchVariable name]
534
535
536 checkParamType :: Context -> String -> AST.ModuleParamType -> Either CheckFailure ()
537 checkParamType context name expected = do
538     actual <- getParameterType context name
539     if actual == expected
540         then return ()
541         else Left $ mismatch actual
542     where
543         mismatch t = checkFailure context [ParamTypeMismatch name expected t]