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