1{- 2 SockeyeSymbolTableBuilder.hs: Symbol Table Builder for Sockeye 3 4 Part of Sockeye 5 6 Copyright (c) 2018, 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, Universitaetstrasse 6, CH-8092 Zurich, 13 Attn: Systems Group. 14-} 15 16{-# LANGUAGE MultiParamTypeClasses #-} 17{-# LANGUAGE FlexibleInstances #-} 18 19module SockeyeSymbolTableBuilder 20 (buildSymbolTable) where 21 22import Data.List (intercalate) 23 24import Data.Map (Map) 25import qualified Data.Map as Map 26 27import Data.Set (Set) 28import qualified Data.Set as Set 29 30import SockeyeChecks 31 32import SockeyeASTMeta 33import qualified SockeyeParserAST as AST 34import qualified SockeyeSymbolTable as ST 35 36data SymbolTableFail 37 = CircularImports [FilePath] 38 | DuplicateImport String ASTMeta 39 | NoSuchExport String String 40 | ImportShadowing String String String ASTMeta 41 | DuplicateModule String ASTMeta 42 | DuplicateType String ASTMeta 43 | ModuleTypeClash String ASTMeta ASTMeta 44 | DuplicateParameter String 45 | DuplicateConstant String ASTMeta 46 | ParameterShadowing String ASTMeta 47 | DuplicateInstance String ASTMeta 48 | DuplicateNode String ASTMeta 49 50instance CheckFailure SymbolTableFail where 51 errorLines (CircularImports loop) = ["Circular imports detected:", intercalate " -> " $ reverse loop] 52 errorLines (DuplicateImport name firstDefined) = ["Duplicate import '" ++ name ++ "'", "First imported at " ++ show firstDefined] 53 errorLines (NoSuchExport name file) = ["File '" ++ file ++ "' does not export symbol '" ++ name ++ "'"] 54 errorLines (ImportShadowing name defSymType impSymType firstDefined) = [defSymType ++ " '" ++ name ++ "' shadows imported " ++ impSymType, "Imported at " ++ show firstDefined] 55 errorLines (DuplicateModule name firstDefined) = ["Duplicate module '" ++ name ++ "'", "First defined at " ++ show firstDefined] 56 errorLines (DuplicateType name firstDefined) = ["Duplicate type '" ++ name ++ "'", "First defined at " ++ show firstDefined] 57 errorLines (ModuleTypeClash name mDef tDef) = ["Module and type with same name '" ++ name ++ "'", "Module declared at " ++ show mDef, "Type declared at " ++ show tDef] 58 errorLines (DuplicateParameter name) = ["Duplicate parameter '" ++ name ++ "'"] 59 errorLines (DuplicateConstant name firstDefined) = ["Duplicate named constant '" ++ name ++ "'", "First defined at " ++ show firstDefined] 60 errorLines (ParameterShadowing name firstDefined) = ["Named constant '" ++ name ++ "' shadows module parameter", "Parameter is declared at " ++ show firstDefined] 61 errorLines (DuplicateInstance name firstDefined) = ["Duplicate instance '" ++ name ++ "'", "First defined at " ++ show firstDefined] 62 errorLines (DuplicateNode name firstDefined) = ["Duplicate node '" ++ name ++ "'", "First defined at " ++ show firstDefined] 63 64data Import 65 = TypeImport ST.NamedType 66 | ModuleImport ST.Module 67 deriving (Show) 68 69instance MetaAST Import where 70 meta (TypeImport t) = meta t 71 meta (ModuleImport m) = meta m 72 73buildSymbolTable :: AST.Sockeye -> Either (FailedChecks SymbolTableFail) ST.Sockeye 74buildSymbolTable ast = runChecks $ symbol ast 75 76class SymbolSource a b where 77 symbol :: a -> Checks SymbolTableFail b 78 79instance SymbolSource AST.Sockeye ST.Sockeye where 80 symbol ast = do 81 let entryPoint = AST.entryPoint ast 82 files <- fileSymbols [] entryPoint Map.empty 83 return ST.Sockeye 84 { ST.entryPoint = entryPoint 85 , ST.files = files 86 } 87 where 88 fileSymbols predecessors filePath fileSyms 89 | filePath `Map.member` fileSyms = return fileSyms 90 | otherwise = do 91 let file = (AST.files ast) Map.! filePath 92 imports = AST.imports file 93 fileSyms' <- foldChecks importFileSymbols fileSyms imports 94 fileSym <- symbol file 95 importSymbols <- foldChecks (collectImports fileSyms') Map.empty imports 96 fileSym' <- foldChecks addImportSymbol fileSym $ Map.assocs importSymbols 97 return $ Map.insert filePath fileSym' fileSyms' 98 where 99 importFileSymbols importAst fileSyms = do 100 let importFile = AST.importFile importAst 101 case loop importFile predecessors of 102 [] -> fileSymbols (importFile:predecessors) importFile fileSyms 103 loop -> failCheck (meta importAst) (CircularImports $ importFile:loop) >> return fileSyms 104 loop name [] = [] 105 loop name path@(p:ps) 106 | name `elem` path = p:(loop name ps) 107 | otherwise = [] 108 109collectImports :: Map FilePath ST.SockeyeFile -> AST.Import -> Map String Import -> Checks SymbolTableFail (Map String Import) 110collectImports fileSymbols importAst importSymbols = do 111 let importedFileName = AST.importFile importAst 112 importedFile = fileSymbols Map.! importedFileName 113 case AST.explImports importAst of 114 Just as -> foldChecks importWithAlias importSymbols as 115 Nothing -> do 116 withTypes <- foldChecks implicitTypeImport importSymbols (Map.assocs $ ST.types importedFile) 117 foldChecks implicitModuleImport withTypes (Map.assocs $ ST.modules importedFile) 118 where 119 importWithAlias a importSymbols = do 120 let importedFileName = AST.importFile importAst 121 importedFile = fileSymbols Map.! importedFileName 122 origName = AST.originalName a 123 types = ST.types importedFile 124 modules = ST.modules importedFile 125 {- 126 - Import either type or module 127 - Only one can exist (see ModuleTypeClash check) 128 -} 129 case Map.lookup origName types of 130 Just t -> explicitTypeImport a t importSymbols 131 Nothing -> case Map.lookup origName modules of 132 Just m -> explicitModuleImport a m importSymbols 133 Nothing -> do 134 failCheck (meta a) $ NoSuchExport origName importedFileName 135 return importSymbols 136 {- Imported types are not exported -} 137 explicitTypeImport a (ST.ImportedType {}) importSymbols = do 138 failCheck (meta importAst) $ NoSuchExport (AST.originalName a) (AST.importFile importAst) 139 return importSymbols 140 explicitTypeImport a (ST.NamedType {}) importSymbols = do 141 let alias = AST.importAlias a 142 case Map.lookup alias importSymbols of 143 Nothing -> return $ Map.insert alias (importedType (AST.originalName a) $ meta a) importSymbols 144 Just dup -> do 145 failCheck (meta a) $ DuplicateImport alias (meta dup) 146 return importSymbols 147 {- Imported modules are not exported -} 148 explicitModuleImport a (ST.ImportedModule {}) importSymbols = do 149 failCheck (meta a) $ NoSuchExport (AST.originalName a) (AST.importFile importAst) 150 return importSymbols 151 explicitModuleImport a (ST.Module {}) importSymbols = do 152 let alias = AST.importAlias a 153 case Map.lookup alias importSymbols of 154 Nothing -> return $ Map.insert alias (importedModule (AST.originalName a) $ meta a) importSymbols 155 Just dup -> do 156 failCheck (meta a) $ DuplicateImport alias (meta dup) 157 return importSymbols 158 {- Only import declared types, not imported ones -} 159 implicitTypeImport (_, ST.ImportedType {}) importSymbols = return importSymbols 160 implicitTypeImport (name, ST.NamedType {}) importSymbols = case Map.lookup name importSymbols of 161 Nothing -> return $ Map.insert name (importedType name $ meta importAst) importSymbols 162 Just dup -> do 163 failCheck (meta importAst) $ DuplicateImport name (meta dup) 164 return importSymbols 165 {- Only import declared modules, not imported ones -} 166 implicitModuleImport (_, ST.ImportedModule {}) importSymbols = return importSymbols 167 implicitModuleImport (name, ST.Module {} ) importSymbols = case Map.lookup name importSymbols of 168 Nothing -> return $ Map.insert name (importedModule name $ meta importAst) importSymbols 169 Just dup -> do 170 failCheck (meta importAst) $ DuplicateImport name (meta dup) 171 return importSymbols 172 importedType typeName m = TypeImport $ ST.ImportedType 173 { ST.namedTypeMeta = m 174 , ST.typeFile = AST.importFile importAst 175 , ST.origTypeName = typeName 176 } 177 importedModule modName m = ModuleImport $ ST.ImportedModule 178 { ST.moduleMeta = m 179 , ST.moduleFile = AST.importFile importAst 180 , ST.origModName = modName 181 } 182 183addImportSymbol :: (String, Import) -> ST.SockeyeFile -> Checks SymbolTableFail ST.SockeyeFile 184addImportSymbol (name, TypeImport i) fileSymbol = do 185 case Map.lookup name (ST.modules fileSymbol) of 186 Nothing -> return () 187 Just m -> failCheck (meta m) $ ImportShadowing name "Module" "type" (meta i) 188 let ts = ST.types fileSymbol 189 case Map.lookup name ts of 190 Nothing -> return $ fileSymbol { ST.types = Map.insert name i ts } 191 Just t -> failCheck (meta t) (ImportShadowing name "Type" "type" (meta i)) >> return fileSymbol 192addImportSymbol (name, ModuleImport i) fileSymbol = do 193 case Map.lookup name (ST.types fileSymbol) of 194 Nothing -> return () 195 Just t -> failCheck (meta t) $ ImportShadowing name "Type" "module" (meta i) 196 let ms = ST.modules fileSymbol 197 case Map.lookup name ms of 198 Nothing -> return $ fileSymbol { ST.modules = Map.insert name i ms } 199 Just m -> failCheck (meta m) (ImportShadowing name "Module" "module" (meta i)) >> return fileSymbol 200 201instance SymbolSource AST.SockeyeFile ST.SockeyeFile where 202 symbol ast = do 203 modules <- symbolMap AST.moduleName moduleDupFail $ AST.modules ast 204 types <- symbolMap AST.typeName typeDupFail $ AST.types ast 205 types' <- foldChecks checkModTypeClash types $ Map.assocs modules 206 return ST.SockeyeFile 207 { ST.sockeyeFileMeta = AST.sockeyeFileMeta ast 208 , ST.modules = modules 209 , ST.types = types' 210 } 211 where 212 moduleDupFail m s = DuplicateModule (AST.moduleName m) (meta s) 213 typeDupFail t s = DuplicateType (AST.typeName t) (meta s) 214 checkModTypeClash (name, m) ts = case Map.lookup name ts of 215 Nothing -> return ts 216 Just t -> do 217 let mMeta = meta m 218 tMeta = meta t 219 failCheck (max mMeta tMeta) $ ModuleTypeClash name mMeta tMeta 220 return $ Map.delete name ts 221 222instance SymbolSource AST.Module ST.Module where 223 symbol ast = do 224 let paramList = AST.parameters ast 225 constantList = AST.constants ast 226 instDecls = AST.instDecls ast 227 nodeDecls = AST.nodeDecls ast 228 parameters <- symbolMap AST.paramName paramDupFail paramList 229 constants <- symbolMap AST.constName constDupFail constantList 230 foldChecks (checkNoShadowing parameters) () constantList 231 instances <- symbolMap AST.instName instDupFail instDecls 232 allNodes <- symbolMap AST.nodeName nodeDupFail nodeDecls 233 let parameterOrder = map AST.paramName paramList 234 inputPortNames = Set.fromList (map AST.nodeName $ filter isInputPort nodeDecls) 235 outputPortNames = Set.fromList (map AST.nodeName $ filter isOutputPort nodeDecls) 236 (outputPorts, nodes) = Map.partitionWithKey (isInSet outputPortNames) allNodes 237 return ST.Module 238 { ST.moduleMeta = meta ast 239 , ST.parameters = parameters 240 , ST.parameterOrder = parameterOrder 241 , ST.constants = constants 242 , ST.inputPorts = inputPortNames 243 , ST.outputPorts = outputPorts 244 , ST.instances = instances 245 , ST.nodes = nodes 246 } 247 where 248 paramDupFail p _ = DuplicateParameter (AST.paramName p) 249 constDupFail c d = DuplicateConstant (AST.constName c) (meta d) 250 instDupFail i d = DuplicateInstance (AST.instName i) (meta d) 251 nodeDupFail n d = DuplicateNode (AST.nodeName n) (meta d) 252 isInputPort n = AST.InputPort == (AST.nodeKind n) 253 isOutputPort n = AST.OutputPort == (AST.nodeKind n) 254 isInSet set k _ = k `Set.member` set 255 checkNoShadowing paramMap c _ = do 256 let name = AST.constName c 257 case Map.lookup name paramMap of 258 Nothing -> return () 259 Just shadowed -> failCheck (meta c) $ ParameterShadowing name (meta shadowed) 260 261instance SymbolSource AST.ModuleParameter ST.ModuleParameter where 262 symbol ast = do 263 return ST.ModuleParameter 264 { ST.paramMeta = meta ast 265 , ST.paramRange = ST.NaturalSet (meta $ AST.paramRange ast) [] 266 } 267 268instance SymbolSource AST.InstanceDeclaration ST.Instance where 269 symbol ast = do 270 return ST.Instance 271 { ST.instMeta = meta ast 272 , ST.instModule = AST.instModName ast 273 , ST.instArrSize = AST.instArrSize ast 274 } 275 276instance SymbolSource AST.NodeDeclaration ST.Node where 277 symbol ast = do 278 return ST.Node 279 { ST.nodeMeta = meta ast 280 , ST.nodeType = AST.nodeType ast 281 , ST.nodeArrSize = AST.nodeArrSize ast 282 } 283 284instance SymbolSource AST.NamedType ST.NamedType where 285 symbol ast = return ST.NamedType 286 { ST.namedTypeMeta = meta ast 287 , ST.namedType = AST.namedType ast 288 } 289 290instance SymbolSource AST.NamedConstant ST.NamedConstant where 291 symbol ast = return ST.NamedConstant 292 { ST.namedConstMeta = meta ast 293 , ST.namedConst = AST.namedConst ast 294 } 295 296symbolMap :: (MetaAST a, MetaAST b, SymbolSource a b) => (a -> String) -> (a -> b -> SymbolTableFail) -> [a] -> Checks SymbolTableFail (Map String b) 297symbolMap keyFn fail = foldChecks f Map.empty 298 where 299 f a symMap = do 300 sym <- symbol a 301 let name = keyFn a 302 case Map.lookup name symMap of 303 Nothing -> return $ Map.insert name sym symMap 304 Just dup -> failCheck (meta a) (fail a dup) >> return symMap 305