78e955729b053de3c59ab8ba89265a6a7b70e4c6
[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 Int Int
48     | ArgTypeMismatch 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 takes given) =
58         let arg = if takes == 1
59             then "argument"
60             else "arguments"
61         in concat ["Module 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 name expected actual) =
65         concat ["Type mismatch for argument '", name, "': 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 == ""
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.MultiPortDef for) = do
207         checkedFor <- check context for
208         return $ AST.MultiPort checkedFor
209     check context portDef = do
210         checkedId <- check context (ParseAST.portId portDef)
211         return $ AST.Port checkedId
212
213 instance Checkable ParseAST.NetSpec (Either AST.NodeDecl AST.ModuleInst) where
214     check context (ParseAST.NodeDeclSpec decl) = do
215         checkedDecl <- check context decl
216         return $ Left checkedDecl
217     check context (ParseAST.ModuleInstSpec inst) = do
218         checkedInst <- check context inst
219         return $ Right checkedInst
220
221 instance Checkable ParseAST.ModuleInst AST.ModuleInst where
222     check context (ParseAST.MultiModuleInst for) = do
223         checkedFor <- check context for
224         return $ AST.MultiModuleInst checkedFor
225     check context ast = do
226         let
227             namespace = ParseAST.namespace ast
228             name = ParseAST.moduleName ast
229             arguments = ParseAST.arguments ast
230             portMaps = ParseAST.portMappings ast
231         mod <- getModule context name
232         let
233             paramNames = AST.paramNames mod
234             instContext = context
235                 { instModule = name }
236         checkedArgs <- checkArgs instContext arguments
237         checkedNamespace <- check instContext namespace
238         inPortMap  <- check instContext $ filter isInMap  portMaps
239         outPortMap <- check instContext $ filter isOutMap portMaps
240         let
241             argMap = Map.fromList $ zip paramNames checkedArgs
242         return AST.ModuleInst
243             { AST.namespace  = checkedNamespace
244             , AST.moduleName = name
245             , AST.arguments  = argMap
246             , AST.inPortMap  = inPortMap
247             , AST.outPortMap = outPortMap
248             }
249         where
250             isInMap (ParseAST.InputPortMap {}) = True
251             isInMap (ParseAST.MultiPortMap for) = isInMap $ ParseAST.body for
252             isInMap _ = False
253             isOutMap = not . isInMap
254             checkArgs context args = do
255                 mod <- getInstantiatedModule context
256                 let
257                     typeMap = AST.paramTypeMap mod
258                     paramNames = AST.paramNames mod
259                     paramTypes = map (typeMap Map.!) paramNames
260                     params = zip paramNames paramTypes
261                 checkArgCount paramNames args
262                 forAll id $ zipWith checkArgType params args
263                 where
264                     checkArgCount params args = do
265                         let
266                             paramc = length params
267                             argc = length args
268                         if argc == paramc
269                             then return ()
270                             else Left $ checkFailure context [WrongNumberOfArgs paramc argc]
271                     checkArgType (name, expected) arg = do
272                         case arg of
273                             ParseAST.AddressArg value -> do
274                                 if expected == AST.AddressParam
275                                     then return $ AST.AddressArg value
276                                     else Left $ mismatch AST.AddressParam
277                             ParseAST.NaturalArg value -> do
278                                 if expected == AST.NaturalParam
279                                     then return $ AST.NaturalArg value
280                                     else Left $ mismatch AST.NaturalParam
281                             ParseAST.ParamArg pName -> do
282                                 checkParamType context pName expected
283                                 return $ AST.ParamArg pName
284                         where
285                             mismatch t = checkFailure context [ArgTypeMismatch name expected t]
286
287 instance Checkable ParseAST.PortMap AST.PortMap where
288     check context (ParseAST.MultiPortMap for) = do
289         checkedFor <- check context for
290         return $ AST.MultiPortMap checkedFor
291     check context portMap = do
292         let
293             mappedId = ParseAST.mappedId portMap
294             mappedPort = ParseAST.mappedPort portMap
295         (checkedId, checkedPort) <- check context (mappedId, mappedPort)
296         return $ AST.PortMap
297             { AST.mappedId   = checkedId
298             , AST.mappedPort = checkedPort
299             }
300
301 instance Checkable ParseAST.NodeDecl AST.NodeDecl where
302     check context (ParseAST.MultiNodeDecl for) = do
303         checkedFor <- check context for
304         return $ AST.MultiNodeDecl checkedFor
305     check context ast = do
306         let
307             nodeId = ParseAST.nodeId ast
308             nodeSpec = ParseAST.nodeSpec ast
309         checkedId <- check context nodeId
310         checkedSpec <- check context nodeSpec
311         return AST.NodeDecl
312             { AST.nodeId   = checkedId
313             , AST.nodeSpec = checkedSpec
314             }
315
316 instance Checkable ParseAST.Identifier AST.Identifier where
317     check _ (ParseAST.SimpleIdent name) = return $ AST.SimpleIdent name
318     check context ast = do
319         let
320             prefix = ParseAST.prefix ast
321             varName = ParseAST.varName ast
322             suffix = ParseAST.suffix ast
323         checkVarInScope context varName
324         checkedSuffix <- case suffix of
325             Nothing    -> return Nothing
326             Just ident -> do
327                 checkedIdent <- check context ident
328                 return $ Just checkedIdent
329         return AST.TemplateIdent
330             { AST.prefix  = prefix
331             , AST.varName = varName
332             , AST.suffix  = checkedSuffix
333             }
334
335 instance Checkable ParseAST.NodeSpec AST.NodeSpec where
336     check context ast = do
337         let 
338             nodeType = ParseAST.nodeType ast
339             accept = ParseAST.accept ast
340             translate = ParseAST.translate ast
341             overlay = ParseAST.overlay ast
342         checkedAccept <- check context accept
343         checkedTranslate <- check context translate
344         checkedOverlay <- case overlay of
345             Nothing    -> return Nothing
346             Just ident -> do
347                 checkedIdent <- check context ident
348                 return $ Just checkedIdent
349         return AST.NodeSpec
350             { AST.nodeType  = nodeType
351             , AST.accept    = checkedAccept
352             , AST.translate = checkedTranslate
353             , AST.overlay   = checkedOverlay
354             }
355
356 instance Checkable ParseAST.BlockSpec AST.BlockSpec where
357     check context (ParseAST.SingletonBlock address) = do
358         checkedAddress <- check context address
359         return AST.SingletonBlock
360             { AST.base = checkedAddress }
361     check context (ParseAST.RangeBlock base limit) = do
362         (checkedBase, checkedLimit) <- check context (base, limit)
363         return AST.RangeBlock
364             { AST.base  = checkedBase
365             , AST.limit = checkedLimit
366             }
367     check context (ParseAST.LengthBlock base bits) = do
368         checkedBase <- check context base
369         return AST.LengthBlock
370             { AST.base = checkedBase
371             , AST.bits = bits
372             }
373
374 instance Checkable ParseAST.MapSpec AST.MapSpec where
375     check context ast = do
376         let
377             block = ParseAST.block ast
378             destNode = ParseAST.destNode ast
379             destBase = ParseAST.destBase ast
380         checkedBlock <- check context block
381         checkedDestNode <- check context destNode
382         checkedDestBase <- case destBase of
383             Nothing      -> return Nothing
384             Just address -> do
385                 checkedAddress <- check context address
386                 return $ Just checkedAddress
387         return AST.MapSpec
388             { AST.block    = checkedBlock
389             , AST.destNode = checkedDestNode
390             , AST.destBase = checkedDestBase
391             }
392
393 instance Checkable ParseAST.Address AST.Address where
394     check _ (ParseAST.LiteralAddress value) = do
395         return $ AST.LiteralAddress value
396     check context (ParseAST.ParamAddress name) = do
397         checkParamType context name AST.AddressParam
398         return $ AST.ParamAddress name
399
400 instance Checkable a b => Checkable (ParseAST.For a) (AST.For b) where
401     check context ast = do
402         let
403             varRanges = ParseAST.varRanges ast
404             varNames = map ParseAST.var varRanges
405             body = ParseAST.body ast
406         checkDuplicates context varNames DuplicateVariable
407         ranges <- check context varRanges
408         let
409             currentVars = vars context
410             bodyVars = currentVars `Set.union` (Set.fromList varNames)
411             bodyContext = context
412                 { vars = bodyVars }
413         checkedBody <- check bodyContext body
414         let
415             checkedVarRanges = Map.fromList $ zip varNames ranges
416         return AST.For
417                 { AST.varRanges = checkedVarRanges
418                 , AST.body      = checkedBody
419                 }
420
421 instance Checkable ParseAST.ForVarRange AST.ForRange where
422     check context ast = do
423         let 
424             start = ParseAST.start ast
425             end = ParseAST.end ast
426         (checkedStart, checkedEnd) <- check context (start, end)
427         return AST.ForRange
428             { AST.start = checkedStart
429             , AST.end   = checkedEnd
430             }
431
432 instance Checkable ParseAST.ForLimit AST.ForLimit where
433     check _ (ParseAST.LiteralLimit value) = do
434         return $ AST.LiteralLimit value
435     check context (ParseAST.ParamLimit name) = do
436         checkParamType context name AST.NaturalParam
437         return $ AST.ParamLimit name
438
439 instance Checkable a b => Checkable [a] [b] where
440     check context as = forAll (check context) as
441
442 instance (Checkable a c, Checkable b d) => Checkable (a, b) (c, d) where
443     check context (a, b) =
444         let
445             eitherC = check context a
446             eitherD = check context b
447         in case (eitherC, eitherD) of
448             (Right c, Right d) -> return (c, d)
449             (Left e1, Left e2) -> Left $ CheckFailure (concat $ map failedChecks [e1, e2])
450             (Left e1, _)       -> Left $ e1
451             (_      , Left e2) -> Left $ e2
452 --
453 -- Helpers
454 --
455 rootModule :: ParseAST.SockeyeSpec -> ParseAST.Module
456 rootModule spec =
457     let
458         body = ParseAST.ModuleBody
459             { ParseAST.ports = []
460             , ParseAST.moduleNet = ParseAST.net spec
461             }
462     in ParseAST.Module
463         { ParseAST.name       = "@root"
464         , ParseAST.parameters = []
465         , ParseAST.moduleBody = body
466         }
467
468 getModule :: Context -> String -> Either CheckFailure AST.Module
469 getModule context name = do
470     let
471         modMap = AST.modules $ spec context
472     case Map.lookup name modMap of
473         Nothing -> Left $ checkFailure context [NoSuchModule name]
474         Just m  -> return m
475
476 getCurrentModule :: Context -> AST.Module
477 getCurrentModule context =
478     let
479         modMap = AST.modules $ spec context
480     in modMap Map.! (moduleName context)
481
482 getInstantiatedModule :: Context -> Either CheckFailure AST.Module
483 getInstantiatedModule context =
484     let
485         modName = instModule context
486     in getModule context modName
487
488 getParameterType :: Context -> String -> Either CheckFailure AST.ModuleParamType
489 getParameterType context name = do
490     let
491         mod = getCurrentModule context
492         paramMap = AST.paramTypeMap mod
493     case Map.lookup name paramMap of
494         Nothing -> Left $ checkFailure context [NoSuchParameter name]
495         Just t  -> return t
496
497 forAll :: (a -> Either CheckFailure b) -> [a] -> Either CheckFailure [b]
498 forAll f as = do
499     let
500         bs = map f as
501         es = concat $ map failedChecks (lefts bs)
502     case es of
503         [] -> return $ rights bs
504         _  -> Left $ CheckFailure es
505
506 checkDuplicates :: Context -> [String] -> (String -> FailedCheckType) -> Either CheckFailure ()
507 checkDuplicates context names failure = do
508     let
509         duplicates = duplicateNames names
510     case duplicates of
511         [] -> return ()
512         _  -> Left $ checkFailure context (map failure duplicates)
513     where
514         duplicateNames [] = []
515         duplicateNames (x:xs)
516             | x `elem` xs = nub $ [x] ++ duplicateNames xs
517             | otherwise = duplicateNames xs
518
519 checkVarInScope :: Context -> String -> Either CheckFailure ()
520 checkVarInScope context name = do
521     if name `Set.member` (vars context)
522         then return ()
523         else Left $ checkFailure context [NoSuchVariable name]
524
525
526 checkParamType :: Context -> String -> AST.ModuleParamType -> Either CheckFailure ()
527 checkParamType context name expected = do
528     actual <- getParameterType context name
529     if actual == expected
530         then return ()
531         else Left $ mismatch actual
532     where
533         mismatch t = checkFailure context [ParamTypeMismatch name expected t]