699e2ac64f8c3fd7862bbd04c28d3042365259f7
[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         (checkedId, checkedPort) <- check context (mappedId, mappedPort)
297         return $ AST.PortMap
298             { AST.mappedId   = checkedId
299             , AST.mappedPort = checkedPort
300             }
301
302 instance Checkable ParseAST.NodeDecl AST.NodeDecl where
303     check context (ParseAST.MultiNodeDecl for) = do
304         checkedFor <- check context for
305         return $ AST.MultiNodeDecl checkedFor
306     check context ast = do
307         let
308             nodeId = ParseAST.nodeId ast
309             nodeSpec = ParseAST.nodeSpec ast
310         checkedId <- check context nodeId
311         checkedSpec <- check context nodeSpec
312         return AST.NodeDecl
313             { AST.nodeId   = checkedId
314             , AST.nodeSpec = checkedSpec
315             }
316
317 instance Checkable ParseAST.Identifier AST.Identifier where
318     check _ (ParseAST.SimpleIdent name) = return $ AST.SimpleIdent name
319     check context ast = do
320         let
321             prefix = ParseAST.prefix ast
322             varName = ParseAST.varName ast
323             suffix = ParseAST.suffix ast
324         checkVarInScope context varName
325         checkedSuffix <- case suffix of
326             Nothing    -> return Nothing
327             Just ident -> do
328                 checkedIdent <- check context ident
329                 return $ Just checkedIdent
330         return AST.TemplateIdent
331             { AST.prefix  = prefix
332             , AST.varName = varName
333             , AST.suffix  = checkedSuffix
334             }
335
336 instance Checkable ParseAST.NodeSpec AST.NodeSpec where
337     check context ast = do
338         let 
339             nodeType = ParseAST.nodeType ast
340             accept = ParseAST.accept ast
341             translate = ParseAST.translate ast
342             overlay = ParseAST.overlay ast
343         checkedAccept <- check context accept
344         checkedTranslate <- check context translate
345         checkedOverlay <- case overlay of
346             Nothing    -> return Nothing
347             Just ident -> do
348                 checkedIdent <- check context ident
349                 return $ Just checkedIdent
350         return AST.NodeSpec
351             { AST.nodeType  = nodeType
352             , AST.accept    = checkedAccept
353             , AST.translate = checkedTranslate
354             , AST.overlay   = checkedOverlay
355             }
356
357 instance Checkable ParseAST.BlockSpec AST.BlockSpec where
358     check context (ParseAST.SingletonBlock address) = do
359         checkedAddress <- check context address
360         return AST.SingletonBlock
361             { AST.address = checkedAddress }
362     check context (ParseAST.RangeBlock base limit) = do
363         (checkedBase, checkedLimit) <- check context (base, limit)
364         return AST.RangeBlock
365             { AST.base  = checkedBase
366             , AST.limit = checkedLimit
367             }
368     check context (ParseAST.LengthBlock base bits) = do
369         checkedBase <- check context base
370         return AST.LengthBlock
371             { AST.base = checkedBase
372             , AST.bits = bits
373             }
374
375 instance Checkable ParseAST.MapSpec AST.MapSpec where
376     check context ast = do
377         let
378             block = ParseAST.block ast
379             destNode = ParseAST.destNode ast
380             destBase = ParseAST.destBase ast
381         checkedBlock <- check context block
382         checkedDestNode <- check context destNode
383         checkedDestBase <- case destBase of
384             Nothing      -> return Nothing
385             Just address -> do
386                 checkedAddress <- check context address
387                 return $ Just checkedAddress
388         return AST.MapSpec
389             { AST.block    = checkedBlock
390             , AST.destNode = checkedDestNode
391             , AST.destBase = checkedDestBase
392             }
393
394 instance Checkable ParseAST.Address AST.Address where
395     check _ (ParseAST.NumberAddress value) = do
396         return $ AST.NumberAddress value
397     check context (ParseAST.ParamAddress name) = do
398         checkParamType context name AST.AddressParam
399         return $ AST.ParamAddress name
400
401 instance Checkable a b => Checkable (ParseAST.For a) (AST.For b) where
402     check context ast = do
403         let
404             varRanges = ParseAST.varRanges ast
405             varNames = map ParseAST.var varRanges
406             body = ParseAST.body ast
407         checkDuplicates context varNames DuplicateVariable
408         ranges <- check context varRanges
409         let
410             currentVars = vars context
411             bodyVars = currentVars `Set.union` (Set.fromList varNames)
412             bodyContext = context
413                 { vars = bodyVars }
414         checkedBody <- check bodyContext body
415         let
416             checkedVarRanges = Map.fromList $ zip varNames ranges
417         return AST.For
418                 { AST.varRanges = checkedVarRanges
419                 , AST.body      = checkedBody
420                 }
421
422 instance Checkable ParseAST.ForVarRange AST.ForRange where
423     check context ast = do
424         let 
425             start = ParseAST.start ast
426             end = ParseAST.end ast
427         (checkedStart, checkedEnd) <- check context (start, end)
428         return AST.ForRange
429             { AST.start = checkedStart
430             , AST.end   = checkedEnd
431             }
432
433 instance Checkable ParseAST.ForLimit AST.ForLimit where
434     check _ (ParseAST.NumberLimit value) = do
435         return $ AST.NumberLimit value
436     check context (ParseAST.ParamLimit name) = do
437         checkParamType context name AST.NumberParam
438         return $ AST.ParamLimit name
439
440 instance Checkable a b => Checkable [a] [b] where
441     check context as = forAll (check context) as
442
443 instance (Checkable a c, Checkable b d) => Checkable (a, b) (c, d) where
444     check context (a, b) =
445         let
446             eitherC = check context a
447             eitherD = check context b
448         in case (eitherC, eitherD) of
449             (Right c, Right d) -> return (c, d)
450             (Left e1, Left e2) -> Left $ CheckFailure (concat $ map failedChecks [e1, e2])
451             (Left e1, _)       -> Left $ e1
452             (_      , Left e2) -> Left $ e2
453 --
454 -- Helpers
455 --
456 rootModule :: ParseAST.SockeyeSpec -> ParseAST.Module
457 rootModule spec =
458     let
459         body = ParseAST.ModuleBody
460             { ParseAST.ports = []
461             , ParseAST.moduleNet = ParseAST.net spec
462             }
463     in ParseAST.Module
464         { ParseAST.name       = "@root"
465         , ParseAST.parameters = []
466         , ParseAST.moduleBody = body
467         }
468
469 getModule :: Context -> String -> Either CheckFailure AST.Module
470 getModule context name = do
471     let
472         modMap = AST.modules $ spec context
473     case Map.lookup name modMap of
474         Nothing -> Left $ checkFailure context [NoSuchModule name]
475         Just m  -> return m
476
477 getCurrentModule :: Context -> AST.Module
478 getCurrentModule context =
479     let
480         modMap = AST.modules $ spec context
481     in modMap Map.! (moduleName context)
482
483 getInstantiatedModule :: Context -> Either CheckFailure AST.Module
484 getInstantiatedModule context =
485     let
486         modName = instModule context
487     in getModule context modName
488
489 getParameterType :: Context -> String -> Either CheckFailure AST.ModuleParamType
490 getParameterType context name = do
491     let
492         mod = getCurrentModule context
493         paramMap = AST.paramTypeMap mod
494     case Map.lookup name paramMap of
495         Nothing -> Left $ checkFailure context [NoSuchParameter name]
496         Just t  -> return t
497
498 forAll :: (a -> Either CheckFailure b) -> [a] -> Either CheckFailure [b]
499 forAll f as = do
500     let
501         bs = map f as
502         es = concat $ map failedChecks (lefts bs)
503     case es of
504         [] -> return $ rights bs
505         _  -> Left $ CheckFailure es
506
507 checkDuplicates :: Context -> [String] -> (String -> FailedCheckType) -> Either CheckFailure ()
508 checkDuplicates context names failure = do
509     let
510         duplicates = duplicateNames names
511     case duplicates of
512         [] -> return ()
513         _  -> Left $ checkFailure context (map failure duplicates)
514     where
515         duplicateNames [] = []
516         duplicateNames (x:xs)
517             | x `elem` xs = nub $ [x] ++ duplicateNames xs
518             | otherwise = duplicateNames xs
519
520 checkVarInScope :: Context -> String -> Either CheckFailure ()
521 checkVarInScope context name = do
522     if name `Set.member` (vars context)
523         then return ()
524         else Left $ checkFailure context [NoSuchVariable name]
525
526
527 checkParamType :: Context -> String -> AST.ModuleParamType -> Either CheckFailure ()
528 checkParamType context name expected = do
529     actual <- getParameterType context name
530     if actual == expected
531         then return ()
532         else Left $ mismatch actual
533     where
534         mismatch t = checkFailure context [ParamTypeMismatch name expected t]