skate: store source position when parsing a skatefile
authorReto Achermann <reto.achermann@inf.ethz.ch>
Sat, 6 May 2017 14:12:53 +0000 (16:12 +0200)
committerReto Achermann <reto.achermann@inf.ethz.ch>
Sat, 6 May 2017 14:12:53 +0000 (16:12 +0200)
Signed-off-by: Reto Achermann <reto.achermann@inf.ethz.ch>

tools/skate/Main.hs
tools/skate/SkateBackendCode.hs
tools/skate/SkateBackendHeader.hs
tools/skate/SkateBackendWiki.hs
tools/skate/SkateChecker.hs
tools/skate/SkateDeclarationTable.hs
tools/skate/SkateParser.hs
tools/skate/SkateSchema.hs
tools/skate/SkateTypeTable.hs
tools/skate/foobar.sks [deleted file]

index 660b4e0..98fe2e9 100644 (file)
@@ -197,8 +197,8 @@ findImport (d:t) f =  do
 resolveImp :: [SkateParser.Schema] -> [String] -> IO [SkateParser.Schema]
 resolveImp dfl path =
     let
-        allimports = nub $ concat [ i | (SkateParser.Schema n _ _ i) <- dfl ]
-        gotimports = [ n | (SkateParser.Schema n _ _ i) <- dfl ]
+        allimports = nub $ concat [ i | (SkateParser.Schema n _ _ i _) <- dfl ]
+        gotimports = [ n | (SkateParser.Schema n _ _ i _) <- dfl ]
         required = allimports \\ gotimports
     in
         case required of
index f05a7b6..cd02563 100644 (file)
@@ -17,6 +17,8 @@ import Data.Char
 import Data.List
 import Data.Char
 
+import Text.ParserCombinators.Parsec.Pos
+
 import qualified CAbsSyntax as C
 import SkateParser
 import SkateSchema
@@ -31,7 +33,7 @@ compile infile outfile s = unlines $ C.pp_unit $  (skate_c_body s infile)
 skate_c_body :: SchemaRecord -> String -> C.Unit
 skate_c_body sr infile =
     let
-        Schema n d decls imps = (schema sr)
+        Schema n d decls imps sp = (schema sr)
     in
     C.UnitList [
         (skate_c_preamble n d infile),
index bd5f559..1fbc158 100644 (file)
@@ -16,6 +16,8 @@ module SkateBackendHeader where
 import Data.List
 import Data.Char
 
+import Text.ParserCombinators.Parsec.Pos
+
 import qualified CAbsSyntax as C
 import SkateParser
 import SkateSchema
@@ -30,7 +32,7 @@ compile infile outfile s = unlines $ C.pp_unit $ skate_header_file s infile
 skate_header_file :: SchemaRecord -> String -> C.Unit
 skate_header_file sr infile =
     let
-        Schema n d decls imps = (schema sr)
+        Schema n d decls imps sp = (schema sr)
         sym = "SKATE__" ++ (map toUpper n) ++ "_SCHEMA_H_"
     in
       C.IfNDef sym ([ C.Define sym [] "1"] ++ (skate_header_body sr infile)) []
@@ -42,7 +44,7 @@ skate_header_file sr infile =
 skate_header_body :: SchemaRecord -> String -> [ C.Unit ]
 skate_header_body sr infile =
     let
-        Schema n d decls imps = (schema sr)
+        Schema n d decls imps sp = (schema sr)
     in
     [C.Blank, C.Blank] ++
     [(skate_c_preamble n d infile)] ++
@@ -100,13 +102,13 @@ skate_c_headerfiles imps = [C.MultiComment ["Imports"]] ++
 ------------------------------------------------------------------------------}
 
 skate_c_header_one_attrib :: String -> FactAttrib -> [C.Param]
-skate_c_header_one_attrib p e@(FactAttrib i d t) = [
+skate_c_header_one_attrib p e@(FactAttrib i d t sp) = [
   C.ParamDoxyComment d,
   C.Param (typeref_to_ctype t) i]
 
-skate_c_header_fact :: String -> String -> [ FactAttrib ]-> [C.Unit]
-skate_c_header_fact i d attrib = [
-    (skate_c_type_comment "Fact" d i),
+skate_c_header_fact :: String -> String -> [ FactAttrib ] -> SourcePos -> [C.Unit]
+skate_c_header_fact i d attrib sp = [
+    (skate_c_type_comment "Fact" d i sp),
     C.StructDecl ttype $ concat (intersperse [C.ParamBlank] [skate_c_header_one_attrib i a | a <- attrib]),
     C.TypeDef (C.Struct ttype) ttype,
     C.Blank]
@@ -121,7 +123,7 @@ skate_c_header_fact i d attrib = [
 
 
 skate_c_header_one_flag :: String -> FlagDef -> C.TypeSpec -> C.Unit
-skate_c_header_one_flag p f@(FlagDef i d v) t = C.UnitList [
+skate_c_header_one_flag p f@(FlagDef i d v _) t = C.UnitList [
     C.DoxyComment d,
     C.Define (flagdef) [] (C.pp_expr $ C.Cast t $
             C.Binary C.LeftShift (C.NumConstant 1) (C.NumConstant v)) ]
@@ -130,9 +132,9 @@ skate_c_header_one_flag p f@(FlagDef i d v) t = C.UnitList [
             flagdef = map toUpper (identifier_to_cname flag)
 
 
-skate_c_header_flags :: String -> String -> Integer ->[ FlagDef ]-> [C.Unit]
-skate_c_header_flags i d w defs = [
-    (skate_c_type_comment "Flags" d i),
+skate_c_header_flags :: String -> String -> Integer ->[ FlagDef ] -> SourcePos -> [C.Unit]
+skate_c_header_flags i d w defs sp = [
+    (skate_c_type_comment "Flags" d i sp),
     C.TypeDef (C.TypeName ttype) tname,
     C.Blank]
     ++ [skate_c_header_one_flag i def (C.TypeName tname) | def <- defs]
@@ -148,22 +150,22 @@ skate_c_header_flags i d w defs = [
 
 
 skate_c_header_one_const :: String -> ConstantDef -> C.TypeSpec -> C.Unit
-skate_c_header_one_const p f@(ConstantDefInt i d v) t = C.UnitList [
+skate_c_header_one_const p f@(ConstantDefInt i d v _) t = C.UnitList [
     C.DoxyComment d,
     C.Define (constdef) [] (C.pp_expr $ C.Cast t $ C.NumConstant v) ]
     where
         c = make_qualified_identifer p i
         constdef = map toUpper (identifier_to_cname c)
-skate_c_header_one_const p f@(ConstantDefStr i d v) t = C.UnitList [
+skate_c_header_one_const p f@(ConstantDefStr i d v _) t = C.UnitList [
     C.DoxyComment d,
     C.Define (constdef) [] (C.pp_expr $ C.Cast t $ C.StringConstant v) ]
         where
             c = make_qualified_identifer p i
             constdef = map toUpper (identifier_to_cname c)
 
-skate_c_header_const :: String -> String -> TypeRef ->[ ConstantDef ] -> [C.Unit]
-skate_c_header_const i d t@(TBuiltIn tref) defs = [
-    (skate_c_type_comment "Constants" d i),
+skate_c_header_const :: String -> String -> TypeRef ->[ ConstantDef ] -> SourcePos -> [C.Unit]
+skate_c_header_const i d t@(TBuiltIn tref) defs sp = [
+    (skate_c_type_comment "Constants" d i sp),
     C.TypeDef (typeref_to_ctype t) tname,
     C.Blank]
     ++ [skate_c_header_one_const i def (C.TypeName tname) | def <- defs]
@@ -178,15 +180,15 @@ skate_c_header_const i d t@(TBuiltIn tref) defs = [
 
 
 skate_c_header_one_enum :: String -> EnumDef -> C.EnumItem
-skate_c_header_one_enum p e@(EnumDef i d) = C.EnumItem name d Nothing
+skate_c_header_one_enum p e@(EnumDef i d _) = C.EnumItem name d Nothing
     where
         enum = make_qualified_identifer p i
         name = map toUpper (identifier_to_cname enum)
 
 
-skate_c_header_enum :: String -> String -> [ EnumDef ] -> [C.Unit]
-skate_c_header_enum i d defs = [
-    (skate_c_type_comment "Enumeration" d i),
+skate_c_header_enum :: String -> String -> [ EnumDef ] -> SourcePos -> [C.Unit]
+skate_c_header_enum i d defs sp = [
+    (skate_c_type_comment "Enumeration" d i sp),
     C.EnumDecl ttype [skate_c_header_one_enum i def | def <- defs],
     C.Blank]
     where
@@ -201,19 +203,20 @@ skate_c_header_enum i d defs = [
 ------------------------------------------------------------------------------}
 
 skate_c_header_one_decl :: Declaration -> [ C.Unit ]
-skate_c_header_one_decl de@(Fact i d a) = skate_c_header_fact i d a
-skate_c_header_one_decl de@(Flags i d w f) = skate_c_header_flags i d w f
-skate_c_header_one_decl de@(Constants i d t f) = skate_c_header_const i d t f
-skate_c_header_one_decl de@(Enumeration i d f) = skate_c_header_enum i d f
+skate_c_header_one_decl de@(Fact i d a sp) = skate_c_header_fact i d a sp
+skate_c_header_one_decl de@(Flags i d w f sp) = skate_c_header_flags i d w f sp
+skate_c_header_one_decl de@(Constants i d t f sp) = skate_c_header_const i d t f sp
+skate_c_header_one_decl de@(Enumeration i d f sp) = skate_c_header_enum i d f sp
 skate_c_header_one_decl _  = []
 
 
 skate_c_header_decls :: [Declaration] -> [ C.Unit ]
 skate_c_header_decls decls = [C.UnitList $ skate_c_header_one_decl d | d <- decls]
 
-skate_c_type_comment :: String -> String -> String -> C.Unit
-skate_c_type_comment t desc defined = C.MultiDoxy [
+skate_c_type_comment :: String -> String -> String -> SourcePos -> C.Unit
+skate_c_type_comment t desc defined sp = C.MultiDoxy [
     "@brief " ++ desc,
     "",
     "Type: " ++ t,
-    "Defined in " ++ defined]
+    "Defined in " ++ defined,
+    "Defined in " ++ (show sp)]
index dac20e9..b66c764 100644 (file)
@@ -20,6 +20,8 @@ import Data.Time.Clock.POSIX
 import Data.List
 import Data.Char
 
+import Text.ParserCombinators.Parsec.Pos
+
 
 import  SkateParser
 import SkateTypes
@@ -33,7 +35,7 @@ compile :: String -> String -> SchemaRecord -> String
 compile infile outfile sr =
     h ++ i ++ W.lineBreak ++ b ++ W.lineBreak ++ f
     where
-        Schema sname sdesc decls imps = (schema sr)
+        Schema sname sdesc decls imps _ = (schema sr)
         h = wikiHeader sname sdesc infile
         i = wikiImports imps
         b = wikiBody decls sname
@@ -65,13 +67,13 @@ wikiBody decls sname = heading ++ concat declstr
 
 
 wikiPrintDecl :: Declaration -> Int -> String -> String
-wikiPrintDecl d@(Fact fn fd attr) l prefix= (wikiPrintFact fn fd attr prefix l)
-wikiPrintDecl d@(Flags f fd w defs) l prefix = (wikiPrintFlags f w fd defs) prefix l
-wikiPrintDecl d@(Constants n cd t defs) l prefix = wikiPrintConstants n t cd defs prefix l
-wikiPrintDecl d@(Enumeration n ed defs) l prefix = wikiPrintEnum n ed defs prefix l
-wikiPrintDecl d@(Namespace n nd defs) l prefix = wikiPrintNameSpace n nd defs l prefix
-wikiPrintDecl d@(Section n defs) l prefix = wikiPrintSection n defs l prefix
-wikiPrintDecl d@(Text t) l prefix = wikiPrintText t
+wikiPrintDecl d@(Fact fn fd attr sp) l prefix= (wikiPrintFact fn fd attr prefix l)
+wikiPrintDecl d@(Flags f fd w defs sp) l prefix = (wikiPrintFlags f w fd defs) prefix l
+wikiPrintDecl d@(Constants n cd t defs sp) l prefix = wikiPrintConstants n t cd defs prefix l
+wikiPrintDecl d@(Enumeration n ed defs sp) l prefix = wikiPrintEnum n ed defs prefix l
+wikiPrintDecl d@(Namespace n nd defs sp) l prefix = wikiPrintNameSpace n nd defs l prefix
+wikiPrintDecl d@(Section n defs sp) l prefix = wikiPrintSection n defs l prefix
+wikiPrintDecl d@(Text t sp) l prefix = wikiPrintText t
 
 
 {----------------------------------------------------------------------------}
@@ -91,10 +93,10 @@ wikiPrintFact n d attrib prefix l = title ++ W.newLine
         prolog = name ++ "(" ++ (concat prologfields) ++ ")"
 
 wikiPrintFactAttrib :: FactAttrib -> [String]
-wikiPrintFactAttrib fa@(FactAttrib n d t) = [n, (show t), d]
+wikiPrintFactAttrib fa@(FactAttrib n d t _) = [n, (show t), d]
 
 wikiPrintFactFieldNames :: FactAttrib -> String
-wikiPrintFactFieldNames fa@(FactAttrib n _ _) = n
+wikiPrintFactFieldNames fa@(FactAttrib n _ _ _) = n
 
 
 {----------------------------------------------------------------------------}
@@ -115,7 +117,7 @@ wikiPrintFlags n w d f prefix l = title ++ W.newLine
         name = makeDeclName prefix n
 
 wikiPrintFlagDefs :: FlagDef -> String -> String -> (String, String, String)
-wikiPrintFlagDefs fd@(FlagDef n d v) flag prefix = (fname, d, fval)
+wikiPrintFlagDefs fd@(FlagDef n d v _) flag prefix = (fname, d, fval)
     where
         fname = makeFlagName prefix flag n
         fval = (show (v))
index ba1aeef..2fbc6d2 100644 (file)
@@ -86,11 +86,11 @@ checkUniqueVal fi i defs = do {
 
 
 checkOneDeclaration :: Declaration -> [TT.TTEntry] -> IO ()
-checkOneDeclaration de@(Fact i d a) ttbl = do {checkFactAttributes i a ttbl [];}
-checkOneDeclaration de@(Flags i d w f) ttbl = do {checkFlagDefs i w f ttbl [] [];}
-checkOneDeclaration de@(Constants i d t f) ttbl = do {checkConstantDefs i t f ttbl [];}
-checkOneDeclaration de@(Enumeration i d f) ttbl = do {checkEnumDefs i f ttbl [];}
-checkOneDeclaration de@(Namespace i d  _ ) ttbl = do {return()}
+checkOneDeclaration de@(Fact i d a sp) ttbl = do {checkFactAttributes i a ttbl [];}
+checkOneDeclaration de@(Flags i d w f sp) ttbl = do {checkFlagDefs i w f ttbl [] [];}
+checkOneDeclaration de@(Constants i d t f sp) ttbl = do {checkConstantDefs i t f ttbl [];}
+checkOneDeclaration de@(Enumeration i d f sp) ttbl = do {checkEnumDefs i f ttbl [];}
+checkOneDeclaration de@(Namespace i d  _ sp) ttbl = do {return()}
 checkOneDeclaration s _ = do {ioError $ userError ("internal error: encoutered unsupported declaration type." ++ (show s))}
 
 checkDeclarations :: [Declaration] -> [TT.TTEntry] -> IO ()
@@ -123,7 +123,7 @@ fieldTypeCheck tr@(TBuiltIn t) ttbl = do {return ()}
 
 
 checkFactAttributes :: String -> [FactAttrib] -> [TT.TTEntry] -> [String] -> IO ()
-checkFactAttributes fi (xs@(FactAttrib i d t):x) ttbl attribs = do {
+checkFactAttributes fi (xs@(FactAttrib i d t sp):x) ttbl attribs = do {
     checkUnique ("fact " ++ fi) i attribs;
     _ <- fieldTypeCheck t ttbl;
     checkFactAttributes fi x ttbl (attribs ++ [i]);
@@ -136,36 +136,36 @@ checkFactAttributes _ [] _ _ = do {return ()}
 ------------------------------------------------------------------------------}
 
 checkConstantDefsInt :: String -> TypeRef -> [ConstantDef] -> [TT.TTEntry] -> [String] -> IO ()
-checkConstantDefsInt fi t (xs@(ConstantDefInt i d v):x) ttbl attribs = do {
+checkConstantDefsInt fi t (xs@(ConstantDefInt i d v sp):x) ttbl attribs = do {
     checkUnique ("constant " ++ fi) i attribs;
     checkConstantDefsInt fi t x ttbl (attribs ++ [i]);
 }
-checkConstantDefsInt fi _ (xs@(ConstantDefStr _ _ _):x) _ _ = do {
+checkConstantDefsInt fi _ (xs@(ConstantDefStr _ _ _ sp):x) _ _ = do {
     ioError $ userError ("error: constant type mismatch '" ++ fi ++ " expected Integer, was String");
 }
 checkConstantDefsInt fi _ [] _ _ = do {return ()}
 
 checkConstantDefsString :: String -> TypeRef -> [ConstantDef] -> [TT.TTEntry] -> [String] -> IO ()
-checkConstantDefsString fi t (xs@(ConstantDefStr i d v):x) ttbl attribs = do {
+checkConstantDefsString fi t (xs@(ConstantDefStr i d v sp):x) ttbl attribs = do {
     checkUnique ("constant " ++ fi) i attribs;
     checkConstantDefsString fi t x ttbl (attribs ++ [i]);
 }
-checkConstantDefsString fi _ (xs@(ConstantDefInt _ _ _):x) _ _ = do {
+checkConstantDefsString fi _ (xs@(ConstantDefInt _ _ _ _):x) _ _ = do {
     ioError $ userError ("error: constant type mismatch '" ++ fi ++ " expected Integer, was String");
 }
 checkConstantDefsString _ _ [] _ _ = do {return ()}
 
 
 checkConstantDefs :: String -> TypeRef -> [ConstantDef] -> [TT.TTEntry] -> [String] -> IO ()
-checkConstantDefs fi t (xs@(ConstantDefInt i d v):x) ttbl attribs = do {checkConstantDefsInt fi t (xs:x) ttbl attribs}
-checkConstantDefs fi t (xs@(ConstantDefStr i d v):x) ttbl attribs = do {checkConstantDefsString fi t (xs:x) ttbl attribs}
+checkConstantDefs fi t (xs@(ConstantDefInt i d v sp):x) ttbl attribs = do {checkConstantDefsInt fi t (xs:x) ttbl attribs}
+checkConstantDefs fi t (xs@(ConstantDefStr i d v sp):x) ttbl attribs = do {checkConstantDefsString fi t (xs:x) ttbl attribs}
 
 {-----------------------------------------------------------------------------
 - Checking Flags
 ------------------------------------------------------------------------------}
 
 checkFlagDefs :: String -> Integer -> [FlagDef] -> [TT.TTEntry] -> [String] -> [Integer] -> IO ()
-checkFlagDefs fi w (xs@(FlagDef i d t):x) ttbl defs bits = do {
+checkFlagDefs fi w (xs@(FlagDef i d t sp):x) ttbl defs bits = do {
     checkUnique ("flags " ++ fi) i defs;
     checkUniqueVal ("flags " ++ fi) t bits;
     if t < w then do {
@@ -182,7 +182,7 @@ checkFlagDefs _ _ [] _ _ _ = do {return ()}
 ------------------------------------------------------------------------------}
 
 checkEnumDefs :: String -> [EnumDef] -> [TT.TTEntry] -> [String] -> IO ()
-checkEnumDefs fi (xs@(EnumDef i d):x) ttbl defs = do {
+checkEnumDefs fi (xs@(EnumDef i d sp):x) ttbl defs = do {
     checkUnique ("enumeration " ++ fi) i defs;
     checkEnumDefs fi x ttbl (defs ++ [i]);
 }
@@ -202,7 +202,7 @@ checkEnumDefs _ [] _ _ = do {return ()}
 checkFilename :: SkateParser.Schema -> String -> IO ()
 checkFilename schema fname = do
     let
-        SkateParser.Schema sname _ _ _ = schema
+        SkateParser.Schema sname _ _ _ _ = schema
     if sname == takeBaseName fname
     then return ()
     else ioError $ userError (
index 3773578..1a6b169 100644 (file)
@@ -38,7 +38,7 @@ data DeclarationTable = DTRec [Declaration] [Declaration] [Declaration] [Declara
 -}
 
 make_table :: Schema -> [TT.TTEntry] -> IO DeclarationTable
-make_table s@(Schema n d decls imps) ttbl = do {
+make_table s@(Schema n d decls imps _) ttbl = do {
     printf "Creating DeclarationTable.\n";
     print (show facts);
     print (show namespaces);
@@ -65,23 +65,23 @@ make_table s@(Schema n d decls imps) ttbl = do {
 
 {- filter functions -}
 fact_filter :: Declaration -> Bool
-fact_filter d@(Fact _ _ _) = True
+fact_filter d@(Fact _ _ _ _) = True
 fact_filter _ = False
 
 namespace_filter :: Declaration -> Bool
-namespace_filter d@(Namespace _ _ _) = True
+namespace_filter d@(Namespace _ _ _ _) = True
 namespace_filter _ = False
 
 flags_filter :: Declaration -> Bool
-flags_filter d@(Flags _ _ _ _) = True
+flags_filter d@(Flags _ _ _ _ _) = True
 flags_filter _ = False
 
 constants_filter :: Declaration -> Bool
-constants_filter d@(Constants _ _ _ _) = True
+constants_filter d@(Constants _ _ _ _ _) = True
 constants_filter _ = False
 
 enumeration_filter :: Declaration -> Bool
-enumeration_filter d@(Enumeration _ _ _) = True
+enumeration_filter d@(Enumeration _ _ _ _) = True
 enumeration_filter _ = False
 
 
@@ -93,10 +93,10 @@ flatten_decl_tree p t [] = t
 
 {- handles each declaration and adds a type  -}
 parseType :: String -> [Declaration] -> Declaration -> [Declaration]
-parseType p t x@(Fact i d a) = t ++ [x]
-parseType p t x@(Flags i d w f) = t ++ [x]
-parseType p t x@(Constants i d a w) = t ++ [x]
-parseType p t x@(Enumeration i d e) = t ++ [x]
-parseType p t x@(Namespace i d decls) = flatten_decl_tree i (t ++ [x]) decls
-parseType p t x@(Section _ decls) = flatten_decl_tree p t decls
-parseType p t x@(Text _) = t
+parseType p t x@(Fact i d a _) = t ++ [x]
+parseType p t x@(Flags i d w f _) = t ++ [x]
+parseType p t x@(Constants i d a w _) = t ++ [x]
+parseType p t x@(Enumeration i d e _) = t ++ [x]
+parseType p t x@(Namespace i d decls _) = flatten_decl_tree i (t ++ [x]) decls
+parseType p t x@(Section _ decls _) = flatten_decl_tree p t decls
+parseType p t x@(Text _ _) = t
index dbdb37e..52173c4 100644 (file)
@@ -44,43 +44,43 @@ make_qualified_identifer parent i = parent ++ "." ++ i
 -}
 
 {- import data type -}
-data Import = Import String
+data Import = Import String SourcePos
 
 {- Facts -}
-data FactAttrib = FactAttrib String String TypeRef
+data FactAttrib = FactAttrib String String TypeRef SourcePos
 
 {- Flags -}
-data FlagDef = FlagDef String String Integer
+data FlagDef = FlagDef String String Integer SourcePos
 
 {- Constants -}
-data ConstantDef = ConstantDefInt String String Integer
-                 | ConstantDefStr String String String
+data ConstantDef = ConstantDefInt String String Integer SourcePos
+                 | ConstantDefStr String String String SourcePos
 
 {- Enumerations -}
-data EnumDef = EnumDef String String
+data EnumDef = EnumDef String String SourcePos
 
 
 {- declarations -}
-data Declaration = Fact String String [ FactAttrib ]
-                  | Flags String String Integer [ FlagDef ]
-                  | Constants String String TypeRef [ ConstantDef ]
-                  | Enumeration String String [ EnumDef ]
-                  | Namespace String String [ Declaration ]
-                  | Section String [ Declaration ]
-                  | Text String
+data Declaration = Fact String String [ FactAttrib ] SourcePos
+                  | Flags String String Integer [ FlagDef ] SourcePos
+                  | Constants String String TypeRef [ ConstantDef ] SourcePos
+                  | Enumeration String String [ EnumDef ] SourcePos
+                  | Namespace String String [ Declaration ] SourcePos
+                  | Section String [ Declaration ] SourcePos
+                  | Text String SourcePos
 
 {--}
 instance Show Declaration where
-    show de@(Fact i d _) = "Fact '" ++ i ++ "'"
-    show de@(Flags  i d _ _) = "Flags '" ++ i ++ "'"
-    show de@(Enumeration  i d _) = "Enumeration '" ++ i ++ "'"
-    show de@(Constants  i d _ _) = "Constants '" ++ i ++ "'"
-    show de@(Namespace  i d _) = "Namespace '" ++ i ++ "'"
-    show de@(Section  i _) = "Section '" ++ i ++ "'"
-    show de@(Text i) = "Text Block"
+    show de@(Fact i d _ _) = "Fact '" ++ i ++ "'"
+    show de@(Flags  i d _ _ _) = "Flags '" ++ i ++ "'"
+    show de@(Enumeration  i d _ _) = "Enumeration '" ++ i ++ "'"
+    show de@(Constants  i d _ _ _) = "Constants '" ++ i ++ "'"
+    show de@(Namespace  i d _ _) = "Namespace '" ++ i ++ "'"
+    show de@(Section  i _ _) = "Section '" ++ i ++ "'"
+    show de@(Text i _) = "Text Block"
 
 {- the schema -}
-data Schema = Schema String String [ Declaration ] [ String ]
+data Schema = Schema String String [ Declaration ] [ String ] SourcePos
 
 
 {-
@@ -149,16 +149,30 @@ binLiteral = do {
 - Parser start point
 ------------------------------------------------------------------------------}
 
+
+pErrorDescription :: String -> String -> SourcePos -> String
+pErrorDescription t i spos = " missing description of "++ t ++ " '" ++ i ++ "'"
+                            ++ " in " ++ (show spos)
+
+
+
+
+
+{------------------------------------------------------------------------------
+- Parser start point
+------------------------------------------------------------------------------}
+
 {- parse the the Skate file -}
 parse = do {
     whiteSpace;
     imps <- many importfacts;
+    p <- getPosition;
     reserved "schema";
     name <- identifier;
-    desc <- option name stringLit;
+    desc <- stringLit <?> pErrorDescription "schema" name p;
     decls <- braces (many1 $ schemadecl name);
     _ <- symbol ";" <?> " ';' missing from end of " ++ name ++ " schema def";
-    return (Schema name desc decls [i | (Import i) <- imps])
+    return (Schema name desc decls [i | (Import i _) <- imps] p)
 }
 
 
@@ -177,9 +191,10 @@ schemadecl sn = factdecl sn  <|>  constantdecl sn   <|> flagsdecl sn    <|>
 
 importfacts = do {
     reserved "import";
-    i <- identifier;
+    p <- getPosition;
+    i <- identifier <?> " required valid identifier";
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " import";
-    return (Import i)
+    return (Import i p)
 }
 
 
@@ -189,11 +204,12 @@ importfacts = do {
 
 namespacedecl parent = do {
     reserved "namespace";
+    p <- getPosition;
     i <- identifier;
-    d <- stringLit;
+    d <- stringLit <?> " missing description of namespace '" ++ (make_qualified_identifer parent i) ++ "'";
     decls <- braces (many1 $ schemadecl (make_qualified_identifer parent i));
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " namespace";
-    return (Namespace (make_qualified_identifer parent i) d decls);
+    return (Namespace (make_qualified_identifer parent i) d decls p);
 }
 
 {------------------------------------------------------------------------------
@@ -202,19 +218,21 @@ namespacedecl parent = do {
 
 factdecl parent = do {
     reserved "fact";
+    p <- getPosition;
     i <- identifier;
-    d <- stringLit;
+    d <- stringLit <?> " missing description of fact '" ++ (make_qualified_identifer parent i) ++ "'";
     f <- braces (many1 $ factattrib parent);
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " fact";
-    return (Fact (make_qualified_identifer parent i) d f)
+    return (Fact (make_qualified_identifer parent i) d f p)
 }
 
 factattrib parent = do {
+    p <- getPosition;
     t <- fieldType parent;
     i <- identifier;
     d <- stringLit;
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " fact attribute";
-    return (FactAttrib i d t)
+    return (FactAttrib i d t p)
 }
 
 
@@ -224,21 +242,23 @@ factattrib parent = do {
 
 flagsdecl parent = do {
     reserved "flags";
+    p <- getPosition;
     i <- identifier;
     b <- integer;
-    d <- stringLit;
+    d <- stringLit <?> " missing description of flags '" ++ (make_qualified_identifer parent i) ++ "'";
     flagvals <- braces (many1 flagvals);
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " flags";
-    return (Flags (make_qualified_identifer parent i) d b flagvals)
+    return (Flags (make_qualified_identifer parent i) d b flagvals p)
 }
 
 {- identifier = value "opt desc"; -}
 flagvals = do {
+    pos <- getPosition;
     p <- integer;
     i <- identifier;
     d <- stringLit;
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " flag val";
-    return (FlagDef i d p)
+    return (FlagDef i d p pos)
 };
 
 
@@ -250,12 +270,13 @@ flagvals = do {
 {- constants fname "desc" {[constantvals]}; -}
 constantdecl parent = do {
     reserved "constants";
+    p <- getPosition;
     i <- identifier;
     t <- fieldTypeBuiltIn;
-    d <- stringLit;
+    d <- stringLit <?> " missing description of constants '" ++ (make_qualified_identifer parent i) ++ "'";
     vals <- braces (many1 (constantvals t));
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " constants";
-    return (Constants (make_qualified_identifer parent i) d t vals)
+    return (Constants (make_qualified_identifer parent i) d t vals p)
 }
 
 constantvals (TBuiltIn String) = constantvalsstring
@@ -275,21 +296,23 @@ constantvals (TBuiltIn Bool) =  constantvalsnum
 constantvals s = error $ "Invalid constant type " ++ (show s)
 
 constantvalsnum = do {
+    p <- getPosition;
     i <- identifier;
     _ <- symbol "=";
     v <- integer;
     d <- stringLit;
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " constant";
-    return (ConstantDefInt i d v)
+    return (ConstantDefInt i d v p)
 };
 
 constantvalsstring = do {
+    p <- getPosition;
     i <- identifier;
     _ <- symbol "=";
     v <- stringLit;
     d <- stringLit;
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " constant";
-    return (ConstantDefStr i d v)
+    return (ConstantDefStr i d v p)
 };
 
 
@@ -299,18 +322,20 @@ constantvalsstring = do {
 
 enumdecl parent = do {
     reserved "enumeration";
+    p <- getPosition;
     i <- identifier;
-    d <- stringLit;
+    d <- stringLit <?> " missing description of enumeration '" ++ (make_qualified_identifer parent i) ++ "'";
     enums <- braces (many1 enumdef);
      _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " enumeration";
-    return (Enumeration (make_qualified_identifer parent i) d enums)
+    return (Enumeration (make_qualified_identifer parent i) d enums p)
 }
 
 enumdef = do {
+    p <- getPosition;
     i <- identifier;
     d <- stringLit;
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " enum item";
-    return (EnumDef i d)
+    return (EnumDef i d p)
 };
 
 
@@ -320,17 +345,19 @@ enumdef = do {
 
 sectiondecl parent = do {
     reserved "section";
+    p <- getPosition;
     i <- stringLit;
     decls <- braces (many1 $ schemadecl parent);
     _ <- symbol ";" <?> " ';' missing from end of " ++ i ++ " section";
-    return (Section i decls);
+    return (Section i decls p);
 };
 
 textdecl = do {
     reserved "text";
+    p <- getPosition;
     t <- braces (many1 stringLit);
     _ <- symbol ";" <?> " ';' missing from end of text block";
-    return (Text (concat (intersperse " " t)) );
+    return (Text (concat (intersperse " " t)) p);
 };
 
 
index 9cc8f27..20f0806 100644 (file)
@@ -47,7 +47,7 @@ skateSchemaTransform sr = do {
 
 
 make_schema_record :: Schema -> [Schema] -> IO SchemaRecord
-make_schema_record s@(Schema n d decls imps) dfl =
+make_schema_record s@(Schema n d decls imps sp) dfl =
     do {
         printf "Creating SchemRecord.\n";
         ttbl <- TT.make_table s;
index 118522b..dd22a10 100644 (file)
@@ -18,6 +18,7 @@ import Data.List
 import System.IO
 import System.IO.Error
 import Text.Printf
+import Text.ParserCombinators.Parsec.Pos
 
 import SkateParser
 import SkateTypes
@@ -32,10 +33,10 @@ instance Show RecType where
     show TTEnum = "enum"
     show TTFact = "fact"
 
-data TTEntry = Rec RecType String
+data TTEntry = Rec RecType String SourcePos
 
 instance Show TTEntry where
-    show (Rec _ s) = "TT.Rec: " ++ s
+    show (Rec _ s _) = "TT.Rec: " ++ s
 
 
 {-
@@ -46,7 +47,7 @@ instance Show TTEntry where
 
 {- creates the Skate type table -}
 make_table :: Schema -> IO [TTEntry]
-make_table s@(Schema n d decls imps) =
+make_table s@(Schema n d decls imps _) =
     let
         tt = addOneTypeToTable n [] decls;
     in
@@ -65,7 +66,7 @@ exist ttbl t a = not (null (filter (type_ref_exists a t) ttbl))
 lookup ::  [TTEntry] -> String -> RecType
 lookup t a = tt
     where
-        Rec tt _ = head (filter (typeExists a) t)
+        Rec tt _  _= head (filter (typeExists a) t)
 
 {-
 ==============================================================================
@@ -82,24 +83,28 @@ addOneTypeToTable p t [] = t
 
 {- handles each declaration and adds a type  -}
 parseType :: String -> [TTEntry] -> Declaration -> [TTEntry]
-parseType p t d@(Fact i _ _) = addOneType i t TTFact
-parseType p t d@(Flags i _ w _) = addOneType i t TTFlags
-parseType p t d@(Constants i _ _ _) = addOneType i t TTConstant
-parseType p t d@(Enumeration i _ _) = addOneType i t TTEnum
-parseType p t d@(Namespace i _ decls) = addOneTypeToTable i t decls
-parseType p t d@(Section _ decls) = addOneTypeToTable p t decls
-parseType p t d@(Text _) = t
+parseType p t d@(Fact i _ _ sp) = addOneType i t TTFact sp
+parseType p t d@(Flags i _ w _ sp) = addOneType i t TTFlags sp
+parseType p t d@(Constants i _ _ _ sp) = addOneType i t TTConstant sp
+parseType p t d@(Enumeration i _ _ sp) = addOneType i t TTEnum sp
+parseType p t d@(Namespace i _ decls sp) = addOneTypeToTable i t decls
+parseType p t d@(Section _ decls sp) = addOneTypeToTable p t decls
+parseType p t d@(Text _ sp) = t
 
 {- boolean function that returns True iff the type record matches -}
 typeExists :: String -> TTEntry -> Bool
-typeExists a d@(Rec _ e) = (a == e)
+typeExists a d@(Rec _ e _) = (a == e)
 
 {- boolean function that returns True iff the type record matches -}
 type_ref_exists :: String -> RecType -> TTEntry -> Bool
-type_ref_exists a t d@(Rec tt e) = ((a == e) &&  (t == tt))
+type_ref_exists a t d@(Rec tt e _) = ((a == e) &&  (t == tt))
 
 {- adds one type to the type table -}
-addOneType :: String -> [TTEntry] -> RecType -> [TTEntry]
-addOneType n recs t =
-    if null (filter (typeExists n) recs) then recs ++ [Rec t n]
-    else error $ "error: type '" ++ n ++ "' has already been defined";
+addOneType :: String -> [TTEntry] -> RecType -> SourcePos -> [TTEntry]
+addOneType n recs t sp =
+    let
+        existingTypes = (filter (typeExists n) recs)
+    in
+    if null existingTypes then recs ++ [Rec t n sp]
+    else error $ "error in " ++ (show sp) ++ ": re-definition of type '" ++ n ++ "'."
+                 ++ " previously defined " ++ (show (head existingTypes));
diff --git a/tools/skate/foobar.sks b/tools/skate/foobar.sks
deleted file mode 100644 (file)
index 4825fdc..0000000
+++ /dev/null
@@ -1,38 +0,0 @@
-
-schema foobar "" {
-    fact myfact "My fact desc" {
-        uint8 attrib1 "attribute 1";
-        uint8 attrib2 "attribute 2";
-        uint8 attrib3 "attribute 3";
-    };
-
-    fact foobar2 "" {
-        uint8 foo "";
-    };
-
-    namespace foobar22 "" {
-    fact foobar3 "" {
-        uint8 foo "";
-    };
-    };
-
-    flags myflags 8 "This are My Flags" {
-        1 flag01 "des";
-        2 flag02 "des";
-    };
-
-    enumeration myenum "this is my enum" {
-        first "sss";
-        second "dddd";
-    };
-
-    constants myintconst uint8 "this are my const" {
-        const1 = 3 "aasdf";
-        const2 = 3 "aasdf";
-    };
-
-    constants mystringconst string "this are my const" {
-        const1 = "asdf" "aasdf";
-        const2 = "asdf" "aasdf";
-    };
-};