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