>
> {-# LANGUAGE FlexibleContexts #-}
> module Database.HsSqlPpp.Utility
> (
> resetAnnotations
> ,queryType
>
>
>
> ,addExplicitCasts
> ,addImplicitCasts
> ,tcTreeInfo
> ,emacsShowErrors
> ) where
> import Data.Generics.Uniplate.Data
> import Data.Data
> import Data.List
> import Data.Maybe
> import Database.HsSqlPpp.Internals.AstInternal
> import Database.HsSqlPpp.Internals.TypesInternal
> import Database.HsSqlPpp.Internals.ParseInternal
> import Database.HsSqlPpp.Internals.Catalog.CatalogTypes
>
> import Database.HsSqlPpp.Parse
> import Database.HsSqlPpp.TypeCheck
>
>
> import qualified Data.Text.Lazy as L
>
> resetAnnotations :: Data a => a -> a
> resetAnnotations = transformBi (const emptyAnnotation)
>
>
> queryType :: Catalog -> L.Text -> Maybe Type
> queryType cat src = do
> ast <- either (const Nothing) Just $ parseQueryExpr defaultParseFlags "" Nothing src
> fmap teType $ anType $ getAnnotation $ typeCheckQueryExpr defaultTypeCheckFlags cat ast
>
>
>
>
>
> tcTreeInfo :: Data a =>
> a
> -> (Maybe TypeExtra,[([TypeError],Maybe SourcePosition)]
> ,[QueryExpr],[ScalarExpr])
> tcTreeInfo ast =
> let noTypeSEs :: [ScalarExpr]
> noTypeSEs = [x | x <- universeBi ast
> , isNothing (anType (getAnnotation x))]
> noTypeQEs :: [QueryExpr]
> noTypeQEs = [x | x <- universeBi ast
> , isNothing (anType (getAnnotation x))]
>
>
> tes :: [([TypeError],Maybe SourcePosition)]
> tes = [(e,sp) | a@(Annotation {}) <- universeBi ast
> , let e = anErrs a
> , let sp = anSrc a
> , not (null e)]
> ty = anType $ getAnnotation ast
> in (ty,tes,noTypeQEs,noTypeSEs)
>
> emacsShowErrors :: [([TypeError],Maybe SourcePosition)] -> String
> emacsShowErrors tes =
> intercalate "\n" $ map se tes
> where
> se (es,sp) =
> (case sp of
> Nothing -> "unknown source"
> Just (fn,l,c) -> fn ++ ":" ++ show l ++ ":" ++ show c ++ ":")
> ++ " " ++ intercalate "\n" (map show es)