{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Database.Persist.Quasi.Internal
( parse
, PersistSettings (..)
, upperCaseSettings
, lowerCaseSettings
, toFKNameInfixed
, Token (..)
, Line (..)
, preparse
, parseLine
, parseFieldType
, associateLines
, LinesWithComments(..)
, parseEntityFields
, takeColsEx
, UnboundEntityDef(..)
, getUnboundEntityNameHS
, unbindEntityDef
, getUnboundFieldDefs
, UnboundForeignDef(..)
, getSqlNameOr
, UnboundFieldDef(..)
, UnboundCompositeDef(..)
, UnboundIdDef(..)
, unbindFieldDef
, isUnboundFieldNullable
, unboundIdDefToFieldDef
, PrimarySpec(..)
, mkAutoIdField'
, UnboundForeignFieldList(..)
, ForeignFieldReference(..)
, mkKeyConType
, isHaskellUnboundField
) where
import Prelude hiding (lines)
import Control.Applicative (Alternative((<|>)))
import Data.Char (isLower, isSpace, isUpper, toLower)
import Data.List (find, foldl')
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.EntityDef.Internal
import Database.Persist.Types
import Language.Haskell.TH.Syntax (Lift)
import Text.Read (readEither)
data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Int -> ParseState a -> ShowS
[ParseState a] -> ShowS
ParseState a -> String
(Int -> ParseState a -> ShowS)
-> (ParseState a -> String)
-> ([ParseState a] -> ShowS)
-> Show (ParseState a)
forall a. Show a => Int -> ParseState a -> ShowS
forall a. Show a => [ParseState a] -> ShowS
forall a. Show a => ParseState a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseState a] -> ShowS
$cshowList :: forall a. Show a => [ParseState a] -> ShowS
show :: ParseState a -> String
$cshow :: forall a. Show a => ParseState a -> String
showsPrec :: Int -> ParseState a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseState a -> ShowS
Show
parseFieldType :: Text -> Either String FieldType
parseFieldType :: Text -> Either String FieldType
parseFieldType Text
t0 =
case Text -> ParseState FieldType
parseApplyFT Text
t0 of
PSSuccess FieldType
ft Text
t'
| (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace Text
t' -> FieldType -> Either String FieldType
forall a b. b -> Either a b
Right FieldType
ft
PSFail String
err -> String -> Either String FieldType
forall a b. a -> Either a b
Left (String -> Either String FieldType)
-> String -> Either String FieldType
forall a b. (a -> b) -> a -> b
$ String
"PSFail " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
ParseState FieldType
other -> String -> Either String FieldType
forall a b. a -> Either a b
Left (String -> Either String FieldType)
-> String -> Either String FieldType
forall a b. (a -> b) -> a -> b
$ ParseState FieldType -> String
forall a. Show a => a -> String
show ParseState FieldType
other
where
parseApplyFT :: Text -> ParseState FieldType
parseApplyFT :: Text -> ParseState FieldType
parseApplyFT Text
t =
case ([FieldType] -> [FieldType]) -> Text -> ParseState [FieldType]
forall a. ([FieldType] -> a) -> Text -> ParseState a
goMany [FieldType] -> [FieldType]
forall a. a -> a
id Text
t of
PSSuccess (FieldType
ft:[FieldType]
fts) Text
t' -> FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess ((FieldType -> FieldType -> FieldType)
-> FieldType -> [FieldType] -> FieldType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' FieldType -> FieldType -> FieldType
FTApp FieldType
ft [FieldType]
fts) Text
t'
PSSuccess [] Text
_ -> String -> ParseState FieldType
forall a. String -> ParseState a
PSFail String
"empty"
PSFail String
err -> String -> ParseState FieldType
forall a. String -> ParseState a
PSFail String
err
ParseState [FieldType]
PSDone -> ParseState FieldType
forall a. ParseState a
PSDone
parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
end FieldType -> FieldType
ftMod Text
t =
let (Text
a, Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
end) Text
t
in case Text -> ParseState FieldType
parseApplyFT Text
a of
PSSuccess FieldType
ft Text
t' -> case ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t', Text -> Maybe (Char, Text)
T.uncons Text
b) of
(Text
"", Just (Char
c, Text
t'')) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
end -> FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess (FieldType -> FieldType
ftMod FieldType
ft) (Text
t'' Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend` Text
t')
(Text
x, Maybe (Char, Text)
y) -> String -> ParseState FieldType
forall a. String -> ParseState a
PSFail (String -> ParseState FieldType) -> String -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ (Text, Text, Maybe (Char, Text)) -> String
forall a. Show a => a -> String
show (Text
b, Text
x, Maybe (Char, Text)
y)
ParseState FieldType
x -> String -> ParseState FieldType
forall a. String -> ParseState a
PSFail (String -> ParseState FieldType) -> String -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ ParseState FieldType -> String
forall a. Show a => a -> String
show ParseState FieldType
x
parse1 :: Text -> ParseState FieldType
parse1 :: Text -> ParseState FieldType
parse1 Text
t =
case Text -> Maybe (Char, Text)
T.uncons Text
t of
Maybe (Char, Text)
Nothing -> ParseState FieldType
forall a. ParseState a
PSDone
Just (Char
c, Text
t')
| Char -> Bool
isSpace Char
c -> Text -> ParseState FieldType
parse1 (Text -> ParseState FieldType) -> Text -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t'
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' -> Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
')' FieldType -> FieldType
forall a. a -> a
id Text
t'
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[' -> Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed Char
']' FieldType -> FieldType
FTList Text
t'
| Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' ->
let (Text
a, Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\Char
x -> Char -> Bool
isSpace Char
x Bool -> Bool -> Bool
|| Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"()[]"::String)) Text
t'
in FieldType -> Text -> ParseState FieldType
forall a. a -> Text -> ParseState a
PSSuccess (Char -> Text -> FieldType
parseFieldTypePiece Char
c Text
a) Text
b
| Bool
otherwise -> String -> ParseState FieldType
forall a. String -> ParseState a
PSFail (String -> ParseState FieldType) -> String -> ParseState FieldType
forall a b. (a -> b) -> a -> b
$ (Char, Text) -> String
forall a. Show a => a -> String
show (Char
c, Text
t')
goMany :: ([FieldType] -> a) -> Text -> ParseState a
goMany :: ([FieldType] -> a) -> Text -> ParseState a
goMany [FieldType] -> a
front Text
t =
case Text -> ParseState FieldType
parse1 Text
t of
PSSuccess FieldType
x Text
t' -> ([FieldType] -> a) -> Text -> ParseState a
forall a. ([FieldType] -> a) -> Text -> ParseState a
goMany ([FieldType] -> a
front ([FieldType] -> a)
-> ([FieldType] -> [FieldType]) -> [FieldType] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldType
xFieldType -> [FieldType] -> [FieldType]
forall a. a -> [a] -> [a]
:)) Text
t'
PSFail String
err -> String -> ParseState a
forall a. String -> ParseState a
PSFail String
err
ParseState FieldType
PSDone -> a -> Text -> ParseState a
forall a. a -> Text -> ParseState a
PSSuccess ([FieldType] -> a
front []) Text
t
parseFieldTypePiece :: Char -> Text -> FieldType
parseFieldTypePiece :: Char -> Text -> FieldType
parseFieldTypePiece Char
fstChar Text
rest =
case Char
fstChar of
Char
'\'' ->
Text -> FieldType
FTTypePromoted Text
rest
Char
_ ->
let t :: Text
t = Char -> Text -> Text
T.cons Char
fstChar Text
rest
in case Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
t of
(Text
_, Text
"") -> Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
t
(Text
"", Text
_) -> Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
t
(Text
a, Text
b) -> Maybe Text -> Text -> FieldType
FTTypeCon (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.init Text
a) Text
b
data PersistSettings = PersistSettings
{ PersistSettings -> Text -> Text
psToDBName :: !(Text -> Text)
, PersistSettings -> EntityNameHS -> ConstraintNameHS -> Text
psToFKName :: !(EntityNameHS -> ConstraintNameHS -> Text)
, PersistSettings -> Bool
psStrictFields :: !Bool
, PersistSettings -> Text
psIdName :: !Text
}
defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings
defaultPersistSettings :: PersistSettings
defaultPersistSettings = PersistSettings :: (Text -> Text)
-> (EntityNameHS -> ConstraintNameHS -> Text)
-> Bool
-> Text
-> PersistSettings
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"
}
upperCaseSettings :: PersistSettings
upperCaseSettings = PersistSettings
defaultPersistSettings
lowerCaseSettings :: PersistSettings
lowerCaseSettings = PersistSettings
defaultPersistSettings
{ psToDBName :: Text -> Text
psToDBName =
let go :: Char -> Text
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 (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
go
}
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
parse :: PersistSettings -> Text -> [UnboundEntityDef]
parse :: PersistSettings -> Text -> [UnboundEntityDef]
parse PersistSettings
ps = [UnboundEntityDef]
-> (NonEmpty Line -> [UnboundEntityDef])
-> Maybe (NonEmpty Line)
-> [UnboundEntityDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
parseLines PersistSettings
ps) (Maybe (NonEmpty Line) -> [UnboundEntityDef])
-> (Text -> Maybe (NonEmpty Line)) -> Text -> [UnboundEntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (NonEmpty Line)
preparse
preparse :: Text -> Maybe (NonEmpty Line)
preparse :: Text -> Maybe (NonEmpty Line)
preparse Text
txt = do
NonEmpty Text
lns <- [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty (Text -> [Text]
T.lines Text
txt)
[Line] -> Maybe (NonEmpty Line)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty ([Line] -> Maybe (NonEmpty Line))
-> [Line] -> Maybe (NonEmpty Line)
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Line) -> [Text] -> [Line]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Line
parseLine (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Text
lns)
parseLine :: Text -> Maybe Line
parseLine :: Text -> Maybe Line
parseLine Text
txt = do
Int -> NonEmpty Token -> Line
Line (Text -> Int
parseIndentationAmount Text
txt) (NonEmpty Token -> Line) -> Maybe (NonEmpty Token) -> Maybe Line
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token] -> Maybe (NonEmpty Token)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty (Text -> [Token]
tokenize Text
txt)
data Token = Token Text
| Text
deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq)
tokenText :: Token -> Text
tokenText :: Token -> Text
tokenText Token
tok =
case Token
tok of
Token Text
t -> Text
t
DocComment Text
t -> Text
"-- | " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
parseIndentationAmount :: Text -> Int
parseIndentationAmount :: Text -> Int
parseIndentationAmount Text
txt =
let (Text
spaces, Text
_) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isSpace Text
txt
in Text -> Int
T.length Text
spaces
tokenize :: Text -> [Token]
tokenize :: Text -> [Token]
tokenize Text
t
| Text -> Bool
T.null Text
t = []
| Just Text
txt <- Text -> Text -> Maybe Text
T.stripPrefix Text
"-- | " Text
t = [Text -> Token
DocComment Text
txt]
| Text
"--" Text -> Text -> Bool
`T.isPrefixOf` Text
t = []
| Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text
t = []
| Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = Text -> ([Text] -> [Text]) -> [Token]
quotes (Text -> Text
T.tail Text
t) [Text] -> [Text]
forall a. a -> a
id
| Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' = Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
1 (Text -> Text
T.tail Text
t) [Text] -> [Text]
forall a. a -> a
id
| Char -> Bool
isSpace (Text -> Char
T.head Text
t) =
Text -> [Token]
tokenize ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t)
| Just (Text
beforeEquals, Text
afterEquals) <- Text -> Maybe (Text, Text)
findMidToken Text
t
, Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isSpace Text
beforeEquals)
, Token Text
next : [Token]
rest <- Text -> [Token]
tokenize Text
afterEquals =
Text -> Token
Token ([Text] -> Text
T.concat [Text
beforeEquals, Text
"=", Text
next]) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
rest
| Bool
otherwise =
let (Text
token, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
t
in Text -> Token
Token Text
token Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
rest
where
findMidToken :: Text -> Maybe (Text, Text)
findMidToken :: Text -> Maybe (Text, Text)
findMidToken Text
t' =
case (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') Text
t' of
(Text
x, Int -> Text -> Text
T.drop Int
1 -> Text
y)
| Text
"\"" Text -> Text -> Bool
`T.isPrefixOf` Text
y Bool -> Bool -> Bool
|| Text
"(" Text -> Text -> Bool
`T.isPrefixOf` Text
y -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
x, Text
y)
(Text, Text)
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
quotes :: Text -> ([Text] -> [Text]) -> [Token]
quotes :: Text -> ([Text] -> [Text]) -> [Token]
quotes Text
t' [Text] -> [Text]
front
| Text -> Bool
T.null Text
t' = String -> [Token]
forall a. HasCallStack => String -> a
error (String -> [Token]) -> String -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
Text
"Unterminated quoted string starting with " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
front []
| Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = Text -> Token
Token ([Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Text -> Text
T.tail Text
t')
| Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 =
Text -> ([Text] -> [Text]) -> [Token]
quotes (Int -> Text -> Text
T.drop Int
2 Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.take Int
1 (Int -> Text -> Text
T.drop Int
1 Text
t')Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
| Bool
otherwise =
let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'\"']) Text
t'
in Text -> ([Text] -> [Text]) -> [Token]
quotes Text
y ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
parens :: Int -> Text -> ([Text] -> [Text]) -> [Token]
parens :: Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count Text
t' [Text] -> [Text]
front
| Text -> Bool
T.null Text
t' = String -> [Token]
forall a. HasCallStack => String -> a
error (String -> [Token]) -> String -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
Text
"Unterminated parens string starting with " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
front []
| Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' =
if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1 :: Int)
then Text -> Token
Token ([Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Text -> Text
T.tail Text
t')
else Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Text -> Text
T.tail Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
")"Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
| Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' =
Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Text -> Text
T.tail Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"("Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
| Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 =
Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count (Int -> Text -> Text
T.drop Int
2 Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.take Int
1 (Int -> Text -> Text
T.drop Int
1 Text
t')Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
| Bool
otherwise =
let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'(',Char
')']) Text
t'
in Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count Text
y ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
data Line = Line
{ Line -> Int
lineIndent :: Int
, Line -> NonEmpty Token
tokens :: NonEmpty Token
} deriving (Line -> Line -> Bool
(Line -> Line -> Bool) -> (Line -> Line -> Bool) -> Eq Line
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Line -> Line -> Bool
$c/= :: Line -> Line -> Bool
== :: Line -> Line -> Bool
$c== :: Line -> Line -> Bool
Eq, Int -> Line -> ShowS
[Line] -> ShowS
Line -> String
(Int -> Line -> ShowS)
-> (Line -> String) -> ([Line] -> ShowS) -> Show Line
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Line] -> ShowS
$cshowList :: [Line] -> ShowS
show :: Line -> String
$cshow :: Line -> String
showsPrec :: Int -> Line -> ShowS
$cshowsPrec :: Int -> Line -> ShowS
Show)
lineText :: Line -> NonEmpty Text
lineText :: Line -> NonEmpty Text
lineText = (Token -> Text) -> NonEmpty Token -> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Text
tokenText (NonEmpty Token -> NonEmpty Text)
-> (Line -> NonEmpty Token) -> Line -> NonEmpty Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> NonEmpty Token
tokens
lowestIndent :: NonEmpty Line -> Int
lowestIndent :: NonEmpty Line -> Int
lowestIndent = NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (NonEmpty Int -> Int)
-> (NonEmpty Line -> NonEmpty Int) -> NonEmpty Line -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Int) -> NonEmpty Line -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line -> Int
lineIndent
parseLines :: PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
parseLines :: PersistSettings -> NonEmpty Line -> [UnboundEntityDef]
parseLines PersistSettings
ps = do
(LinesWithComments -> UnboundEntityDef)
-> [LinesWithComments] -> [UnboundEntityDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PersistSettings -> ParsedEntityDef -> UnboundEntityDef
mkUnboundEntityDef PersistSettings
ps (ParsedEntityDef -> UnboundEntityDef)
-> (LinesWithComments -> ParsedEntityDef)
-> LinesWithComments
-> UnboundEntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> ParsedEntityDef
toParsedEntityDef) ([LinesWithComments] -> [UnboundEntityDef])
-> (NonEmpty Line -> [LinesWithComments])
-> NonEmpty Line
-> [UnboundEntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Line -> [LinesWithComments]
associateLines
data ParsedEntityDef = ParsedEntityDef
{ :: [Text]
, ParsedEntityDef -> EntityNameHS
parsedEntityDefEntityName :: EntityNameHS
, ParsedEntityDef -> Bool
parsedEntityDefIsSum :: Bool
, ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes :: [Attr]
, ParsedEntityDef -> [[Token]]
parsedEntityDefFieldAttributes :: [[Token]]
, :: M.Map Text [ExtraLine]
}
entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)
entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)
entityNamesFromParsedDef PersistSettings
ps ParsedEntityDef
parsedEntDef = (EntityNameHS
entNameHS, EntityNameDB
entNameDB)
where
entNameHS :: EntityNameHS
entNameHS =
ParsedEntityDef -> EntityNameHS
parsedEntityDefEntityName ParsedEntityDef
parsedEntDef
entNameDB :: EntityNameDB
entNameDB =
Text -> EntityNameDB
EntityNameDB (Text -> EntityNameDB) -> Text -> EntityNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entNameHS) (ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes ParsedEntityDef
parsedEntDef)
toParsedEntityDef :: LinesWithComments -> ParsedEntityDef
toParsedEntityDef :: LinesWithComments -> ParsedEntityDef
toParsedEntityDef LinesWithComments
lwc = ParsedEntityDef :: [Text]
-> EntityNameHS
-> Bool
-> [Text]
-> [[Token]]
-> Map Text [[Text]]
-> ParsedEntityDef
ParsedEntityDef
{ parsedEntityDefComments :: [Text]
parsedEntityDefComments = LinesWithComments -> [Text]
lwcComments LinesWithComments
lwc
, parsedEntityDefEntityName :: EntityNameHS
parsedEntityDefEntityName = EntityNameHS
entNameHS
, parsedEntityDefIsSum :: Bool
parsedEntityDefIsSum = Bool
isSum
, parsedEntityDefEntityAttributes :: [Text]
parsedEntityDefEntityAttributes = [Text]
entAttribs
, parsedEntityDefFieldAttributes :: [[Token]]
parsedEntityDefFieldAttributes = [[Token]]
attribs
, parsedEntityDefExtras :: Map Text [[Text]]
parsedEntityDefExtras = Map Text [[Text]]
extras
}
where
Line
entityLine :| [Line]
fieldLines =
LinesWithComments -> NonEmpty Line
lwcLines LinesWithComments
lwc
(Text
entityName :| [Text]
entAttribs) =
Line -> NonEmpty Text
lineText Line
entityLine
(Bool
isSum, EntityNameHS
entNameHS) =
case Text -> Maybe (Char, Text)
T.uncons Text
entityName of
Just (Char
'+', Text
x) -> (Bool
True, Text -> EntityNameHS
EntityNameHS Text
x)
Maybe (Char, Text)
_ -> (Bool
False, Text -> EntityNameHS
EntityNameHS Text
entityName)
([[Token]]
attribs, Map Text [[Text]]
extras) =
[Line] -> ([[Token]], Map Text [[Text]])
parseEntityFields [Line]
fieldLines
isDocComment :: Token -> Maybe Text
Token
tok =
case Token
tok of
DocComment Text
txt -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
txt
Token
_ -> Maybe Text
forall a. Maybe a
Nothing
data =
{ LinesWithComments -> NonEmpty Line
lwcLines :: NonEmpty Line
, :: [Text]
} deriving (LinesWithComments -> LinesWithComments -> Bool
(LinesWithComments -> LinesWithComments -> Bool)
-> (LinesWithComments -> LinesWithComments -> Bool)
-> Eq LinesWithComments
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinesWithComments -> LinesWithComments -> Bool
$c/= :: LinesWithComments -> LinesWithComments -> Bool
== :: LinesWithComments -> LinesWithComments -> Bool
$c== :: LinesWithComments -> LinesWithComments -> Bool
Eq, Int -> LinesWithComments -> ShowS
[LinesWithComments] -> ShowS
LinesWithComments -> String
(Int -> LinesWithComments -> ShowS)
-> (LinesWithComments -> String)
-> ([LinesWithComments] -> ShowS)
-> Show LinesWithComments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinesWithComments] -> ShowS
$cshowList :: [LinesWithComments] -> ShowS
show :: LinesWithComments -> String
$cshow :: LinesWithComments -> String
showsPrec :: Int -> LinesWithComments -> ShowS
$cshowsPrec :: Int -> LinesWithComments -> ShowS
Show)
instance Semigroup LinesWithComments where
LinesWithComments
a <> :: LinesWithComments -> LinesWithComments -> LinesWithComments
<> LinesWithComments
b =
LinesWithComments :: NonEmpty Line -> [Text] -> LinesWithComments
LinesWithComments
{ lwcLines :: NonEmpty Line
lwcLines =
(Line -> NonEmpty Line -> NonEmpty Line)
-> NonEmpty Line -> NonEmpty Line -> NonEmpty Line
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Line -> NonEmpty Line -> NonEmpty Line
forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons (LinesWithComments -> NonEmpty Line
lwcLines LinesWithComments
b) (LinesWithComments -> NonEmpty Line
lwcLines LinesWithComments
a)
, lwcComments :: [Text]
lwcComments =
LinesWithComments -> [Text]
lwcComments LinesWithComments
a [Text] -> [Text] -> [Text]
forall a. Monoid a => a -> a -> a
`mappend` LinesWithComments -> [Text]
lwcComments LinesWithComments
b
}
appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc = LinesWithComments -> LinesWithComments -> LinesWithComments
forall a. Semigroup a => a -> a -> a
(<>)
newLine :: Line -> LinesWithComments
newLine :: Line -> LinesWithComments
newLine Line
l = NonEmpty Line -> [Text] -> LinesWithComments
LinesWithComments (Line -> NonEmpty Line
forall (f :: * -> *) a. Applicative f => a -> f a
pure Line
l) []
firstLine :: LinesWithComments -> Line
firstLine :: LinesWithComments -> Line
firstLine = NonEmpty Line -> Line
forall a. NonEmpty a -> a
NEL.head (NonEmpty Line -> Line)
-> (LinesWithComments -> NonEmpty Line)
-> LinesWithComments
-> Line
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> NonEmpty Line
lwcLines
consLine :: Line -> LinesWithComments -> LinesWithComments
consLine :: Line -> LinesWithComments -> LinesWithComments
consLine Line
l LinesWithComments
lwc = LinesWithComments
lwc { lwcLines :: NonEmpty Line
lwcLines = Line -> NonEmpty Line -> NonEmpty Line
forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons Line
l (LinesWithComments -> NonEmpty Line
lwcLines LinesWithComments
lwc) }
consComment :: Text -> LinesWithComments -> LinesWithComments
Text
l LinesWithComments
lwc = LinesWithComments
lwc { lwcComments :: [Text]
lwcComments = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: LinesWithComments -> [Text]
lwcComments LinesWithComments
lwc }
associateLines :: NonEmpty Line -> [LinesWithComments]
associateLines :: NonEmpty Line -> [LinesWithComments]
associateLines NonEmpty Line
lines =
(LinesWithComments -> [LinesWithComments] -> [LinesWithComments])
-> [LinesWithComments]
-> [LinesWithComments]
-> [LinesWithComments]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
combine [] ([LinesWithComments] -> [LinesWithComments])
-> [LinesWithComments] -> [LinesWithComments]
forall a b. (a -> b) -> a -> b
$
(Line -> [LinesWithComments] -> [LinesWithComments])
-> [LinesWithComments] -> NonEmpty Line -> [LinesWithComments]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Line -> [LinesWithComments] -> [LinesWithComments]
toLinesWithComments [] NonEmpty Line
lines
where
toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments]
toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments]
toLinesWithComments Line
line [LinesWithComments]
linesWithComments =
case [LinesWithComments]
linesWithComments of
[] ->
[Line -> LinesWithComments
newLine Line
line]
(LinesWithComments
lwc : [LinesWithComments]
lwcs) ->
case Token -> Maybe Text
isDocComment (NonEmpty Token -> Token
forall a. NonEmpty a -> a
NEL.head (Line -> NonEmpty Token
tokens Line
line)) of
Just Text
comment
| Line -> Int
lineIndent Line
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== NonEmpty Line -> Int
lowestIndent NonEmpty Line
lines ->
Text -> LinesWithComments -> LinesWithComments
consComment Text
comment LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
Maybe Text
_ ->
if Line -> Int
lineIndent Line
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Line -> Int
lineIndent (LinesWithComments -> Line
firstLine LinesWithComments
lwc)
Bool -> Bool -> Bool
&& Line -> Int
lineIndent (LinesWithComments -> Line
firstLine LinesWithComments
lwc) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= NonEmpty Line -> Int
lowestIndent NonEmpty Line
lines
then
Line -> LinesWithComments -> LinesWithComments
consLine Line
line LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
else
Line -> LinesWithComments
newLine Line
line LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
combine LinesWithComments
lwc [] =
[LinesWithComments
lwc]
combine LinesWithComments
lwc (LinesWithComments
lwc' : [LinesWithComments]
lwcs) =
let minIndent :: Int
minIndent = LinesWithComments -> Int
minimumIndentOf LinesWithComments
lwc
otherIndent :: Int
otherIndent = LinesWithComments -> Int
minimumIndentOf LinesWithComments
lwc'
in
if Int
minIndent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
otherIndent then
LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc LinesWithComments
lwc LinesWithComments
lwc' LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
else
LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: LinesWithComments
lwc' LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
minimumIndentOf :: LinesWithComments -> Int
minimumIndentOf :: LinesWithComments -> Int
minimumIndentOf = NonEmpty Line -> Int
lowestIndent (NonEmpty Line -> Int)
-> (LinesWithComments -> NonEmpty Line) -> LinesWithComments -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> NonEmpty Line
lwcLines
data UnboundEntityDef
= UnboundEntityDef
{ UnboundEntityDef -> [UnboundForeignDef]
unboundForeignDefs :: [UnboundForeignDef]
, UnboundEntityDef -> PrimarySpec
unboundPrimarySpec :: PrimarySpec
, UnboundEntityDef -> EntityDef
unboundEntityDef :: EntityDef
, UnboundEntityDef -> [UnboundFieldDef]
unboundEntityFields :: [UnboundFieldDef]
}
deriving (UnboundEntityDef -> UnboundEntityDef -> Bool
(UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> Eq UnboundEntityDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c/= :: UnboundEntityDef -> UnboundEntityDef -> Bool
== :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c== :: UnboundEntityDef -> UnboundEntityDef -> Bool
Eq, Eq UnboundEntityDef
Eq UnboundEntityDef
-> (UnboundEntityDef -> UnboundEntityDef -> Ordering)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> Bool)
-> (UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef)
-> (UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef)
-> Ord UnboundEntityDef
UnboundEntityDef -> UnboundEntityDef -> Bool
UnboundEntityDef -> UnboundEntityDef -> Ordering
UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
$cmin :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
max :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
$cmax :: UnboundEntityDef -> UnboundEntityDef -> UnboundEntityDef
>= :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c>= :: UnboundEntityDef -> UnboundEntityDef -> Bool
> :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c> :: UnboundEntityDef -> UnboundEntityDef -> Bool
<= :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c<= :: UnboundEntityDef -> UnboundEntityDef -> Bool
< :: UnboundEntityDef -> UnboundEntityDef -> Bool
$c< :: UnboundEntityDef -> UnboundEntityDef -> Bool
compare :: UnboundEntityDef -> UnboundEntityDef -> Ordering
$ccompare :: UnboundEntityDef -> UnboundEntityDef -> Ordering
$cp1Ord :: Eq UnboundEntityDef
Ord, Int -> UnboundEntityDef -> ShowS
[UnboundEntityDef] -> ShowS
UnboundEntityDef -> String
(Int -> UnboundEntityDef -> ShowS)
-> (UnboundEntityDef -> String)
-> ([UnboundEntityDef] -> ShowS)
-> Show UnboundEntityDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundEntityDef] -> ShowS
$cshowList :: [UnboundEntityDef] -> ShowS
show :: UnboundEntityDef -> String
$cshow :: UnboundEntityDef -> String
showsPrec :: Int -> UnboundEntityDef -> ShowS
$cshowsPrec :: Int -> UnboundEntityDef -> ShowS
Show, UnboundEntityDef -> Q Exp
UnboundEntityDef -> Q (TExp UnboundEntityDef)
(UnboundEntityDef -> Q Exp)
-> (UnboundEntityDef -> Q (TExp UnboundEntityDef))
-> Lift UnboundEntityDef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundEntityDef -> Q (TExp UnboundEntityDef)
$cliftTyped :: UnboundEntityDef -> Q (TExp UnboundEntityDef)
lift :: UnboundEntityDef -> Q Exp
$clift :: UnboundEntityDef -> Q Exp
Lift)
unbindEntityDef :: EntityDef -> UnboundEntityDef
unbindEntityDef :: EntityDef -> UnboundEntityDef
unbindEntityDef EntityDef
ed =
UnboundEntityDef :: [UnboundForeignDef]
-> PrimarySpec
-> EntityDef
-> [UnboundFieldDef]
-> UnboundEntityDef
UnboundEntityDef
{ unboundForeignDefs :: [UnboundForeignDef]
unboundForeignDefs =
(ForeignDef -> UnboundForeignDef)
-> [ForeignDef] -> [UnboundForeignDef]
forall a b. (a -> b) -> [a] -> [b]
map ForeignDef -> UnboundForeignDef
unbindForeignDef (EntityDef -> [ForeignDef]
entityForeigns EntityDef
ed)
, unboundPrimarySpec :: PrimarySpec
unboundPrimarySpec =
case EntityDef -> EntityIdDef
entityId EntityDef
ed of
EntityIdField FieldDef
fd ->
UnboundIdDef -> PrimarySpec
SurrogateKey (EntityNameHS -> FieldDef -> UnboundIdDef
unbindIdDef (EntityDef -> EntityNameHS
entityHaskell EntityDef
ed) FieldDef
fd)
EntityIdNaturalKey CompositeDef
cd ->
UnboundCompositeDef -> PrimarySpec
NaturalKey (CompositeDef -> UnboundCompositeDef
unbindCompositeDef CompositeDef
cd)
, unboundEntityDef :: EntityDef
unboundEntityDef =
EntityDef
ed
, unboundEntityFields :: [UnboundFieldDef]
unboundEntityFields =
(FieldDef -> UnboundFieldDef) -> [FieldDef] -> [UnboundFieldDef]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> UnboundFieldDef
unbindFieldDef (EntityDef -> [FieldDef]
entityFields EntityDef
ed)
}
getUnboundFieldDefs :: UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs :: UnboundEntityDef -> [UnboundFieldDef]
getUnboundFieldDefs = UnboundEntityDef -> [UnboundFieldDef]
unboundEntityFields
unbindCompositeDef :: CompositeDef -> UnboundCompositeDef
unbindCompositeDef :: CompositeDef -> UnboundCompositeDef
unbindCompositeDef CompositeDef
cd =
UnboundCompositeDef :: [FieldNameHS] -> [Text] -> UnboundCompositeDef
UnboundCompositeDef
{ unboundCompositeCols :: [FieldNameHS]
unboundCompositeCols =
NonEmpty FieldNameHS -> [FieldNameHS]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty FieldNameHS -> [FieldNameHS])
-> NonEmpty FieldNameHS -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ (FieldDef -> FieldNameHS)
-> NonEmpty FieldDef -> NonEmpty FieldNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameHS
fieldHaskell (CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
cd)
, unboundCompositeAttrs :: [Text]
unboundCompositeAttrs =
CompositeDef -> [Text]
compositeAttrs CompositeDef
cd
}
data UnboundFieldDef
= UnboundFieldDef
{ UnboundFieldDef -> FieldNameHS
unboundFieldNameHS :: FieldNameHS
, UnboundFieldDef -> FieldNameDB
unboundFieldNameDB :: FieldNameDB
, UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs :: [FieldAttr]
, UnboundFieldDef -> Bool
unboundFieldStrict :: Bool
, UnboundFieldDef -> FieldType
unboundFieldType :: FieldType
, UnboundFieldDef -> FieldCascade
unboundFieldCascade :: FieldCascade
, UnboundFieldDef -> Maybe Text
unboundFieldGenerated :: Maybe Text
, :: Maybe Text
}
deriving (UnboundFieldDef -> UnboundFieldDef -> Bool
(UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> Eq UnboundFieldDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c/= :: UnboundFieldDef -> UnboundFieldDef -> Bool
== :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c== :: UnboundFieldDef -> UnboundFieldDef -> Bool
Eq, Eq UnboundFieldDef
Eq UnboundFieldDef
-> (UnboundFieldDef -> UnboundFieldDef -> Ordering)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> Bool)
-> (UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef)
-> (UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef)
-> Ord UnboundFieldDef
UnboundFieldDef -> UnboundFieldDef -> Bool
UnboundFieldDef -> UnboundFieldDef -> Ordering
UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
$cmin :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
max :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
$cmax :: UnboundFieldDef -> UnboundFieldDef -> UnboundFieldDef
>= :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c>= :: UnboundFieldDef -> UnboundFieldDef -> Bool
> :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c> :: UnboundFieldDef -> UnboundFieldDef -> Bool
<= :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c<= :: UnboundFieldDef -> UnboundFieldDef -> Bool
< :: UnboundFieldDef -> UnboundFieldDef -> Bool
$c< :: UnboundFieldDef -> UnboundFieldDef -> Bool
compare :: UnboundFieldDef -> UnboundFieldDef -> Ordering
$ccompare :: UnboundFieldDef -> UnboundFieldDef -> Ordering
$cp1Ord :: Eq UnboundFieldDef
Ord, Int -> UnboundFieldDef -> ShowS
[UnboundFieldDef] -> ShowS
UnboundFieldDef -> String
(Int -> UnboundFieldDef -> ShowS)
-> (UnboundFieldDef -> String)
-> ([UnboundFieldDef] -> ShowS)
-> Show UnboundFieldDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundFieldDef] -> ShowS
$cshowList :: [UnboundFieldDef] -> ShowS
show :: UnboundFieldDef -> String
$cshow :: UnboundFieldDef -> String
showsPrec :: Int -> UnboundFieldDef -> ShowS
$cshowsPrec :: Int -> UnboundFieldDef -> ShowS
Show, UnboundFieldDef -> Q Exp
UnboundFieldDef -> Q (TExp UnboundFieldDef)
(UnboundFieldDef -> Q Exp)
-> (UnboundFieldDef -> Q (TExp UnboundFieldDef))
-> Lift UnboundFieldDef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundFieldDef -> Q (TExp UnboundFieldDef)
$cliftTyped :: UnboundFieldDef -> Q (TExp UnboundFieldDef)
lift :: UnboundFieldDef -> Q Exp
$clift :: UnboundFieldDef -> Q Exp
Lift)
unbindFieldDef :: FieldDef -> UnboundFieldDef
unbindFieldDef :: FieldDef -> UnboundFieldDef
unbindFieldDef FieldDef
fd = UnboundFieldDef :: FieldNameHS
-> FieldNameDB
-> [FieldAttr]
-> Bool
-> FieldType
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> UnboundFieldDef
UnboundFieldDef
{ unboundFieldNameHS :: FieldNameHS
unboundFieldNameHS =
FieldDef -> FieldNameHS
fieldHaskell FieldDef
fd
, unboundFieldNameDB :: FieldNameDB
unboundFieldNameDB =
FieldDef -> FieldNameDB
fieldDB FieldDef
fd
, unboundFieldAttrs :: [FieldAttr]
unboundFieldAttrs =
FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
, unboundFieldType :: FieldType
unboundFieldType =
FieldDef -> FieldType
fieldType FieldDef
fd
, unboundFieldStrict :: Bool
unboundFieldStrict =
FieldDef -> Bool
fieldStrict FieldDef
fd
, unboundFieldCascade :: FieldCascade
unboundFieldCascade =
FieldDef -> FieldCascade
fieldCascade FieldDef
fd
, unboundFieldComments :: Maybe Text
unboundFieldComments =
FieldDef -> Maybe Text
fieldComments FieldDef
fd
, unboundFieldGenerated :: Maybe Text
unboundFieldGenerated =
FieldDef -> Maybe Text
fieldGenerated FieldDef
fd
}
isUnboundFieldNullable :: UnboundFieldDef -> IsNullable
isUnboundFieldNullable :: UnboundFieldDef -> IsNullable
isUnboundFieldNullable =
[FieldAttr] -> IsNullable
fieldAttrsContainsNullable ([FieldAttr] -> IsNullable)
-> (UnboundFieldDef -> [FieldAttr])
-> UnboundFieldDef
-> IsNullable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs
data PrimarySpec
= NaturalKey UnboundCompositeDef
| SurrogateKey UnboundIdDef
| DefaultKey FieldNameDB
deriving (PrimarySpec -> PrimarySpec -> Bool
(PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool) -> Eq PrimarySpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrimarySpec -> PrimarySpec -> Bool
$c/= :: PrimarySpec -> PrimarySpec -> Bool
== :: PrimarySpec -> PrimarySpec -> Bool
$c== :: PrimarySpec -> PrimarySpec -> Bool
Eq, Eq PrimarySpec
Eq PrimarySpec
-> (PrimarySpec -> PrimarySpec -> Ordering)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> Bool)
-> (PrimarySpec -> PrimarySpec -> PrimarySpec)
-> (PrimarySpec -> PrimarySpec -> PrimarySpec)
-> Ord PrimarySpec
PrimarySpec -> PrimarySpec -> Bool
PrimarySpec -> PrimarySpec -> Ordering
PrimarySpec -> PrimarySpec -> PrimarySpec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PrimarySpec -> PrimarySpec -> PrimarySpec
$cmin :: PrimarySpec -> PrimarySpec -> PrimarySpec
max :: PrimarySpec -> PrimarySpec -> PrimarySpec
$cmax :: PrimarySpec -> PrimarySpec -> PrimarySpec
>= :: PrimarySpec -> PrimarySpec -> Bool
$c>= :: PrimarySpec -> PrimarySpec -> Bool
> :: PrimarySpec -> PrimarySpec -> Bool
$c> :: PrimarySpec -> PrimarySpec -> Bool
<= :: PrimarySpec -> PrimarySpec -> Bool
$c<= :: PrimarySpec -> PrimarySpec -> Bool
< :: PrimarySpec -> PrimarySpec -> Bool
$c< :: PrimarySpec -> PrimarySpec -> Bool
compare :: PrimarySpec -> PrimarySpec -> Ordering
$ccompare :: PrimarySpec -> PrimarySpec -> Ordering
$cp1Ord :: Eq PrimarySpec
Ord, Int -> PrimarySpec -> ShowS
[PrimarySpec] -> ShowS
PrimarySpec -> String
(Int -> PrimarySpec -> ShowS)
-> (PrimarySpec -> String)
-> ([PrimarySpec] -> ShowS)
-> Show PrimarySpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrimarySpec] -> ShowS
$cshowList :: [PrimarySpec] -> ShowS
show :: PrimarySpec -> String
$cshow :: PrimarySpec -> String
showsPrec :: Int -> PrimarySpec -> ShowS
$cshowsPrec :: Int -> PrimarySpec -> ShowS
Show, PrimarySpec -> Q Exp
PrimarySpec -> Q (TExp PrimarySpec)
(PrimarySpec -> Q Exp)
-> (PrimarySpec -> Q (TExp PrimarySpec)) -> Lift PrimarySpec
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: PrimarySpec -> Q (TExp PrimarySpec)
$cliftTyped :: PrimarySpec -> Q (TExp PrimarySpec)
lift :: PrimarySpec -> Q Exp
$clift :: PrimarySpec -> Q Exp
Lift)
mkUnboundEntityDef
:: PersistSettings
-> ParsedEntityDef
-> UnboundEntityDef
mkUnboundEntityDef :: PersistSettings -> ParsedEntityDef -> UnboundEntityDef
mkUnboundEntityDef PersistSettings
ps ParsedEntityDef
parsedEntDef =
UnboundEntityDef :: [UnboundForeignDef]
-> PrimarySpec
-> EntityDef
-> [UnboundFieldDef]
-> UnboundEntityDef
UnboundEntityDef
{ unboundForeignDefs :: [UnboundForeignDef]
unboundForeignDefs =
EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList EntityConstraintDefs
entityConstraintDefs
, unboundPrimarySpec :: PrimarySpec
unboundPrimarySpec =
case (Maybe UnboundIdDef
idField, Maybe UnboundCompositeDef
primaryComposite) of
(Just {}, Just {}) ->
String -> PrimarySpec
forall a. HasCallStack => String -> a
error String
"Specified both an ID field and a Primary field"
(Just UnboundIdDef
a, Maybe UnboundCompositeDef
Nothing) ->
if UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
a Maybe FieldType -> Maybe FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just (EntityNameHS -> FieldType
mkKeyConType (UnboundIdDef -> EntityNameHS
unboundIdEntityName UnboundIdDef
a))
then
FieldNameDB -> PrimarySpec
DefaultKey (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps)
else
UnboundIdDef -> PrimarySpec
SurrogateKey UnboundIdDef
a
(Maybe UnboundIdDef
Nothing, Just UnboundCompositeDef
a) ->
UnboundCompositeDef -> PrimarySpec
NaturalKey UnboundCompositeDef
a
(Maybe UnboundIdDef
Nothing, Maybe UnboundCompositeDef
Nothing) ->
FieldNameDB -> PrimarySpec
DefaultKey (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps)
, unboundEntityFields :: [UnboundFieldDef]
unboundEntityFields =
[UnboundFieldDef]
cols
, unboundEntityDef :: EntityDef
unboundEntityDef =
EntityDef :: EntityNameHS
-> EntityNameDB
-> EntityIdDef
-> [Text]
-> [FieldDef]
-> [UniqueDef]
-> [ForeignDef]
-> [Text]
-> Map Text [[Text]]
-> Bool
-> Maybe Text
-> EntityDef
EntityDef
{ entityHaskell :: EntityNameHS
entityHaskell = EntityNameHS
entNameHS
, entityDB :: EntityNameDB
entityDB = EntityNameDB
entNameDB
, entityId :: EntityIdDef
entityId =
FieldDef -> EntityIdDef
EntityIdField (FieldDef -> EntityIdDef) -> FieldDef -> EntityIdDef
forall a b. (a -> b) -> a -> b
$
FieldDef
-> (UnboundIdDef -> FieldDef) -> Maybe UnboundIdDef -> FieldDef
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldDef
autoIdField (FieldNameDB -> EntityNameHS -> UnboundIdDef -> FieldDef
unboundIdDefToFieldDef (PersistSettings -> FieldNameDB
defaultIdName PersistSettings
ps) EntityNameHS
entNameHS) Maybe UnboundIdDef
idField
, entityAttrs :: [Text]
entityAttrs =
ParsedEntityDef -> [Text]
parsedEntityDefEntityAttributes ParsedEntityDef
parsedEntDef
, entityFields :: [FieldDef]
entityFields =
[]
, entityUniques :: [UniqueDef]
entityUniques = EntityConstraintDefs -> [UniqueDef]
entityConstraintDefsUniquesList EntityConstraintDefs
entityConstraintDefs
, entityForeigns :: [ForeignDef]
entityForeigns = []
, entityDerives :: [Text]
entityDerives = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ ([Text] -> Maybe [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Text] -> Maybe [Text]
takeDerives [[Text]]
textAttribs
, entityExtra :: Map Text [[Text]]
entityExtra = ParsedEntityDef -> Map Text [[Text]]
parsedEntityDefExtras ParsedEntityDef
parsedEntDef
, entitySum :: Bool
entitySum = ParsedEntityDef -> Bool
parsedEntityDefIsSum ParsedEntityDef
parsedEntDef
, entityComments :: Maybe Text
entityComments =
case ParsedEntityDef -> [Text]
parsedEntityDefComments ParsedEntityDef
parsedEntDef of
[] -> Maybe Text
forall a. Maybe a
Nothing
[Text]
comments -> Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
T.unlines [Text]
comments)
}
}
where
(EntityNameHS
entNameHS, EntityNameDB
entNameDB) =
PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)
entityNamesFromParsedDef PersistSettings
ps ParsedEntityDef
parsedEntDef
attribs :: [[Token]]
attribs =
ParsedEntityDef -> [[Token]]
parsedEntityDefFieldAttributes ParsedEntityDef
parsedEntDef
textAttribs :: [[Text]]
textAttribs :: [[Text]]
textAttribs =
(Token -> Text) -> [Token] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Text
tokenText ([Token] -> [Text]) -> [[Token]] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Token]]
attribs
entityConstraintDefs :: EntityConstraintDefs
entityConstraintDefs =
([Text] -> EntityConstraintDefs)
-> [[Text]] -> EntityConstraintDefs
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (EntityConstraintDefs
-> (NonEmpty Text -> EntityConstraintDefs)
-> Maybe (NonEmpty Text)
-> EntityConstraintDefs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EntityConstraintDefs
forall a. Monoid a => a
mempty (PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> NonEmpty Text
-> EntityConstraintDefs
takeConstraint PersistSettings
ps EntityNameHS
entNameHS [UnboundFieldDef]
cols) (Maybe (NonEmpty Text) -> EntityConstraintDefs)
-> ([Text] -> Maybe (NonEmpty Text))
-> [Text]
-> EntityConstraintDefs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty) [[Text]]
textAttribs
idField :: Maybe UnboundIdDef
idField =
case EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField EntityConstraintDefs
entityConstraintDefs of
SetOnceAtMost UnboundIdDef
SetMoreThanOnce -> String -> Maybe UnboundIdDef
forall a. HasCallStack => String -> a
error String
"expected only one Id declaration per entity"
SetOnce UnboundIdDef
a -> UnboundIdDef -> Maybe UnboundIdDef
forall a. a -> Maybe a
Just UnboundIdDef
a
SetOnceAtMost UnboundIdDef
NotSet -> Maybe UnboundIdDef
forall a. Maybe a
Nothing
primaryComposite :: Maybe UnboundCompositeDef
primaryComposite =
case EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite EntityConstraintDefs
entityConstraintDefs of
SetOnceAtMost UnboundCompositeDef
SetMoreThanOnce -> String -> Maybe UnboundCompositeDef
forall a. HasCallStack => String -> a
error String
"expected only one Primary declaration per entity"
SetOnce UnboundCompositeDef
a -> UnboundCompositeDef -> Maybe UnboundCompositeDef
forall a. a -> Maybe a
Just UnboundCompositeDef
a
SetOnceAtMost UnboundCompositeDef
NotSet -> Maybe UnboundCompositeDef
forall a. Maybe a
Nothing
cols :: [UnboundFieldDef]
cols :: [UnboundFieldDef]
cols = [UnboundFieldDef] -> [UnboundFieldDef]
forall a. [a] -> [a]
reverse ([UnboundFieldDef] -> [UnboundFieldDef])
-> ([[Token]] -> [UnboundFieldDef])
-> [[Token]]
-> [UnboundFieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UnboundFieldDef], [Text]) -> [UnboundFieldDef]
forall a b. (a, b) -> a
fst (([UnboundFieldDef], [Text]) -> [UnboundFieldDef])
-> ([[Token]] -> ([UnboundFieldDef], [Text]))
-> [[Token]]
-> [UnboundFieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Token]
-> ([UnboundFieldDef], [Text]) -> ([UnboundFieldDef], [Text]))
-> ([UnboundFieldDef], [Text])
-> [[Token]]
-> ([UnboundFieldDef], [Text])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PersistSettings
-> [Token]
-> ([UnboundFieldDef], [Text])
-> ([UnboundFieldDef], [Text])
associateComments PersistSettings
ps) ([], []) ([[Token]] -> [UnboundFieldDef]) -> [[Token]] -> [UnboundFieldDef]
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [[Token]]
forall a. [a] -> [a]
reverse [[Token]]
attribs
autoIdField :: FieldDef
autoIdField :: FieldDef
autoIdField =
PersistSettings -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField PersistSettings
ps EntityNameHS
entNameHS SqlType
idSqlType
idSqlType :: SqlType
idSqlType :: SqlType
idSqlType =
SqlType
-> (UnboundCompositeDef -> SqlType)
-> Maybe UnboundCompositeDef
-> SqlType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SqlType
SqlInt64 (SqlType -> UnboundCompositeDef -> SqlType
forall a b. a -> b -> a
const (SqlType -> UnboundCompositeDef -> SqlType)
-> SqlType -> UnboundCompositeDef -> SqlType
forall a b. (a -> b) -> a -> b
$ Text -> SqlType
SqlOther Text
"Primary Key") Maybe UnboundCompositeDef
primaryComposite
defaultIdName :: PersistSettings -> FieldNameDB
defaultIdName :: PersistSettings -> FieldNameDB
defaultIdName = Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB)
-> (PersistSettings -> Text) -> PersistSettings -> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistSettings -> Text
psIdName
unboundIdDefToFieldDef
:: FieldNameDB
-> EntityNameHS
-> UnboundIdDef
-> FieldDef
unboundIdDefToFieldDef :: FieldNameDB -> EntityNameHS -> UnboundIdDef -> FieldDef
unboundIdDefToFieldDef FieldNameDB
dbField EntityNameHS
entNameHS UnboundIdDef
uid =
FieldDef :: FieldNameHS
-> FieldNameDB
-> FieldType
-> SqlType
-> [FieldAttr]
-> Bool
-> ReferenceDef
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> Bool
-> FieldDef
FieldDef
{ fieldHaskell :: FieldNameHS
fieldHaskell =
Text -> FieldNameHS
FieldNameHS Text
"Id"
, fieldDB :: FieldNameDB
fieldDB =
FieldNameDB -> [FieldAttr] -> FieldNameDB
getSqlNameOr FieldNameDB
dbField (UnboundIdDef -> [FieldAttr]
unboundIdAttrs UnboundIdDef
uid)
, fieldType :: FieldType
fieldType =
FieldType -> Maybe FieldType -> FieldType
forall a. a -> Maybe a -> a
fromMaybe (EntityNameHS -> FieldType
mkKeyConType EntityNameHS
entNameHS) (Maybe FieldType -> FieldType) -> Maybe FieldType -> FieldType
forall a b. (a -> b) -> a -> b
$ UnboundIdDef -> Maybe FieldType
unboundIdType UnboundIdDef
uid
, fieldSqlType :: SqlType
fieldSqlType =
Text -> SqlType
SqlOther Text
"SqlType unset for Id"
, fieldStrict :: Bool
fieldStrict =
Bool
False
, fieldReference :: ReferenceDef
fieldReference =
EntityNameHS -> ReferenceDef
ForeignRef EntityNameHS
entNameHS
, fieldAttrs :: [FieldAttr]
fieldAttrs =
UnboundIdDef -> [FieldAttr]
unboundIdAttrs UnboundIdDef
uid
, fieldComments :: Maybe Text
fieldComments =
Maybe Text
forall a. Maybe a
Nothing
, fieldCascade :: FieldCascade
fieldCascade = UnboundIdDef -> FieldCascade
unboundIdCascade UnboundIdDef
uid
, fieldGenerated :: Maybe Text
fieldGenerated = Maybe Text
forall a. Maybe a
Nothing
, fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn = Bool
True
}
mkKeyConType :: EntityNameHS -> FieldType
mkKeyConType :: EntityNameHS -> FieldType
mkKeyConType EntityNameHS
entNameHs =
Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing (EntityNameHS -> Text
keyConName EntityNameHS
entNameHs)
unbindIdDef :: EntityNameHS -> FieldDef -> UnboundIdDef
unbindIdDef :: EntityNameHS -> FieldDef -> UnboundIdDef
unbindIdDef EntityNameHS
entityName FieldDef
fd =
UnboundIdDef :: EntityNameHS
-> FieldNameDB
-> [FieldAttr]
-> FieldCascade
-> Maybe FieldType
-> UnboundIdDef
UnboundIdDef
{ unboundIdEntityName :: EntityNameHS
unboundIdEntityName =
EntityNameHS
entityName
, unboundIdDBName :: FieldNameDB
unboundIdDBName =
FieldDef -> FieldNameDB
fieldDB FieldDef
fd
, unboundIdAttrs :: [FieldAttr]
unboundIdAttrs =
FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
, unboundIdCascade :: FieldCascade
unboundIdCascade =
FieldDef -> FieldCascade
fieldCascade FieldDef
fd
, unboundIdType :: Maybe FieldType
unboundIdType =
FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just (FieldType -> Maybe FieldType) -> FieldType -> Maybe FieldType
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldType
fieldType FieldDef
fd
}
associateComments
:: PersistSettings
-> [Token]
-> ([UnboundFieldDef], [Text])
-> ([UnboundFieldDef], [Text])
PersistSettings
ps [Token]
x (![UnboundFieldDef]
acc, ![Text]
comments) =
case [Token] -> Maybe Token
forall a. [a] -> Maybe a
listToMaybe [Token]
x of
Just (DocComment Text
comment) ->
([UnboundFieldDef]
acc, Text
comment Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
comments)
Maybe Token
_ ->
case ([Text] -> UnboundFieldDef -> UnboundFieldDef
setFieldComments ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
comments) (UnboundFieldDef -> UnboundFieldDef)
-> Maybe UnboundFieldDef -> Maybe UnboundFieldDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeColsEx PersistSettings
ps (Token -> Text
tokenText (Token -> Text) -> [Token] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token]
x)) of
Just UnboundFieldDef
sm ->
(UnboundFieldDef
sm UnboundFieldDef -> [UnboundFieldDef] -> [UnboundFieldDef]
forall a. a -> [a] -> [a]
: [UnboundFieldDef]
acc, [])
Maybe UnboundFieldDef
Nothing ->
([UnboundFieldDef]
acc, [])
setFieldComments :: [Text] -> UnboundFieldDef -> UnboundFieldDef
[Text]
xs UnboundFieldDef
fld =
case [Text]
xs of
[] -> UnboundFieldDef
fld
[Text]
_ -> UnboundFieldDef
fld { unboundFieldComments :: Maybe Text
unboundFieldComments = Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
T.unlines [Text]
xs) }
mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField PersistSettings
ps =
FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField' (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps)
mkAutoIdField' :: FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField' :: FieldNameDB -> EntityNameHS -> SqlType -> FieldDef
mkAutoIdField' FieldNameDB
dbName EntityNameHS
entName SqlType
idSqlType =
FieldDef :: FieldNameHS
-> FieldNameDB
-> FieldType
-> SqlType
-> [FieldAttr]
-> Bool
-> ReferenceDef
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> Bool
-> FieldDef
FieldDef
{ fieldHaskell :: FieldNameHS
fieldHaskell = Text -> FieldNameHS
FieldNameHS Text
"Id"
, fieldDB :: FieldNameDB
fieldDB = FieldNameDB
dbName
, fieldType :: FieldType
fieldType = Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing (Text -> FieldType) -> Text -> FieldType
forall a b. (a -> b) -> a -> b
$ EntityNameHS -> Text
keyConName EntityNameHS
entName
, fieldSqlType :: SqlType
fieldSqlType = SqlType
idSqlType
, fieldReference :: ReferenceDef
fieldReference =
ReferenceDef
NoReference
, fieldAttrs :: [FieldAttr]
fieldAttrs = []
, fieldStrict :: Bool
fieldStrict = Bool
True
, fieldComments :: Maybe Text
fieldComments = Maybe Text
forall a. Maybe a
Nothing
, fieldCascade :: FieldCascade
fieldCascade = FieldCascade
noCascade
, fieldGenerated :: Maybe Text
fieldGenerated = Maybe Text
forall a. Maybe a
Nothing
, fieldIsImplicitIdColumn :: Bool
fieldIsImplicitIdColumn = Bool
True
}
keyConName :: EntityNameHS -> Text
keyConName :: EntityNameHS -> Text
keyConName EntityNameHS
entName = EntityNameHS -> Text
unEntityNameHS EntityNameHS
entName Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"Id"
parseEntityFields
:: [Line]
-> ([[Token]], M.Map Text [ExtraLine])
parseEntityFields :: [Line] -> ([[Token]], Map Text [[Text]])
parseEntityFields [Line]
lns =
case [Line]
lns of
[] -> ([], Map Text [[Text]]
forall k a. Map k a
M.empty)
(Line
line : [Line]
rest) ->
case NonEmpty Token -> [Token]
forall a. NonEmpty a -> [a]
NEL.toList (Line -> NonEmpty Token
tokens Line
line) of
[Token Text
name]
| Text -> Bool
isCapitalizedText Text
name ->
let ([Line]
children, [Line]
rest') = (Line -> Bool) -> [Line] -> ([Line], [Line])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Line -> Int
lineIndent Line
line) (Int -> Bool) -> (Line -> Int) -> Line -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Int
lineIndent) [Line]
rest
([[Token]]
x, Map Text [[Text]]
y) = [Line] -> ([[Token]], Map Text [[Text]])
parseEntityFields [Line]
rest'
in ([[Token]]
x, Text -> [[Text]] -> Map Text [[Text]] -> Map Text [[Text]]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty Text -> [Text])
-> (Line -> NonEmpty Text) -> Line -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> NonEmpty Text
lineText (Line -> [Text]) -> [Line] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Line]
children) Map Text [[Text]]
y)
[Token]
ts ->
let ([[Token]]
x, Map Text [[Text]]
y) = [Line] -> ([[Token]], Map Text [[Text]])
parseEntityFields [Line]
rest
in ([Token]
ts[Token] -> [[Token]] -> [[Token]]
forall a. a -> [a] -> [a]
:[[Token]]
x, Map Text [[Text]]
y)
isCapitalizedText :: Text -> Bool
isCapitalizedText :: Text -> Bool
isCapitalizedText Text
t =
Bool -> Bool
not (Text -> Bool
T.null Text
t) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head Text
t)
takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeColsEx =
(Text -> String -> Maybe UnboundFieldDef)
-> PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeCols
(\Text
ft String
perr -> String -> Maybe UnboundFieldDef
forall a. HasCallStack => String -> a
error (String -> Maybe UnboundFieldDef)
-> String -> Maybe UnboundFieldDef
forall a b. (a -> b) -> a -> b
$ String
"Invalid field type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
ft String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
perr)
takeCols
:: (Text -> String -> Maybe UnboundFieldDef)
-> PersistSettings
-> [Text]
-> Maybe UnboundFieldDef
takeCols :: (Text -> String -> Maybe UnboundFieldDef)
-> PersistSettings -> [Text] -> Maybe UnboundFieldDef
takeCols Text -> String -> Maybe UnboundFieldDef
_ PersistSettings
_ (Text
"deriving":[Text]
_) = Maybe UnboundFieldDef
forall a. Maybe a
Nothing
takeCols Text -> String -> Maybe UnboundFieldDef
onErr PersistSettings
ps (Text
n':Text
typ:[Text]
rest')
| Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isLower (Text -> Char
T.head Text
n) =
case Text -> Either String FieldType
parseFieldType Text
typ of
Left String
err -> Text -> String -> Maybe UnboundFieldDef
onErr Text
typ String
err
Right FieldType
ft -> UnboundFieldDef -> Maybe UnboundFieldDef
forall a. a -> Maybe a
Just UnboundFieldDef :: FieldNameHS
-> FieldNameDB
-> [FieldAttr]
-> Bool
-> FieldType
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> UnboundFieldDef
UnboundFieldDef
{ unboundFieldNameHS :: FieldNameHS
unboundFieldNameHS =
Text -> FieldNameHS
FieldNameHS Text
n
, unboundFieldNameDB :: FieldNameDB
unboundFieldNameDB =
PersistSettings -> Text -> [FieldAttr] -> FieldNameDB
getDbName' PersistSettings
ps Text
n [FieldAttr]
fieldAttrs_
, unboundFieldType :: FieldType
unboundFieldType =
FieldType
ft
, unboundFieldAttrs :: [FieldAttr]
unboundFieldAttrs =
[FieldAttr]
fieldAttrs_
, unboundFieldStrict :: Bool
unboundFieldStrict =
Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Bool
psStrictFields PersistSettings
ps) Maybe Bool
mstrict
, unboundFieldComments :: Maybe Text
unboundFieldComments =
Maybe Text
forall a. Maybe a
Nothing
, unboundFieldCascade :: FieldCascade
unboundFieldCascade =
FieldCascade
cascade_
, unboundFieldGenerated :: Maybe Text
unboundFieldGenerated =
Maybe Text
generated_
}
where
fieldAttrs_ :: [FieldAttr]
fieldAttrs_ = [Text] -> [FieldAttr]
parseFieldAttrs [Text]
attrs_
generated_ :: Maybe Text
generated_ = [Text] -> Maybe Text
parseGenerated [Text]
attrs_
(FieldCascade
cascade_, [Text]
attrs_) = [Text] -> (FieldCascade, [Text])
parseCascade [Text]
rest'
(Maybe Bool
mstrict, Text
n)
| Just Text
x <- Text -> Text -> Maybe Text
T.stripPrefix Text
"!" Text
n' = (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True, Text
x)
| Just Text
x <- Text -> Text -> Maybe Text
T.stripPrefix Text
"~" Text
n' = (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False, Text
x)
| Bool
otherwise = (Maybe Bool
forall a. Maybe a
Nothing, Text
n')
takeCols Text -> String -> Maybe UnboundFieldDef
_ PersistSettings
_ [Text]
_ = Maybe UnboundFieldDef
forall a. Maybe a
Nothing
parseGenerated :: [Text] -> Maybe Text
parseGenerated :: [Text] -> Maybe Text
parseGenerated = (Maybe Text -> Text -> Maybe Text)
-> Maybe Text -> [Text] -> Maybe Text
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Maybe Text
acc Text
x -> Maybe Text
acc Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Text -> Maybe Text
T.stripPrefix Text
"generated=" Text
x) Maybe Text
forall a. Maybe a
Nothing
getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n =
Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
n) (Maybe Text -> Text) -> ([Text] -> Maybe Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text)
-> ([Text] -> [Text]) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe Text) -> [Text] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Text -> Maybe Text
T.stripPrefix Text
"sql=")
getDbName' :: PersistSettings -> Text -> [FieldAttr] -> FieldNameDB
getDbName' :: PersistSettings -> Text -> [FieldAttr] -> FieldNameDB
getDbName' PersistSettings
ps Text
n =
FieldNameDB -> [FieldAttr] -> FieldNameDB
getSqlNameOr (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
n)
getSqlNameOr
:: FieldNameDB
-> [FieldAttr]
-> FieldNameDB
getSqlNameOr :: FieldNameDB -> [FieldAttr] -> FieldNameDB
getSqlNameOr FieldNameDB
def =
FieldNameDB -> (Text -> FieldNameDB) -> Maybe Text -> FieldNameDB
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldNameDB
def Text -> FieldNameDB
FieldNameDB (Maybe Text -> FieldNameDB)
-> ([FieldAttr] -> Maybe Text) -> [FieldAttr] -> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldAttr] -> Maybe Text
findAttrSql
where
findAttrSql :: [FieldAttr] -> Maybe Text
findAttrSql =
[Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text)
-> ([FieldAttr] -> [Text]) -> [FieldAttr] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldAttr -> Maybe Text) -> [FieldAttr] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldAttr -> Maybe Text
isAttrSql
isAttrSql :: FieldAttr -> Maybe Text
isAttrSql FieldAttr
attr =
case FieldAttr
attr of
FieldAttrSql Text
t ->
Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
FieldAttr
_ ->
Maybe Text
forall a. Maybe a
Nothing
data SetOnceAtMost a
= NotSet
| SetOnce a
| SetMoreThanOnce
instance Semigroup (SetOnceAtMost a) where
SetOnceAtMost a
a <> :: SetOnceAtMost a -> SetOnceAtMost a -> SetOnceAtMost a
<> SetOnceAtMost a
b =
case (SetOnceAtMost a
a, SetOnceAtMost a
b) of
(SetOnceAtMost a
_, SetOnceAtMost a
NotSet) -> SetOnceAtMost a
a
(SetOnceAtMost a
NotSet, SetOnceAtMost a
_) -> SetOnceAtMost a
b
(SetOnce a
_, SetOnce a
_) -> SetOnceAtMost a
forall a. SetOnceAtMost a
SetMoreThanOnce
(SetOnceAtMost a, SetOnceAtMost a)
_ -> SetOnceAtMost a
a
instance Monoid (SetOnceAtMost a) where
mempty :: SetOnceAtMost a
mempty =
SetOnceAtMost a
forall a. SetOnceAtMost a
NotSet
data EntityConstraintDefs = EntityConstraintDefs
{ EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef
, EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef
, EntityConstraintDefs -> Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
, EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef)
}
instance Semigroup EntityConstraintDefs where
EntityConstraintDefs
a <> :: EntityConstraintDefs
-> EntityConstraintDefs -> EntityConstraintDefs
<> EntityConstraintDefs
b =
EntityConstraintDefs :: SetOnceAtMost UnboundIdDef
-> SetOnceAtMost UnboundCompositeDef
-> Maybe (NonEmpty UniqueDef)
-> Maybe (NonEmpty UnboundForeignDef)
-> EntityConstraintDefs
EntityConstraintDefs
{ entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField = EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField EntityConstraintDefs
a SetOnceAtMost UnboundIdDef
-> SetOnceAtMost UnboundIdDef -> SetOnceAtMost UnboundIdDef
forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField EntityConstraintDefs
b
, entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite = EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite EntityConstraintDefs
a SetOnceAtMost UnboundCompositeDef
-> SetOnceAtMost UnboundCompositeDef
-> SetOnceAtMost UnboundCompositeDef
forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite EntityConstraintDefs
b
, entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques = EntityConstraintDefs -> Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques EntityConstraintDefs
a Maybe (NonEmpty UniqueDef)
-> Maybe (NonEmpty UniqueDef) -> Maybe (NonEmpty UniqueDef)
forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques EntityConstraintDefs
b
, entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns = EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns EntityConstraintDefs
a Maybe (NonEmpty UnboundForeignDef)
-> Maybe (NonEmpty UnboundForeignDef)
-> Maybe (NonEmpty UnboundForeignDef)
forall a. Semigroup a => a -> a -> a
<> EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns EntityConstraintDefs
b
}
instance Monoid EntityConstraintDefs where
mempty :: EntityConstraintDefs
mempty =
SetOnceAtMost UnboundIdDef
-> SetOnceAtMost UnboundCompositeDef
-> Maybe (NonEmpty UniqueDef)
-> Maybe (NonEmpty UnboundForeignDef)
-> EntityConstraintDefs
EntityConstraintDefs SetOnceAtMost UnboundIdDef
forall a. Monoid a => a
mempty SetOnceAtMost UnboundCompositeDef
forall a. Monoid a => a
mempty Maybe (NonEmpty UniqueDef)
forall a. Maybe a
Nothing Maybe (NonEmpty UnboundForeignDef)
forall a. Maybe a
Nothing
entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef]
entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef]
entityConstraintDefsUniquesList = (NonEmpty UniqueDef -> [UniqueDef])
-> Maybe (NonEmpty UniqueDef) -> [UniqueDef]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NonEmpty UniqueDef -> [UniqueDef]
forall a. NonEmpty a -> [a]
NEL.toList (Maybe (NonEmpty UniqueDef) -> [UniqueDef])
-> (EntityConstraintDefs -> Maybe (NonEmpty UniqueDef))
-> EntityConstraintDefs
-> [UniqueDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityConstraintDefs -> Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques
entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef]
entityConstraintDefsForeignsList = (NonEmpty UnboundForeignDef -> [UnboundForeignDef])
-> Maybe (NonEmpty UnboundForeignDef) -> [UnboundForeignDef]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NonEmpty UnboundForeignDef -> [UnboundForeignDef]
forall a. NonEmpty a -> [a]
NEL.toList (Maybe (NonEmpty UnboundForeignDef) -> [UnboundForeignDef])
-> (EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef))
-> EntityConstraintDefs
-> [UnboundForeignDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityConstraintDefs -> Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns
takeConstraint
:: PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> NonEmpty Text
-> EntityConstraintDefs
takeConstraint :: PersistSettings
-> EntityNameHS
-> [UnboundFieldDef]
-> NonEmpty Text
-> EntityConstraintDefs
takeConstraint PersistSettings
ps EntityNameHS
entityName [UnboundFieldDef]
defs (Text
n :| [Text]
rest) =
case Text
n of
Text
"Unique" ->
EntityConstraintDefs
forall a. Monoid a => a
mempty
{ entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques =
UniqueDef -> NonEmpty UniqueDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UniqueDef -> NonEmpty UniqueDef)
-> Maybe UniqueDef -> Maybe (NonEmpty UniqueDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings
-> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef
takeUniq PersistSettings
ps (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName) [UnboundFieldDef]
defs [Text]
rest
}
Text
"Foreign" ->
EntityConstraintDefs
forall a. Monoid a => a
mempty
{ entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef)
entityConstraintDefsForeigns =
NonEmpty UnboundForeignDef -> Maybe (NonEmpty UnboundForeignDef)
forall a. a -> Maybe a
Just (NonEmpty UnboundForeignDef -> Maybe (NonEmpty UnboundForeignDef))
-> NonEmpty UnboundForeignDef -> Maybe (NonEmpty UnboundForeignDef)
forall a b. (a -> b) -> a -> b
$ UnboundForeignDef -> NonEmpty UnboundForeignDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PersistSettings -> EntityNameHS -> [Text] -> UnboundForeignDef
takeForeign PersistSettings
ps EntityNameHS
entityName [Text]
rest)
}
Text
"Primary" ->
EntityConstraintDefs
forall a. Monoid a => a
mempty
{ entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef
entityConstraintDefsPrimaryComposite =
UnboundCompositeDef -> SetOnceAtMost UnboundCompositeDef
forall a. a -> SetOnceAtMost a
SetOnce ([FieldNameHS] -> [Text] -> UnboundCompositeDef
takeComposite (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS (UnboundFieldDef -> FieldNameHS)
-> [UnboundFieldDef] -> [FieldNameHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UnboundFieldDef]
defs) [Text]
rest)
}
Text
"Id" ->
EntityConstraintDefs
forall a. Monoid a => a
mempty
{ entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef
entityConstraintDefsIdField =
UnboundIdDef -> SetOnceAtMost UnboundIdDef
forall a. a -> SetOnceAtMost a
SetOnce (PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef
takeId PersistSettings
ps EntityNameHS
entityName [Text]
rest)
}
Text
_ | Text -> Bool
isCapitalizedText Text
n ->
EntityConstraintDefs
forall a. Monoid a => a
mempty
{ entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef)
entityConstraintDefsUniques =
UniqueDef -> NonEmpty UniqueDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UniqueDef -> NonEmpty UniqueDef)
-> Maybe UniqueDef -> Maybe (NonEmpty UniqueDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings
-> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef
takeUniq PersistSettings
ps Text
"" [UnboundFieldDef]
defs (Text
n Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest)
}
Text
_ ->
EntityConstraintDefs
forall a. Monoid a => a
mempty
data UnboundIdDef = UnboundIdDef
{ UnboundIdDef -> EntityNameHS
unboundIdEntityName :: EntityNameHS
, UnboundIdDef -> FieldNameDB
unboundIdDBName :: !FieldNameDB
, UnboundIdDef -> [FieldAttr]
unboundIdAttrs :: [FieldAttr]
, UnboundIdDef -> FieldCascade
unboundIdCascade :: FieldCascade
, UnboundIdDef -> Maybe FieldType
unboundIdType :: Maybe FieldType
}
deriving (UnboundIdDef -> UnboundIdDef -> Bool
(UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool) -> Eq UnboundIdDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundIdDef -> UnboundIdDef -> Bool
$c/= :: UnboundIdDef -> UnboundIdDef -> Bool
== :: UnboundIdDef -> UnboundIdDef -> Bool
$c== :: UnboundIdDef -> UnboundIdDef -> Bool
Eq, Eq UnboundIdDef
Eq UnboundIdDef
-> (UnboundIdDef -> UnboundIdDef -> Ordering)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> Bool)
-> (UnboundIdDef -> UnboundIdDef -> UnboundIdDef)
-> (UnboundIdDef -> UnboundIdDef -> UnboundIdDef)
-> Ord UnboundIdDef
UnboundIdDef -> UnboundIdDef -> Bool
UnboundIdDef -> UnboundIdDef -> Ordering
UnboundIdDef -> UnboundIdDef -> UnboundIdDef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
$cmin :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
max :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
$cmax :: UnboundIdDef -> UnboundIdDef -> UnboundIdDef
>= :: UnboundIdDef -> UnboundIdDef -> Bool
$c>= :: UnboundIdDef -> UnboundIdDef -> Bool
> :: UnboundIdDef -> UnboundIdDef -> Bool
$c> :: UnboundIdDef -> UnboundIdDef -> Bool
<= :: UnboundIdDef -> UnboundIdDef -> Bool
$c<= :: UnboundIdDef -> UnboundIdDef -> Bool
< :: UnboundIdDef -> UnboundIdDef -> Bool
$c< :: UnboundIdDef -> UnboundIdDef -> Bool
compare :: UnboundIdDef -> UnboundIdDef -> Ordering
$ccompare :: UnboundIdDef -> UnboundIdDef -> Ordering
$cp1Ord :: Eq UnboundIdDef
Ord, Int -> UnboundIdDef -> ShowS
[UnboundIdDef] -> ShowS
UnboundIdDef -> String
(Int -> UnboundIdDef -> ShowS)
-> (UnboundIdDef -> String)
-> ([UnboundIdDef] -> ShowS)
-> Show UnboundIdDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundIdDef] -> ShowS
$cshowList :: [UnboundIdDef] -> ShowS
show :: UnboundIdDef -> String
$cshow :: UnboundIdDef -> String
showsPrec :: Int -> UnboundIdDef -> ShowS
$cshowsPrec :: Int -> UnboundIdDef -> ShowS
Show, UnboundIdDef -> Q Exp
UnboundIdDef -> Q (TExp UnboundIdDef)
(UnboundIdDef -> Q Exp)
-> (UnboundIdDef -> Q (TExp UnboundIdDef)) -> Lift UnboundIdDef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundIdDef -> Q (TExp UnboundIdDef)
$cliftTyped :: UnboundIdDef -> Q (TExp UnboundIdDef)
lift :: UnboundIdDef -> Q Exp
$clift :: UnboundIdDef -> Q Exp
Lift)
takeId :: PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef
takeId :: PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef
takeId PersistSettings
ps EntityNameHS
entityName [Text]
texts =
UnboundIdDef :: EntityNameHS
-> FieldNameDB
-> [FieldAttr]
-> FieldCascade
-> Maybe FieldType
-> UnboundIdDef
UnboundIdDef
{ unboundIdDBName :: FieldNameDB
unboundIdDBName =
Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps
, unboundIdEntityName :: EntityNameHS
unboundIdEntityName =
EntityNameHS
entityName
, unboundIdCascade :: FieldCascade
unboundIdCascade =
FieldCascade
cascade_
, unboundIdAttrs :: [FieldAttr]
unboundIdAttrs =
[Text] -> [FieldAttr]
parseFieldAttrs [Text]
attrs_
, unboundIdType :: Maybe FieldType
unboundIdType =
Maybe FieldType
typ
}
where
typ :: Maybe FieldType
typ =
case [Text]
texts of
[] ->
Maybe FieldType
forall a. Maybe a
Nothing
(Text
t : [Text]
_) ->
case Text -> Either String FieldType
parseFieldType Text
t of
Left String
_ ->
Maybe FieldType
forall a. Maybe a
Nothing
Right FieldType
ft ->
FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just FieldType
ft
(FieldCascade
cascade_, [Text]
attrs_) = [Text] -> (FieldCascade, [Text])
parseCascade [Text]
texts
data UnboundCompositeDef = UnboundCompositeDef
{ UnboundCompositeDef -> [FieldNameHS]
unboundCompositeCols :: [FieldNameHS]
, UnboundCompositeDef -> [Text]
unboundCompositeAttrs :: [Attr]
}
deriving (UnboundCompositeDef -> UnboundCompositeDef -> Bool
(UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> Eq UnboundCompositeDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c/= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
== :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c== :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
Eq, Eq UnboundCompositeDef
Eq UnboundCompositeDef
-> (UnboundCompositeDef -> UnboundCompositeDef -> Ordering)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef -> UnboundCompositeDef -> Bool)
-> (UnboundCompositeDef
-> UnboundCompositeDef -> UnboundCompositeDef)
-> (UnboundCompositeDef
-> UnboundCompositeDef -> UnboundCompositeDef)
-> Ord UnboundCompositeDef
UnboundCompositeDef -> UnboundCompositeDef -> Bool
UnboundCompositeDef -> UnboundCompositeDef -> Ordering
UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
$cmin :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
max :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
$cmax :: UnboundCompositeDef -> UnboundCompositeDef -> UnboundCompositeDef
>= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c>= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
> :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c> :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
<= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c<= :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
< :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
$c< :: UnboundCompositeDef -> UnboundCompositeDef -> Bool
compare :: UnboundCompositeDef -> UnboundCompositeDef -> Ordering
$ccompare :: UnboundCompositeDef -> UnboundCompositeDef -> Ordering
$cp1Ord :: Eq UnboundCompositeDef
Ord, Int -> UnboundCompositeDef -> ShowS
[UnboundCompositeDef] -> ShowS
UnboundCompositeDef -> String
(Int -> UnboundCompositeDef -> ShowS)
-> (UnboundCompositeDef -> String)
-> ([UnboundCompositeDef] -> ShowS)
-> Show UnboundCompositeDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundCompositeDef] -> ShowS
$cshowList :: [UnboundCompositeDef] -> ShowS
show :: UnboundCompositeDef -> String
$cshow :: UnboundCompositeDef -> String
showsPrec :: Int -> UnboundCompositeDef -> ShowS
$cshowsPrec :: Int -> UnboundCompositeDef -> ShowS
Show, UnboundCompositeDef -> Q Exp
UnboundCompositeDef -> Q (TExp UnboundCompositeDef)
(UnboundCompositeDef -> Q Exp)
-> (UnboundCompositeDef -> Q (TExp UnboundCompositeDef))
-> Lift UnboundCompositeDef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundCompositeDef -> Q (TExp UnboundCompositeDef)
$cliftTyped :: UnboundCompositeDef -> Q (TExp UnboundCompositeDef)
lift :: UnboundCompositeDef -> Q Exp
$clift :: UnboundCompositeDef -> Q Exp
Lift)
takeComposite
:: [FieldNameHS]
-> [Text]
-> UnboundCompositeDef
takeComposite :: [FieldNameHS] -> [Text] -> UnboundCompositeDef
takeComposite [FieldNameHS]
fields [Text]
pkcols =
UnboundCompositeDef :: [FieldNameHS] -> [Text] -> UnboundCompositeDef
UnboundCompositeDef
{ unboundCompositeCols :: [FieldNameHS]
unboundCompositeCols =
(Text -> FieldNameHS) -> [Text] -> [FieldNameHS]
forall a b. (a -> b) -> [a] -> [b]
map ([FieldNameHS] -> Text -> FieldNameHS
getDef [FieldNameHS]
fields) [Text]
cols
, unboundCompositeAttrs :: [Text]
unboundCompositeAttrs =
[Text]
attrs
}
where
([Text]
cols, [Text]
attrs) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
pkcols
getDef :: [FieldNameHS] -> Text -> FieldNameHS
getDef [] Text
t = String -> FieldNameHS
forall a. HasCallStack => String -> a
error (String -> FieldNameHS) -> String -> FieldNameHS
forall a b. (a -> b) -> a -> b
$ String
"Unknown column in primary key constraint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
getDef (FieldNameHS
d:[FieldNameHS]
ds) Text
t
| FieldNameHS
d FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
t =
FieldNameHS
d
| Bool
otherwise =
[FieldNameHS] -> Text -> FieldNameHS
getDef [FieldNameHS]
ds Text
t
takeUniq
:: PersistSettings
-> Text
-> [UnboundFieldDef]
-> [Text]
-> Maybe UniqueDef
takeUniq :: PersistSettings
-> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef
takeUniq PersistSettings
ps Text
tableName [UnboundFieldDef]
defs (Text
n : [Text]
rest)
| Text -> Bool
isCapitalizedText Text
n = do
NonEmpty Text
fields <- Maybe (NonEmpty Text)
mfields
UniqueDef -> Maybe UniqueDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure UniqueDef :: ConstraintNameHS
-> ConstraintNameDB
-> NonEmpty (FieldNameHS, FieldNameDB)
-> [Text]
-> UniqueDef
UniqueDef
{ uniqueHaskell :: ConstraintNameHS
uniqueHaskell =
Text -> ConstraintNameHS
ConstraintNameHS Text
n
, uniqueDBName :: ConstraintNameDB
uniqueDBName =
ConstraintNameDB
dbName
, uniqueFields :: NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields =
(Text -> (FieldNameHS, FieldNameDB))
-> NonEmpty Text -> NonEmpty (FieldNameHS, FieldNameDB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
a -> (Text -> FieldNameHS
FieldNameHS Text
a, [UnboundFieldDef] -> Text -> FieldNameDB
getDBName [UnboundFieldDef]
defs Text
a)) NonEmpty Text
fields
, uniqueAttrs :: [Text]
uniqueAttrs =
[Text]
attrs
}
where
isAttr :: Text -> Bool
isAttr Text
a =
Text
"!" Text -> Text -> Bool
`T.isPrefixOf` Text
a
isSqlName :: Text -> Bool
isSqlName Text
a =
Text
"sql=" Text -> Text -> Bool
`T.isPrefixOf` Text
a
isNonField :: Text -> Bool
isNonField Text
a =
Text -> Bool
isAttr Text
a Bool -> Bool -> Bool
|| Text -> Bool
isSqlName Text
a
([Text]
fieldsList, [Text]
nonFields) =
(Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
isNonField [Text]
rest
mfields :: Maybe (NonEmpty Text)
mfields =
[Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Text]
fieldsList
attrs :: [Text]
attrs = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isAttr [Text]
nonFields
usualDbName :: ConstraintNameDB
usualDbName =
Text -> ConstraintNameDB
ConstraintNameDB (Text -> ConstraintNameDB) -> Text -> ConstraintNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (Text
tableName Text -> Text -> Text
`T.append` Text
n)
sqlName :: Maybe ConstraintNameDB
sqlName :: Maybe ConstraintNameDB
sqlName =
case (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Text -> Bool
isSqlName [Text]
nonFields of
Maybe Text
Nothing ->
Maybe ConstraintNameDB
forall a. Maybe a
Nothing
(Just Text
t) ->
case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"=" Text
t of
(Text
x : [Text]
_) -> ConstraintNameDB -> Maybe ConstraintNameDB
forall a. a -> Maybe a
Just (Text -> ConstraintNameDB
ConstraintNameDB Text
x)
[Text]
_ -> Maybe ConstraintNameDB
forall a. Maybe a
Nothing
dbName :: ConstraintNameDB
dbName = ConstraintNameDB -> Maybe ConstraintNameDB -> ConstraintNameDB
forall a. a -> Maybe a -> a
fromMaybe ConstraintNameDB
usualDbName Maybe ConstraintNameDB
sqlName
getDBName :: [UnboundFieldDef] -> Text -> FieldNameDB
getDBName [] Text
t = String -> FieldNameDB
forall a. HasCallStack => String -> a
error (String -> FieldNameDB) -> String -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> [UnboundFieldDef] -> Text -> Text
unknownUniqueColumnError Text
t [UnboundFieldDef]
defs Text
n)
getDBName (UnboundFieldDef
d:[UnboundFieldDef]
ds) Text
t
| UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
d FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
t =
UnboundFieldDef -> FieldNameDB
unboundFieldNameDB UnboundFieldDef
d
| Bool
otherwise =
[UnboundFieldDef] -> Text -> FieldNameDB
getDBName [UnboundFieldDef]
ds Text
t
takeUniq PersistSettings
_ Text
tableName [UnboundFieldDef]
_ [Text]
xs =
String -> Maybe UniqueDef
forall a. HasCallStack => String -> a
error (String -> Maybe UniqueDef) -> String -> Maybe UniqueDef
forall a b. (a -> b) -> a -> b
$ String
"invalid unique constraint on table["
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
tableName
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] expecting an uppercase constraint name xs="
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
xs
unknownUniqueColumnError :: Text -> [UnboundFieldDef] -> Text -> Text
unknownUniqueColumnError :: Text -> [UnboundFieldDef] -> Text -> Text
unknownUniqueColumnError Text
t [UnboundFieldDef]
defs Text
n =
Text
"Unknown column in \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" constraint: \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" possible fields: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Text] -> String
forall a. Show a => a -> String
show (UnboundFieldDef -> Text
toFieldName (UnboundFieldDef -> Text) -> [UnboundFieldDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UnboundFieldDef]
defs))
where
toFieldName :: UnboundFieldDef -> Text
toFieldName :: UnboundFieldDef -> Text
toFieldName UnboundFieldDef
fd =
FieldNameHS -> Text
unFieldNameHS (UnboundFieldDef -> FieldNameHS
unboundFieldNameHS UnboundFieldDef
fd)
data UnboundForeignDef
= UnboundForeignDef
{ UnboundForeignDef -> UnboundForeignFieldList
unboundForeignFields :: UnboundForeignFieldList
, UnboundForeignDef -> ForeignDef
unboundForeignDef :: ForeignDef
}
deriving (UnboundForeignDef -> UnboundForeignDef -> Bool
(UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> Eq UnboundForeignDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c/= :: UnboundForeignDef -> UnboundForeignDef -> Bool
== :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c== :: UnboundForeignDef -> UnboundForeignDef -> Bool
Eq, Eq UnboundForeignDef
Eq UnboundForeignDef
-> (UnboundForeignDef -> UnboundForeignDef -> Ordering)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> Bool)
-> (UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef)
-> (UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef)
-> Ord UnboundForeignDef
UnboundForeignDef -> UnboundForeignDef -> Bool
UnboundForeignDef -> UnboundForeignDef -> Ordering
UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
$cmin :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
max :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
$cmax :: UnboundForeignDef -> UnboundForeignDef -> UnboundForeignDef
>= :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c>= :: UnboundForeignDef -> UnboundForeignDef -> Bool
> :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c> :: UnboundForeignDef -> UnboundForeignDef -> Bool
<= :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c<= :: UnboundForeignDef -> UnboundForeignDef -> Bool
< :: UnboundForeignDef -> UnboundForeignDef -> Bool
$c< :: UnboundForeignDef -> UnboundForeignDef -> Bool
compare :: UnboundForeignDef -> UnboundForeignDef -> Ordering
$ccompare :: UnboundForeignDef -> UnboundForeignDef -> Ordering
$cp1Ord :: Eq UnboundForeignDef
Ord, Int -> UnboundForeignDef -> ShowS
[UnboundForeignDef] -> ShowS
UnboundForeignDef -> String
(Int -> UnboundForeignDef -> ShowS)
-> (UnboundForeignDef -> String)
-> ([UnboundForeignDef] -> ShowS)
-> Show UnboundForeignDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundForeignDef] -> ShowS
$cshowList :: [UnboundForeignDef] -> ShowS
show :: UnboundForeignDef -> String
$cshow :: UnboundForeignDef -> String
showsPrec :: Int -> UnboundForeignDef -> ShowS
$cshowsPrec :: Int -> UnboundForeignDef -> ShowS
Show, UnboundForeignDef -> Q Exp
UnboundForeignDef -> Q (TExp UnboundForeignDef)
(UnboundForeignDef -> Q Exp)
-> (UnboundForeignDef -> Q (TExp UnboundForeignDef))
-> Lift UnboundForeignDef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundForeignDef -> Q (TExp UnboundForeignDef)
$cliftTyped :: UnboundForeignDef -> Q (TExp UnboundForeignDef)
lift :: UnboundForeignDef -> Q Exp
$clift :: UnboundForeignDef -> Q Exp
Lift)
data UnboundForeignFieldList
= FieldListImpliedId (NonEmpty FieldNameHS)
| FieldListHasReferences (NonEmpty ForeignFieldReference)
deriving (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
(UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> Eq UnboundForeignFieldList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c/= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
== :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c== :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
Eq, Eq UnboundForeignFieldList
Eq UnboundForeignFieldList
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList -> UnboundForeignFieldList -> Bool)
-> (UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList)
-> (UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList)
-> Ord UnboundForeignFieldList
UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering
UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
$cmin :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
max :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
$cmax :: UnboundForeignFieldList
-> UnboundForeignFieldList -> UnboundForeignFieldList
>= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c>= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
> :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c> :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
<= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c<= :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
< :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
$c< :: UnboundForeignFieldList -> UnboundForeignFieldList -> Bool
compare :: UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering
$ccompare :: UnboundForeignFieldList -> UnboundForeignFieldList -> Ordering
$cp1Ord :: Eq UnboundForeignFieldList
Ord, Int -> UnboundForeignFieldList -> ShowS
[UnboundForeignFieldList] -> ShowS
UnboundForeignFieldList -> String
(Int -> UnboundForeignFieldList -> ShowS)
-> (UnboundForeignFieldList -> String)
-> ([UnboundForeignFieldList] -> ShowS)
-> Show UnboundForeignFieldList
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnboundForeignFieldList] -> ShowS
$cshowList :: [UnboundForeignFieldList] -> ShowS
show :: UnboundForeignFieldList -> String
$cshow :: UnboundForeignFieldList -> String
showsPrec :: Int -> UnboundForeignFieldList -> ShowS
$cshowsPrec :: Int -> UnboundForeignFieldList -> ShowS
Show, UnboundForeignFieldList -> Q Exp
UnboundForeignFieldList -> Q (TExp UnboundForeignFieldList)
(UnboundForeignFieldList -> Q Exp)
-> (UnboundForeignFieldList -> Q (TExp UnboundForeignFieldList))
-> Lift UnboundForeignFieldList
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnboundForeignFieldList -> Q (TExp UnboundForeignFieldList)
$cliftTyped :: UnboundForeignFieldList -> Q (TExp UnboundForeignFieldList)
lift :: UnboundForeignFieldList -> Q Exp
$clift :: UnboundForeignFieldList -> Q Exp
Lift)
data ForeignFieldReference =
ForeignFieldReference
{ ForeignFieldReference -> FieldNameHS
ffrSourceField :: FieldNameHS
, ForeignFieldReference -> FieldNameHS
ffrTargetField :: FieldNameHS
}
deriving (ForeignFieldReference -> ForeignFieldReference -> Bool
(ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> Eq ForeignFieldReference
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c/= :: ForeignFieldReference -> ForeignFieldReference -> Bool
== :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c== :: ForeignFieldReference -> ForeignFieldReference -> Bool
Eq, Eq ForeignFieldReference
Eq ForeignFieldReference
-> (ForeignFieldReference -> ForeignFieldReference -> Ordering)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference -> ForeignFieldReference -> Bool)
-> (ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference)
-> (ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference)
-> Ord ForeignFieldReference
ForeignFieldReference -> ForeignFieldReference -> Bool
ForeignFieldReference -> ForeignFieldReference -> Ordering
ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
$cmin :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
max :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
$cmax :: ForeignFieldReference
-> ForeignFieldReference -> ForeignFieldReference
>= :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c>= :: ForeignFieldReference -> ForeignFieldReference -> Bool
> :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c> :: ForeignFieldReference -> ForeignFieldReference -> Bool
<= :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c<= :: ForeignFieldReference -> ForeignFieldReference -> Bool
< :: ForeignFieldReference -> ForeignFieldReference -> Bool
$c< :: ForeignFieldReference -> ForeignFieldReference -> Bool
compare :: ForeignFieldReference -> ForeignFieldReference -> Ordering
$ccompare :: ForeignFieldReference -> ForeignFieldReference -> Ordering
$cp1Ord :: Eq ForeignFieldReference
Ord, Int -> ForeignFieldReference -> ShowS
[ForeignFieldReference] -> ShowS
ForeignFieldReference -> String
(Int -> ForeignFieldReference -> ShowS)
-> (ForeignFieldReference -> String)
-> ([ForeignFieldReference] -> ShowS)
-> Show ForeignFieldReference
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ForeignFieldReference] -> ShowS
$cshowList :: [ForeignFieldReference] -> ShowS
show :: ForeignFieldReference -> String
$cshow :: ForeignFieldReference -> String
showsPrec :: Int -> ForeignFieldReference -> ShowS
$cshowsPrec :: Int -> ForeignFieldReference -> ShowS
Show, ForeignFieldReference -> Q Exp
ForeignFieldReference -> Q (TExp ForeignFieldReference)
(ForeignFieldReference -> Q Exp)
-> (ForeignFieldReference -> Q (TExp ForeignFieldReference))
-> Lift ForeignFieldReference
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: ForeignFieldReference -> Q (TExp ForeignFieldReference)
$cliftTyped :: ForeignFieldReference -> Q (TExp ForeignFieldReference)
lift :: ForeignFieldReference -> Q Exp
$clift :: ForeignFieldReference -> Q Exp
Lift)
unbindForeignDef :: ForeignDef -> UnboundForeignDef
unbindForeignDef :: ForeignDef -> UnboundForeignDef
unbindForeignDef ForeignDef
fd =
UnboundForeignDef :: UnboundForeignFieldList -> ForeignDef -> UnboundForeignDef
UnboundForeignDef
{ unboundForeignFields :: UnboundForeignFieldList
unboundForeignFields =
NonEmpty ForeignFieldReference -> UnboundForeignFieldList
FieldListHasReferences (NonEmpty ForeignFieldReference -> UnboundForeignFieldList)
-> NonEmpty ForeignFieldReference -> UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$ [ForeignFieldReference] -> NonEmpty ForeignFieldReference
forall a. [a] -> NonEmpty a
NEL.fromList ([ForeignFieldReference] -> NonEmpty ForeignFieldReference)
-> [ForeignFieldReference] -> NonEmpty ForeignFieldReference
forall a b. (a -> b) -> a -> b
$ (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> ForeignFieldReference)
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [ForeignFieldReference]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> ForeignFieldReference
forall b b.
((FieldNameHS, b), (FieldNameHS, b)) -> ForeignFieldReference
mk (ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fd)
, unboundForeignDef :: ForeignDef
unboundForeignDef =
ForeignDef
fd
}
where
mk :: ((FieldNameHS, b), (FieldNameHS, b)) -> ForeignFieldReference
mk ((FieldNameHS
fH, b
_), (FieldNameHS
pH, b
_)) =
ForeignFieldReference :: FieldNameHS -> FieldNameHS -> ForeignFieldReference
ForeignFieldReference
{ ffrSourceField :: FieldNameHS
ffrSourceField = FieldNameHS
fH
, ffrTargetField :: FieldNameHS
ffrTargetField = FieldNameHS
pH
}
mkUnboundForeignFieldList
:: [Text]
-> [Text]
-> Either String UnboundForeignFieldList
mkUnboundForeignFieldList :: [Text] -> [Text] -> Either String UnboundForeignFieldList
mkUnboundForeignFieldList ((Text -> FieldNameHS) -> [Text] -> [FieldNameHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FieldNameHS
FieldNameHS -> [FieldNameHS]
source) ((Text -> FieldNameHS) -> [Text] -> [FieldNameHS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FieldNameHS
FieldNameHS -> [FieldNameHS]
target) =
case [FieldNameHS] -> Maybe (NonEmpty FieldNameHS)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [FieldNameHS]
source of
Maybe (NonEmpty FieldNameHS)
Nothing ->
String -> Either String UnboundForeignFieldList
forall a b. a -> Either a b
Left String
"No fields on foreign reference."
Just NonEmpty FieldNameHS
sources ->
case [FieldNameHS] -> Maybe (NonEmpty FieldNameHS)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [FieldNameHS]
target of
Maybe (NonEmpty FieldNameHS)
Nothing ->
UnboundForeignFieldList -> Either String UnboundForeignFieldList
forall a b. b -> Either a b
Right (UnboundForeignFieldList -> Either String UnboundForeignFieldList)
-> UnboundForeignFieldList -> Either String UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$ NonEmpty FieldNameHS -> UnboundForeignFieldList
FieldListImpliedId NonEmpty FieldNameHS
sources
Just NonEmpty FieldNameHS
targets ->
if NonEmpty FieldNameHS -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty FieldNameHS
targets Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= NonEmpty FieldNameHS -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty FieldNameHS
sources
then
String -> Either String UnboundForeignFieldList
forall a b. a -> Either a b
Left String
"Target and source length differe on foreign reference."
else
UnboundForeignFieldList -> Either String UnboundForeignFieldList
forall a b. b -> Either a b
Right
(UnboundForeignFieldList -> Either String UnboundForeignFieldList)
-> UnboundForeignFieldList -> Either String UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$ NonEmpty ForeignFieldReference -> UnboundForeignFieldList
FieldListHasReferences
(NonEmpty ForeignFieldReference -> UnboundForeignFieldList)
-> NonEmpty ForeignFieldReference -> UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$ (FieldNameHS -> FieldNameHS -> ForeignFieldReference)
-> NonEmpty FieldNameHS
-> NonEmpty FieldNameHS
-> NonEmpty ForeignFieldReference
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NEL.zipWith FieldNameHS -> FieldNameHS -> ForeignFieldReference
ForeignFieldReference NonEmpty FieldNameHS
sources NonEmpty FieldNameHS
targets
takeForeign
:: PersistSettings
-> EntityNameHS
-> [Text]
-> UnboundForeignDef
takeForeign :: PersistSettings -> EntityNameHS -> [Text] -> UnboundForeignDef
takeForeign PersistSettings
ps EntityNameHS
entityName = [Text] -> UnboundForeignDef
takeRefTable
where
errorPrefix :: String
errorPrefix :: String
errorPrefix = String
"invalid foreign key constraint on table[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (EntityNameHS -> Text
unEntityNameHS EntityNameHS
entityName) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] "
takeRefTable :: [Text] -> UnboundForeignDef
takeRefTable :: [Text] -> UnboundForeignDef
takeRefTable [] =
String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" expecting foreign table name"
takeRefTable (Text
refTableName:[Text]
restLine) =
[Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
restLine Maybe CascadeAction
forall a. Maybe a
Nothing Maybe CascadeAction
forall a. Maybe a
Nothing
where
go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go :: [Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go (Text
constraintNameText:[Text]
rest) Maybe CascadeAction
onDelete Maybe CascadeAction
onUpdate
| Bool -> Bool
not (Text -> Bool
T.null Text
constraintNameText) Bool -> Bool -> Bool
&& Char -> Bool
isLower (Text -> Char
T.head Text
constraintNameText) =
UnboundForeignDef :: UnboundForeignFieldList -> ForeignDef -> UnboundForeignDef
UnboundForeignDef
{ unboundForeignFields :: UnboundForeignFieldList
unboundForeignFields =
(String -> UnboundForeignFieldList)
-> (UnboundForeignFieldList -> UnboundForeignFieldList)
-> Either String UnboundForeignFieldList
-> UnboundForeignFieldList
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> UnboundForeignFieldList
forall a. HasCallStack => String -> a
error UnboundForeignFieldList -> UnboundForeignFieldList
forall a. a -> a
id (Either String UnboundForeignFieldList -> UnboundForeignFieldList)
-> Either String UnboundForeignFieldList -> UnboundForeignFieldList
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> Either String UnboundForeignFieldList
mkUnboundForeignFieldList [Text]
foreignFields [Text]
parentFields
, unboundForeignDef :: ForeignDef
unboundForeignDef =
ForeignDef :: EntityNameHS
-> EntityNameDB
-> ConstraintNameHS
-> ConstraintNameDB
-> FieldCascade
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
-> Bool
-> Bool
-> ForeignDef
ForeignDef
{ foreignRefTableHaskell :: EntityNameHS
foreignRefTableHaskell =
Text -> EntityNameHS
EntityNameHS Text
refTableName
, foreignRefTableDBName :: EntityNameDB
foreignRefTableDBName =
Text -> EntityNameDB
EntityNameDB (Text -> EntityNameDB) -> Text -> EntityNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
refTableName
, foreignConstraintNameHaskell :: ConstraintNameHS
foreignConstraintNameHaskell =
ConstraintNameHS
constraintName
, foreignConstraintNameDBName :: ConstraintNameDB
foreignConstraintNameDBName =
PersistSettings
-> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB
toFKConstraintNameDB PersistSettings
ps EntityNameHS
entityName ConstraintNameHS
constraintName
, foreignFieldCascade :: FieldCascade
foreignFieldCascade =
FieldCascade :: Maybe CascadeAction -> Maybe CascadeAction -> FieldCascade
FieldCascade
{ fcOnDelete :: Maybe CascadeAction
fcOnDelete = Maybe CascadeAction
onDelete
, fcOnUpdate :: Maybe CascadeAction
fcOnUpdate = Maybe CascadeAction
onUpdate
}
, foreignAttrs :: [Text]
foreignAttrs =
[Text]
attrs
, foreignFields :: [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields =
[]
, foreignNullable :: Bool
foreignNullable =
Bool
False
, foreignToPrimary :: Bool
foreignToPrimary =
[Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
parentFields
}
}
where
constraintName :: ConstraintNameHS
constraintName =
Text -> ConstraintNameHS
ConstraintNameHS Text
constraintNameText
([Text]
fields, [Text]
attrs) =
(Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
rest
([Text]
foreignFields, [Text]
parentFields) =
case (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"References") [Text]
fields of
([Text]
ffs, []) ->
([Text]
ffs, [])
([Text]
ffs, Text
_ : [Text]
pfs) ->
case ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ffs, [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
pfs) of
(Int
flen, Int
plen)
| Int
flen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
plen ->
([Text]
ffs, [Text]
pfs)
(Int
flen, Int
plen) ->
String -> ([Text], [Text])
forall a. HasCallStack => String -> a
error (String -> ([Text], [Text])) -> String -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Found " , Int -> String
forall a. Show a => a -> String
show Int
flen
, String
" foreign fields but "
, Int -> String
forall a. Show a => a -> String
show Int
plen, String
" parent fields"
]
go ((CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeDelete -> Just CascadeAction
cascadingAction) : [Text]
rest) Maybe CascadeAction
onDelete' Maybe CascadeAction
onUpdate =
case Maybe CascadeAction
onDelete' of
Maybe CascadeAction
Nothing ->
[Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
rest (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascadingAction) Maybe CascadeAction
onUpdate
Just CascadeAction
_ ->
String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"found more than one OnDelete actions"
go ((CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeUpdate -> Just CascadeAction
cascadingAction) : [Text]
rest) Maybe CascadeAction
onDelete Maybe CascadeAction
onUpdate' =
case Maybe CascadeAction
onUpdate' of
Maybe CascadeAction
Nothing ->
[Text]
-> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
go [Text]
rest Maybe CascadeAction
onDelete (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascadingAction)
Just CascadeAction
_ ->
String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"found more than one OnUpdate actions"
go [Text]
xs Maybe CascadeAction
_ Maybe CascadeAction
_ = String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ String
errorPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"expecting a lower case constraint name or a cascading action xs=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
xs
toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB
toFKConstraintNameDB :: PersistSettings
-> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB
toFKConstraintNameDB PersistSettings
ps EntityNameHS
entityName ConstraintNameHS
constraintName =
Text -> ConstraintNameDB
ConstraintNameDB (Text -> ConstraintNameDB) -> Text -> ConstraintNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (PersistSettings -> EntityNameHS -> ConstraintNameHS -> Text
psToFKName PersistSettings
ps EntityNameHS
entityName ConstraintNameHS
constraintName)
data CascadePrefix = CascadeUpdate | CascadeDelete
parseCascade :: [Text] -> (FieldCascade, [Text])
parseCascade :: [Text] -> (FieldCascade, [Text])
parseCascade [Text]
allTokens =
[Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go [] Maybe CascadeAction
forall a. Maybe a
Nothing Maybe CascadeAction
forall a. Maybe a
Nothing [Text]
allTokens
where
go :: [Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go [Text]
acc Maybe CascadeAction
mupd Maybe CascadeAction
mdel [Text]
tokens_ =
case [Text]
tokens_ of
[] ->
( FieldCascade :: Maybe CascadeAction -> Maybe CascadeAction -> FieldCascade
FieldCascade
{ fcOnDelete :: Maybe CascadeAction
fcOnDelete = Maybe CascadeAction
mdel
, fcOnUpdate :: Maybe CascadeAction
fcOnUpdate = Maybe CascadeAction
mupd
}
, [Text]
acc
)
Text
this : [Text]
rest ->
case CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeUpdate Text
this of
Just CascadeAction
cascUpd ->
case Maybe CascadeAction
mupd of
Maybe CascadeAction
Nothing ->
[Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go [Text]
acc (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascUpd) Maybe CascadeAction
mdel [Text]
rest
Just CascadeAction
_ ->
String -> (FieldCascade, [Text])
nope String
"found more than one OnUpdate action"
Maybe CascadeAction
Nothing ->
case CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
CascadeDelete Text
this of
Just CascadeAction
cascDel ->
case Maybe CascadeAction
mdel of
Maybe CascadeAction
Nothing ->
[Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go [Text]
acc Maybe CascadeAction
mupd (CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
cascDel) [Text]
rest
Just CascadeAction
_ ->
String -> (FieldCascade, [Text])
nope String
"found more than one OnDelete action"
Maybe CascadeAction
Nothing ->
[Text]
-> Maybe CascadeAction
-> Maybe CascadeAction
-> [Text]
-> (FieldCascade, [Text])
go (Text
this Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Maybe CascadeAction
mupd Maybe CascadeAction
mdel [Text]
rest
nope :: String -> (FieldCascade, [Text])
nope String
msg =
String -> (FieldCascade, [Text])
forall a. HasCallStack => String -> a
error (String -> (FieldCascade, [Text]))
-> String -> (FieldCascade, [Text])
forall a b. (a -> b) -> a -> b
$ String
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", tokens: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
allTokens
parseCascadeAction
:: CascadePrefix
-> Text
-> Maybe CascadeAction
parseCascadeAction :: CascadePrefix -> Text -> Maybe CascadeAction
parseCascadeAction CascadePrefix
prfx Text
text = do
Text
cascadeStr <- Text -> Text -> Maybe Text
T.stripPrefix (Text
"On" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CascadePrefix -> Text
forall p. IsString p => CascadePrefix -> p
toPrefix CascadePrefix
prfx) Text
text
case String -> Either String CascadeAction
forall a. Read a => String -> Either String a
readEither (Text -> String
T.unpack Text
cascadeStr) of
Right CascadeAction
a ->
CascadeAction -> Maybe CascadeAction
forall a. a -> Maybe a
Just CascadeAction
a
Left String
_ ->
Maybe CascadeAction
forall a. Maybe a
Nothing
where
toPrefix :: CascadePrefix -> p
toPrefix CascadePrefix
cp =
case CascadePrefix
cp of
CascadePrefix
CascadeUpdate -> p
"Update"
CascadePrefix
CascadeDelete -> p
"Delete"
takeDerives :: [Text] -> Maybe [Text]
takeDerives :: [Text] -> Maybe [Text]
takeDerives (Text
"deriving":[Text]
rest) = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
rest
takeDerives [Text]
_ = Maybe [Text]
forall a. Maybe a
Nothing
isHaskellUnboundField :: UnboundFieldDef -> Bool
isHaskellUnboundField :: UnboundFieldDef -> Bool
isHaskellUnboundField UnboundFieldDef
fd =
FieldAttr
FieldAttrMigrationOnly FieldAttr -> [FieldAttr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs UnboundFieldDef
fd Bool -> Bool -> Bool
&&
FieldAttr
FieldAttrSafeToRemove FieldAttr -> [FieldAttr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` UnboundFieldDef -> [FieldAttr]
unboundFieldAttrs UnboundFieldDef
fd
getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS = EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS)
-> (UnboundEntityDef -> EntityDef)
-> UnboundEntityDef
-> EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef