module Database.Persist.Quasi.PersistSettings.Internal where

import Data.Char (isDigit, isLower, isSpace, isUpper, toLower)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import Database.Persist.Names
import Database.Persist.Types
import Text.Megaparsec
    ( ParseError
    , ParseErrorBundle (..)
    , PosState
    , SourcePos
    , errorBundlePretty
    , pstateSourcePos
    )

data PersistSettings = PersistSettings
    { PersistSettings -> Text -> Text
psToDBName :: !(Text -> Text)
    -- ^ Modify the Haskell-style name into a database-style name.
    , PersistSettings -> EntityNameHS -> ConstraintNameHS -> Text
psToFKName :: !(EntityNameHS -> ConstraintNameHS -> Text)
    -- ^ A function for generating the constraint name, with access to
    -- the entity and constraint names. Default value: @mappend@
    --
    -- @since 2.13.0.0
    , PersistSettings -> Bool
psStrictFields :: !Bool
    -- ^ Whether fields are by default strict. Default value: @True@.
    --
    -- @since 1.2
    , PersistSettings -> Text
psIdName :: !Text
    -- ^ The name of the id column. Default value: @id@
    -- The name of the id column can also be changed on a per-model basis
    -- <https://github.com/yesodweb/persistent/wiki/Persistent-entity-syntax>
    --
    -- @since 2.0
    , PersistSettings -> Maybe ParserErrorLevel
psTabErrorLevel :: Maybe ParserErrorLevel
    -- ^ Whether and with what severity to disallow tabs in entity source text.
    --
    -- @since 2.16.0.0
    }

defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings
defaultPersistSettings :: PersistSettings
defaultPersistSettings =
    PersistSettings
        { psToDBName :: Text -> Text
psToDBName = Text -> Text
forall a. a -> a
id
        , psToFKName :: EntityNameHS -> ConstraintNameHS -> Text
psToFKName = \(EntityNameHS Text
entName) (ConstraintNameHS Text
conName) -> Text
entName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
conName
        , psStrictFields :: Bool
psStrictFields = Bool
True
        , psIdName :: Text
psIdName = Text
"id"
        , psTabErrorLevel :: Maybe ParserErrorLevel
psTabErrorLevel = ParserErrorLevel -> Maybe ParserErrorLevel
forall a. a -> Maybe a
Just ParserErrorLevel
LevelWarning
        }
upperCaseSettings :: PersistSettings
upperCaseSettings = PersistSettings
defaultPersistSettings
lowerCaseSettings :: PersistSettings
lowerCaseSettings =
    PersistSettings
defaultPersistSettings
        { psToDBName =
            let
                go Char
c
                    | Char -> Bool
isUpper Char
c = String -> Text
T.pack [Char
'_', Char -> Char
toLower Char
c]
                    | Bool
otherwise = Char -> Text
T.singleton Char
c
             in
                T.dropWhile (== '_') . T.concatMap go
        }

-- |
--
-- @since 2.16.0.0
data ParserErrorLevel = LevelError | LevelWarning deriving (ParserErrorLevel -> ParserErrorLevel -> Bool
(ParserErrorLevel -> ParserErrorLevel -> Bool)
-> (ParserErrorLevel -> ParserErrorLevel -> Bool)
-> Eq ParserErrorLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParserErrorLevel -> ParserErrorLevel -> Bool
== :: ParserErrorLevel -> ParserErrorLevel -> Bool
$c/= :: ParserErrorLevel -> ParserErrorLevel -> Bool
/= :: ParserErrorLevel -> ParserErrorLevel -> Bool
Eq, Int -> ParserErrorLevel -> ShowS
[ParserErrorLevel] -> ShowS
ParserErrorLevel -> String
(Int -> ParserErrorLevel -> ShowS)
-> (ParserErrorLevel -> String)
-> ([ParserErrorLevel] -> ShowS)
-> Show ParserErrorLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParserErrorLevel -> ShowS
showsPrec :: Int -> ParserErrorLevel -> ShowS
$cshow :: ParserErrorLevel -> String
show :: ParserErrorLevel -> String
$cshowList :: [ParserErrorLevel] -> ShowS
showList :: [ParserErrorLevel] -> ShowS
Show)

-- |
--
-- @since 2.16.0.0
data ParserWarning = ParserWarning
    { ParserWarning -> String
parserWarningExtraMessage :: String
    , ParserWarning -> ParseError String Void
parserWarningUnderlyingError :: ParseError String Void
    , ParserWarning -> PosState String
parserWarningPosState :: PosState String
    }
    deriving (ParserWarning -> ParserWarning -> Bool
(ParserWarning -> ParserWarning -> Bool)
-> (ParserWarning -> ParserWarning -> Bool) -> Eq ParserWarning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParserWarning -> ParserWarning -> Bool
== :: ParserWarning -> ParserWarning -> Bool
$c/= :: ParserWarning -> ParserWarning -> Bool
/= :: ParserWarning -> ParserWarning -> Bool
Eq, Int -> ParserWarning -> ShowS
[ParserWarning] -> ShowS
ParserWarning -> String
(Int -> ParserWarning -> ShowS)
-> (ParserWarning -> String)
-> ([ParserWarning] -> ShowS)
-> Show ParserWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParserWarning -> ShowS
showsPrec :: Int -> ParserWarning -> ShowS
$cshow :: ParserWarning -> String
show :: ParserWarning -> String
$cshowList :: [ParserWarning] -> ShowS
showList :: [ParserWarning] -> ShowS
Show)

warningPos :: ParserWarning -> SourcePos
warningPos :: ParserWarning -> SourcePos
warningPos = PosState String -> SourcePos
forall s. PosState s -> SourcePos
pstateSourcePos (PosState String -> SourcePos)
-> (ParserWarning -> PosState String) -> ParserWarning -> SourcePos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserWarning -> PosState String
parserWarningPosState

instance Ord ParserWarning where
    ParserWarning
l <= :: ParserWarning -> ParserWarning -> Bool
<= ParserWarning
r =
        if ParserWarning -> SourcePos
warningPos ParserWarning
l SourcePos -> SourcePos -> Bool
forall a. Eq a => a -> a -> Bool
== ParserWarning -> SourcePos
warningPos ParserWarning
r
            then ParserWarning -> String
parserWarningMessage ParserWarning
l String -> String -> Bool
forall a. Ord a => a -> a -> Bool
<= ParserWarning -> String
parserWarningMessage ParserWarning
r
            else ParserWarning -> SourcePos
warningPos ParserWarning
l SourcePos -> SourcePos -> Bool
forall a. Ord a => a -> a -> Bool
<= ParserWarning -> SourcePos
warningPos ParserWarning
r

-- | Uses @errorBundlePretty@ to render a parser warning.
--
-- @since 2.16.0.0
parserWarningMessage :: ParserWarning -> String
parserWarningMessage :: ParserWarning -> String
parserWarningMessage ParserWarning
pw =
    ParserWarning -> String
parserWarningExtraMessage ParserWarning
pw
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ( ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void -> String
forall a b. (a -> b) -> a -> b
$
                ParseErrorBundle
                    { bundleErrors :: NonEmpty (ParseError String Void)
bundleErrors = ParserWarning -> ParseError String Void
parserWarningUnderlyingError ParserWarning
pw ParseError String Void
-> [ParseError String Void] -> NonEmpty (ParseError String Void)
forall a. a -> [a] -> NonEmpty a
:| []
                    , bundlePosState :: PosState String
bundlePosState = ParserWarning -> PosState String
parserWarningPosState ParserWarning
pw
                    }
           )

toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text
toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text
toFKNameInfixed Text
inf (EntityNameHS Text
entName) (ConstraintNameHS Text
conName) =
    Text
entName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inf Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
conName

-- | Retrieve the function in the 'PersistSettings' that modifies the names into
-- database names.
--
-- @since 2.13.0.0
getPsToDBName :: PersistSettings -> Text -> Text
getPsToDBName :: PersistSettings -> Text -> Text
getPsToDBName = PersistSettings -> Text -> Text
psToDBName

-- | Set the name modification function that translates the QuasiQuoted names
-- for use in the database.
--
-- @since 2.13.0.0
setPsToDBName :: (Text -> Text) -> PersistSettings -> PersistSettings
setPsToDBName :: (Text -> Text) -> PersistSettings -> PersistSettings
setPsToDBName Text -> Text
f PersistSettings
ps = PersistSettings
ps{psToDBName = f}

-- | Set a custom function used to create the constraint name
-- for a foreign key.
--
-- @since 2.13.0.0
setPsToFKName
    :: (EntityNameHS -> ConstraintNameHS -> Text) -> PersistSettings -> PersistSettings
setPsToFKName :: (EntityNameHS -> ConstraintNameHS -> Text)
-> PersistSettings -> PersistSettings
setPsToFKName EntityNameHS -> ConstraintNameHS -> Text
setter PersistSettings
ps = PersistSettings
ps{psToFKName = setter}

-- | A preset configuration function that puts an underscore
-- between the entity name and the constraint name when
-- creating a foreign key constraint name
--
-- @since 2.14.2.0
setPsUseSnakeCaseForeignKeys :: PersistSettings -> PersistSettings
setPsUseSnakeCaseForeignKeys :: PersistSettings -> PersistSettings
setPsUseSnakeCaseForeignKeys = (EntityNameHS -> ConstraintNameHS -> Text)
-> PersistSettings -> PersistSettings
setPsToFKName (Text -> EntityNameHS -> ConstraintNameHS -> Text
toFKNameInfixed Text
"_")

-- | Equivalent to 'setPsUseSnakeCaseForeignKeys', but misspelled.
--
-- @since 2.13.0.0
setPsUseSnakeCaseForiegnKeys :: PersistSettings -> PersistSettings
setPsUseSnakeCaseForiegnKeys :: PersistSettings -> PersistSettings
setPsUseSnakeCaseForiegnKeys = PersistSettings -> PersistSettings
setPsUseSnakeCaseForeignKeys
{-# DEPRECATED
    setPsUseSnakeCaseForiegnKeys
    "use the correctly spelled, equivalent, setPsUseSnakeCaseForeignKeys instead"
    #-}

-- | Retrieve whether or not the 'PersistSettings' will generate code with
-- strict fields.
--
-- @since 2.13.0.0
getPsStrictFields :: PersistSettings -> Bool
getPsStrictFields :: PersistSettings -> Bool
getPsStrictFields = PersistSettings -> Bool
psStrictFields

-- | Set whether or not the 'PersistSettings' will make fields strict.
--
-- @since 2.13.0.0
setPsStrictFields :: Bool -> PersistSettings -> PersistSettings
setPsStrictFields :: Bool -> PersistSettings -> PersistSettings
setPsStrictFields Bool
a PersistSettings
ps = PersistSettings
ps{psStrictFields = a}

-- | Retrieve the default name of the @id@ column.
--
-- @since 2.13.0.0
getPsIdName :: PersistSettings -> Text
getPsIdName :: PersistSettings -> Text
getPsIdName = PersistSettings -> Text
psIdName

-- | Set the default name of the @id@ column.
--
-- @since 2.13.0.0
setPsIdName :: Text -> PersistSettings -> PersistSettings
setPsIdName :: Text -> PersistSettings -> PersistSettings
setPsIdName Text
n PersistSettings
ps = PersistSettings
ps{psIdName = n}

-- | Retrieve the severity of the error generated when the parser encounters a tab.
-- If it is @Nothing@, tabs are permitted in entity definitions.
--
-- @since 2.16.0.0
getPsTabErrorLevel :: PersistSettings -> Maybe ParserErrorLevel
getPsTabErrorLevel :: PersistSettings -> Maybe ParserErrorLevel
getPsTabErrorLevel = PersistSettings -> Maybe ParserErrorLevel
psTabErrorLevel

-- | Set the severity of the error generated when the parser encounters a tab.
-- If set to @Nothing@, tabs are permitted in entity definitions.
--
-- @since 2.16.0.0
setPsTabErrorLevel
    :: Maybe ParserErrorLevel -> PersistSettings -> PersistSettings
setPsTabErrorLevel :: Maybe ParserErrorLevel -> PersistSettings -> PersistSettings
setPsTabErrorLevel Maybe ParserErrorLevel
l PersistSettings
ps = PersistSettings
ps{psTabErrorLevel = l}