{-# LANGUAGE PatternGuards #-}
-- | Intended for creating new backends.
module Database.Persist.Sql.Internal
    ( mkColumns
    , defaultAttribute
    ) where

import Data.Char (isSpace)
import Data.Monoid (mappend, mconcat)
import Data.Text (Text)
import qualified Data.Text as T

import Database.Persist.Quasi
import Database.Persist.Sql.Types
import Database.Persist.Types

defaultAttribute :: [Attr] -> Maybe Text
defaultAttribute :: [Attr] -> Maybe Attr
defaultAttribute [] = Maybe Attr
forall a. Maybe a
Nothing
defaultAttribute (Attr
a:[Attr]
as)
    | Just Attr
d <- Attr -> Attr -> Maybe Attr
T.stripPrefix Attr
"default=" Attr
a = Attr -> Maybe Attr
forall a. a -> Maybe a
Just Attr
d
    | Bool
otherwise = [Attr] -> Maybe Attr
defaultAttribute [Attr]
as

-- | Create the list of columns for the given entity.
mkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
mkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
mkColumns [EntityDef]
allDefs EntityDef
t =
    ([Column]
cols, EntityDef -> [UniqueDef]
entityUniques EntityDef
t, EntityDef -> [ForeignDef]
entityForeigns EntityDef
t)
  where
    cols :: [Column]
    cols :: [Column]
cols = (FieldDef -> Column) -> [FieldDef] -> [Column]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Column
go (EntityDef -> [FieldDef]
entityFields EntityDef
t)

    tn :: DBName
    tn :: DBName
tn = EntityDef -> DBName
entityDB EntityDef
t

    go :: FieldDef -> Column
    go :: FieldDef -> Column
go FieldDef
fd =
        DBName
-> Bool
-> SqlType
-> Maybe Attr
-> Maybe DBName
-> Maybe Integer
-> Maybe (DBName, DBName)
-> Column
Column
            (FieldDef -> DBName
fieldDB FieldDef
fd)
            ([Attr] -> IsNullable
nullable (FieldDef -> [Attr]
fieldAttrs FieldDef
fd) IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
/= IsNullable
NotNullable Bool -> Bool -> Bool
|| EntityDef -> Bool
entitySum EntityDef
t)
            (FieldDef -> SqlType
fieldSqlType FieldDef
fd)
            ([Attr] -> Maybe Attr
defaultAttribute ([Attr] -> Maybe Attr) -> [Attr] -> Maybe Attr
forall a b. (a -> b) -> a -> b
$ FieldDef -> [Attr]
fieldAttrs FieldDef
fd)
            Maybe DBName
forall a. Maybe a
Nothing
            ([Attr] -> Maybe Integer
maxLen ([Attr] -> Maybe Integer) -> [Attr] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ FieldDef -> [Attr]
fieldAttrs FieldDef
fd)
            (DBName -> ReferenceDef -> [Attr] -> Maybe (DBName, DBName)
ref (FieldDef -> DBName
fieldDB FieldDef
fd) (FieldDef -> ReferenceDef
fieldReference FieldDef
fd) (FieldDef -> [Attr]
fieldAttrs FieldDef
fd))

    maxLen :: [Attr] -> Maybe Integer
    maxLen :: [Attr] -> Maybe Integer
maxLen [] = Maybe Integer
forall a. Maybe a
Nothing
    maxLen (Attr
a:[Attr]
as)
        | Just Attr
d <- Attr -> Attr -> Maybe Attr
T.stripPrefix Attr
"maxlen=" Attr
a =
            case ReadS Integer
forall a. Read a => ReadS a
reads (Attr -> String
T.unpack Attr
d) of
              [(Integer
i, String
s)] | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
              [(Integer, String)]
_ -> String -> Maybe Integer
forall a. HasCallStack => String -> a
error (String -> Maybe Integer) -> String -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ String
"Could not parse maxlen field with value " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           Attr -> String
forall a. Show a => a -> String
show Attr
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DBName -> String
forall a. Show a => a -> String
show DBName
tn
        | Bool
otherwise = [Attr] -> Maybe Integer
maxLen [Attr]
as

    ref :: DBName
        -> ReferenceDef
        -> [Attr]
        -> Maybe (DBName, DBName) -- table name, constraint name
    ref :: DBName -> ReferenceDef -> [Attr] -> Maybe (DBName, DBName)
ref DBName
c ReferenceDef
fe []
        | ForeignRef HaskellName
f FieldType
_ <- ReferenceDef
fe =
            (DBName, DBName) -> Maybe (DBName, DBName)
forall a. a -> Maybe a
Just ([EntityDef] -> HaskellName -> DBName
resolveTableName [EntityDef]
allDefs HaskellName
f, DBName -> DBName -> DBName
refName DBName
tn DBName
c)
        | Bool
otherwise = Maybe (DBName, DBName)
forall a. Maybe a
Nothing
    ref DBName
_ ReferenceDef
_ (Attr
"noreference":[Attr]
_) = Maybe (DBName, DBName)
forall a. Maybe a
Nothing
    ref DBName
c ReferenceDef
fe (Attr
a:[Attr]
as)
        | Just Attr
x <- Attr -> Attr -> Maybe Attr
T.stripPrefix Attr
"reference=" Attr
a = do
            DBName
constraintName <- (DBName, DBName) -> DBName
forall a b. (a, b) -> b
snd ((DBName, DBName) -> DBName)
-> Maybe (DBName, DBName) -> Maybe DBName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DBName -> ReferenceDef -> [Attr] -> Maybe (DBName, DBName)
ref DBName
c ReferenceDef
fe [Attr]
as)
            (DBName, DBName) -> Maybe (DBName, DBName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> DBName
DBName Attr
x, DBName
constraintName)
        | Just Attr
x <- Attr -> Attr -> Maybe Attr
T.stripPrefix Attr
"constraint=" Attr
a = do
            DBName
tableName <- (DBName, DBName) -> DBName
forall a b. (a, b) -> a
fst ((DBName, DBName) -> DBName)
-> Maybe (DBName, DBName) -> Maybe DBName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DBName -> ReferenceDef -> [Attr] -> Maybe (DBName, DBName)
ref DBName
c ReferenceDef
fe [Attr]
as)
            (DBName, DBName) -> Maybe (DBName, DBName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DBName
tableName, Attr -> DBName
DBName Attr
x)
    ref DBName
c ReferenceDef
x (Attr
_:[Attr]
as) = DBName -> ReferenceDef -> [Attr] -> Maybe (DBName, DBName)
ref DBName
c ReferenceDef
x [Attr]
as

refName :: DBName -> DBName -> DBName
refName :: DBName -> DBName -> DBName
refName (DBName Attr
table) (DBName Attr
column) =
    Attr -> DBName
DBName (Attr -> DBName) -> Attr -> DBName
forall a b. (a -> b) -> a -> b
$ [Attr] -> Attr
forall a. Monoid a => [a] -> a
Data.Monoid.mconcat [Attr
table, Attr
"_", Attr
column, Attr
"_fkey"]

resolveTableName :: [EntityDef] -> HaskellName -> DBName
resolveTableName :: [EntityDef] -> HaskellName -> DBName
resolveTableName [] (HaskellName Attr
hn) = String -> DBName
forall a. HasCallStack => String -> a
error (String -> DBName) -> String -> DBName
forall a b. (a -> b) -> a -> b
$ String
"Table not found: " String -> String -> String
forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend` Attr -> String
T.unpack Attr
hn
resolveTableName (EntityDef
e:[EntityDef]
es) HaskellName
hn
    | EntityDef -> HaskellName
entityHaskell EntityDef
e HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== HaskellName
hn = EntityDef -> DBName
entityDB EntityDef
e
    | Bool
otherwise = [EntityDef] -> HaskellName -> DBName
resolveTableName [EntityDef]
es HaskellName
hn