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

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

The basic structure of the syntax looks like this:

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

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

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

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

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

It generates a Haskell datatype with the following form:

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

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

= Deriving

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

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

= Unique Keys

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

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

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

= Setting defaults

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

@
User
    name    Text
    admin   Bool default=false
@

This creates a SQL definition like this:

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

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

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

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

= Custom ID column

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

> User
>     Id   Text
>     name Text
>     age  Int

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

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

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

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

= Custom Primary Keys

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

@
Email
    firstPart   Text
    secondPart  Text

    Primary firstPart secondPart
@

This creates a table with the following form:

@
CREATE TABLE email (
    first_part  varchar,
    second_part varchar,

    PRIMARY KEY (first_part, second_part)
@

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

import Prelude hiding (lines)

import Control.Applicative hiding (empty)
import Control.Arrow ((&&&))
import Control.Monad (msum, mplus)
import Data.Char
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)
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 = PersistSettings -> [Line] -> [EntityDef]
parseLines PersistSettings
ps ([Line] -> [EntityDef]) -> (Text -> [Line]) -> Text -> [EntityDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Line]
preparse

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

-- | A token used by the parser.
data Token = Spaces !Int   -- ^ @Spaces n@ are @n@ consecutive spaces.
           | Token Text    -- ^ @Token tok@ is token @tok@ already unquoted.
           | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified.
  deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq)

-- | Tokenize a string.
tokenize :: Text -> [Token]
tokenize :: Text -> [Token]
tokenize Text
t
    | Text -> Bool
T.null Text
t = []
    | Text
"-- | " Text -> Text -> Bool
`T.isPrefixOf` Text
t = [Text -> Token
DocComment Text
t]
    | Text
"--" Text -> Text -> Bool
`T.isPrefixOf` Text
t = [] -- Comment until the end of the line.
    | Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text
t = [] -- Also comment to the end of the line, needed for a CPP bug (#110)
    | Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = Text -> ([Text] -> [Text]) -> [Token]
quotes (Text -> Text
T.tail Text
t) [Text] -> [Text]
forall a. a -> a
id
    | Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' = Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
1 (Text -> Text
T.tail Text
t) [Text] -> [Text]
forall a. a -> a
id
    | Char -> Bool
isSpace (Text -> Char
T.head Text
t) =
        let (Text
spaces, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isSpace Text
t
         in Int -> Token
Spaces (Text -> Int
T.length Text
spaces) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
rest

    -- support mid-token quotes and parens
    | Just (Text
beforeEquals, Text
afterEquals) <- Text -> Maybe (Text, Text)
findMidToken Text
t
    , Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isSpace Text
beforeEquals)
    , Token Text
next : [Token]
rest <- Text -> [Token]
tokenize Text
afterEquals =
        Text -> Token
Token ([Text] -> Text
T.concat [Text
beforeEquals, Text
"=", Text
next]) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
rest

    | Bool
otherwise =
        let (Text
token, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
t
         in Text -> Token
Token Text
token Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize Text
rest
  where
    findMidToken :: Text -> Maybe (Text, Text)
findMidToken Text
t' =
        case (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') Text
t' of
            (Text
x, Int -> Text -> Text
T.drop Int
1 -> Text
y)
                | Text
"\"" Text -> Text -> Bool
`T.isPrefixOf` Text
y Bool -> Bool -> Bool
|| Text
"(" Text -> Text -> Bool
`T.isPrefixOf` Text
y -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
x, Text
y)
            (Text, Text)
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing

    quotes :: Text -> ([Text] -> [Text]) -> [Token]
quotes Text
t' [Text] -> [Text]
front
        | Text -> Bool
T.null Text
t' = String -> [Token]
forall a. HasCallStack => String -> a
error (String -> [Token]) -> String -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            Text
"Unterminated quoted string starting with " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
front []
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = Text -> Token
Token ([Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Text -> Text
T.tail Text
t')
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 =
            Text -> ([Text] -> [Text]) -> [Token]
quotes (Int -> Text -> Text
T.drop Int
2 Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.take Int
1 (Int -> Text -> Text
T.drop Int
1 Text
t')Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        | Bool
otherwise =
            let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'\"']) Text
t'
             in Text -> ([Text] -> [Text]) -> [Token]
quotes Text
y ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
    parens :: Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count Text
t' [Text] -> [Text]
front
        | Text -> Bool
T.null Text
t' = String -> [Token]
forall a. HasCallStack => String -> a
error (String -> [Token]) -> String -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            Text
"Unterminated parens string starting with " Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
front []
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' =
            if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1 :: Int)
                then Text -> Token
Token ([Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
front []) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Text -> [Token]
tokenize (Text -> Text
T.tail Text
t')
                else Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Text -> Text
T.tail Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
")"Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' =
            Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Text -> Text
T.tail Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"("Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        | Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 =
            Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count (Int -> Text -> Text
T.drop Int
2 Text
t') ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.take Int
1 (Int -> Text -> Text
T.drop Int
1 Text
t')Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        | Bool
otherwise =
            let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'(',Char
')']) Text
t'
             in Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count Text
y ([Text] -> [Text]
front ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))

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

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

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

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

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

type Line = Line' []

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

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

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

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

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

data LinesWithComments = LinesWithComments
    { LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines :: NonEmpty (Line' NonEmpty)
    , LinesWithComments -> [Text]
lwcComments :: [Text]
    } deriving (LinesWithComments -> LinesWithComments -> Bool
(LinesWithComments -> LinesWithComments -> Bool)
-> (LinesWithComments -> LinesWithComments -> Bool)
-> Eq LinesWithComments
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinesWithComments -> LinesWithComments -> Bool
$c/= :: LinesWithComments -> LinesWithComments -> Bool
== :: LinesWithComments -> LinesWithComments -> Bool
$c== :: LinesWithComments -> LinesWithComments -> Bool
Eq, Int -> LinesWithComments -> ShowS
[LinesWithComments] -> ShowS
LinesWithComments -> String
(Int -> LinesWithComments -> ShowS)
-> (LinesWithComments -> String)
-> ([LinesWithComments] -> ShowS)
-> Show LinesWithComments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinesWithComments] -> ShowS
$cshowList :: [LinesWithComments] -> ShowS
show :: LinesWithComments -> String
$cshow :: LinesWithComments -> String
showsPrec :: Int -> LinesWithComments -> ShowS
$cshowsPrec :: Int -> LinesWithComments -> ShowS
Show)

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

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

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

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

consComment :: Text -> LinesWithComments -> LinesWithComments
consComment :: Text -> LinesWithComments -> LinesWithComments
consComment Text
l LinesWithComments
lwc = LinesWithComments
lwc { lwcComments :: [Text]
lwcComments = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: LinesWithComments -> [Text]
lwcComments LinesWithComments
lwc }

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

    lowestIndent :: Int
lowestIndent = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int)
-> ([Line' NonEmpty] -> [Int]) -> [Line' NonEmpty] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line' NonEmpty -> Int) -> [Line' NonEmpty] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line' NonEmpty -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent ([Line' NonEmpty] -> Int) -> [Line' NonEmpty] -> Int
forall a b. (a -> b) -> a -> b
$ [Line' NonEmpty]
lines
    combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
    combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
combine LinesWithComments
lwc [] =
        [LinesWithComments
lwc]
    combine LinesWithComments
lwc (LinesWithComments
lwc' : [LinesWithComments]
lwcs) =
        let minIndent :: Int
minIndent = LinesWithComments -> Int
minimumIndentOf LinesWithComments
lwc
            otherIndent :: Int
otherIndent = LinesWithComments -> Int
minimumIndentOf LinesWithComments
lwc'
         in
            if Int
minIndent Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
otherIndent then
                LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc LinesWithComments
lwc LinesWithComments
lwc' LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs
            else
                LinesWithComments
lwc LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: LinesWithComments
lwc' LinesWithComments -> [LinesWithComments] -> [LinesWithComments]
forall a. a -> [a] -> [a]
: [LinesWithComments]
lwcs


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

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

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

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

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

    -- check the count and the sqltypes match and update the foreignFields with the names of the 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 =
                             DBName -> Text
unDBName (EntityDef -> DBName
entityDB EntityDef
pent)
                         oldDbName :: Text
oldDbName =
                             DBName -> Text
unDBName (ForeignDef -> DBName
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 :: DBName
foreignRefTableDBName =
                             Text -> DBName
DBName Text
dbname
                         , foreignConstraintNameDBName :: DBName
foreignConstraintNameDBName =
                             Text -> DBName
DBName
                             (Text -> DBName) -> (DBName -> Text) -> DBName -> DBName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
oldDbName Text
dbname (Text -> Text) -> (DBName -> Text) -> DBName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBName -> Text
unDBName
                             (DBName -> DBName) -> DBName -> DBName
forall a b. (a -> b) -> a -> b
$ ForeignDef -> DBName
foreignConstraintNameDBName ForeignDef
fdef
                         }
             Maybe [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]
++ HaskellName -> String
forall a. Show a => a -> String
show (ForeignDef -> HaskellName
foreignRefTableHaskell ForeignDef
fdef)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" fdef=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ForeignDef -> String
forall a. Show a => a -> String
show ForeignDef
fdef String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" allnames="
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show ((UnboundEntityDef -> Text) -> [UnboundEntityDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HaskellName -> Text
unHaskellName (HaskellName -> Text)
-> (UnboundEntityDef -> HaskellName) -> UnboundEntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> HaskellName
entityHaskell (EntityDef -> HaskellName)
-> (UnboundEntityDef -> EntityDef)
-> UnboundEntityDef
-> HaskellName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityDef
unboundEntityDef) [UnboundEntityDef]
unEnts)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\nents=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [EntityDef] -> String
forall a. Show a => a -> String
show [EntityDef]
ents
        pent :: EntityDef
pent =
            EntityDef -> Maybe EntityDef -> EntityDef
forall a. a -> Maybe a -> a
fromMaybe EntityDef
pentError (Maybe EntityDef -> EntityDef) -> Maybe EntityDef -> EntityDef
forall a b. (a -> b) -> a -> b
$ HaskellName -> Map HaskellName EntityDef -> Maybe EntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ForeignDef -> HaskellName
foreignRefTableHaskell ForeignDef
fdef) Map HaskellName EntityDef
entLookup
        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 -> HaskellName -> FieldDef
getFd EntityDef
pent (HaskellName -> FieldDef)
-> (Text -> HaskellName) -> Text -> FieldDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HaskellName
HaskellName) [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 (HaskellName -> Text
unHaskellName (HaskellName -> Text)
-> (FieldDef -> HaskellName) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> HaskellName
fieldHaskell) (FieldDef
fdFieldDef -> [FieldDef] -> [FieldDef]
forall a. a -> [a] -> [a]
:[FieldDef]
fds))
        isNull :: FieldDef -> Bool
isNull = (IsNullable
NotNullable IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
/=) (IsNullable -> Bool)
-> (FieldDef -> IsNullable) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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 -> HaskellName -> FieldDef -> Maybe String
forall p. FieldDef -> p -> FieldDef -> Maybe String
chktypes FieldDef
fd HaskellName
haskellField FieldDef
pfd of
               Just String
err -> String -> (FieldDef, (ForeignFieldDef, ForeignFieldDef))
forall a. HasCallStack => String -> a
error String
err
               Maybe String
Nothing -> (FieldDef
fd, ((HaskellName
haskellField, FieldDef -> DBName
fieldDB FieldDef
fd), (HaskellName
pfh, DBName
pfdb)))
          where
            fd :: FieldDef
fd = EntityDef -> HaskellName -> FieldDef
getFd EntityDef
ent HaskellName
haskellField

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

            chktypes :: FieldDef -> 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 -> HaskellName -> FieldDef
        getFd :: EntityDef -> HaskellName -> FieldDef
getFd EntityDef
entity HaskellName
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 (HaskellName -> Text
unHaskellName (HaskellName -> Text) -> HaskellName -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> HaskellName
entityHaskell EntityDef
entity)
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" unknown column: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HaskellName -> String
forall a. Show a => a -> String
show HaskellName
t
            go (FieldDef
f:[FieldDef]
fs)
                | FieldDef -> HaskellName
fieldHaskell FieldDef
f HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== HaskellName
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 :: HaskellName
-> DBName
-> FieldDef
-> [Text]
-> [FieldDef]
-> [UniqueDef]
-> [ForeignDef]
-> [Text]
-> Map Text [[Text]]
-> Bool
-> Maybe Text
-> EntityDef
EntityDef
        { entityHaskell :: HaskellName
entityHaskell = Text -> HaskellName
HaskellName Text
name'
        , entityDB :: DBName
entityDB = Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
name' [Text]
entattribs
        -- idField is the user-specified Id
        -- otherwise useAutoIdField
        -- but, adjust it if the user specified a Primary
        , entityId :: FieldDef
entityId = Maybe CompositeDef -> FieldDef -> FieldDef
setComposite Maybe CompositeDef
primaryComposite (FieldDef -> FieldDef) -> FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$ FieldDef -> Maybe FieldDef -> FieldDef
forall a. a -> Maybe a -> a
fromMaybe FieldDef
autoIdField Maybe FieldDef
idField
        , entityAttrs :: [Text]
entityAttrs = [Text]
entattribs
        , entityFields :: [FieldDef]
entityFields = [FieldDef]
cols
        , entityUniques :: [UniqueDef]
entityUniques = [UniqueDef]
uniqs
        , entityForeigns :: [ForeignDef]
entityForeigns = []
        , entityDerives :: [Text]
entityDerives = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ ([Text] -> Maybe [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Text] -> Maybe [Text]
takeDerives [[Text]]
attribs
        , 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 :: HaskellName
entName = Text -> HaskellName
HaskellName Text
name'
    (Bool
isSum, Text
name') =
        case Text -> Maybe (Char, Text)
T.uncons Text
name of
            Just (Char
'+', Text
x) -> (Bool
True, Text
x)
            Maybe (Char, Text)
_ -> (Bool
False, Text
name)
    ([[Text]]
attribs, Map Text [[Text]]
extras) = [Line] -> ([[Text]], Map Text [[Text]])
splitExtras [Line]
lines

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

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

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

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

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


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

mkAutoIdField :: PersistSettings -> HaskellName -> Maybe DBName -> SqlType -> FieldDef
mkAutoIdField :: PersistSettings
-> HaskellName -> Maybe DBName -> SqlType -> FieldDef
mkAutoIdField PersistSettings
ps HaskellName
entName Maybe DBName
idName SqlType
idSqlType =
    FieldDef :: HaskellName
-> DBName
-> FieldType
-> SqlType
-> [FieldAttr]
-> Bool
-> ReferenceDef
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> FieldDef
FieldDef
        { fieldHaskell :: HaskellName
fieldHaskell = Text -> HaskellName
HaskellName Text
"Id"
        -- this should be modeled as a Maybe
        -- but that sucks for non-ID field
        -- TODO: use a sumtype FieldDef | IdFieldDef
        , fieldDB :: DBName
fieldDB = DBName -> Maybe DBName -> DBName
forall a. a -> Maybe a -> a
fromMaybe (Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text
psIdName PersistSettings
ps) Maybe DBName
idName
        , fieldType :: FieldType
fieldType = Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing (Text -> FieldType) -> Text -> FieldType
forall a b. (a -> b) -> a -> b
$ Text -> Text
keyConName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HaskellName -> Text
unHaskellName HaskellName
entName
        , fieldSqlType :: SqlType
fieldSqlType = SqlType
idSqlType
        -- the primary field is actually a reference to the entity
        , fieldReference :: ReferenceDef
fieldReference = HaskellName -> FieldType -> ReferenceDef
ForeignRef HaskellName
entName FieldType
defaultReferenceTypeCon
        , fieldAttrs :: [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]
    -> ( [[Text]]
       , M.Map Text [[Text]]
       )
splitExtras :: [Line] -> ([[Text]], Map Text [[Text]])
splitExtras [] = ([], Map Text [[Text]]
forall k a. Map k a
M.empty)
splitExtras (Line Int
indent [Text
name]:[Line]
rest)
    | Bool -> Bool
not (Text -> Bool
T.null Text
name) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head Text
name) =
        let ([Line]
children, [Line]
rest') = (Line -> Bool) -> [Line] -> ([Line], [Line])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
indent) (Int -> Bool) -> (Line -> Int) -> Line -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Int
forall (f :: * -> *). Line' f -> Int
lineIndent) [Line]
rest
            ([[Text]]
x, Map Text [[Text]]
y) = [Line] -> ([[Text]], Map Text [[Text]])
splitExtras [Line]
rest'
         in ([[Text]]
x, Text -> [[Text]] -> Map Text [[Text]] -> Map Text [[Text]]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
name ((Line -> [Text]) -> [Line] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map Line -> [Text]
forall (f :: * -> *). Line' f -> f Text
tokens [Line]
children) Map Text [[Text]]
y)
splitExtras (Line Int
_ [Text]
ts:[Line]
rest) =
    let ([[Text]]
x, Map Text [[Text]]
y) = [Line] -> ([[Text]], Map Text [[Text]])
splitExtras [Line]
rest
     in ([Text]
ts[Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
:[[Text]]
x, Map Text [[Text]]
y)

takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef
takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef
takeColsEx =
    (Text -> String -> Maybe FieldDef)
-> PersistSettings -> [Text] -> Maybe FieldDef
takeCols
        (\Text
ft String
perr -> String -> Maybe FieldDef
forall a. HasCallStack => String -> a
error (String -> Maybe FieldDef) -> String -> Maybe FieldDef
forall a b. (a -> b) -> a -> b
$ String
"Invalid field type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
ft String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
perr)

takeCols
    :: (Text -> String -> Maybe FieldDef)
    -> PersistSettings
    -> [Text]
    -> Maybe FieldDef
takeCols :: (Text -> String -> Maybe FieldDef)
-> PersistSettings -> [Text] -> Maybe FieldDef
takeCols Text -> String -> Maybe FieldDef
_ PersistSettings
_ (Text
"deriving":[Text]
_) = Maybe FieldDef
forall a. Maybe a
Nothing
takeCols Text -> String -> Maybe FieldDef
onErr PersistSettings
ps (Text
n':Text
typ:[Text]
rest')
    | Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isLower (Text -> Char
T.head Text
n) =
        case Text -> Either String FieldType
parseFieldType Text
typ of
            Left String
err -> Text -> String -> Maybe FieldDef
onErr Text
typ String
err
            Right FieldType
ft -> FieldDef -> Maybe FieldDef
forall a. a -> Maybe a
Just FieldDef :: HaskellName
-> DBName
-> FieldType
-> SqlType
-> [FieldAttr]
-> Bool
-> ReferenceDef
-> FieldCascade
-> Maybe Text
-> Maybe Text
-> FieldDef
FieldDef
                { fieldHaskell :: HaskellName
fieldHaskell = Text -> HaskellName
HaskellName Text
n
                , fieldDB :: DBName
fieldDB = Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n [Text]
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) | Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head Text
n) = (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef,
 Maybe UnboundForeignDef)
takeConstraint'
    where
      takeConstraint' :: (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef,
 Maybe UnboundForeignDef)
takeConstraint'
            | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Unique"  = (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, UniqueDef -> Maybe UniqueDef
forall a. a -> Maybe a
Just (UniqueDef -> Maybe UniqueDef) -> UniqueDef -> Maybe UniqueDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [FieldDef] -> [Text] -> UniqueDef
takeUniq PersistSettings
ps Text
tableName [FieldDef]
defs [Text]
rest, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
            | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Foreign" = (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, UnboundForeignDef -> Maybe UnboundForeignDef
forall a. a -> Maybe a
Just (UnboundForeignDef -> Maybe UnboundForeignDef)
-> UnboundForeignDef -> Maybe UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ PersistSettings
-> Text -> [FieldDef] -> [Text] -> UnboundForeignDef
takeForeign PersistSettings
ps Text
tableName [FieldDef]
defs [Text]
rest)
            | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Primary" = (Maybe FieldDef
forall a. Maybe a
Nothing, CompositeDef -> Maybe CompositeDef
forall a. a -> Maybe a
Just (CompositeDef -> Maybe CompositeDef)
-> CompositeDef -> Maybe CompositeDef
forall a b. (a -> b) -> a -> b
$ [FieldDef] -> [Text] -> CompositeDef
takeComposite [FieldDef]
defs [Text]
rest, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
            | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Id"      = (FieldDef -> Maybe FieldDef
forall a. a -> Maybe a
Just (FieldDef -> Maybe FieldDef) -> FieldDef -> Maybe FieldDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> FieldDef
takeId PersistSettings
ps Text
tableName (Text
nText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest), Maybe CompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
            | Bool
otherwise      = (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, UniqueDef -> Maybe UniqueDef
forall a. a -> Maybe a
Just (UniqueDef -> Maybe UniqueDef) -> UniqueDef -> Maybe UniqueDef
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [FieldDef] -> [Text] -> UniqueDef
takeUniq PersistSettings
ps Text
"" [FieldDef]
defs (Text
nText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest), Maybe UnboundForeignDef
forall a. Maybe a
Nothing) -- retain compatibility with original unique constraint
takeConstraint PersistSettings
_ Text
_ [FieldDef]
_ [Text]
_ = (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, Maybe UniqueDef
forall a. Maybe a
Nothing, Maybe UnboundForeignDef
forall a. Maybe a
Nothing)

-- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName.
-- need to re-work takeCols function
takeId :: PersistSettings -> Text -> [Text] -> FieldDef
takeId :: PersistSettings -> Text -> [Text] -> FieldDef
takeId PersistSettings
ps Text
tableName (Text
n:[Text]
rest) =
    FieldDef -> 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 =
            HaskellName -> FieldType -> ReferenceDef
ForeignRef (Text -> HaskellName
HaskellName 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 -> HaskellName
fieldHaskell FieldDef
d HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> HaskellName
HaskellName 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)
    | Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head Text
n)
        = HaskellName -> DBName -> [ForeignFieldDef] -> [Text] -> UniqueDef
UniqueDef
            (Text -> HaskellName
HaskellName Text
n)
            DBName
dbName
            ((Text -> ForeignFieldDef) -> [Text] -> [ForeignFieldDef]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> HaskellName
HaskellName (Text -> HaskellName)
-> (Text -> DBName) -> Text -> ForeignFieldDef
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [FieldDef] -> Text -> DBName
getDBName [FieldDef]
defs) [Text]
fields)
            [Text]
attrs
  where
    isAttr :: Text -> Bool
isAttr Text
a =
      Text
"!" Text -> Text -> Bool
`T.isPrefixOf` Text
a
    isSqlName :: Text -> Bool
isSqlName Text
a =
      Text
"sql=" Text -> Text -> Bool
`T.isPrefixOf` Text
a
    isNonField :: Text -> Bool
isNonField Text
a =
       Text -> Bool
isAttr Text
a
      Bool -> Bool -> Bool
|| Text -> Bool
isSqlName Text
a
    ([Text]
fields, [Text]
nonFields) =
      (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
isNonField [Text]
rest
    attrs :: [Text]
attrs = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isAttr [Text]
nonFields
    usualDbName :: DBName
usualDbName =
      Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (Text
tableName Text -> Text -> Text
`T.append` Text
n)
    sqlName :: Maybe DBName
    sqlName :: Maybe DBName
sqlName =
      case (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Text -> Bool
isSqlName [Text]
nonFields of
        Maybe Text
Nothing ->
          Maybe DBName
forall a. Maybe a
Nothing
        (Just Text
t) ->
          case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"=" Text
t of
            (Text
x : [Text]
_) -> DBName -> Maybe DBName
forall a. a -> Maybe a
Just (Text -> DBName
DBName Text
x)
            [Text]
_ -> Maybe DBName
forall a. Maybe a
Nothing
    dbName :: DBName
dbName = DBName -> Maybe DBName -> DBName
forall a. a -> Maybe a -> a
fromMaybe DBName
usualDbName Maybe DBName
sqlName
    getDBName :: [FieldDef] -> Text -> DBName
getDBName [] Text
t =
      String -> DBName
forall a. HasCallStack => String -> a
error (String -> DBName) -> String -> DBName
forall a b. (a -> b) -> a -> b
$ String
"Unknown column in unique constraint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [FieldDef] -> String
forall a. Show a => a -> String
show [FieldDef]
defs String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
attrs
    getDBName (FieldDef
d:[FieldDef]
ds) Text
t
        | FieldDef -> HaskellName
fieldHaskell FieldDef
d HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> HaskellName
HaskellName Text
t = FieldDef -> DBName
fieldDB FieldDef
d
        | Bool
otherwise = [FieldDef] -> Text -> DBName
getDBName [FieldDef]
ds Text
t
takeUniq PersistSettings
_ Text
tableName [FieldDef]
_ [Text]
xs =
  String -> UniqueDef
forall a. HasCallStack => String -> a
error (String -> UniqueDef) -> String -> UniqueDef
forall a b. (a -> b) -> a -> b
$ String
"invalid unique constraint on table["
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
tableName
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] expecting an uppercase constraint name xs="
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
xs

data UnboundForeignDef = UnboundForeignDef
                         { UnboundForeignDef -> [Text]
_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 :: HaskellName
-> DBName
-> HaskellName
-> DBName
-> FieldCascade
-> [(ForeignFieldDef, ForeignFieldDef)]
-> [Text]
-> Bool
-> Bool
-> ForeignDef
ForeignDef
                { foreignRefTableHaskell :: HaskellName
foreignRefTableHaskell =
                    Text -> HaskellName
HaskellName Text
refTableName
                , foreignRefTableDBName :: DBName
foreignRefTableDBName =
                    Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
refTableName
                , foreignConstraintNameHaskell :: HaskellName
foreignConstraintNameHaskell =
                    Text -> HaskellName
HaskellName Text
n
                , foreignConstraintNameDBName :: DBName
foreignConstraintNameDBName =
                    Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (Text
tableName Text -> Text -> Text
`T.append` Text
n)
                , 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