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