Copyright 2009 Jake Wheat
The annotation data types and utilities for working with them.
Annotations are used to store source positions, types, errors,
warnings, environment deltas, information, and other stuff a client might
want to use when looking at an ast. Internal annotations which are
used in the typechecking/ annotation process use the attribute
grammar code and aren't exposed.
>
>
> module Database.HsSqlPpp.AstInternals.AstAnnotation
> (
> Annotation
> ,AnnotationElement(..)
> --,stripAnnotations
> ,getTopLevelTypes
> ,getTopLevelInfos
> ,getTopLevelEnvUpdates
> ,getTypeAnnotation
> ,getTypeErrors
> ,stripAnnotations
> ,updateAnnotation
> ,getAnnotation
> ,getAnnotations
> --,getTypeErrors
> --,pack
> ,StatementInfo(..)
> ,getSIAnnotation
> ) where
> import Data.Generics
> import Data.Maybe
> import Control.Arrow
> import Database.HsSqlPpp.AstInternals.TypeType
> import Database.HsSqlPpp.AstInternals.EnvironmentInternal
>
>
> type Annotation = [AnnotationElement]
>
>
> data AnnotationElement = SourcePos String Int Int
> | TypeAnnotation Type
> | TypeErrorA TypeError
> | StatementInfoA StatementInfo
> | EnvUpdates [EnvironmentUpdate]
> deriving (Eq, Show,Typeable,Data)
Use syb to pull annotation values from an ast.
I like to cut and paste code from the internet which I don't
understand, then keep changing it till it compiles and passes the tests.
>
>
> getTopLevelTypes :: Data a => [a] -> [Type]
> getTopLevelTypes st =
> getTopLevelXs typeAnnot st
> where
> typeAnnot :: Annotation -> [Type]
> typeAnnot (x:xs) = case x of
> TypeAnnotation t -> [t]
> _ -> typeAnnot xs
> typeAnnot [] = [TypeCheckFailed]
> getTopLevelXs :: forall a b a1.
> (Data a1, Typeable b) =>
> (b -> [a]) -> a1 -> [a]
> getTopLevelXs st = everythingOne (++) $ mkQ [] st
> getTypeAnnotation :: Data a => a -> Type
> getTypeAnnotation st =
> case getTopLevelX typeAnnot st of
> x:_ -> x
> [] -> TypeCheckFailed
> where
> typeAnnot :: Annotation -> [Type]
> typeAnnot (x:xs) = case x of
> TypeAnnotation t -> [t]
> _ -> typeAnnot xs
> typeAnnot [] = [TypeCheckFailed]
> getTopLevelX :: forall a b a1.
> (Data a1, Typeable b) =>
> (b -> [a]) -> a1 -> [a]
> getTopLevelX p = everythingOne (++) (mkQ [] p)
> everythingTwo :: (r -> r -> r) -> GenericQ r -> GenericQ r
> everythingTwo k f x
> = foldl k (f x) (gmapQ (everythingOne k f) x)
> everythingZero :: (r -> r -> r) -> GenericQ r -> GenericQ r
> everythingZero k f x
> = foldl k (f x) (gmapQ f x)
> everythingOne :: (r -> r -> r) -> GenericQ r -> GenericQ r
> everythingOne k f x
> = foldl k (f x) (gmapQ (everythingZero k f) x)
> getSIAnnotation :: Annotation -> [Maybe StatementInfo]
> getSIAnnotation (x:xs) = case x of
> StatementInfoA t -> [Just t]
> _ -> getSIAnnotation xs
> getSIAnnotation [] = [Nothing]
> getEuAnnotation :: Annotation -> [[EnvironmentUpdate]]
> getEuAnnotation (x:xs) = case x of
> EnvUpdates t -> t:getEuAnnotation xs
> _ -> getEuAnnotation xs
> getEuAnnotation [] = []
>
>
> getTopLevelInfos :: Data a => [a] -> [Maybe StatementInfo]
> getTopLevelInfos = getTopLevelXs getSIAnnotation
> getTopLevelEnvUpdates :: Data a => [a] -> [[EnvironmentUpdate]]
> getTopLevelEnvUpdates = getTopLevelXs getEuAnnotation
> data StatementInfo = DefaultStatementInfo Type
> | SelectInfo Type
> | InsertInfo String Type
> | UpdateInfo String Type
> | DeleteInfo String
> deriving (Eq,Show,Typeable,Data)
todo:
add environment deltas to statementinfo
question:
if a node has no source position e.g. the all in select all or select
distinct may correspond to a token or may be synthesized as the
default if neither all or distinct is present. Should this have the
source position of where the token would have appeared, should it
inherit it from its parent, should there be a separate ctor to
represent a fake node with no source position?
hack job, often not interested in the source positions when testing
the asts produced, so this function will reset all the source
positions to empty ("", 0, 0) so we can compare them for equality, etc.
without having to get the positions correct.
>
>
> stripAnnotations :: (Data a) => a -> a
> stripAnnotations = everywhere (mkT stripAn)
> where
> stripAn :: [AnnotationElement] -> [AnnotationElement]
> stripAn _ = []
>
>
>
>
>
> getTypeErrors :: (Data a) => a -> [(Maybe AnnotationElement,[TypeError])]
> getTypeErrors sts =
> filter (\(_,te) -> not $ null te) $ map (gtsp &&& gte) $ getAnnotations sts
> where
> gte (a:as) = case a of
> TypeErrorA e -> e:gte as
> _ -> gte as
> gte _ = []
> gtsp (a:as) = case a of
> s@(SourcePos _ _ _) -> Just s
> _ -> gtsp as
> gtsp _ = Nothing
> updateAnnotation :: forall a.(Data a) =>
> (Annotation -> Annotation) -> a -> a
> updateAnnotation f = oneLevel (mkT f)
> oneLevel :: (forall a.Data a => a -> a)
> -> (forall a.Data a => a -> a)
> oneLevel f = gmapT f
> getAnnotation :: forall a.(Data a) => a -> Annotation
> getAnnotation a =
> case oneLevelQ (mkQ [] f) a of
> an:_ -> an
> [] -> []
> where
> f :: Annotation -> Annotation
> f = id
> oneLevelQ :: forall a.Data a => forall u. (forall d. (Data d) => d -> u) -> a -> [u]
> oneLevelQ = gmapQ
> getAnnotations :: forall a.(Data a) =>
> a -> [Annotation]
> getAnnotations = listifyWholeLists (\(_::Annotation) -> True)
> listifyWholeLists :: Typeable b => ([b] -> Bool) -> GenericQ [[b]]
> listifyWholeLists blp = flip (synthesize id (.) (mkQ id (\bl _ -> if blp bl then (bl:) else id))) []