1{- 2 SkateTypeTable: List of all defined types 3 4 Part of Skate: a Schema specification languge 5 6 Copyright (c) 2017, ETH Zurich. 7 All rights reserved. 8 9 This file is distributed under the terms in the attached LICENSE file. 10 If you do not find this file, copies can be found by writing to: 11 ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group. 12-} 13 14module SkateTypeTable where 15 16import Data.List 17 18import System.IO 19import System.IO.Error 20import Text.Printf 21import Text.ParserCombinators.Parsec.Pos 22 23import SkateParser 24import SkateTypes 25 26data RecType = TTBuiltIn | TTFlags | TTConstant | TTEnum | TTFact 27 deriving(Eq) 28 29instance Show RecType where 30 show TTBuiltIn = "builtin" 31 show TTFlags = "flag" 32 show TTConstant = "const" 33 show TTEnum = "enum" 34 show TTFact = "fact" 35 36data TTEntry = Rec RecType String TypeBuiltIn SourcePos 37 38instance Show TTEntry where 39 show (Rec _ s _ _) = "TT.Rec: " ++ s 40 41 42{- 43============================================================================== 44= Public Functions 45============================================================================== 46-} 47 48{- creates the Skate type table -} 49make_table :: Schema -> IO [TTEntry] 50make_table s@(Schema n d decls imps _) = 51 let 52 tt = addOneTypeToTable n [] decls; 53 in 54 do { 55 printf "Creating TypeTable.\n"; 56 57 print (show tt); 58 return (tt) 59} 60 61{- -} 62exist :: [TTEntry] -> RecType -> String -> Bool 63exist ttbl t a = not (null (filter (type_ref_exists a t) ttbl)) 64 65{- -} 66lookup :: [TTEntry] -> String -> RecType 67lookup t a = tt 68 where 69 Rec tt _ _ _= head (filter (typeExists a) t) 70 71 72get_builtin_type :: String -> [TTEntry] -> TypeBuiltIn 73get_builtin_type a t = tt 74 where 75 Rec rt _ tt _ = head (filter (typeExists a) t) 76 77{- 78============================================================================== 79= Module Private Functions 80============================================================================== 81-} 82 83 84{- recursively adds a list of declarations to the type table -} 85addOneTypeToTable :: String -> [TTEntry] -> [Declaration] -> [TTEntry] 86addOneTypeToTable p t (xs:x) = (addOneTypeToTable p (parseType p t xs) x) 87addOneTypeToTable p t [] = t 88 89 90{- handles each declaration and adds a type -} 91parseType :: String -> [TTEntry] -> Declaration -> [TTEntry] 92parseType p t d@(Fact i _ _ sp) = addOneType i t TTFact UInt8 sp 93parseType p t d@(Flags i _ w _ sp) = addOneType i t TTFlags (builtin_flag_type w) sp 94parseType p t d@(Constants i _ a@(TBuiltIn tr) _ sp) = addOneType i t TTConstant tr sp 95parseType p t d@(Enumeration i _ _ sp) = addOneType i t TTEnum UInt32 sp 96parseType p t d@(Namespace i _ decls sp) = addOneTypeToTable i t decls 97parseType p t d@(Section _ decls sp) = addOneTypeToTable p t decls 98parseType p t d@(Text _ sp) = t 99 100{- boolean function that returns True iff the type record matches -} 101typeExists :: String -> TTEntry -> Bool 102typeExists a d@(Rec _ e _ _) = (a == e) 103 104{- boolean function that returns True iff the type record matches -} 105type_ref_exists :: String -> RecType -> TTEntry -> Bool 106type_ref_exists a t d@(Rec tt e _ _) = ((a == e) && (t == tt)) 107 108{- adds one type to the type table -} 109addOneType :: String -> [TTEntry] -> RecType -> TypeBuiltIn -> SourcePos -> [TTEntry] 110addOneType n recs t tr sp = 111 let 112 existingTypes = (filter (typeExists n) recs) 113 in 114 if null existingTypes then recs ++ [Rec t n tr sp] 115 else error $ "error in " ++ (show sp) ++ ": re-definition of type '" ++ n ++ "'." 116 ++ " previously defined " ++ (show (head existingTypes)); 117