Helper.hs

{-|
module Internal.     : Data.Basic.TH.Types
Description : Data types and utility function used during TH generation phase
License     : MIT

This module Internal.contains helper functions that are used in code generation process.
-}
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

-- | lifts a list of types to a type level (i.e. typelevel list)
--   e.g. `listToTypeLeve [Int, String, Double] = '[ Int, String, Double ]`
listToTypeLevel :: [TH.Type] -> TH.Type
listToTypeLevel = foldr (\t le -> AppT (AppT PromotedConsT t) le) PromotedNilT


-- | Used to append n times `<$> field` to the expression
addFields :: TH.Exp -> Int -> TH.Exp
addFields e n
  | n > 1 = addField (addFields e (n - 1))
  | otherwise = e

-- | Used to append `<$> field` at the end of the expression
addField :: TH.Exp -> TH.Exp
addField a = InfixE (Just a) (VarE '(<*>)) (Just $ VarE 'field)

-- | 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
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)

-- | 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

-- | Converts camel case or snake case to normal form. Examples:
--
-- > normalizeName "ABCDE"
-- "abcde"
-- > normalizeName "ABC_DE"
-- "abcDe"
-- > normalizeName "AbcDe"
-- "abcDe"
-- > normalizeName "abcDe"
-- "abcDe"
-- > normalizeName "abcde"
-- "abcde"
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)

-- Our convention for "standarnized names"
-- @TODO What if users have their own naming scheme?
normalizeTable :: Text -> Text
normalizeTable = upperFirst . normalizeName

-- | 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