module Internal.Data.Basic.TH.SqlToHsTypes (toHsType) where
import qualified Data.Text as T
import Data.Time.LocalTime (LocalTime, TimeOfDay)
import Data.Time (Day)
import Internal.Interlude hiding (Type)
import Language.Haskell.TH hiding (Name)
import qualified Database.HsSqlPpp.Syntax as SQL
import Data.Scientific
import Control.Effects.Signal
import Internal.Data.Basic.TH.Helper
import Internal.Data.Basic.TH.Types
toHsType :: Throws ParseError m => SQL.TypeName -> m (Type, [ColumnConstraint])
toHsType (SQL.SimpleTypeName _ name) = do
t <- columnTypeToHs n
return (t, applyColumnConstraints n)
where n = getName name
toHsType (SQL.PrecTypeName _ name _) = do
t <- columnTypeToHs n
return (t, applyColumnConstraints n)
where n = getName name
toHsType (SQL.Prec2TypeName _ name _ _) = do
t <- columnTypeToHs n
return (t, applyColumnConstraints n)
where n = getName name
toHsType x = throwSignal $ ParseError $ "Compile error: unknown column type " <> show x
applyColumnConstraints :: Text -> [ColumnConstraint]
applyColumnConstraints fname
| fname == "serial" = [NotNullConstraint, DefaultConstraint]
| otherwise = []
columnTypeToHs :: Throws ParseError m => Text -> m Type
columnTypeToHs fname
| fname `elem` ["serial", "bigint", "integer", "int", "int4"] = use ''Int
| fname == "boolean" = use ''Bool
| fname == "timestamp" = use ''LocalTime
| fname == "time" = use ''TimeOfDay
| fname == "point" = return $ AppT (AppT (TupleT 2) (ConT ''Double)) (ConT ''Double)
| fname `elem` ["double precision", "double"] = use ''Double
| fname `elem` ["character varying", "text"] = use ''Text
| fname == "numeric" = use ''Scientific
| fname == "date" = use ''Day
| fname == "bytea" = use ''ByteString
| otherwise = throwSignal $ ParseError $ "Compile error: cannot deduct Haskell type " `T.append` toS fname
where use x = return $ ConT x