115 lines
2.9 KiB
Haskell
115 lines
2.9 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Ringo.Generator.Sql where
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy as TL
|
|
|
|
import Database.HsSqlPpp.Annotation
|
|
import Database.HsSqlPpp.Dialect (postgresDialect)
|
|
import Database.HsSqlPpp.Pretty
|
|
import Database.HsSqlPpp.Syntax
|
|
import Data.Text (Text)
|
|
|
|
ea :: Annotation
|
|
ea = emptyAnnotation
|
|
|
|
name :: Text -> Name
|
|
name n = Name ea [nmc n]
|
|
|
|
nmc :: Text -> NameComponent
|
|
nmc = Nmc . Text.unpack
|
|
|
|
attDef :: Text -> Text -> RowConstraint -> AttributeDef
|
|
attDef nam typ constr =
|
|
AttributeDef ea (nmc nam) (SimpleTypeName ea $ name typ) Nothing [constr]
|
|
|
|
member :: ScalarExpr -> ScalarExpr -> ScalarExpr
|
|
member a b = BinaryOp ea (name ".") a b
|
|
|
|
num :: Text -> ScalarExpr
|
|
num n = NumberLit ea $ Text.unpack n
|
|
|
|
str :: Text -> ScalarExpr
|
|
str = StringLit ea . Text.unpack
|
|
|
|
app :: Text -> [ScalarExpr] -> ScalarExpr
|
|
app n as = App ea (name n) as
|
|
|
|
specop :: Text -> [ScalarExpr] -> ScalarExpr
|
|
specop n as = SpecialOp ea (name n) as
|
|
|
|
prefop :: Text -> ScalarExpr -> ScalarExpr
|
|
prefop n a = PrefixOp ea (name n) a
|
|
|
|
postop :: Text -> ScalarExpr -> ScalarExpr
|
|
postop n a = PostfixOp ea (name n) a
|
|
|
|
binop :: Text -> ScalarExpr -> ScalarExpr -> ScalarExpr
|
|
binop n a0 a1 = BinaryOp ea (name n) a0 a1
|
|
|
|
foldBinop :: Text -> [ScalarExpr] -> ScalarExpr
|
|
foldBinop _ [] = error "List must be non empty"
|
|
foldBinop n (a : as) = foldl (binop n) a as
|
|
|
|
placeholder :: ScalarExpr
|
|
placeholder = Placeholder ea
|
|
|
|
parens :: ScalarExpr -> ScalarExpr
|
|
parens = Parens ea
|
|
|
|
qstar :: Text -> ScalarExpr
|
|
qstar = QStar ea . nmc
|
|
|
|
-- Table ref
|
|
tref :: Text -> TableRef
|
|
tref s = Tref ea (name s)
|
|
|
|
-- Table ref alias
|
|
trefa :: Text -> Text -> TableRef
|
|
trefa t a = TableAlias ea (nmc a) $ Tref ea (name t)
|
|
|
|
-- Subquery Table ref alias
|
|
subtrefa :: Text -> QueryExpr -> TableRef
|
|
subtrefa a = TableAlias ea (nmc a) . SubTref ea
|
|
|
|
-- Table join
|
|
tjoin :: TableRef -> JoinType -> TableRef -> Maybe ScalarExpr -> TableRef
|
|
tjoin ta jt tb on = JoinTref ea ta Unnatural jt Nothing tb (fmap (JoinOn ea) on)
|
|
|
|
-- Select item
|
|
si :: ScalarExpr -> SelectItem
|
|
si = SelExp ea
|
|
|
|
-- Select item alias
|
|
sia :: ScalarExpr -> NameComponent -> SelectItem
|
|
sia e a = SelectItem ea e a
|
|
|
|
-- Expression qualified identifier
|
|
eqi :: Text -> Text -> ScalarExpr
|
|
eqi c x = Identifier ea $ qn c x
|
|
|
|
-- Expression identifier
|
|
ei :: Text -> ScalarExpr
|
|
ei = Identifier ea . name
|
|
|
|
-- Qualified name
|
|
qn :: Text -> Text -> Name
|
|
qn c n = Name ea [nmc c, nmc n]
|
|
|
|
-- Select list
|
|
sl :: [SelectItem] -> SelectList
|
|
sl = SelectList ea
|
|
|
|
insert :: Text -> [Text] -> QueryExpr -> Statement
|
|
insert tName cNames selectExp =
|
|
Insert ea (name tName) (map nmc cNames) selectExp Nothing
|
|
|
|
ppSQL :: Statement -> Text
|
|
ppSQL st = TL.toStrict $ prettyStatements (PrettyFlags postgresDialect) [st]
|
|
|
|
ppScalarExpr :: ScalarExpr -> Text
|
|
ppScalarExpr = TL.toStrict . prettyScalarExpr (PrettyFlags postgresDialect)
|
|
|
|
ppQueryExpr :: QueryExpr -> Text
|
|
ppQueryExpr = TL.toStrict . prettyQueryExpr (PrettyFlags postgresDialect)
|