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