{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE 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 "Database.Persist.TH" module 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)
@

Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo.
As a key with multiple fields, it is also a "composite key."

You can specify a @Primary@ key with a single field, too.

= 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"]]
@

= Foreign Keys

If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly.

@
Person
    name    Text

Dog
    name    Text
    owner   PersonId
@

This automatically creates a foreign key reference from @Dog@ to @Person@.
The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database.
If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred.

== OnUpdate and OnDelete

These options affects how a referring record behaves when the target record is changed.
There are several options:

* 'Restrict' - This is the default. It prevents the action from occurring.
* 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too.
* 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys.
* 'SetDefault' - This will set the column's value to the @default@ for the column, if specified.

To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action.

@
Record
    -- If the referred Foo is deleted or updated, then this record will
    -- also be deleted or updated.
    fooId   FooId   OnDeleteCascade OnUpdateCascade

    -- If the referred Bar is deleted, then we'll set the reference to
    -- 'Nothing'. If the referred Bar is updated, then we'll cascade the
    -- update.
    barId   BarId Maybe     OnDeleteSetNull OnUpdateCascade

    -- If the referred Baz is deleted, then we set to the default ID.
    bazId   BazId   OnDeleteSetDefault  default=1
@

Let's demonstrate this with a shopping cart example.

@
User
    name    Text

Cart
    user    UserId Maybe

CartItem
    cartId  CartId
    itemId  ItemId

Item
    name    Text
    price   Int
@

Let's consider how we want to handle deletions and updates.
If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@.

@
Cart
    user    UserId Maybe OnDeleteCascade OnUpdateCascade
@

If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database.
If a @Cart@ is deleted, though, then we just want to delete the @CartItem@.

@
CartItem
    cartId CartId   OnDeleteCascade
    itemId ItemId   OnDeleteSetDefault default=1
@

== @Foreign@ keyword

The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword.

A pseudo formal syntax for @Foreign@ is:

@
Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ]

columns := column0 [column1 column2 .. columnX]
references := References $(target-columns)
target-columns := target-column0 [target-column1 target-columns2 .. target-columnX]
@

Columns are the columns as defined on this entity.
@target-columns@ are the columns as defined on the target entity.

Let's look at some examples.

=== Composite Primary Key References

The most common use for this is to refer to a composite primary key.
Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column.

@
Email
    firstPart   Text
    secondPart  Text
    Primary firstPart secondPart

User
    name            Text
    emailFirstPart  Text
    emailSecondPart Text

    Foreign Email fk_user_email emailFirstPart emailSecondPart
@

If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key.
If we wanted to be fully redundant, we could specify the @References@ keyword.

@
    Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart
@

We can specify delete/cascade behavior directly after the target table.

@
    Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart
@

Now, if the email is deleted or updated, the user will be deleted or updated to match.

=== Non-Primary Key References

SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint.
Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent.
To do this, we must use the @References@ keyword.

@
User
    name    Text
    email   Text

    UniqueEmail email

Notification
    content Text
    sentTo  Text

    Foreign User fk_noti_user sentTo References email
@

If the target uniqueness constraint has multiple columns, then you must specify them independently.

@
User
    name            Text
    emailFirst      Text
    emailSecond     Text

    UniqueEmail emailFirst emailSecond

Notification
    content         Text
    sentToFirst     Text
    sentToSecond    Text

    Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond
@

= 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
    , parseLine
    , parseFieldType
    , associateLines
    , skipEmpty
    , LinesWithComments(..)
    , splitExtras
    , takeColsEx
#endif
    ) where

import Prelude hiding (lines)

import Control.Applicative ( Alternative((<|>)) )
import Control.Arrow ((&&&))
import Control.Monad (msum, mplus)
import Data.Char ( isLower, isSpace, isUpper, toLower )
import Data.List (find, foldl')
import qualified Data.List.NonEmpty as NEL
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map as M
import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe)
import Data.Monoid (mappend)
#if !MIN_VERSION_base(4,11,0)
-- This can be removed when GHC < 8.2.2 isn't supported anymore
import Data.Semigroup ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.Types
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
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 = [EntityDef]
-> (NonEmpty Line -> [EntityDef])
-> Maybe (NonEmpty Line)
-> [EntityDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (PersistSettings -> NonEmpty Line -> [EntityDef]
parseLines PersistSettings
ps) (Maybe (NonEmpty Line) -> [EntityDef])
-> (Text -> Maybe (NonEmpty Line)) -> Text -> [EntityDef]
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)

-- TODO: refactor to return (Line' NonEmpty), made possible by
-- https://github.com/yesodweb/persistent/pull/1206 but left out
-- in order to minimize the diff
parseLine :: Text -> Maybe Line
parseLine :: Text -> Maybe Line
parseLine Text
txt =
    case Text -> [Token]
tokenize Text
txt of
      [] ->
          Maybe Line
forall a. Maybe a
Nothing
      [Token]
toks ->
          Line -> Maybe Line
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Line -> Maybe Line) -> Line -> Maybe Line
forall a b. (a -> b) -> a -> b
$ Int -> [Token] -> Line
forall (f :: * -> *). Int -> f Token -> Line' f
Line (Text -> Int
parseIndentationAmount Text
txt) [Token]
toks

-- | A token used by the parser.
data Token = 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)

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 a string.
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 = [] -- 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) =
        Text -> [Token]
tokenize ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t)

    -- 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 line.  We don't care about spaces in the middle of the
-- line.  Also, we don't care about the amount of indentation.
data Line' f
    = Line
    { Line' f -> Int
lineIndent   :: Int
    , Line' f -> f Token
tokens       :: f Token
    }

deriving instance Show (f Token) => Show (Line' f)
deriving instance Eq (f Token) => 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 Token
t) = Int -> g Token -> Line' g
forall (f :: * -> *). Int -> f Token -> Line' f
Line Int
i (f Token -> g Token
forall x. f x -> g x
k f Token
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 Token
xs) = Int -> g Token -> Line' g
forall (f :: * -> *). Int -> f Token -> Line' f
Line Int
i (g Token -> Line' g) -> t (g Token) -> t (Line' g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Token -> t (g Token)
forall x. f x -> t (g x)
k f Token
xs

lineText :: Functor f => Line' f -> f Text
lineText :: Line' f -> f Text
lineText = (Token -> Text) -> f Token -> f Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Text
tokenText (f Token -> f Text) -> (Line' f -> f Token) -> Line' f -> f Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line' f -> f Token
forall (f :: * -> *). Line' f -> f Token
tokens

type Line = Line' []

lowestIndent
    :: Functor f
    => Foldable f
    => Functor g
    => f (Line' g)
    -> Int
lowestIndent :: f (Line' g) -> Int
lowestIndent = f Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (f Int -> Int) -> (f (Line' g) -> f Int) -> f (Line' g) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line' g -> Int) -> f (Line' g) -> f Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line' g -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent

-- | Divide lines into blocks and make entity definitions.
parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef]
parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef]
parseLines PersistSettings
ps =
    [UnboundEntityDef] -> [EntityDef]
fixForeignKeysAll ([UnboundEntityDef] -> [EntityDef])
-> (NonEmpty Line -> [UnboundEntityDef])
-> NonEmpty Line
-> [EntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LinesWithComments -> UnboundEntityDef)
-> [LinesWithComments] -> [UnboundEntityDef]
forall a b. (a -> b) -> [a] -> [b]
map LinesWithComments -> UnboundEntityDef
mk ([LinesWithComments] -> [UnboundEntityDef])
-> (NonEmpty Line -> [LinesWithComments])
-> NonEmpty Line
-> [UnboundEntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line' NonEmpty] -> [LinesWithComments]
associateLines ([Line' NonEmpty] -> [LinesWithComments])
-> (NonEmpty Line -> [Line' NonEmpty])
-> NonEmpty Line
-> [LinesWithComments]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Line -> [Line' NonEmpty]
skipEmpty
  where
    mk :: LinesWithComments -> UnboundEntityDef
    mk :: LinesWithComments -> UnboundEntityDef
mk LinesWithComments
lwc =
        let Line' NonEmpty
ln :| [Line' NonEmpty]
rest = LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines LinesWithComments
lwc
            (Text
name :| [Text]
entAttribs) = Line' NonEmpty -> NonEmpty Text
forall (f :: * -> *). Functor f => Line' f -> f Text
lineText Line' NonEmpty
ln
         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 a. NonEmpty a -> [a]) -> Line' NonEmpty -> Line
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> Line' f -> Line' g
mapLine forall a. NonEmpty a -> [a]
NEL.toList) [Line' NonEmpty]
rest)

isDocComment :: Token -> Maybe Text
isDocComment :: Token -> Maybe Text
isDocComment 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 = 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 -> [LinesWithComments] -> [LinesWithComments]
toLinesWithComments Line' NonEmpty
line [LinesWithComments]
linesWithComments =
        case [LinesWithComments]
linesWithComments of
            [] ->
                [Line' NonEmpty -> LinesWithComments
newLine Line' NonEmpty
line]
            (LinesWithComments
lwc : [LinesWithComments]
lwcs) ->
                case Token -> Maybe Text
isDocComment (NonEmpty Token -> Token
forall a. NonEmpty a -> a
NEL.head (Line' NonEmpty -> NonEmpty Token
forall (f :: * -> *). Line' f -> f Token
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
== [Line' NonEmpty] -> Int
forall (f :: * -> *) (g :: * -> *).
(Functor f, Foldable f, Functor g) =>
f (Line' g) -> Int
lowestIndent [Line' NonEmpty]
lines ->
                        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)
                            Bool -> Bool -> Bool
&& Line' NonEmpty -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent (LinesWithComments -> Line' NonEmpty
firstLine LinesWithComments
lwc) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Line' NonEmpty] -> Int
forall (f :: * -> *) (g :: * -> *).
(Functor f, Foldable f, Functor g) =>
f (Line' g) -> Int
lowestIndent [Line' NonEmpty]
lines
                        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

    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 (Line' NonEmpty) -> Int
forall (f :: * -> *) (g :: * -> *).
(Functor f, Foldable f, Functor g) =>
f (Line' g) -> Int
lowestIndent (NonEmpty (Line' NonEmpty) -> Int)
-> (LinesWithComments -> NonEmpty (Line' NonEmpty))
-> LinesWithComments
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines

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

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 EntityNameHS EntityDef
entLookup = [(EntityNameHS, EntityDef)] -> Map EntityNameHS EntityDef
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EntityNameHS, EntityDef)] -> Map EntityNameHS EntityDef)
-> [(EntityNameHS, EntityDef)] -> Map EntityNameHS EntityDef
forall a b. (a -> b) -> a -> b
$ (EntityDef -> (EntityNameHS, EntityDef))
-> [EntityDef] -> [(EntityNameHS, EntityDef)]
forall a b. (a -> b) -> [a] -> [b]
map (\EntityDef
e -> (EntityDef -> EntityNameHS
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 referenced columns
    fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef
    fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef
fixForeignKey EntityDef
ent (UnboundForeignDef [Text]
foreignFieldTexts [Text]
parentFieldTexts ForeignDef
fdef) =
        case Maybe [FieldDef]
mfdefs of
             Just [FieldDef]
fdefs ->
                 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 [FieldDef]
fdefs
                 then
                     [FieldDef] -> ForeignDef
lengthError [FieldDef]
fdefs
                 else
                     let
                         fds_ffs :: [(FieldDef, (ForeignFieldDef, ForeignFieldDef))]
fds_ffs =
                             (Text
 -> FieldDef -> (FieldDef, (ForeignFieldDef, ForeignFieldDef)))
-> [Text]
-> [FieldDef]
-> [(FieldDef, (ForeignFieldDef, ForeignFieldDef))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> FieldDef -> (FieldDef, (ForeignFieldDef, ForeignFieldDef))
toForeignFields
                                 [Text]
foreignFieldTexts
                                 [FieldDef]
fdefs
                         dbname :: Text
dbname =
                             EntityNameDB -> Text
unEntityNameDB (EntityDef -> EntityNameDB
entityDB EntityDef
pent)
                         oldDbName :: Text
oldDbName =
                             EntityNameDB -> Text
unEntityNameDB (ForeignDef -> EntityNameDB
foreignRefTableDBName ForeignDef
fdef)
                      in ForeignDef
fdef
                         { foreignFields :: [(ForeignFieldDef, ForeignFieldDef)]
foreignFields = ((FieldDef, (ForeignFieldDef, ForeignFieldDef))
 -> (ForeignFieldDef, ForeignFieldDef))
-> [(FieldDef, (ForeignFieldDef, ForeignFieldDef))]
-> [(ForeignFieldDef, ForeignFieldDef)]
forall a b. (a -> b) -> [a] -> [b]
map (FieldDef, (ForeignFieldDef, ForeignFieldDef))
-> (ForeignFieldDef, ForeignFieldDef)
forall a b. (a, b) -> b
snd [(FieldDef, (ForeignFieldDef, ForeignFieldDef))]
fds_ffs
                         , foreignNullable :: Bool
foreignNullable = [FieldDef] -> Bool
setNull ([FieldDef] -> Bool) -> [FieldDef] -> Bool
forall a b. (a -> b) -> a -> b
$ ((FieldDef, (ForeignFieldDef, ForeignFieldDef)) -> FieldDef)
-> [(FieldDef, (ForeignFieldDef, ForeignFieldDef))] -> [FieldDef]
forall a b. (a -> b) -> [a] -> [b]
map (FieldDef, (ForeignFieldDef, ForeignFieldDef)) -> FieldDef
forall a b. (a, b) -> a
fst [(FieldDef, (ForeignFieldDef, ForeignFieldDef))]
fds_ffs
                         , foreignRefTableDBName :: EntityNameDB
foreignRefTableDBName =
                             Text -> EntityNameDB
EntityNameDB Text
dbname
                         , foreignConstraintNameDBName :: ConstraintNameDB
foreignConstraintNameDBName =
                             Text -> ConstraintNameDB
ConstraintNameDB
                             (Text -> ConstraintNameDB)
-> (ConstraintNameDB -> Text)
-> ConstraintNameDB
-> ConstraintNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
oldDbName Text
dbname (Text -> Text)
-> (ConstraintNameDB -> Text) -> ConstraintNameDB -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintNameDB -> Text
unConstraintNameDB
                             (ConstraintNameDB -> ConstraintNameDB)
-> ConstraintNameDB -> ConstraintNameDB
forall a b. (a -> b) -> a -> b
$ ForeignDef -> ConstraintNameDB
foreignConstraintNameDBName ForeignDef
fdef
                         }
             Maybe [FieldDef]
Nothing ->
                 String -> ForeignDef
forall a. HasCallStack => String -> a
error (String -> ForeignDef) -> String -> ForeignDef
forall a b. (a -> b) -> a -> b
$ String
"no primary key found 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
        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]
++ EntityNameHS -> String
forall a. Show a => a -> String
show (ForeignDef -> EntityNameHS
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 (EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text)
-> (UnboundEntityDef -> EntityNameHS) -> UnboundEntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS)
-> (UnboundEntityDef -> EntityDef)
-> UnboundEntityDef
-> EntityNameHS
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
$ EntityNameHS -> Map EntityNameHS EntityDef -> Maybe EntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ForeignDef -> EntityNameHS
foreignRefTableHaskell ForeignDef
fdef) Map EntityNameHS EntityDef
entLookup
        mfdefs :: Maybe [FieldDef]
mfdefs = case [Text]
parentFieldTexts of
            [] -> EntityDef -> Maybe [FieldDef]
entitiesPrimary EntityDef
pent
            [Text]
_  -> [FieldDef] -> Maybe [FieldDef]
forall a. a -> Maybe a
Just ([FieldDef] -> Maybe [FieldDef]) -> [FieldDef] -> Maybe [FieldDef]
forall a b. (a -> b) -> a -> b
$ (Text -> FieldDef) -> [Text] -> [FieldDef]
forall a b. (a -> b) -> [a] -> [b]
map (EntityDef -> FieldNameHS -> FieldDef
getFd EntityDef
pent (FieldNameHS -> FieldDef)
-> (Text -> FieldNameHS) -> Text -> FieldDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FieldNameHS
FieldNameHS) [Text]
parentFieldTexts

        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 (FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> (FieldDef -> FieldNameHS) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameHS
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
. [FieldAttr] -> IsNullable
nullable ([FieldAttr] -> IsNullable)
-> (FieldDef -> [FieldAttr]) -> FieldDef -> IsNullable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> [FieldAttr]
fieldAttrs

        toForeignFields :: Text -> FieldDef
            -> (FieldDef, (ForeignFieldDef, ForeignFieldDef))
        toForeignFields :: Text -> FieldDef -> (FieldDef, (ForeignFieldDef, ForeignFieldDef))
toForeignFields Text
fieldText FieldDef
pfd =
           case FieldDef -> FieldNameHS -> FieldDef -> Maybe String
forall p. FieldDef -> p -> FieldDef -> Maybe String
chktypes FieldDef
fd FieldNameHS
haskellField FieldDef
pfd of
               Just String
err -> String -> (FieldDef, (ForeignFieldDef, ForeignFieldDef))
forall a. HasCallStack => String -> a
error String
err
               Maybe String
Nothing -> (FieldDef
fd, ((FieldNameHS
haskellField, FieldDef -> FieldNameDB
fieldDB FieldDef
fd), (FieldNameHS
pfh, FieldNameDB
pfdb)))
          where
            fd :: FieldDef
fd = EntityDef -> FieldNameHS -> FieldDef
getFd EntityDef
ent FieldNameHS
haskellField

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

            chktypes :: FieldDef -> p -> FieldDef -> Maybe String
chktypes FieldDef
ffld p
_fkey FieldDef
pfld =
                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)

        getFd :: EntityDef -> FieldNameHS -> FieldDef
        getFd :: EntityDef -> FieldNameHS -> FieldDef
getFd EntityDef
entity FieldNameHS
t = [FieldDef] -> FieldDef
go (EntityDef -> [FieldDef]
keyAndEntityFields EntityDef
entity)
          where
            go :: [FieldDef] -> FieldDef
go [] = 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 (EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text) -> EntityNameHS -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameHS
entityHaskell EntityDef
entity)
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" unknown column: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldNameHS -> String
forall a. Show a => a -> String
show FieldNameHS
t
            go (FieldDef
f:[FieldDef]
fs)
                | FieldDef -> FieldNameHS
fieldHaskell FieldDef
f FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== FieldNameHS
t = FieldDef
f
                | Bool
otherwise = [FieldDef] -> FieldDef
go [FieldDef]
fs

        lengthError :: [FieldDef] -> ForeignDef
lengthError [FieldDef]
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 [FieldDef]
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]
++ [FieldDef] -> String
forall a. Show a => a -> String
show [FieldDef]
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 :: EntityNameHS
-> EntityNameDB
-> FieldDef
-> [Text]
-> [FieldDef]
-> [UniqueDef]
-> [ForeignDef]
-> [Text]
-> Map Text [[Text]]
-> Bool
-> Maybe Text
-> EntityDef
EntityDef
        { entityHaskell :: EntityNameHS
entityHaskell = Text -> EntityNameHS
EntityNameHS Text
name'
        , entityDB :: EntityNameDB
entityDB = Text -> EntityNameDB
EntityNameDB (Text -> EntityNameDB) -> Text -> EntityNameDB
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]] -> [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 = Map Text [[Text]]
extras
        , entitySum :: Bool
entitySum = Bool
isSum
        , entityComments :: Maybe Text
entityComments = Maybe Text
forall a. Maybe a
Nothing
        }
  where
    entName :: EntityNameHS
entName = Text -> EntityNameHS
EntityNameHS 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)
    ([[Token]]
attribs, Map Text [[Text]]
extras) = [Line] -> ([[Token]], Map Text [[Text]])
splitExtras [Line]
lines

    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

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

    cols :: [FieldDef]
    cols :: [FieldDef]
cols = [FieldDef] -> [FieldDef]
forall a. [a] -> [a]
reverse ([FieldDef] -> [FieldDef])
-> ([[Token]] -> [FieldDef]) -> [[Token]] -> [FieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FieldDef], [Text]) -> [FieldDef]
forall a b. (a, b) -> a
fst (([FieldDef], [Text]) -> [FieldDef])
-> ([[Token]] -> ([FieldDef], [Text])) -> [[Token]] -> [FieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Token] -> ([FieldDef], [Text]) -> ([FieldDef], [Text]))
-> ([FieldDef], [Text]) -> [[Token]] -> ([FieldDef], [Text])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Token] -> ([FieldDef], [Text]) -> ([FieldDef], [Text])
k ([], []) ([[Token]] -> [FieldDef]) -> [[Token]] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [[Token]]
forall a. [a] -> [a]
reverse [[Token]]
attribs

    k :: [Token] -> ([FieldDef], [Text]) -> ([FieldDef], [Text])
k [Token]
x (![FieldDef]
acc, ![Text]
comments) =
        case [Token] -> Maybe Token
forall a. [a] -> Maybe a
listToMaybe [Token]
x of
            Just (DocComment Text
comment) ->
                ([FieldDef]
acc, Text
comment Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
comments)
            Maybe Token
_ ->
                case ([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 (Token -> Text
tokenText (Token -> Text) -> [Token] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token]
x)) of
                  Just FieldDef
sm ->
                      (FieldDef
sm FieldDef -> [FieldDef] -> [FieldDef]
forall a. a -> [a] -> [a]
: [FieldDef]
acc, [])
                  Maybe FieldDef
Nothing ->
                      ([FieldDef]
acc, [])

    autoIdField :: FieldDef
autoIdField = PersistSettings
-> EntityNameHS -> Maybe FieldNameDB -> SqlType -> FieldDef
mkAutoIdField PersistSettings
ps EntityNameHS
entName (Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Maybe Text -> Maybe FieldNameDB
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
        }

setFieldComments :: [Text] -> FieldDef -> FieldDef
setFieldComments :: [Text] -> FieldDef -> FieldDef
setFieldComments [Text]
xs FieldDef
fld =
    case [Text]
xs of
        [] -> FieldDef
fld
        [Text]
_ -> FieldDef
fld { fieldComments :: Maybe Text
fieldComments = Text -> Maybe Text
forall a. a -> Maybe a
Just ([Text] -> Text
T.unlines [Text]
xs) }

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

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]
    -> ( [[Token]]
       , M.Map Text [ExtraLine]
       )
splitExtras :: [Line] -> ([[Token]], Map Text [[Text]])
splitExtras [Line]
lns =
    case [Line]
lns of
        [] -> ([], Map Text [[Text]]
forall k a. Map k a
M.empty)
        (Line
line : [Line]
rest) ->
            case Line
line of
                Line Int
indent [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
> 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
                        ([[Token]]
x, Map Text [[Text]]
y) = [Line] -> ([[Token]], Map Text [[Text]])
splitExtras [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 ((Line -> [Text]) -> [Line] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map Line -> [Text]
forall (f :: * -> *). Functor f => Line' f -> f Text
lineText [Line]
children) Map Text [[Text]]
y)
                Line Int
_ [Token]
ts ->
                    let ([[Token]]
x, Map Text [[Text]]
y) = [Line] -> ([[Token]], Map Text [[Text]])
splitExtras [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 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 :: FieldNameHS
-> FieldNameDB
-> FieldType
-> SqlType
-> [FieldAttr]
-> Bool
-> ReferenceDef
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> FieldDef
FieldDef
                { fieldHaskell :: FieldNameHS
fieldHaskell = Text -> FieldNameHS
FieldNameHS Text
n
                , fieldDB :: FieldNameDB
fieldDB = Text -> FieldNameDB
FieldNameDB (Text -> FieldNameDB) -> Text -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n [Text]
attrs_
                , 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 :: [FieldAttr]
fieldAttrs = [FieldAttr]
fieldAttrs_
                , 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
                , fieldCascade :: FieldCascade
fieldCascade = FieldCascade
cascade_
                , fieldGenerated :: Maybe Text
fieldGenerated = 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 FieldDef
_ PersistSettings
_ [Text]
_ = Maybe FieldDef
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 [] = 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) | Text -> Bool
isCapitalizedText 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 -> FieldDef
setFieldDef
    (FieldDef -> FieldDef) -> FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$ 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
$ (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) -- `mappend` 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 ) -- `mappend` setIdName)
    setFieldDef :: FieldDef -> FieldDef
setFieldDef FieldDef
fd = FieldDef
fd
        { fieldReference :: ReferenceDef
fieldReference =
            EntityNameHS -> FieldType -> ReferenceDef
ForeignRef (Text -> EntityNameHS
EntityNameHS Text
tableName) (FieldType -> ReferenceDef) -> FieldType -> ReferenceDef
forall a b. (a -> b) -> a -> b
$
                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
        }
    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 = ["sql=" `mappend` psIdName 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 -> FieldNameHS
fieldHaskell FieldDef
d FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
t =
            if [FieldAttr] -> IsNullable
nullable (FieldDef -> [FieldAttr]
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ [FieldDef] -> String
forall a. Show a => a -> String
show [FieldDef]
fields
                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)
    | Text -> Bool
isCapitalizedText Text
n
        = ConstraintNameHS
-> ConstraintNameDB -> [ForeignFieldDef] -> [Text] -> UniqueDef
UniqueDef
            (Text -> ConstraintNameHS
ConstraintNameHS Text
n)
            ConstraintNameDB
dbName
            ((Text -> ForeignFieldDef) -> [Text] -> [ForeignFieldDef]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldNameHS
FieldNameHS (Text -> FieldNameHS)
-> (Text -> FieldNameDB) -> Text -> ForeignFieldDef
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [FieldDef] -> Text -> FieldNameDB
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 :: 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 :: [FieldDef] -> Text -> FieldNameDB
getDBName [] Text
t =
      String -> FieldNameDB
forall a. HasCallStack => String -> a
error (String -> FieldNameDB) -> String -> FieldNameDB
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 -> FieldNameHS
fieldHaskell FieldDef
d FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
t = FieldDef -> FieldNameDB
fieldDB FieldDef
d
        | Bool
otherwise = [FieldDef] -> Text -> FieldNameDB
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]
_unboundForeignFields :: [Text] -- ^ fields in the parent entity
                         , UnboundForeignDef -> [Text]
_unboundParentFields :: [Text] -- ^ fields in parent 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] -> 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 Text
tableName 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
n:[Text]
rest) Maybe CascadeAction
onDelete Maybe CascadeAction
onUpdate | Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isLower (Text -> Char
T.head Text
n)
            = [Text] -> [Text] -> ForeignDef -> UnboundForeignDef
UnboundForeignDef [Text]
fFields [Text]
pFields (ForeignDef -> UnboundForeignDef)
-> ForeignDef -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ ForeignDef :: EntityNameHS
-> EntityNameDB
-> ConstraintNameHS
-> ConstraintNameDB
-> FieldCascade
-> [(ForeignFieldDef, ForeignFieldDef)]
-> [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 =
                    Text -> ConstraintNameHS
ConstraintNameHS Text
n
                , foreignConstraintNameDBName :: ConstraintNameDB
foreignConstraintNameDBName =
                    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)
                , foreignFieldCascade :: FieldCascade
foreignFieldCascade = FieldCascade :: Maybe CascadeAction -> Maybe CascadeAction -> FieldCascade
FieldCascade
                    { fcOnDelete :: Maybe CascadeAction
fcOnDelete = Maybe CascadeAction
onDelete
                    , fcOnUpdate :: Maybe CascadeAction
fcOnUpdate = Maybe CascadeAction
onUpdate
                    }
                , foreignFields :: [(ForeignFieldDef, ForeignFieldDef)]
foreignFields =
                    []
                , foreignAttrs :: [Text]
foreignAttrs =
                    [Text]
attrs
                , foreignNullable :: Bool
foreignNullable =
                    Bool
False
                , foreignToPrimary :: Bool
foreignToPrimary =
                    [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
pFields
                }
          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
            ([Text]
fFields, [Text]
pFields) = 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

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

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