1{-
2  SkateChecker: Checker for the AST
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 SkateChecker where
15
16import Data.Bits
17import System.FilePath.Posix
18import Text.Printf
19
20import SkateParser
21import SkateSchema
22import SkateTypes
23
24import qualified SkateTypeTable as TT
25import qualified SkateDeclarationTable as DT
26
27{-
28==============================================================================
29= Public Functions
30==============================================================================
31-}
32
33{- run various checks -}
34run_all_checks :: String -> SchemaRecord -> IO String
35run_all_checks inFile schemaRecord = do {
36    printf "Running tests on  '%s'\n" inFile;
37    _ <- checkFilename (skateSchemaGetAst schemaRecord) inFile;
38    printf "Checking Namespaces in '%s'\n" inFile;
39    _ <- checkDeclarations (namespaces schemaRecord) [];
40    printf "Checking Flags in '%s'\n" inFile;
41    _ <- checkDeclarations (flags schemaRecord) [];
42    printf "Checking Constants in '%s'\n" inFile;
43    _ <- checkDeclarations (constants schemaRecord) [];
44    printf "Checking Enumerations in '%s'\n" inFile;
45    _ <- checkDeclarations (enumerations schemaRecord) [];
46    printf "Checking Facts in '%s'\n" inFile;
47    _ <- checkDeclarations (facts schemaRecord) (allTypes schemaRecord) ;
48    return ""
49}
50
51
52{-
53==============================================================================
54= Module Private Functions
55==============================================================================
56-}
57
58
59{-----------------------------------------------------------------------------
60- Checking Declarations
61------------------------------------------------------------------------------}
62
63fieldExists :: String -> String -> Bool
64fieldExists a s = (a == s)
65
66valueExists :: Integer -> Integer -> Bool
67valueExists a s = (a == s)
68
69checkUnique :: String -> String -> [String] -> IO ()
70checkUnique fi i defs = do {
71    if not (null (filter (fieldExists i) defs)) then do {
72        ioError $ userError ("error: double definition of '" ++ i ++ "' in '" ++ fi ++ "'");
73    } else do {
74        return()
75    }
76}
77
78checkUniqueVal :: String -> Integer -> [Integer] -> IO ()
79checkUniqueVal fi i defs = do {
80    if not (null (filter (valueExists i) defs)) then do {
81        ioError $ userError ("error: double definition of value '" ++ show(i) ++ "' in '" ++ fi ++ "'");
82    } else do {
83        return()
84    }
85}
86
87
88checkOneDeclaration :: Declaration -> [TT.TTEntry] -> IO ()
89checkOneDeclaration de@(Fact i d a sp) ttbl = do {checkFactAttributes i a ttbl [];}
90checkOneDeclaration de@(Flags i d w f sp) ttbl = do {checkFlagDefs i w f ttbl [] [];}
91checkOneDeclaration de@(Constants i d t f sp) ttbl = do {checkConstantDefs i t f ttbl [];}
92checkOneDeclaration de@(Enumeration i d f sp) ttbl = do {checkEnumDefs i f ttbl [];}
93checkOneDeclaration de@(Namespace i d  _ sp) ttbl = do {return()}
94checkOneDeclaration s _ = do {ioError $ userError ("internal error: encoutered unsupported declaration type." ++ (show s))}
95
96checkDeclarations :: [Declaration] -> [TT.TTEntry] -> IO ()
97checkDeclarations (xs:x) ttbl = do {checkOneDeclaration xs ttbl; checkDeclarations x ttbl}
98checkDeclarations [] _ = do {return ()}
99
100{-----------------------------------------------------------------------------
101- Checking Facts
102------------------------------------------------------------------------------}
103
104fieldTypeLookup :: [TT.TTEntry] -> TT.RecType -> String -> String -> IO ()
105fieldTypeLookup ttbl rt t s = do {
106    if not (TT.exist ttbl rt t) then do {
107        if not (TT.exist ttbl rt (make_qualified_identifer s t)) then do {
108            ioError $ userError ("error: unknown type '" ++ (show rt) ++ " " ++ t ++ "'" );
109        } else do {
110            return ()
111        }
112    } else do {
113        return ()
114    }
115}
116
117fieldTypeCheck :: TypeRef -> [TT.TTEntry] -> IO ()
118fieldTypeCheck tr@(TEnum t s) ttbl = fieldTypeLookup ttbl TT.TTEnum t s
119fieldTypeCheck tr@(TConstant t s) ttbl =fieldTypeLookup ttbl TT.TTConstant t s
120fieldTypeCheck tr@(TFact  t s) ttbl =fieldTypeLookup ttbl TT.TTFact t s
121fieldTypeCheck tr@(TFlags t s) ttbl =fieldTypeLookup ttbl TT.TTFlags t s
122fieldTypeCheck tr@(TBuiltIn t) ttbl = do {return ()}
123
124
125checkFactAttributes :: String -> [FactAttrib] -> [TT.TTEntry] -> [String] -> IO ()
126checkFactAttributes fi (xs@(FactAttrib i d t sp):x) ttbl attribs = do {
127    checkUnique ("fact " ++ fi) i attribs;
128    _ <- fieldTypeCheck t ttbl;
129    checkFactAttributes fi x ttbl (attribs ++ [i]);
130    return ()
131}
132checkFactAttributes _ [] _ _ = do {return ()}
133
134{-----------------------------------------------------------------------------
135- Checking Constants
136------------------------------------------------------------------------------}
137
138checkConstantDefsInt :: String -> TypeRef -> [ConstantDef] -> [TT.TTEntry] -> [String] -> IO ()
139checkConstantDefsInt fi t (xs@(ConstantDefInt i d v sp):x) ttbl attribs = do {
140    checkUnique ("constant " ++ fi) i attribs;
141    checkConstantDefsInt fi t x ttbl (attribs ++ [i]);
142}
143checkConstantDefsInt fi _ (xs@(ConstantDefStr _ _ _ sp):x) _ _ = do {
144    ioError $ userError ("error: constant type mismatch '" ++ fi ++ " expected Integer, was String");
145}
146checkConstantDefsInt fi _ [] _ _ = do {return ()}
147
148checkConstantDefsString :: String -> TypeRef -> [ConstantDef] -> [TT.TTEntry] -> [String] -> IO ()
149checkConstantDefsString fi t (xs@(ConstantDefStr i d v sp):x) ttbl attribs = do {
150    checkUnique ("constant " ++ fi) i attribs;
151    checkConstantDefsString fi t x ttbl (attribs ++ [i]);
152}
153checkConstantDefsString fi _ (xs@(ConstantDefInt _ _ _ _):x) _ _ = do {
154    ioError $ userError ("error: constant type mismatch '" ++ fi ++ " expected Integer, was String");
155}
156checkConstantDefsString _ _ [] _ _ = do {return ()}
157
158
159checkConstantDefs :: String -> TypeRef -> [ConstantDef] -> [TT.TTEntry] -> [String] -> IO ()
160checkConstantDefs fi t (xs@(ConstantDefInt i d v sp):x) ttbl attribs = do {checkConstantDefsInt fi t (xs:x) ttbl attribs}
161checkConstantDefs fi t (xs@(ConstantDefStr i d v sp):x) ttbl attribs = do {checkConstantDefsString fi t (xs:x) ttbl attribs}
162
163{-----------------------------------------------------------------------------
164- Checking Flags
165------------------------------------------------------------------------------}
166
167checkFlagDefs :: String -> Integer -> [FlagDef] -> [TT.TTEntry] -> [String] -> [Integer] -> IO ()
168checkFlagDefs fi w (xs@(FlagDef i d t sp):x) ttbl defs bits = do {
169    checkUnique ("flags " ++ fi) i defs;
170    checkUniqueVal ("flags " ++ fi) t bits;
171    if t < w then do {
172        checkFlagDefs fi w x ttbl (defs ++ [i]) (bits ++ [t]);
173    } else do {
174        ioError $ userError ("error: bit position of flag '" ++ i ++ "' exceeds declared width of '" ++ fi ++ "");
175    }
176}
177checkFlagDefs _ _ [] _ _ _ = do {return ()}
178
179
180{-----------------------------------------------------------------------------
181- Checking Enumerations
182------------------------------------------------------------------------------}
183
184checkEnumDefs :: String -> [EnumDef] -> [TT.TTEntry] -> [String] -> IO ()
185checkEnumDefs fi (xs@(EnumDef i d sp):x) ttbl defs = do {
186    checkUnique ("enumeration " ++ fi) i defs;
187    checkEnumDefs fi x ttbl (defs ++ [i]);
188}
189checkEnumDefs _ [] _ _ = do {return ()}
190
191{-----------------------------------------------------------------------------
192- Checking Namespaces
193------------------------------------------------------------------------------}
194
195
196
197{-----------------------------------------------------------------------------
198- Checking File name
199------------------------------------------------------------------------------}
200
201{- verifies that the filename matches with the query definition -}
202checkFilename :: SkateParser.Schema -> String -> IO ()
203checkFilename schema fname = do
204    let
205        SkateParser.Schema sname _ _ _ _ = schema
206    if sname == takeBaseName fname
207    then return ()
208    else ioError $ userError (
209        "Schema name '" ++ sname ++ "' has to equal filename in " ++ fname)
210
211
212
213
214
215 --   case (Checks.check_all inFile schema) of
216 --     Just errors ->
217 --         do { (hPutStrLn stderr (unlines [ e ++ "\n"  | e <-errors]))
218 --            ; System.Exit.exitWith (ExitFailure 1)
219 --            }
220 --     Nothing -> do { return "" }
221