module Internal.Data.Basic.TH.Helper where
import Internal.Interlude
import Cases
import Internal.Data.Basic.TH.Types
import Database.PostgreSQL.Simple.FromRow
import Database.HsSqlPpp.Parse
import qualified Data.Text as T
import Control.Effects.Signal
import Language.Haskell.TH.Syntax as TH
import qualified Database.HsSqlPpp.Syntax as SQL
import Data.Void
type Throws e = MonadEffect (Signal e Void)
liftError :: Throws ParseError m => Either ParseErrorExtra a -> m a
liftError (Left pex) = throwSignal $ ParseError $ toS $ "\n\n\nError while parsing sql file " ++ show pex
liftError (Right a) = return a
listToTypeLevel :: [TH.Type] -> TH.Type
listToTypeLevel = foldr (\t le -> AppT (AppT PromotedConsT t) le) PromotedNilT
addFields :: TH.Exp -> Int -> TH.Exp
addFields e n
| n > 1 = addField (addFields e (n 1))
| otherwise = e
addField :: TH.Exp -> TH.Exp
addField a = InfixE (Just a) (VarE '(<*>)) (Just $ VarE 'field)
quasyPlural :: Text -> Text
quasyPlural s = if T.null s then "" else case T.last s of
's' -> s <> "es"
_ -> s <> "s"
nameUnnamedConstraints :: Throws ParseError m => EntityInfo -> m EntityInfo
nameUnnamedConstraints ei = do
namedConstraints <- sequence $ nameUnnamedConstraint ei <$> cl
return $ ei & entityInfoConstraintList .~ namedConstraints
where cl = ei ^. entityInfoConstraintList
nameUnnamedConstraint :: Throws ParseError m => EntityInfo -> SQL.Constraint -> m SQL.Constraint
nameUnnamedConstraint ei (SQL.UniqueConstraint a name ncs) = return $ SQL.UniqueConstraint a cname ncs
where cname = toS $ ei ^. entityInfoText <> "_uq_"<> nameConstraint (toS name) ncs
nameUnnamedConstraint ei (SQL.PrimaryKeyConstraint a name ncs) = return $ SQL.PrimaryKeyConstraint a cname ncs
where cname = toS $ ei ^. entityInfoText <> "_pk_"<> nameConstraint (toS name) ncs
nameUnnamedConstraint _ a = throwSignal $ ParseError $ "Cannot name constraint: " <> show a
nameConstraint :: Text -> [SQL.NameComponent] -> Text
nameConstraint s ncs = if T.null s then T.intercalate "_" (toS. SQL.ncStr <$> ncs) else s
getName :: SQL.Name -> Text
getName n = toS $ fmap toLower (intercalate "." $ SQL.ncStr <$> SQL.nameComponents n)
getDynamicDefaultColumns :: ParseContext -> EntityInfo -> [ColumnInfo]
getDynamicDefaultColumns ctx ei = columns
where columns = filter isOptional (ei ^. entityInfoColumnMap)
isPrimaryKey ci = any (\pk -> ci `elem` (pk ^. pkCols)) (ctx ^. pks)
isUnique ci = any (\uq -> ci `elem` (uq ^. uqCols)) (ctx ^. uqs)
isOptional ci = elem DefaultConstraint (ci ^. columnInfoConstraints) ||
not (isPrimaryKey ci) && not (isUnique ci) && notElem NotNullConstraint (ci ^. columnInfoConstraints)
getEntityByName :: Throws ParseError m => SQL.Name -> [EntityInfo] -> m EntityInfo
getEntityByName name m = maybe (throwSignal $ ParseError err) return els
where els = listToMaybe $ filter (\v -> getName name == v ^. entityInfoText ) m
err = "Lookup by Name failed: " <> getName name <> " not found in EntityMap"
getEntityBySQLName :: Throws ParseError m => SQL.Name -> [EntityInfo] -> m EntityInfo
getEntityBySQLName name m = maybe (throwSignal $ ParseError err) return els
where els = listToMaybe $ filter (\v -> _entityInfoSQLName v == name) m
err = "Lookup by SQL name failed: " <> getName name <> " not found in EntityMap"
getColumn :: Throws ParseError m => EntityInfo -> Text -> m ColumnInfo
getColumn ei name = maybe (throwSignal $ ParseError err) return info
where info = listToMaybe $ filter (\c -> name == c ^. columnInfoText) (ei ^. entityInfoColumnMap)
err = "Column lookup failed: " <> name <> " not found in EntityInfo: " <> show ei
lowerFirst :: Text -> Text
lowerFirst t = fromMaybe t (f <$> T.uncons t)
where f (a, b) = T.cons (toLower a) b
upperFirst :: Text -> Text
upperFirst t = fromMaybe t (f <$> T.uncons t)
where f (a, b) = T.cons (toUpper a) b
normalizeName :: Text -> Text
normalizeName =
lowerFirst
. camelize
. mconcat
. fmap (\g -> if isUpper (T.head g) then upperFirst (T.map toLower g) else g)
. T.groupBy (\c1 c2 -> isUpper c1 && isUpper c2)
normalizeTable :: Text -> Text
normalizeTable = upperFirst . normalizeName
getEntityPrimaryKey :: ParseContext -> EntityInfo -> Maybe PrimaryKeyConstraint
getEntityPrimaryKey ctx ei = listToMaybe $ filter (\pk -> pk ^. pkEntity == ei) (ctx ^. pks)
columnNameToLensName :: Text -> Text
columnNameToLensName = lowerFirst