4216d8b45030bce448f2f0461dfa9ac015d15077
[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 String Int Int
49     | ArgTypeMismatch String 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 name takes given) =
59         let arg = if takes == 1
60             then "argument"
61             else "arguments"
62         in concat ["Module '", name, "' 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 modName name expected actual) =
66         concat ["Type mismatch for argument '", name, "' for module '", modName, "': 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 == "@root"
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.InputPortDef portId portWidth) = do
208         checkedId <- check context portId
209         return $ AST.InputPort checkedId portWidth
210     check context (ParseAST.OutputPortDef portId portWidth) = do
211         checkedId <- check context portId
212         return $ AST.OutputPort checkedId portWidth
213     check context (ParseAST.MultiPortDef for) = do
214         checkedFor <- check context for
215         return $ AST.MultiPort checkedFor
216
217 instance Checkable ParseAST.NetSpec (Either AST.NodeDecl AST.ModuleInst) where
218     check context (ParseAST.NodeDeclSpec decl) = do
219         checkedDecl <- check context decl
220         return $ Left checkedDecl
221     check context (ParseAST.ModuleInstSpec inst) = do
222         checkedInst <- check context inst
223         return $ Right checkedInst
224
225 instance Checkable ParseAST.ModuleInst AST.ModuleInst where
226     check context (ParseAST.MultiModuleInst for) = do
227         checkedFor <- check context for
228         return $ AST.MultiModuleInst checkedFor
229     check context ast = do
230         let
231             namespace = ParseAST.namespace ast
232             name = ParseAST.moduleName ast
233             arguments = ParseAST.arguments ast
234             portMaps = ParseAST.portMappings ast
235             instContext = context
236                 { instModule = name }
237         checkedArgs <- check instContext arguments
238         checkedNamespace <- check instContext namespace
239         inPortMap  <- check instContext $ filter isInMap  portMaps
240         outPortMap <- check instContext $ filter isOutMap portMaps
241         return AST.ModuleInst
242             { AST.namespace  = checkedNamespace
243             , AST.moduleName = name
244             , AST.arguments  = checkedArgs
245             , AST.inPortMap  = inPortMap
246             , AST.outPortMap = outPortMap
247             }
248         where
249             isInMap (ParseAST.InputPortMap {}) = True
250             isInMap (ParseAST.MultiPortMap for) = isInMap $ ParseAST.body for
251             isInMap _ = False
252             isOutMap = not . isInMap
253
254 instance Checkable [ParseAST.ModuleArg] (Map String AST.ModuleArg) where
255     check 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         checkedArgs <- forAll id $ zipWith checkArgType params args
264         return $ Map.fromList $ zip paramNames checkedArgs
265         where
266             checkArgCount params args = do
267                 let
268                     paramc = length params
269                     argc = length args
270                 if argc == paramc
271                     then return ()
272                     else Left $ checkFailure context [WrongNumberOfArgs (instModule context) paramc argc]
273             checkArgType (name, expected) arg = do
274                 case arg of
275                     ParseAST.AddressArg value -> do
276                         if expected == AST.AddressParam
277                             then return $ AST.AddressArg value
278                             else Left $ mismatch AST.AddressParam
279                     ParseAST.NaturalArg value -> do
280                         if expected == AST.NaturalParam
281                             then return $ AST.NaturalArg value
282                             else Left $ mismatch AST.NaturalParam
283                     ParseAST.ParamArg pName -> do
284                         checkParamType context pName expected
285                         return $ AST.ParamArg pName
286                 where
287                     mismatch t = checkFailure context [ArgTypeMismatch (instModule context) name expected t]
288
289 instance Checkable ParseAST.PortMap AST.PortMap where
290     check context (ParseAST.MultiPortMap for) = do
291         checkedFor <- check context for
292         return $ AST.MultiPortMap checkedFor
293     check context portMap = do
294         let
295             mappedId = ParseAST.mappedId portMap
296             mappedPort = ParseAST.mappedPort portMap
297         (checkedId, checkedPort) <- check context (mappedId, mappedPort)
298         return $ AST.PortMap
299             { AST.mappedId   = checkedId
300             , AST.mappedPort = checkedPort
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             reserved = ParseAST.reserved ast
345         checkedAccept <- check context accept
346         checkedTranslate <- check context translate
347         checkedReserved <- check context reserved
348         checkedOverlay <- case overlay of
349             Nothing    -> return Nothing
350             Just ident -> do
351                 checkedIdent <- check context ident
352                 return $ Just checkedIdent
353         return AST.NodeSpec
354             { AST.nodeType  = nodeType
355             , AST.accept    = checkedAccept
356             , AST.translate = checkedTranslate
357             , AST.reserved  = checkedReserved
358             , AST.overlay   = checkedOverlay
359             }
360
361 instance Checkable ParseAST.BlockSpec AST.BlockSpec where
362     check context (ParseAST.SingletonBlock address) = do
363         checkedAddress <- check context address
364         return AST.SingletonBlock
365             { AST.base = checkedAddress }
366     check context (ParseAST.RangeBlock base limit) = do
367         (checkedBase, checkedLimit) <- check context (base, limit)
368         return AST.RangeBlock
369             { AST.base  = checkedBase
370             , AST.limit = checkedLimit
371             }
372     check context (ParseAST.LengthBlock base bits) = do
373         checkedBase <- check context base
374         return AST.LengthBlock
375             { AST.base = checkedBase
376             , AST.bits = bits
377             }
378
379 instance Checkable ParseAST.MapSpec AST.MapSpec where
380     check context ast = do
381         let
382             block = ParseAST.block ast
383             destNode = ParseAST.destNode ast
384             destBase = ParseAST.destBase ast
385         checkedBlock <- check context block
386         checkedDestNode <- check context destNode
387         checkedDestBase <- case destBase of
388             Nothing      -> return Nothing
389             Just address -> do
390                 checkedAddress <- check context address
391                 return $ Just checkedAddress
392         return AST.MapSpec
393             { AST.block    = checkedBlock
394             , AST.destNode = checkedDestNode
395             , AST.destBase = checkedDestBase
396             }
397
398 instance Checkable ParseAST.OverlaySpec AST.OverlaySpec where
399     check context (ParseAST.OverlaySpec over width) = do
400         checkedOver <- check context over
401         return $ AST.OverlaySpec checkedOver width
402
403 instance Checkable ParseAST.Address AST.Address where
404     check _ (ParseAST.LiteralAddress value) = do
405         return $ AST.LiteralAddress 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.LiteralLimit value) = do
444         return $ AST.LiteralLimit value
445     check context (ParseAST.ParamLimit name) = do
446         checkParamType context name AST.NaturalParam
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]