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