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
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)
-- Our convention for "standarnized names"
-- @TODO What if users have their own naming scheme?
standardizeName :: Text -> Text
standardizeName s = toS (process title camel $ camelize (toS s))
-- | returns a plural of a known noun.
-- Basically just appends `s` or `es`
quasyPlural :: Text -> Text
quasyPlural s = if T.null s then "" else case T.last s of
's' -> s <> "es"
_ -> s <> "s"
-- | Tries to name multiples constraints
nameUnnamedConstraints :: Throws ParseError m => EntityInfo -> m EntityInfo
nameUnnamedConstraints ei = do
namedConstraints <- sequence $ nameUnnamedConstraint ei <$> cl
return $ ei & entityInfoConstraintList .~ namedConstraints
where cl = ei ^. entityInfoConstraintList
-- | Mechanism for naming unnamed constraints. If a constraint cannot be named, an error is trown
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
-- | Provides default naming scheme for constraints
nameConstraint :: Text -> [SQL.NameComponent] -> Text
nameConstraint s ncs = if T.null s then T.intercalate "_" (toS. SQL.ncStr <$> ncs) else s
-- | Converts a 'SQL.Name' to a plain text
-- @TODO test complex naming schemes
getName :: SQL.Name -> Text
getName n = toS $ fmap toLower (intercalate "." $ SQL.ncStr <$> SQL.nameComponents n)
-- | Retrieves a list of optional columns in an entity
getOptionalColumns :: ParseContext -> EntityInfo -> [ColumnInfo]
getOptionalColumns 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 = isPrimaryKey ci || isUnique ci || hasOptionalConsts (ci ^. columnInfoConstraints)
hasOptionalConsts consts = null consts || elem NullConstraint consts
-- | Tries to retrieve entity information. If an entity with that name doesn't exist an error is thrown.
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"
-- | Tries to retrieve entity information. If an entity with that name doesn't exist an error is thrown.
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"
-- | Tries to retrieve column information from entity. If a column with that name doesn't exist an error is thrown.
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
-- | Retrieves the primary key for an entity from 'ParseContext'
getEntityPrimaryKey :: ParseContext -> EntityInfo -> Maybe PrimaryKeyConstraint
getEntityPrimaryKey ctx ei = listToMaybe $ filter (\pk -> pk ^. pkEntity == ei) (ctx ^. pks)
-- | Generates name for the column lens (i.e. lowercases first letter)
columnNameToLensName :: Text -> Text
columnNameToLensName = lowerFirst