Sockeye TN: Start updating checks section
[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 portId portWidth) = do
207         checkedId <- check context portId
208         return $ AST.InputPort checkedId portWidth
209     check context (ParseAST.OutputPortDef portId portWidth) = do
210         checkedId <- check context portId
211         return $ AST.OutputPort checkedId portWidth
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             reserved = ParseAST.reserved ast
346         checkedAccept <- check context accept
347         checkedTranslate <- check context translate
348         checkedReserved <- check context reserved
349         checkedOverlay <- case overlay of
350             Nothing    -> return Nothing
351             Just ident -> do
352                 checkedIdent <- check context ident
353                 return $ Just checkedIdent
354         return AST.NodeSpec
355             { AST.nodeType  = nodeType
356             , AST.accept    = checkedAccept
357             , AST.translate = checkedTranslate
358             , AST.reserved  = checkedReserved
359             , AST.overlay   = checkedOverlay
360             }
361
362 instance Checkable ParseAST.BlockSpec AST.BlockSpec where
363     check context (ParseAST.SingletonBlock address) = do
364         checkedAddress <- check context address
365         return AST.SingletonBlock
366             { AST.base = checkedAddress }
367     check context (ParseAST.RangeBlock base limit) = do
368         (checkedBase, checkedLimit) <- check context (base, limit)
369         return AST.RangeBlock
370             { AST.base  = checkedBase
371             , AST.limit = checkedLimit
372             }
373     check context (ParseAST.LengthBlock base bits) = do
374         checkedBase <- check context base
375         return AST.LengthBlock
376             { AST.base = checkedBase
377             , AST.bits = bits
378             }
379
380 instance Checkable ParseAST.MapSpec AST.MapSpec where
381     check context ast = do
382         let
383             block = ParseAST.block ast
384             destNode = ParseAST.destNode ast
385             destBase = ParseAST.destBase ast
386         checkedBlock <- check context block
387         checkedDestNode <- check context destNode
388         checkedDestBase <- case destBase of
389             Nothing      -> return Nothing
390             Just address -> do
391                 checkedAddress <- check context address
392                 return $ Just checkedAddress
393         return AST.MapSpec
394             { AST.block    = checkedBlock
395             , AST.destNode = checkedDestNode
396             , AST.destBase = checkedDestBase
397             }
398
399 instance Checkable ParseAST.OverlaySpec AST.OverlaySpec where
400     check context (ParseAST.OverlaySpec over width) = do
401         checkedOver <- check context over
402         return $ AST.OverlaySpec checkedOver width
403
404 instance Checkable ParseAST.Address AST.Address where
405     check _ (ParseAST.LiteralAddress value) = do
406         return $ AST.LiteralAddress value
407     check context (ParseAST.ParamAddress name) = do
408         checkParamType context name AST.AddressParam
409         return $ AST.ParamAddress name
410
411 instance Checkable a b => Checkable (ParseAST.For a) (AST.For b) where
412     check context ast = do
413         let
414             varRanges = ParseAST.varRanges ast
415             varNames = map ParseAST.var varRanges
416             body = ParseAST.body ast
417         checkDuplicates context varNames DuplicateVariable
418         ranges <- check context varRanges
419         let
420             currentVars = vars context
421             bodyVars = currentVars `Set.union` (Set.fromList varNames)
422             bodyContext = context
423                 { vars = bodyVars }
424         checkedBody <- check bodyContext body
425         let
426             checkedVarRanges = Map.fromList $ zip varNames ranges
427         return AST.For
428                 { AST.varRanges = checkedVarRanges
429                 , AST.body      = checkedBody
430                 }
431
432 instance Checkable ParseAST.ForVarRange AST.ForRange where
433     check context ast = do
434         let 
435             start = ParseAST.start ast
436             end = ParseAST.end ast
437         (checkedStart, checkedEnd) <- check context (start, end)
438         return AST.ForRange
439             { AST.start = checkedStart
440             , AST.end   = checkedEnd
441             }
442
443 instance Checkable ParseAST.ForLimit AST.ForLimit where
444     check _ (ParseAST.LiteralLimit value) = do
445         return $ AST.LiteralLimit value
446     check context (ParseAST.ParamLimit name) = do
447         checkParamType context name AST.NaturalParam
448         return $ AST.ParamLimit name
449
450 instance Checkable a b => Checkable [a] [b] where
451     check context as = forAll (check context) as
452
453 instance (Checkable a c, Checkable b d) => Checkable (a, b) (c, d) where
454     check context (a, b) =
455         let
456             eitherC = check context a
457             eitherD = check context b
458         in case (eitherC, eitherD) of
459             (Right c, Right d) -> return (c, d)
460             (Left e1, Left e2) -> Left $ CheckFailure (concat $ map failedChecks [e1, e2])
461             (Left e1, _)       -> Left $ e1
462             (_      , Left e2) -> Left $ e2
463 --
464 -- Helpers
465 --
466 rootModule :: ParseAST.SockeyeSpec -> ParseAST.Module
467 rootModule spec =
468     let
469         body = ParseAST.ModuleBody
470             { ParseAST.ports = []
471             , ParseAST.moduleNet = ParseAST.net spec
472             }
473     in ParseAST.Module
474         { ParseAST.name       = "@root"
475         , ParseAST.parameters = []
476         , ParseAST.moduleBody = body
477         }
478
479 getModule :: Context -> String -> Either CheckFailure AST.Module
480 getModule context name = do
481     let
482         modMap = AST.modules $ spec context
483     case Map.lookup name modMap of
484         Nothing -> Left $ checkFailure context [NoSuchModule name]
485         Just m  -> return m
486
487 getCurrentModule :: Context -> AST.Module
488 getCurrentModule context =
489     let
490         modMap = AST.modules $ spec context
491     in modMap Map.! (moduleName context)
492
493 getInstantiatedModule :: Context -> Either CheckFailure AST.Module
494 getInstantiatedModule context =
495     let
496         modName = instModule context
497     in getModule context modName
498
499 getParameterType :: Context -> String -> Either CheckFailure AST.ModuleParamType
500 getParameterType context name = do
501     let
502         mod = getCurrentModule context
503         paramMap = AST.paramTypeMap mod
504     case Map.lookup name paramMap of
505         Nothing -> Left $ checkFailure context [NoSuchParameter name]
506         Just t  -> return t
507
508 forAll :: (a -> Either CheckFailure b) -> [a] -> Either CheckFailure [b]
509 forAll f as = do
510     let
511         bs = map f as
512         es = concat $ map failedChecks (lefts bs)
513     case es of
514         [] -> return $ rights bs
515         _  -> Left $ CheckFailure es
516
517 checkDuplicates :: Context -> [String] -> (String -> FailedCheckType) -> Either CheckFailure ()
518 checkDuplicates context names failure = do
519     let
520         duplicates = duplicateNames names
521     case duplicates of
522         [] -> return ()
523         _  -> Left $ checkFailure context (map failure duplicates)
524     where
525         duplicateNames [] = []
526         duplicateNames (x:xs)
527             | x `elem` xs = nub $ [x] ++ duplicateNames xs
528             | otherwise = duplicateNames xs
529
530 checkVarInScope :: Context -> String -> Either CheckFailure ()
531 checkVarInScope context name = do
532     if name `Set.member` (vars context)
533         then return ()
534         else Left $ checkFailure context [NoSuchVariable name]
535
536
537 checkParamType :: Context -> String -> AST.ModuleParamType -> Either CheckFailure ()
538 checkParamType context name expected = do
539     actual <- getParameterType context name
540     if actual == expected
541         then return ()
542         else Left $ mismatch actual
543     where
544         mismatch t = checkFailure context [ParamTypeMismatch name expected t]