AstAnnotation.lhs

Copyright 2009 Jake Wheat

The annotation data types and utilities for working with them.

Annotations are used to store source positions, types, errors,
warnings, scope deltas, information, and other stuff a client might
want to use when looking at an ast. Internal annotations which are
used in the type-checking/ annotation process use the attribute
grammar code and aren't exposed.

> {-# LANGUAGE ExistentialQuantification #-}
> {-# OPTIONS_HADDOCK hide #-}

> module Database.HsSqlPpp.TypeChecking.AstAnnotation
>     (
>      Annotated(..)
>     ,Annotation
>     ,AnnotationElement(..)
>     ,stripAnnotations
>     ,getTopLevelTypes
>     ,getTopLevelInfos
>     ,getTypeAnnotation
>     ,getTypeErrors
>     ,pack
>     ,StatementInfo(..)
>     ,getSIAnnotation
>     ) where

> import Database.HsSqlPpp.TypeChecking.TypeType

> -- | Annotation type - one of these is attached to most of the
> -- data types used in the ast.
> type Annotation = [AnnotationElement]

> -- | the elements of an annotation. Source positions are generated by
> -- the parser, the rest come from the separate ast annotation process.
> data AnnotationElement = SourcePos String Int Int
>                        | TypeAnnotation Type
>                        | TypeErrorA TypeError
>                        | StatementInfoA StatementInfo
>                          deriving (Eq, Show)

> class Annotated a where
>     ann :: a -> Annotation
>     setAnn :: a -> Annotation -> a
>     changeAnn :: a -> (Annotation -> Annotation) -> a
>     changeAnn a = setAnn a . ($ ann a)
>     changeAnnRecurse :: (Annotation -> Annotation) -> a -> a
>     getAnnChildren :: a -> [Annotatable]

> data Annotatable = forall a . (Annotated a, Show a) => MkAnnotatable a

> instance Show Annotatable
>   where
>   showsPrec p (MkAnnotatable a) = showsPrec p a

> pack :: (Annotated a, Show a) => a -> Annotatable
> pack = MkAnnotatable

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.

> -- | strip all the annotations from a tree. E.g. can be used to compare
> -- two asts are the same, ignoring any source position annotation differences.
> stripAnnotations :: Annotated a => a -> a
> stripAnnotations = changeAnnRecurse (const [])

> -- | run through the ast, and pull the type annotation from each
> -- of the top level items.
> getTopLevelTypes :: Annotated a =>
>                     [a] -- ^ the ast items
>                  -> [Type] -- ^ the type annotations, this list should be the same
>                            -- length as the argument
> getTopLevelTypes = map getTypeAnnotation

> getTypeAnnotation :: Annotated a => a  -> Type
> getTypeAnnotation at = let as = ann at
>                        in gta as
>                        where
>                          gta (x:xs) = case x of
>                                         TypeAnnotation t -> t
>                                         _ -> gta xs
>                          gta _ = TypeCheckFailed -- error "couldn't find type annotation"

> getSIAnnotation :: Annotated a => a  -> StatementInfo
> getSIAnnotation at = let as = ann at
>                        in gta as
>                        where
>                          gta (x:xs) = case x of
>                                         StatementInfoA t -> t
>                                         _ -> gta xs
>                          gta _ = error "couldn't find statement info annotation"


> getAnnotationsRecurse :: Annotated a => a -> [Annotation]
> getAnnotationsRecurse a =
>   ann a : concatMap getAnnotationsRecurse' (getAnnChildren a)
>   where
>     getAnnotationsRecurse' :: Annotatable -> [Annotation]
>     getAnnotationsRecurse' an =
>       hann an : concatMap getAnnotationsRecurse' (hgac an)
>     hann (MkAnnotatable an) = ann an
>     hgac (MkAnnotatable an) = getAnnChildren an

> -- | runs through the ast given and returns a list of all the type errors
> -- in the ast. Recurses into all ast nodes to find type errors.
> -- This is the function to use to see if an ast has passed the type checking process.
> -- Source position information will be added to the return type at some point
> getTypeErrors :: Annotated a => [a] -> [TypeError]
> getTypeErrors sts =
>     concatMap (concatMap gte . getAnnotationsRecurse) sts
>     where
>       gte (a:as) = case a of
>                     TypeErrorA e -> [e]
>                     _ -> gte as
>       gte _ = []

> -- | Run through the ast given and return a list of statementinfos
> -- from the top level items.
> getTopLevelInfos :: Annotated a =>
>                     [a] -- ^ the ast to check
>                  -> [StatementInfo]
> getTopLevelInfos = map getSIAnnotation


> data StatementInfo = DefaultStatementInfo Type
>                    | RelvarInfo CompositeDef
>                    | CreateFunctionInfo FunctionPrototype
>                    | SelectInfo Type
>                    | InsertInfo String Type
>                    | UpdateInfo String Type
>                    | DeleteInfo String
>                    | CreateDomainInfo String Type
>                    | DropInfo [(String,String)]
>                    | DropFunctionInfo [(String,[Type])]
>                      deriving (Eq,Show)

todo:
add scope 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?