{-# LANGUAGE BangPatterns, CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

{-|
This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities.

The basic structure of the syntax looks like this:

> TableName
>     fieldName      FieldType
>     otherField     String
>     nullableField  Int       Maybe

You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type.

@persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL:

> CREATE TABLE table_name (
>     id                SERIAL PRIMARY KEY,
>     field_name        field_type NOT NULL,
>     other_field       varchar    NOT NULL,
>     nullable_field    int NULL
> );

Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function.

It generates a Haskell datatype with the following form:

@
data TableName = TableName
    { tableNameFieldName :: FieldType
    , tableNameOtherField :: String
    , tableNameNullableField :: Maybe Int
    }
@

As with the SQL generated, the specifics of this are customizable.
See the @persistent-template@ package for details.

= Deriving

You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that.
Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses.

> User
>     name String
>     age  Int
>     deriving Eq Show
>     deriving Ord

= Unique Keys

You can define a uniqueness key on a table with the following format:

> User
>    name String
>    age  Int
>
>    UniqueUserName name

This will put a unique index on the @user@ table and the @name@ field.

= Setting defaults

You can use a @default=${sql expression}@ clause to set a default for a field.
The thing following the `=` is interpreted as SQL that will be put directly into the table definition.

@
User
    name    Text
    admin   Bool default=false
@

This creates a SQL definition like this:

> CREATE TABLE user (
>   id      SERIAL PRIMARY KEY,
>   name    VARCHAR NOT NULL,
>   admin   BOOL DEFAULT=false
> );

A restriction here is that you still need to provide a value when performing an `insert`, because the generated Haskell type has the form:

@
data User = User
    { userName :: Text
    , userAdmin :: Bool
    }
@

You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default.

= Custom ID column

If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field.
This @User@ has a @Text@ ID.

> User
>     Id   Text
>     name Text
>     age  Int

If you do this, it's a good idea to set a default for the ID.
Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts.

@
'insertKey' (UserKey "Hello world!") (User "Bob" 32)
@

If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore.
So instead just use a default expression, like this:

@
User
    Id      Text default=generate_user_id()
    name    Text
    age     Int
@

= Custom Primary Keys

Sometimes you don't want to have an ID column, and you want a different sort of primary key.
This is a table that stores unique email addresses, and the email is the primary key.
We store the first and second part (eg @first\@second@) separately.

@
Email
    firstPart   Text
    secondPart  Text

    Primary firstPart secondPart
@

This creates a table with the following form:

@
CREATE TABLE email (
    first_part  varchar,
    second_part varchar,

    PRIMARY KEY (first_part, second_part)
@

You can specify 1 or more columns in the primary key.

= Overriding SQL

You can use a @sql=custom@ annotation to provide some customization on the entity and field.
For example, you might prefer to name a table differently than what @persistent@ will do by default.
You may also prefer to name a field differently.

@
User sql=big_user_table
    fullName    String sql=name
    age         Int
@

This will alter the generated SQL to be:

@
CREATE TABEL big_user_table (
    id      SERIAL PRIMARY KEY,
    name    VARCHAR,
    age     INT
);
@

= Attributes

The QuasiQuoter allows you to provide arbitrary attributes to an entity or field.
This can be used to extend the code in ways that the library hasn't anticipated.
If you use this feature, we'd definitely appreciate hearing about it and potentially supporting your use case directly!

@
User !funny
    field   String  !sad
    good    Dog     !sogood
@

We can see the attributes using the 'entityAttrs' field and the 'fieldAttrs' field.

@
userAttrs = do
    let userDefinition = 'entityDef' ('Proxy' :: 'Proxy' User)
    let userAttributes = 'entityAttrs' userDefinition
    let fieldAttributes = 'map' 'fieldAttrs' ('entityFields' userDefinition)
    print userAttributes
-- ["funny"]
    print fieldAttributes
-- [["sad"],["sogood"]]
@

= Documentation Comments

The quasiquoter supports ordinary comments with @--@ and @#@.
Since @persistent-2.10.5.1@, it also supports documentation comments.
The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions:

1. Only the @-- | @ form is allowed.
2. You must put a space before and after the @|@ pipe character.
3. The comment must be indented at the same level as the entity or field it documents.

An example of the field documentation is:

@
-- | I am a doc comment for a User. Users are important
-- | to the application, and should be treasured.
User
    -- | Users have names. Call them by names.
    name String
    -- | A user can be old, or young, and we care about
    -- | this for some reason.
    age Int
@

The documentation is present on the `entityComments` field on the `EntityDef` for the entity:

@
>>> let userDefinition = entityDef (Proxy :: Proxy User)
>>> entityComments userDefinition
"I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n"
@

Likewise, the field documentation is present in the `fieldComments` field on the `FieldDef` present in the `EntityDef`:

@
>>> let userFields = entityFields userDefinition
>>> let comments = map fieldComments userFields
>>> mapM_ putStrLn comments
"Users have names. Call them by names."
"A user can be old, or young, and we care about\nthis for some reason."
@

Unfortunately, we can't use this to create Haddocks for you, because <https://gitlab.haskell.org/ghc/ghc/issues/5467 Template Haskell does not support Haddock yet>.
`persistent` backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions.

-}
module Database.Persist.Quasi
    ( parse
    , PersistSettings (..)
    , upperCaseSettings
    , lowerCaseSettings
    , nullable
#if TEST
    , Token (..)
    , Line' (..)
    , preparse
    , tokenize
    , parseFieldType
    , empty
    , removeSpaces
    , associateLines
    , skipEmpty
    , LinesWithComments(..)
#endif
    ) where

import Prelude hiding (lines)

import qualified Data.List.NonEmpty as NEL
import Data.List.NonEmpty (NonEmpty(..))
import Control.Arrow ((&&&))
import Control.Monad (msum, mplus)
import Data.Char
import Data.List (find, foldl')
import qualified Data.Map as M
import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.Types

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
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
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 ->
                    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 (Text -> FieldType
getCon 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')
    getCon :: Text -> FieldType
getCon Text
t =
        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
    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
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
            -- _ ->

data PersistSettings = PersistSettings
    { PersistSettings -> Text -> Text
psToDBName :: !(Text -> Text)
    , PersistSettings -> Bool
psStrictFields :: !Bool
    -- ^ Whether fields are by default strict. Default value: @True@.
    --
    -- @since 1.2
    , PersistSettings -> Text
psIdName :: !Text
    -- ^ The name of the id column. Default value: @id@
    -- The name of the id column can also be changed on a per-model basis
    -- <https://github.com/yesodweb/persistent/wiki/Persistent-entity-syntax>
    --
    -- @since 2.0
    }

defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings
defaultPersistSettings :: PersistSettings
defaultPersistSettings = PersistSettings :: (Text -> Text) -> Bool -> Text -> PersistSettings
PersistSettings
    { psToDBName :: Text -> Text
psToDBName = Text -> Text
forall a. a -> a
id
    , 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
    }

-- | Parses a quasi-quoted syntax into a list of entity definitions.
parse :: PersistSettings -> Text -> [EntityDef]
parse :: PersistSettings -> Text -> [EntityDef]
parse PersistSettings
ps = PersistSettings -> [Line] -> [EntityDef]
parseLines PersistSettings
ps ([Line] -> [EntityDef]) -> (Text -> [Line]) -> Text -> [EntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Line]
preparse

preparse :: Text -> [Line]
preparse :: Text -> [Line]
preparse =
    [[Token]] -> [Line]
removeSpaces
        ([[Token]] -> [Line]) -> (Text -> [[Token]]) -> Text -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Token] -> Bool) -> [[Token]] -> [[Token]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Token] -> Bool) -> [Token] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Bool
empty)
        ([[Token]] -> [[Token]])
-> (Text -> [[Token]]) -> Text -> [[Token]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Token]) -> [Text] -> [[Token]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Token]
tokenize
        ([Text] -> [[Token]]) -> (Text -> [Text]) -> Text -> [[Token]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

-- | A token used by the parser.
data Token = Spaces !Int   -- ^ @Spaces n@ are @n@ consecutive spaces.
           | Token Text    -- ^ @Token tok@ is token @tok@ already unquoted.
           | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified.
  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)

-- | Tokenize a string.
tokenize :: Text -> [Token]
tokenize :: Text -> [Token]
tokenize Text
t
    | Text -> Bool
T.null Text
t = []
    | Text
"-- | " Text -> Text -> Bool
`T.isPrefixOf` Text
t = [Text -> Token
DocComment Text
t]
    | Text
"--" Text -> Text -> Bool
`T.isPrefixOf` Text
t = [] -- Comment until the end of the line.
    | Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text
t = [] -- Also comment to the end of the line, needed for a CPP bug (#110)
    | 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) =
        let (Text
spaces, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isSpace Text
t
         in Int -> Token
Spaces (Text -> Int
T.length Text
spaces) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
rest

    -- support mid-token quotes and parens
    | 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
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
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
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]
:))

-- | A string of tokens is empty when it has only spaces.  There
-- can't be two consecutive 'Spaces', so this takes /O(1)/ time.
empty :: [Token] -> Bool
empty :: [Token] -> Bool
empty []         = Bool
True
empty [Spaces Int
_] = Bool
True
empty [Token]
_          = Bool
False

-- | A line.  We don't care about spaces in the middle of the
-- line.  Also, we don't care about the ammount of indentation.
data Line' f
    = Line
    { Line' f -> Int
lineIndent   :: Int
    , Line' f -> f Text
tokens       :: f Text
    }

deriving instance Show (f Text) => Show (Line' f)
deriving instance Eq (f Text) => Eq (Line' f)

mapLine :: (forall x. f x -> g x) -> Line' f -> Line' g
mapLine :: (forall x. f x -> g x) -> Line' f -> Line' g
mapLine forall x. f x -> g x
k (Line Int
i f Text
t) = Int -> g Text -> Line' g
forall (f :: * -> *). Int -> f Text -> Line' f
Line Int
i (f Text -> g Text
forall x. f x -> g x
k f Text
t)

traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g)
traverseLine :: (forall x. f x -> t (g x)) -> Line' f -> t (Line' g)
traverseLine forall x. f x -> t (g x)
k (Line Int
i f Text
xs) = Int -> g Text -> Line' g
forall (f :: * -> *). Int -> f Text -> Line' f
Line Int
i (g Text -> Line' g) -> t (g Text) -> t (Line' g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Text -> t (g Text)
forall x. f x -> t (g x)
k f Text
xs

type Line = Line' []

-- | Remove leading spaces and remove spaces in the middle of the
-- tokens.
removeSpaces :: [[Token]] -> [Line]
removeSpaces :: [[Token]] -> [Line]
removeSpaces =
    ([Token] -> Line) -> [[Token]] -> [Line]
forall a b. (a -> b) -> [a] -> [b]
map [Token] -> Line
toLine
  where
    toLine :: [Token] -> Line
toLine (Spaces Int
i:[Token]
rest) = Int -> [Token] -> Line
toLine' Int
i [Token]
rest
    toLine [Token]
xs              = Int -> [Token] -> Line
toLine' Int
0 [Token]
xs

    toLine' :: Int -> [Token] -> Line
toLine' Int
i = Int -> [Text] -> Line
forall (f :: * -> *). Int -> f Text -> Line' f
Line Int
i ([Text] -> Line) -> ([Token] -> [Text]) -> [Token] -> Line
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Maybe Text) -> [Token] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Token -> Maybe Text
fromToken

    fromToken :: Token -> Maybe Text
fromToken (Token Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
    fromToken (DocComment Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
    fromToken Spaces{}  = Maybe Text
forall a. Maybe a
Nothing

-- | Divide lines into blocks and make entity definitions.
parseLines :: PersistSettings -> [Line] -> [EntityDef]
parseLines :: PersistSettings -> [Line] -> [EntityDef]
parseLines PersistSettings
ps [Line]
lines =
    [UnboundEntityDef] -> [EntityDef]
fixForeignKeysAll ([UnboundEntityDef] -> [EntityDef])
-> [UnboundEntityDef] -> [EntityDef]
forall a b. (a -> b) -> a -> b
$ [Line] -> [UnboundEntityDef]
toEnts [Line]
lines
  where
    toEnts :: [Line] -> [UnboundEntityDef]
    toEnts :: [Line] -> [UnboundEntityDef]
toEnts =
        (LinesWithComments -> UnboundEntityDef)
-> [LinesWithComments] -> [UnboundEntityDef]
forall a b. (a -> b) -> [a] -> [b]
map LinesWithComments -> UnboundEntityDef
mk
        ([LinesWithComments] -> [UnboundEntityDef])
-> ([Line] -> [LinesWithComments]) -> [Line] -> [UnboundEntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line' NonEmpty] -> [LinesWithComments]
associateLines
        ([Line' NonEmpty] -> [LinesWithComments])
-> ([Line] -> [Line' NonEmpty]) -> [Line] -> [LinesWithComments]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> [Line' NonEmpty]
skipEmpty
    mk :: LinesWithComments -> UnboundEntityDef
    mk :: LinesWithComments -> UnboundEntityDef
mk LinesWithComments
lwc =
        let Line Int
_ (Text
name :| [Text]
entAttribs) :| [Line' NonEmpty]
rest = LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines LinesWithComments
lwc
         in [Text] -> UnboundEntityDef -> UnboundEntityDef
setComments (LinesWithComments -> [Text]
lwcComments LinesWithComments
lwc) (UnboundEntityDef -> UnboundEntityDef)
-> UnboundEntityDef -> UnboundEntityDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> [Line] -> UnboundEntityDef
mkEntityDef PersistSettings
ps Text
name [Text]
entAttribs ((Line' NonEmpty -> Line) -> [Line' NonEmpty] -> [Line]
forall a b. (a -> b) -> [a] -> [b]
map ((forall x. NonEmpty x -> [x]) -> Line' NonEmpty -> Line
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> Line' f -> Line' g
mapLine forall x. NonEmpty x -> [x]
NEL.toList) [Line' NonEmpty]
rest)

isComment :: Text -> Maybe Text
isComment :: Text -> Maybe Text
isComment Text
xs =
    Text -> Text -> Maybe Text
T.stripPrefix Text
"-- | " Text
xs

data LinesWithComments = LinesWithComments
    { LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines :: NonEmpty (Line' NonEmpty)
    , LinesWithComments -> [Text]
lwcComments :: [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)

-- TODO: drop this and use <> when 8.2 isn't supported anymore so the
-- monoid/semigroup nonsense isn't annoying
appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc LinesWithComments
a LinesWithComments
b =
    NonEmpty (Line' NonEmpty) -> [Text] -> LinesWithComments
LinesWithComments ((Line' NonEmpty
 -> NonEmpty (Line' NonEmpty) -> NonEmpty (Line' NonEmpty))
-> NonEmpty (Line' NonEmpty)
-> NonEmpty (Line' NonEmpty)
-> NonEmpty (Line' NonEmpty)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Line' NonEmpty
-> NonEmpty (Line' NonEmpty) -> NonEmpty (Line' NonEmpty)
forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons (LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines LinesWithComments
b) (LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines LinesWithComments
a)) (LinesWithComments -> [Text]
lwcComments LinesWithComments
a [Text] -> [Text] -> [Text]
forall a. Monoid a => a -> a -> a
`mappend` LinesWithComments -> [Text]
lwcComments LinesWithComments
b)

newLine :: Line' NonEmpty -> LinesWithComments
newLine :: Line' NonEmpty -> LinesWithComments
newLine Line' NonEmpty
l = NonEmpty (Line' NonEmpty) -> [Text] -> LinesWithComments
LinesWithComments (Line' NonEmpty -> NonEmpty (Line' NonEmpty)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Line' NonEmpty
l) []

firstLine :: LinesWithComments -> Line' NonEmpty
firstLine :: LinesWithComments -> Line' NonEmpty
firstLine = NonEmpty (Line' NonEmpty) -> Line' NonEmpty
forall a. NonEmpty a -> a
NEL.head (NonEmpty (Line' NonEmpty) -> Line' NonEmpty)
-> (LinesWithComments -> NonEmpty (Line' NonEmpty))
-> LinesWithComments
-> Line' NonEmpty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines

consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments
consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments
consLine Line' NonEmpty
l LinesWithComments
lwc = LinesWithComments
lwc { lwcLines :: NonEmpty (Line' NonEmpty)
lwcLines = Line' NonEmpty
-> NonEmpty (Line' NonEmpty) -> NonEmpty (Line' NonEmpty)
forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons Line' NonEmpty
l (LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines LinesWithComments
lwc) }

consComment :: Text -> LinesWithComments -> LinesWithComments
consComment :: Text -> LinesWithComments -> LinesWithComments
consComment 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 :: [Line' NonEmpty] -> [LinesWithComments]
associateLines :: [Line' NonEmpty] -> [LinesWithComments]
associateLines [Line' NonEmpty]
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' NonEmpty -> [LinesWithComments] -> [LinesWithComments])
-> [LinesWithComments] -> [Line' NonEmpty] -> [LinesWithComments]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Line' NonEmpty -> [LinesWithComments] -> [LinesWithComments]
toLinesWithComments [] [Line' NonEmpty]
lines
  where
    toLinesWithComments :: Line' NonEmpty -> [LinesWithComments] -> [LinesWithComments]
toLinesWithComments Line' NonEmpty
line [LinesWithComments]
linesWithComments =
        case [LinesWithComments]
linesWithComments of
            [] ->
                [Line' NonEmpty -> LinesWithComments
newLine Line' NonEmpty
line]
            (LinesWithComments
lwc : [LinesWithComments]
lwcs) ->
                case Text -> Maybe Text
isComment (NonEmpty Text -> Text
forall a. NonEmpty a -> a
NEL.head (Line' NonEmpty -> NonEmpty Text
forall (f :: * -> *). Line' f -> f Text
tokens Line' NonEmpty
line)) of
                    Just Text
comment
                        | Line' NonEmpty -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent Line' NonEmpty
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lowestIndent ->
                        Text -> LinesWithComments -> LinesWithComments
consComment Text
comment LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
                    Maybe Text
_ ->
                        if Line' NonEmpty -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent Line' NonEmpty
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Line' NonEmpty -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent (LinesWithComments -> Line' NonEmpty
firstLine LinesWithComments
lwc)
                        then
                            Line' NonEmpty -> LinesWithComments -> LinesWithComments
consLine Line' NonEmpty
line LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
                        else
                            Line' NonEmpty -> LinesWithComments
newLine Line' NonEmpty
line LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs

    lowestIndent :: Int
lowestIndent = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int)
-> ([Line' NonEmpty] -> [Int]) -> [Line' NonEmpty] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line' NonEmpty -> Int) -> [Line' NonEmpty] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line' NonEmpty -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent ([Line' NonEmpty] -> Int) -> [Line' NonEmpty] -> Int
forall a b. (a -> b) -> a -> b
$ [Line' NonEmpty]
lines
    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 = NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (NonEmpty Int -> Int)
-> (LinesWithComments -> NonEmpty Int) -> LinesWithComments -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line' NonEmpty -> Int)
-> NonEmpty (Line' NonEmpty) -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line' NonEmpty -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent (NonEmpty (Line' NonEmpty) -> NonEmpty Int)
-> (LinesWithComments -> NonEmpty (Line' NonEmpty))
-> LinesWithComments
-> NonEmpty Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines

skipEmpty :: [Line' []] -> [Line' NonEmpty]
skipEmpty :: [Line] -> [Line' NonEmpty]
skipEmpty = (Line -> Maybe (Line' NonEmpty)) -> [Line] -> [Line' NonEmpty]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((forall x. [x] -> Maybe (NonEmpty x))
-> Line -> Maybe (Line' NonEmpty)
forall (t :: * -> *) (f :: * -> *) (g :: * -> *).
Functor t =>
(forall x. f x -> t (g x)) -> Line' f -> t (Line' g)
traverseLine forall x. [x] -> Maybe (NonEmpty x)
NEL.nonEmpty)

setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef
setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef
setComments [] = UnboundEntityDef -> UnboundEntityDef
forall a. a -> a
id
setComments [Text]
comments =
    (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overUnboundEntityDef (\EntityDef
ed -> EntityDef
ed { entityComments :: Maybe Text
entityComments = Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
T.unlines [Text]
comments) })

fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef]
fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef]
fixForeignKeysAll [UnboundEntityDef]
unEnts = (UnboundEntityDef -> EntityDef)
-> [UnboundEntityDef] -> [EntityDef]
forall a b. (a -> b) -> [a] -> [b]
map UnboundEntityDef -> EntityDef
fixForeignKeys [UnboundEntityDef]
unEnts
  where
    ents :: [EntityDef]
ents = (UnboundEntityDef -> EntityDef)
-> [UnboundEntityDef] -> [EntityDef]
forall a b. (a -> b) -> [a] -> [b]
map UnboundEntityDef -> EntityDef
unboundEntityDef [UnboundEntityDef]
unEnts
    entLookup :: Map HaskellName EntityDef
entLookup = [(HaskellName, EntityDef)] -> Map HaskellName EntityDef
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(HaskellName, EntityDef)] -> Map HaskellName EntityDef)
-> [(HaskellName, EntityDef)] -> Map HaskellName EntityDef
forall a b. (a -> b) -> a -> b
$ (EntityDef -> (HaskellName, EntityDef))
-> [EntityDef] -> [(HaskellName, EntityDef)]
forall a b. (a -> b) -> [a] -> [b]
map (\EntityDef
e -> (EntityDef -> HaskellName
entityHaskell EntityDef
e, EntityDef
e)) [EntityDef]
ents

    fixForeignKeys :: UnboundEntityDef -> EntityDef
    fixForeignKeys :: UnboundEntityDef -> EntityDef
fixForeignKeys (UnboundEntityDef [UnboundForeignDef]
foreigns EntityDef
ent) =
      EntityDef
ent { entityForeigns :: [ForeignDef]
entityForeigns = (UnboundForeignDef -> ForeignDef)
-> [UnboundForeignDef] -> [ForeignDef]
forall a b. (a -> b) -> [a] -> [b]
map (EntityDef -> UnboundForeignDef -> ForeignDef
fixForeignKey EntityDef
ent) [UnboundForeignDef]
foreigns }

    -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns
    fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef
    fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef
fixForeignKey EntityDef
ent (UnboundForeignDef [Text]
foreignFieldTexts ForeignDef
fdef) =
        let pentError :: EntityDef
pentError =
                String -> EntityDef
forall a. HasCallStack => String -> a
error (String -> EntityDef) -> String -> EntityDef
forall a b. (a -> b) -> a -> b
$ String
"could not find table " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HaskellName -> String
forall a. Show a => a -> String
show (ForeignDef -> HaskellName
foreignRefTableHaskell ForeignDef
fdef)
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" fdef=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ForeignDef -> String
forall a. Show a => a -> String
show ForeignDef
fdef String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" allnames="
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show ((UnboundEntityDef -> Text) -> [UnboundEntityDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HaskellName -> Text
unHaskellName (HaskellName -> Text)
-> (UnboundEntityDef -> HaskellName) -> UnboundEntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> HaskellName
entityHaskell (EntityDef -> HaskellName)
-> (UnboundEntityDef -> EntityDef)
-> UnboundEntityDef
-> HaskellName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef) [UnboundEntityDef]
unEnts)
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\nents=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [EntityDef] -> String
forall a. Show a => a -> String
show [EntityDef]
ents
            pent :: EntityDef
pent =
                EntityDef -> Maybe EntityDef -> EntityDef
forall a. a -> Maybe a -> a
fromMaybe EntityDef
pentError (Maybe EntityDef -> EntityDef) -> Maybe EntityDef -> EntityDef
forall a b. (a -> b) -> a -> b
$ HaskellName -> Map HaskellName EntityDef -> Maybe EntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ForeignDef -> HaskellName
foreignRefTableHaskell ForeignDef
fdef) Map HaskellName EntityDef
entLookup
         in
            case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
pent of
                Just CompositeDef
pdef ->
                    if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
foreignFieldTexts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [FieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef)
                    then
                        CompositeDef -> ForeignDef
lengthError CompositeDef
pdef
                    else
                        let
                            fds_ffs :: [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
fds_ffs =
                                (Text
 -> FieldDef
 -> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName))))
-> [Text]
-> [FieldDef]
-> [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (EntityDef
-> Text
-> FieldDef
-> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
toForeignFields EntityDef
pent)
                                    [Text]
foreignFieldTexts
                                    (CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef)
                            dbname :: Text
dbname =
                                DBName -> Text
unDBName (EntityDef -> DBName
entityDB EntityDef
pent)
                            oldDbName :: Text
oldDbName =
                                DBName -> Text
unDBName (ForeignDef -> DBName
foreignRefTableDBName ForeignDef
fdef)
                         in ForeignDef
fdef
                            { foreignFields :: [((HaskellName, DBName), (HaskellName, DBName))]
foreignFields = ((FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
 -> ((HaskellName, DBName), (HaskellName, DBName)))
-> [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
-> [((HaskellName, DBName), (HaskellName, DBName))]
forall a b. (a -> b) -> [a] -> [b]
map (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
-> ((HaskellName, DBName), (HaskellName, DBName))
forall a b. (a, b) -> b
snd [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
fds_ffs
                            , foreignNullable :: Bool
foreignNullable = [FieldDef] -> Bool
setNull ([FieldDef] -> Bool) -> [FieldDef] -> Bool
forall a b. (a -> b) -> a -> b
$ ((FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
 -> FieldDef)
-> [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
-> [FieldDef]
forall a b. (a -> b) -> [a] -> [b]
map (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
-> FieldDef
forall a b. (a, b) -> a
fst [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
fds_ffs
                            , foreignRefTableDBName :: DBName
foreignRefTableDBName =
                                Text -> DBName
DBName Text
dbname
                            , foreignConstraintNameDBName :: DBName
foreignConstraintNameDBName =
                                Text -> DBName
DBName
                                (Text -> DBName) -> (DBName -> Text) -> DBName -> DBName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
oldDbName Text
dbname (Text -> Text) -> (DBName -> Text) -> DBName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBName -> Text
unDBName
                                (DBName -> DBName) -> DBName -> DBName
forall a b. (a -> b) -> a -> b
$ ForeignDef -> DBName
foreignConstraintNameDBName ForeignDef
fdef
                            }
                Maybe CompositeDef
Nothing ->
                    String -> ForeignDef
forall a. HasCallStack => String -> a
error (String -> ForeignDef) -> String -> ForeignDef
forall a b. (a -> b) -> a -> b
$ String
"no explicit primary key fdef="String -> ShowS
forall a. [a] -> [a] -> [a]
++ForeignDef -> String
forall a. Show a => a -> String
show ForeignDef
fdefString -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ent="String -> ShowS
forall a. [a] -> [a] -> [a]
++EntityDef -> String
forall a. Show a => a -> String
show EntityDef
ent
      where
        setNull :: [FieldDef] -> Bool
        setNull :: [FieldDef] -> Bool
setNull [] = String -> Bool
forall a. HasCallStack => String -> a
error String
"setNull: impossible!"
        setNull (FieldDef
fd:[FieldDef]
fds) = let nullSetting :: Bool
nullSetting = FieldDef -> Bool
isNull FieldDef
fd in
          if (FieldDef -> Bool) -> [FieldDef] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Bool
nullSetting Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
==) (Bool -> Bool) -> (FieldDef -> Bool) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> Bool
isNull) [FieldDef]
fds then Bool
nullSetting
            else String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"foreign key columns must all be nullable or non-nullable"
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show ((FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HaskellName -> Text
unHaskellName (HaskellName -> Text)
-> (FieldDef -> HaskellName) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> HaskellName
fieldHaskell) (FieldDef
fdFieldDef -> [FieldDef] -> [FieldDef]
forall a. a -> [a] -> [a]
:[FieldDef]
fds))
        isNull :: FieldDef -> Bool
isNull = (IsNullable
NotNullable IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
/=) (IsNullable -> Bool)
-> (FieldDef -> IsNullable) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> IsNullable
nullable ([Text] -> IsNullable)
-> (FieldDef -> [Text]) -> FieldDef -> IsNullable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> [Text]
fieldAttrs

        toForeignFields :: EntityDef
-> Text
-> FieldDef
-> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
toForeignFields EntityDef
pent Text
fieldText FieldDef
pfd =
           case FieldDef
-> HaskellName -> [FieldDef] -> HaskellName -> Maybe String
chktypes FieldDef
fd HaskellName
haskellField (EntityDef -> [FieldDef]
entityFields EntityDef
pent) HaskellName
pfh of
               Just String
err -> String
-> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
forall a. HasCallStack => String -> a
error String
err
               Maybe String
Nothing -> (FieldDef
fd, ((HaskellName
haskellField, FieldDef -> DBName
fieldDB FieldDef
fd), (HaskellName
pfh, DBName
pfdb)))
          where
            fd :: FieldDef
fd = [FieldDef] -> HaskellName -> FieldDef
getFd (EntityDef -> [FieldDef]
entityFields EntityDef
ent) HaskellName
haskellField

            haskellField :: HaskellName
haskellField = Text -> HaskellName
HaskellName Text
fieldText
            (HaskellName
pfh, DBName
pfdb) = (FieldDef -> HaskellName
fieldHaskell FieldDef
pfd, FieldDef -> DBName
fieldDB FieldDef
pfd)

            chktypes :: FieldDef -> HaskellName -> [FieldDef] -> HaskellName -> Maybe String
            chktypes :: FieldDef
-> HaskellName -> [FieldDef] -> HaskellName -> Maybe String
chktypes FieldDef
ffld HaskellName
_fkey [FieldDef]
pflds HaskellName
pkey =
                if FieldDef -> FieldType
fieldType FieldDef
ffld FieldType -> FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== FieldDef -> FieldType
fieldType FieldDef
pfld then Maybe String
forall a. Maybe a
Nothing
                  else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"fieldType mismatch: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldType -> String
forall a. Show a => a -> String
show (FieldDef -> FieldType
fieldType FieldDef
ffld) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldType -> String
forall a. Show a => a -> String
show (FieldDef -> FieldType
fieldType FieldDef
pfld)
              where
                pfld :: FieldDef
pfld = [FieldDef] -> HaskellName -> FieldDef
getFd [FieldDef]
pflds HaskellName
pkey

            entName :: HaskellName
entName = EntityDef -> HaskellName
entityHaskell EntityDef
ent
            getFd :: [FieldDef] -> HaskellName -> FieldDef
getFd [] HaskellName
t = String -> FieldDef
forall a. HasCallStack => String -> a
error (String -> FieldDef) -> String -> FieldDef
forall a b. (a -> b) -> a -> b
$ String
"foreign key constraint for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (HaskellName -> Text
unHaskellName HaskellName
entName)
                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" unknown column: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HaskellName -> String
forall a. Show a => a -> String
show HaskellName
t
            getFd (FieldDef
f:[FieldDef]
fs) HaskellName
t
                | FieldDef -> HaskellName
fieldHaskell FieldDef
f HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== HaskellName
t = FieldDef
f
                | Bool
otherwise = [FieldDef] -> HaskellName -> FieldDef
getFd [FieldDef]
fs HaskellName
t

        lengthError :: CompositeDef -> ForeignDef
lengthError CompositeDef
pdef = String -> ForeignDef
forall a. HasCallStack => String -> a
error (String -> ForeignDef) -> String -> ForeignDef
forall a b. (a -> b) -> a -> b
$ String
"found " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
foreignFieldTexts) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" fkeys and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([FieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" pkeys: fdef=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ForeignDef -> String
forall a. Show a => a -> String
show ForeignDef
fdef String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" pdef=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CompositeDef -> String
forall a. Show a => a -> String
show CompositeDef
pdef


data UnboundEntityDef = UnboundEntityDef
                        { UnboundEntityDef -> [UnboundForeignDef]
_unboundForeignDefs :: [UnboundForeignDef]
                        , UnboundEntityDef -> EntityDef
unboundEntityDef :: EntityDef
                        }

overUnboundEntityDef
    :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overUnboundEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overUnboundEntityDef EntityDef -> EntityDef
f UnboundEntityDef
ubed =
    UnboundEntityDef
ubed { unboundEntityDef :: EntityDef
unboundEntityDef = EntityDef -> EntityDef
f (UnboundEntityDef -> EntityDef
unboundEntityDef UnboundEntityDef
ubed) }

lookupKeyVal :: Text -> [Text] -> Maybe Text
lookupKeyVal :: Text -> [Text] -> Maybe Text
lookupKeyVal Text
key = Text -> [Text] -> Maybe Text
lookupPrefix (Text -> [Text] -> Maybe Text) -> Text -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
key Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"="

lookupPrefix :: Text -> [Text] -> Maybe Text
lookupPrefix :: Text -> [Text] -> Maybe Text
lookupPrefix Text
prefix = [Maybe Text] -> Maybe Text
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Text] -> Maybe Text)
-> ([Text] -> [Maybe Text]) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe Text) -> [Text] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Maybe Text
T.stripPrefix Text
prefix)

-- | Construct an entity definition.
mkEntityDef :: PersistSettings
            -> Text -- ^ name
            -> [Attr] -- ^ entity attributes
            -> [Line] -- ^ indented lines
            -> UnboundEntityDef
mkEntityDef :: PersistSettings -> Text -> [Text] -> [Line] -> UnboundEntityDef
mkEntityDef PersistSettings
ps Text
name [Text]
entattribs [Line]
lines =
  [UnboundForeignDef] -> EntityDef -> UnboundEntityDef
UnboundEntityDef [UnboundForeignDef]
foreigns (EntityDef -> UnboundEntityDef) -> EntityDef -> UnboundEntityDef
forall a b. (a -> b) -> a -> b
$
    EntityDef :: HaskellName
-> DBName
-> FieldDef
-> [Text]
-> [FieldDef]
-> [UniqueDef]
-> [ForeignDef]
-> [Text]
-> Map Text [[Text]]
-> Bool
-> Maybe Text
-> EntityDef
EntityDef
        { entityHaskell :: HaskellName
entityHaskell = HaskellName
entName
        , entityDB :: DBName
entityDB = Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
name' [Text]
entattribs
        -- idField is the user-specified Id
        -- otherwise useAutoIdField
        -- but, adjust it if the user specified a Primary
        , entityId :: FieldDef
entityId = (Maybe CompositeDef -> FieldDef -> FieldDef
setComposite Maybe CompositeDef
primaryComposite (FieldDef -> FieldDef) -> FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$ FieldDef -> Maybe FieldDef -> FieldDef
forall a. a -> Maybe a -> a
fromMaybe FieldDef
autoIdField Maybe FieldDef
idField)
        , entityAttrs :: [Text]
entityAttrs = [Text]
entattribs
        , entityFields :: [FieldDef]
entityFields = [FieldDef]
cols
        , entityUniques :: [UniqueDef]
entityUniques = [UniqueDef]
uniqs
        , entityForeigns :: [ForeignDef]
entityForeigns = []
        , entityDerives :: [Text]
entityDerives = [Text]
derives
        , entityExtra :: Map Text [[Text]]
entityExtra = Map Text [[Text]]
extras
        , entitySum :: Bool
entitySum = Bool
isSum
        , entityComments :: Maybe Text
entityComments = Maybe Text
forall a. Maybe a
comments
        }
  where
    comments :: Maybe a
comments = Maybe a
forall a. Maybe a
Nothing
    entName :: HaskellName
entName = Text -> HaskellName
HaskellName Text
name'
    (Bool
isSum, Text
name') =
        case Text -> Maybe (Char, Text)
T.uncons Text
name of
            Just (Char
'+', Text
x) -> (Bool
True, Text
x)
            Maybe (Char, Text)
_ -> (Bool
False, Text
name)
    ([[Text]]
attribs, Map Text [[Text]]
extras) = [Line] -> ([[Text]], Map Text [[Text]])
splitExtras [Line]
lines

    attribPrefix :: Text -> Maybe Text
attribPrefix = (Text -> [Text] -> Maybe Text) -> [Text] -> Text -> Maybe Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [Text] -> Maybe Text
lookupKeyVal [Text]
entattribs
    idName :: Maybe Text
idName | Just Text
_ <- Text -> Maybe Text
attribPrefix Text
"id" = String -> Maybe Text
forall a. HasCallStack => String -> a
error String
"id= is deprecated, ad a field named 'Id' and use sql="
           | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing

    (Maybe FieldDef
idField, Maybe CompositeDef
primaryComposite, [UniqueDef]
uniqs, [UnboundForeignDef]
foreigns) = ((Maybe FieldDef, Maybe CompositeDef, [UniqueDef],
  [UnboundForeignDef])
 -> [Text]
 -> (Maybe FieldDef, Maybe CompositeDef, [UniqueDef],
     [UnboundForeignDef]))
-> (Maybe FieldDef, Maybe CompositeDef, [UniqueDef],
    [UnboundForeignDef])
-> [[Text]]
-> (Maybe FieldDef, Maybe CompositeDef, [UniqueDef],
    [UnboundForeignDef])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Maybe FieldDef
mid, Maybe CompositeDef
mp, [UniqueDef]
us, [UnboundForeignDef]
fs) [Text]
attr ->
        let (Maybe FieldDef
i, Maybe CompositeDef
p, Maybe UniqueDef
u, Maybe UnboundForeignDef
f) = PersistSettings
-> Text
-> [FieldDef]
-> [Text]
-> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef,
    Maybe UnboundForeignDef)
takeConstraint PersistSettings
ps Text
name' [FieldDef]
cols [Text]
attr
            squish :: [a] -> Maybe a -> [a]
squish [a]
xs Maybe a
m = [a]
xs [a] -> [a] -> [a]
forall a. Monoid a => a -> a -> a
`mappend` Maybe a -> [a]
forall a. Maybe a -> [a]
maybeToList Maybe a
m
        in (Maybe FieldDef -> Maybe FieldDef -> Maybe FieldDef
forall x. Show x => Maybe x -> Maybe x -> Maybe x
just1 Maybe FieldDef
mid Maybe FieldDef
i, Maybe CompositeDef -> Maybe CompositeDef -> Maybe CompositeDef
forall x. Show x => Maybe x -> Maybe x -> Maybe x
just1 Maybe CompositeDef
mp Maybe CompositeDef
p, [UniqueDef] -> Maybe UniqueDef -> [UniqueDef]
forall a. [a] -> Maybe a -> [a]
squish [UniqueDef]
us Maybe UniqueDef
u, [UnboundForeignDef]
-> Maybe UnboundForeignDef -> [UnboundForeignDef]
forall a. [a] -> Maybe a -> [a]
squish [UnboundForeignDef]
fs Maybe UnboundForeignDef
f)) (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, [],[]) [[Text]]
attribs

    derives :: [Text]
derives = [[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]]
attribs

    cols :: [FieldDef]
    cols :: [FieldDef]
cols = [FieldDef] -> [FieldDef]
forall a. [a] -> [a]
reverse ([FieldDef] -> [FieldDef])
-> ([[Text]] -> [FieldDef]) -> [[Text]] -> [FieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FieldDef], [Text]) -> [FieldDef]
forall a b. (a, b) -> a
fst (([FieldDef], [Text]) -> [FieldDef])
-> ([[Text]] -> ([FieldDef], [Text])) -> [[Text]] -> [FieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> ([FieldDef], [Text]) -> ([FieldDef], [Text]))
-> ([FieldDef], [Text]) -> [[Text]] -> ([FieldDef], [Text])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Text] -> ([FieldDef], [Text]) -> ([FieldDef], [Text])
k ([], []) ([[Text]] -> [FieldDef]) -> [[Text]] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [[Text]]
forall a. [a] -> [a]
reverse [[Text]]
attribs
    k :: [Text] -> ([FieldDef], [Text]) -> ([FieldDef], [Text])
k [Text]
x (![FieldDef]
acc, ![Text]
comments) =
        case Text -> Maybe Text
isComment (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text]
x of
            Just Text
comment ->
                ([FieldDef]
acc, Text
comment Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
comments)
            Maybe Text
Nothing ->
                ( ([FieldDef] -> [FieldDef])
-> (FieldDef -> [FieldDef] -> [FieldDef])
-> Maybe FieldDef
-> [FieldDef]
-> [FieldDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [FieldDef] -> [FieldDef]
forall a. a -> a
id (:) ([Text] -> FieldDef -> FieldDef
setFieldComments [Text]
comments (FieldDef -> FieldDef) -> Maybe FieldDef -> Maybe FieldDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistSettings -> [Text] -> Maybe FieldDef
takeColsEx PersistSettings
ps [Text]
x) [FieldDef]
acc
                , []
                )
    setFieldComments :: [Text] -> FieldDef -> FieldDef
setFieldComments [] FieldDef
x = FieldDef
x
    setFieldComments [Text]
xs FieldDef
fld =
        FieldDef
fld { fieldComments :: Maybe Text
fieldComments = Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
T.unlines [Text]
xs) }

    autoIdField :: FieldDef
autoIdField = PersistSettings
-> HaskellName -> Maybe DBName -> SqlType -> FieldDef
mkAutoIdField PersistSettings
ps HaskellName
entName (Text -> DBName
DBName (Text -> DBName) -> Maybe Text -> Maybe DBName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Text
idName) SqlType
idSqlType
    idSqlType :: SqlType
idSqlType = SqlType
-> (CompositeDef -> SqlType) -> Maybe CompositeDef -> SqlType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SqlType
SqlInt64 (SqlType -> CompositeDef -> SqlType
forall a b. a -> b -> a
const (SqlType -> CompositeDef -> SqlType)
-> SqlType -> CompositeDef -> SqlType
forall a b. (a -> b) -> a -> b
$ Text -> SqlType
SqlOther Text
"Primary Key") Maybe CompositeDef
primaryComposite

    setComposite :: Maybe CompositeDef -> FieldDef -> FieldDef
setComposite Maybe CompositeDef
Nothing FieldDef
fd = FieldDef
fd
    setComposite (Just CompositeDef
c) FieldDef
fd = FieldDef
fd { fieldReference :: ReferenceDef
fieldReference = CompositeDef -> ReferenceDef
CompositeRef CompositeDef
c }


just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x
just1 :: Maybe x -> Maybe x -> Maybe x
just1 (Just x
x) (Just x
y) = String -> Maybe x
forall a. HasCallStack => String -> a
error (String -> Maybe x) -> String -> Maybe x
forall a b. (a -> b) -> a -> b
$ String
"expected only one of: "
  String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` x -> String
forall a. Show a => a -> String
show x
x String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` String
" " String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` x -> String
forall a. Show a => a -> String
show x
y
just1 Maybe x
x Maybe x
y = Maybe x
x Maybe x -> Maybe x -> Maybe x
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe x
y


mkAutoIdField :: PersistSettings -> HaskellName -> Maybe DBName -> SqlType -> FieldDef
mkAutoIdField :: PersistSettings
-> HaskellName -> Maybe DBName -> SqlType -> FieldDef
mkAutoIdField PersistSettings
ps HaskellName
entName Maybe DBName
idName SqlType
idSqlType = FieldDef :: HaskellName
-> DBName
-> FieldType
-> SqlType
-> [Text]
-> Bool
-> ReferenceDef
-> Maybe Text
-> FieldDef
FieldDef
      { fieldHaskell :: HaskellName
fieldHaskell = Text -> HaskellName
HaskellName Text
"Id"
      -- this should be modeled as a Maybe
      -- but that sucks for non-ID field
      -- TODO: use a sumtype FieldDef | IdFieldDef
      , fieldDB :: DBName
fieldDB = DBName -> Maybe DBName -> DBName
forall a. a -> Maybe a -> a
fromMaybe (Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps) Maybe DBName
idName
      , 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
$ Text -> Text
keyConName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HaskellName -> Text
unHaskellName HaskellName
entName
      , fieldSqlType :: SqlType
fieldSqlType = SqlType
idSqlType
      -- the primary field is actually a reference to the entity
      , fieldReference :: ReferenceDef
fieldReference = HaskellName -> FieldType -> ReferenceDef
ForeignRef HaskellName
entName  FieldType
defaultReferenceTypeCon
      , fieldAttrs :: [Text]
fieldAttrs = []
      , fieldStrict :: Bool
fieldStrict = Bool
True
      , fieldComments :: Maybe Text
fieldComments = Maybe Text
forall a. Maybe a
Nothing
      }

defaultReferenceTypeCon :: FieldType
defaultReferenceTypeCon :: FieldType
defaultReferenceTypeCon = Maybe Text -> Text -> FieldType
FTTypeCon (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Data.Int") Text
"Int64"

keyConName :: Text -> Text
keyConName :: Text -> Text
keyConName Text
entName = Text
entName Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"Id"


splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]])
splitExtras :: [Line] -> ([[Text]], Map Text [[Text]])
splitExtras [] = ([], Map Text [[Text]]
forall k a. Map k a
M.empty)
splitExtras (Line Int
indent [Text
name]:[Line]
rest)
    | Bool -> Bool
not (Text -> Bool
T.null Text
name) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head 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
> Int
indent) (Int -> Bool) -> (Line -> Int) -> Line -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent) [Line]
rest
            ([[Text]]
x, Map Text [[Text]]
y) = [Line] -> ([[Text]], Map Text [[Text]])
splitExtras [Line]
rest'
         in ([[Text]]
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 ((Line -> [Text]) -> [Line] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map Line -> [Text]
forall (f :: * -> *). Line' f -> f Text
tokens [Line]
children) Map Text [[Text]]
y)
splitExtras (Line Int
_ [Text]
ts:[Line]
rest) =
    let ([[Text]]
x, Map Text [[Text]]
y) = [Line] -> ([[Text]], Map Text [[Text]])
splitExtras [Line]
rest
     in ([Text]
ts[Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
:[[Text]]
x, Map Text [[Text]]
y)

takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef
takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef
takeColsEx =
    (Text -> String -> Maybe FieldDef)
-> PersistSettings -> [Text] -> Maybe FieldDef
takeCols
        (\Text
ft String
perr -> String -> Maybe FieldDef
forall a. HasCallStack => String -> a
error (String -> Maybe FieldDef) -> String -> Maybe FieldDef
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 FieldDef)
    -> PersistSettings
    -> [Text]
    -> Maybe FieldDef
takeCols :: (Text -> String -> Maybe FieldDef)
-> PersistSettings -> [Text] -> Maybe FieldDef
takeCols Text -> String -> Maybe FieldDef
_ PersistSettings
_ (Text
"deriving":[Text]
_) = Maybe FieldDef
forall a. Maybe a
Nothing
takeCols Text -> String -> Maybe FieldDef
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 FieldDef
onErr Text
typ String
err
            Right FieldType
ft -> FieldDef -> Maybe FieldDef
forall a. a -> Maybe a
Just FieldDef :: HaskellName
-> DBName
-> FieldType
-> SqlType
-> [Text]
-> Bool
-> ReferenceDef
-> Maybe Text
-> FieldDef
FieldDef
                { fieldHaskell :: HaskellName
fieldHaskell = Text -> HaskellName
HaskellName Text
n
                , fieldDB :: DBName
fieldDB = Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n [Text]
rest
                , fieldType :: FieldType
fieldType = FieldType
ft
                , fieldSqlType :: SqlType
fieldSqlType = Text -> SqlType
SqlOther (Text -> SqlType) -> Text -> SqlType
forall a b. (a -> b) -> a -> b
$ Text
"SqlType unset for " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
n
                , fieldAttrs :: [Text]
fieldAttrs = [Text]
rest
                , fieldStrict :: Bool
fieldStrict = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Bool
psStrictFields PersistSettings
ps) Maybe Bool
mstrict
                , fieldReference :: ReferenceDef
fieldReference = ReferenceDef
NoReference
                , fieldComments :: Maybe Text
fieldComments = Maybe Text
forall a. Maybe a
Nothing
                }
  where
    (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 FieldDef
_ PersistSettings
_ [Text]
_ = Maybe FieldDef
forall a. Maybe a
Nothing

getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n [] = PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
n
getDbName PersistSettings
ps Text
n (Text
a:[Text]
as) = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n [Text]
as) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"sql=" Text
a

takeConstraint :: PersistSettings
          -> Text
          -> [FieldDef]
          -> [Text]
          -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef)
takeConstraint :: PersistSettings
-> Text
-> [FieldDef]
-> [Text]
-> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef,
    Maybe UnboundForeignDef)
takeConstraint PersistSettings
ps Text
tableName [FieldDef]
defs (Text
n:[Text]
rest) | Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head Text
n) = (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef,
 Maybe UnboundForeignDef)
takeConstraint'
    where
      takeConstraint' :: (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef,
 Maybe UnboundForeignDef)
takeConstraint'
            | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Unique"  = (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, UniqueDef -> Maybe UniqueDef
forall a. a -> Maybe a
Just (UniqueDef -> Maybe UniqueDef) -> UniqueDef -> Maybe UniqueDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [FieldDef] -> [Text] -> UniqueDef
takeUniq PersistSettings
ps Text
tableName [FieldDef]
defs [Text]
rest, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
            | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Foreign" = (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, UnboundForeignDef -> Maybe UnboundForeignDef
forall a. a -> Maybe a
Just (UnboundForeignDef -> Maybe UnboundForeignDef)
-> UnboundForeignDef -> Maybe UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ PersistSettings
-> Text -> [FieldDef] -> [Text] -> UnboundForeignDef
takeForeign PersistSettings
ps Text
tableName [FieldDef]
defs [Text]
rest)
            | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Primary" = (Maybe FieldDef
forall a. Maybe a
Nothing, CompositeDef -> Maybe CompositeDef
forall a. a -> Maybe a
Just (CompositeDef -> Maybe CompositeDef)
-> CompositeDef -> Maybe CompositeDef
forall a b. (a -> b) -> a -> b
$ [FieldDef] -> [Text] -> CompositeDef
takeComposite [FieldDef]
defs [Text]
rest, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
            | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Id"      = (FieldDef -> Maybe FieldDef
forall a. a -> Maybe a
Just (FieldDef -> Maybe FieldDef) -> FieldDef -> Maybe FieldDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> FieldDef
takeId PersistSettings
ps Text
tableName (Text
nText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest), Maybe CompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
            | Bool
otherwise      = (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, UniqueDef -> Maybe UniqueDef
forall a. a -> Maybe a
Just (UniqueDef -> Maybe UniqueDef) -> UniqueDef -> Maybe UniqueDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [FieldDef] -> [Text] -> UniqueDef
takeUniq PersistSettings
ps Text
"" [FieldDef]
defs (Text
nText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest), Maybe UnboundForeignDef
forall a. Maybe a
Nothing) -- retain compatibility with original unique constraint
takeConstraint PersistSettings
_ Text
_ [FieldDef]
_ [Text]
_ = (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)

-- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName.
-- need to re-work takeCols function
takeId :: PersistSettings -> Text -> [Text] -> FieldDef
takeId :: PersistSettings -> Text -> [Text] -> FieldDef
takeId PersistSettings
ps Text
tableName (Text
n:[Text]
rest) = FieldDef -> Maybe FieldDef -> FieldDef
forall a. a -> Maybe a -> a
fromMaybe (String -> FieldDef
forall a. HasCallStack => String -> a
error String
"takeId: impossible!") (Maybe FieldDef -> FieldDef) -> Maybe FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$ Maybe FieldDef -> Maybe FieldDef
setFieldDef (Maybe FieldDef -> Maybe FieldDef)
-> Maybe FieldDef -> Maybe FieldDef
forall a b. (a -> b) -> a -> b
$
    (Text -> String -> Maybe FieldDef)
-> PersistSettings -> [Text] -> Maybe FieldDef
takeCols (\Text
_ String
_ -> Maybe FieldDef
addDefaultIdType) PersistSettings
ps (Text
fieldText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest [Text] -> [Text] -> [Text]
forall a. Monoid a => a -> a -> a
`mappend` [Text]
setIdName)
  where
    field :: Text
field = case Text -> Maybe (Char, Text)
T.uncons Text
n of
      Maybe (Char, Text)
Nothing -> String -> Text
forall a. HasCallStack => String -> a
error String
"takeId: empty field"
      Just (Char
f, Text
ield) -> Char -> Char
toLower Char
f Char -> Text -> Text
`T.cons` Text
ield
    addDefaultIdType :: Maybe FieldDef
addDefaultIdType = PersistSettings -> [Text] -> Maybe FieldDef
takeColsEx PersistSettings
ps (Text
field Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
keyCon Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest [Text] -> [Text] -> [Text]
forall a. Monoid a => a -> a -> a
`mappend` [Text]
setIdName)
    setFieldDef :: Maybe FieldDef -> Maybe FieldDef
setFieldDef = (FieldDef -> FieldDef) -> Maybe FieldDef -> Maybe FieldDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldDef
fd ->
      let refFieldType :: FieldType
refFieldType = if FieldDef -> FieldType
fieldType FieldDef
fd FieldType -> FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
keyCon
              then FieldType
defaultReferenceTypeCon
              else FieldDef -> FieldType
fieldType FieldDef
fd
      in FieldDef
fd { fieldReference :: ReferenceDef
fieldReference = HaskellName -> FieldType -> ReferenceDef
ForeignRef (Text -> HaskellName
HaskellName Text
tableName) (FieldType -> ReferenceDef) -> FieldType -> ReferenceDef
forall a b. (a -> b) -> a -> b
$ FieldType
refFieldType
            })
    keyCon :: Text
keyCon = Text -> Text
keyConName Text
tableName
    -- this will be ignored if there is already an existing sql=
    -- TODO: I think there is a ! ignore syntax that would screw this up
    setIdName :: [Text]
setIdName = [Text
"sql=" Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` PersistSettings -> Text
psIdName PersistSettings
ps]
takeId PersistSettings
_ Text
tableName [Text]
_ = String -> FieldDef
forall a. HasCallStack => String -> a
error (String -> FieldDef) -> String -> FieldDef
forall a b. (a -> b) -> a -> b
$ String
"empty Id field for " String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` Text -> String
forall a. Show a => a -> String
show Text
tableName


takeComposite :: [FieldDef]
              -> [Text]
              -> CompositeDef
takeComposite :: [FieldDef] -> [Text] -> CompositeDef
takeComposite [FieldDef]
fields [Text]
pkcols
        = [FieldDef] -> [Text] -> CompositeDef
CompositeDef
            ((Text -> FieldDef) -> [Text] -> [FieldDef]
forall a b. (a -> b) -> [a] -> [b]
map ([FieldDef] -> Text -> FieldDef
getDef [FieldDef]
fields) [Text]
pkcols)
            [Text]
attrs
  where
    ([Text]
_, [Text]
attrs) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text
"!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
pkcols
    getDef :: [FieldDef] -> Text -> FieldDef
getDef [] Text
t = String -> FieldDef
forall a. HasCallStack => String -> a
error (String -> FieldDef) -> String -> FieldDef
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 (FieldDef
d:[FieldDef]
ds) Text
t
        | FieldDef -> HaskellName
fieldHaskell FieldDef
d HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> HaskellName
HaskellName Text
t =
            if [Text] -> IsNullable
nullable (FieldDef -> [Text]
fieldAttrs FieldDef
d) IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
/= IsNullable
NotNullable
                then String -> FieldDef
forall a. HasCallStack => String -> a
error (String -> FieldDef) -> String -> FieldDef
forall a b. (a -> b) -> a -> b
$ String
"primary key column cannot be nullable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
                else FieldDef
d
        | Bool
otherwise = [FieldDef] -> Text -> FieldDef
getDef [FieldDef]
ds Text
t

-- Unique UppercaseConstraintName list of lowercasefields terminated
-- by ! or sql= such that a unique constraint can look like:
-- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force`
-- Here using sql= sets the name of the constraint.
takeUniq :: PersistSettings
         -> Text
         -> [FieldDef]
         -> [Text]
         -> UniqueDef
takeUniq :: PersistSettings -> Text -> [FieldDef] -> [Text] -> UniqueDef
takeUniq PersistSettings
ps Text
tableName [FieldDef]
defs (Text
n:[Text]
rest)
    | Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head Text
n)
        = HaskellName
-> DBName -> [(HaskellName, DBName)] -> [Text] -> UniqueDef
UniqueDef
            (Text -> HaskellName
HaskellName Text
n)
            DBName
dbName
            ((Text -> (HaskellName, DBName))
-> [Text] -> [(HaskellName, DBName)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> HaskellName
HaskellName (Text -> HaskellName)
-> (Text -> DBName) -> Text -> (HaskellName, DBName)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [FieldDef] -> Text -> DBName
getDBName [FieldDef]
defs) [Text]
fields)
            [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]
fields, [Text]
nonFields) =
      (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
isNonField [Text]
rest
    attrs :: [Text]
attrs = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isAttr [Text]
nonFields
    usualDbName :: DBName
usualDbName =
      Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (Text
tableName Text -> Text -> Text
`T.append` Text
n)
    sqlName :: Maybe DBName
    sqlName :: Maybe DBName
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 DBName
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]
_) -> DBName -> Maybe DBName
forall a. a -> Maybe a
Just (Text -> DBName
DBName Text
x)
            [Text]
_ -> Maybe DBName
forall a. Maybe a
Nothing
    dbName :: DBName
dbName = DBName -> Maybe DBName -> DBName
forall a. a -> Maybe a -> a
fromMaybe DBName
usualDbName Maybe DBName
sqlName
    getDBName :: [FieldDef] -> Text -> DBName
getDBName [] Text
t =
      String -> DBName
forall a. HasCallStack => String -> a
error (String -> DBName) -> String -> DBName
forall a b. (a -> b) -> a -> b
$ String
"Unknown column in unique constraint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [FieldDef] -> String
forall a. Show a => a -> String
show [FieldDef]
defs String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
attrs
    getDBName (FieldDef
d:[FieldDef]
ds) Text
t
        | FieldDef -> HaskellName
fieldHaskell FieldDef
d HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> HaskellName
HaskellName Text
t = FieldDef -> DBName
fieldDB FieldDef
d
        | Bool
otherwise = [FieldDef] -> Text -> DBName
getDBName [FieldDef]
ds Text
t
takeUniq PersistSettings
_ Text
tableName [FieldDef]
_ [Text]
xs =
  String -> UniqueDef
forall a. HasCallStack => String -> a
error (String -> UniqueDef) -> String -> 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

data UnboundForeignDef = UnboundForeignDef
                         { UnboundForeignDef -> [Text]
_unboundFields :: [Text] -- ^ fields in other entity
                         , UnboundForeignDef -> ForeignDef
_unboundForeignDef :: ForeignDef
                         }

takeForeign :: PersistSettings
          -> Text
          -> [FieldDef]
          -> [Text]
          -> UnboundForeignDef
takeForeign :: PersistSettings
-> Text -> [FieldDef] -> [Text] -> UnboundForeignDef
takeForeign PersistSettings
ps Text
tableName [FieldDef]
_defs (Text
refTableName:Text
n:[Text]
rest)
    | Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isLower (Text -> Char
T.head Text
n)
        = [Text] -> ForeignDef -> UnboundForeignDef
UnboundForeignDef [Text]
fields (ForeignDef -> UnboundForeignDef)
-> ForeignDef -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ ForeignDef :: HaskellName
-> DBName
-> HaskellName
-> DBName
-> [((HaskellName, DBName), (HaskellName, DBName))]
-> [Text]
-> Bool
-> ForeignDef
ForeignDef
            { foreignRefTableHaskell :: HaskellName
foreignRefTableHaskell =
                Text -> HaskellName
HaskellName Text
refTableName
            , foreignRefTableDBName :: DBName
foreignRefTableDBName =
                Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
refTableName
            , foreignConstraintNameHaskell :: HaskellName
foreignConstraintNameHaskell =
                Text -> HaskellName
HaskellName Text
n
            , foreignConstraintNameDBName :: DBName
foreignConstraintNameDBName =
                Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (Text
tableName Text -> Text -> Text
`T.append` Text
n)
            , foreignFields :: [((HaskellName, DBName), (HaskellName, DBName))]
foreignFields =
                []
            , foreignAttrs :: [Text]
foreignAttrs =
                [Text]
attrs
            , foreignNullable :: Bool
foreignNullable =
                Bool
False
            }
  where
    ([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

takeForeign PersistSettings
_ Text
tableName [FieldDef]
_ [Text]
xs = String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ String
"invalid foreign key 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 a lower case constraint name xs=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
xs

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

nullable :: [Text] -> IsNullable
nullable :: [Text] -> IsNullable
nullable [Text]
s
    | Text
"Maybe"    Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
s = WhyNullable -> IsNullable
Nullable WhyNullable
ByMaybeAttr
    | Text
"nullable" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
s = WhyNullable -> IsNullable
Nullable WhyNullable
ByNullableAttr
    | Bool
otherwise = IsNullable
NotNullable