Sql.hs

Sql.hs

{-# LANGUAGE FlexibleInstances, OverloadedLists, OverloadedStrings, TypeFamilies #-}

import Data.Monoid
import Data.String
import GHC.Exts

data Sql = Sql (DiffList Char) (DiffList SqlBinding)
  deriving (Show)

data SqlBinding = SqlString String
                | SqlInteger !Int
                | SqlFloat !Double
                | SqlNull
  deriving (Show)

data DiffList a = DiffList ([a] -> [a])

instance (Show a) => Show (DiffList a) where
  show = show . toList

instance IsList (DiffList a) where
  type Item (DiffList a) = a
  fromList xs = DiffList (xs++)
  toList (DiffList f) = f []

instance IsString (DiffList Char) where
  fromString = fromList

instance Semigroup (DiffList a) where
  (<>) (DiffList f) (DiffList g) = DiffList (f . g)

instance Monoid (DiffList a) where
  mempty = DiffList id

instance Semigroup Sql where
  (<>) (Sql s1 bs1) (Sql s2 bs2) = Sql (s1 <> s2) (bs1 <> bs2)

instance Monoid Sql where
  mempty = Sql mempty mempty

join :: String -> [Sql] -> Sql
join sep (x:xs) = step x xs
  where
    step acc (x:xs) = step (acc <> (Sql (fromList sep) []) <> x) xs
    step acc []     = acc
join sep [] = Sql "" []

values :: [SqlBinding] -> Sql
values (b:bs) = step (Sql "(?" [b]) bs
  where
    step acc (b:bs) = step (acc <> (Sql ", ?" [b])) bs
    step acc []     = acc <> (Sql ")" [])
values [] = Sql "()" []

main = do
  print $ (Sql "SELECT * WHERE " []) <> join " AND "
    [ (Sql "c1 = ?" [SqlInteger 123])
    , (Sql "c2 = ?" [SqlInteger 456])
    , (Sql "c3 IN " []) <> (values [SqlInteger 123, SqlInteger 456])
    ]