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