{-# LANGUAGE BangPatterns, CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Database.Persist.Quasi
( parse
, PersistSettings (..)
, upperCaseSettings
, lowerCaseSettings
, nullable
#if TEST
, Token (..)
, Line' (..)
, preparse
, tokenize
, parseFieldType
, empty
, removeSpaces
, associateLines
, skipEmpty
, LinesWithComments(..)
#endif
) where
import Prelude hiding (lines)
import qualified Data.List.NonEmpty as NEL
import Data.List.NonEmpty (NonEmpty(..))
import Control.Arrow ((&&&))
import Control.Monad (msum, mplus)
import Data.Char
import Data.List (find, foldl')
import qualified Data.Map as M
import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.Types
data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Int -> ParseState a -> ShowS
[ParseState a] -> ShowS
ParseState a -> String
(Int -> ParseState a -> ShowS)
-> (ParseState a -> String)
-> ([ParseState a] -> ShowS)
-> Show (ParseState a)
forall a. Show a => Int -> ParseState a -> ShowS
forall a. Show a => [ParseState a] -> ShowS
forall a. Show a => ParseState a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseState a] -> ShowS
$cshowList :: forall a. Show a => [ParseState a] -> ShowS
show :: ParseState a -> String
$cshow :: forall a. Show a => ParseState a -> String
showsPrec :: Int -> ParseState a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseState a -> ShowS
Show
parseFieldType :: Text -> Either String FieldType
parseFieldType :: Text -> Either String FieldType
parseFieldType t0 :: Text
t0 =
case Text -> ParseState FieldType
parseApplyFT Text
t0 of
PSSuccess ft :: FieldType
ft t' :: 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 err :: 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
$ "PSFail " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
other :: 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 t :: 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 (ft :: FieldType
ft:fts :: [FieldType]
fts) t' :: 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 [] _ -> String -> ParseState FieldType
forall a. String -> ParseState a
PSFail "empty"
PSFail err :: String
err -> String -> ParseState FieldType
forall a. String -> ParseState a
PSFail String
err
PSDone -> ParseState FieldType
forall a. ParseState a
PSDone
parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed end :: Char
end ftMod :: FieldType -> FieldType
ftMod t :: Text
t =
let (a :: Text
a, b :: 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 ft :: FieldType
ft t' :: Text
t' -> case ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
t', Text -> Maybe (Char, Text)
T.uncons Text
b) of
("", Just (c :: Char
c, t'' :: 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')
(x :: Text
x, y :: 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)
x :: 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 t :: Text
t =
case Text -> Maybe (Char, Text)
T.uncons Text
t of
Nothing -> ParseState FieldType
forall a. ParseState a
PSDone
Just (c :: Char
c, t' :: 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 -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed ')' FieldType -> FieldType
forall a. a -> a
id Text
t'
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '[' -> Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
parseEnclosed ']' FieldType -> FieldType
FTList Text
t'
| Char -> Bool
isUpper Char
c ->
let (a :: Text
a, b :: Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\x :: 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)) 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 t :: Text
t =
case Text -> Text -> (Text, Text)
T.breakOnEnd "." Text
t of
(_, "") -> Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
t
("", _) -> Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
t
(a :: Text
a, b :: 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 front :: [FieldType] -> a
front t :: Text
t =
case Text -> ParseState FieldType
parse1 Text
t of
PSSuccess x :: FieldType
x t' :: 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 err :: String
err -> String -> ParseState a
forall a. String -> ParseState a
PSFail String
err
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
, PersistSettings -> Text
psIdName :: !Text
}
defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings
defaultPersistSettings :: PersistSettings
defaultPersistSettings = $WPersistSettings :: (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 = "id"
}
upperCaseSettings :: PersistSettings
upperCaseSettings = PersistSettings
defaultPersistSettings
lowerCaseSettings :: PersistSettings
lowerCaseSettings = PersistSettings
defaultPersistSettings
{ psToDBName :: Text -> Text
psToDBName =
let go :: Char -> Text
go c :: Char
c
| Char -> Bool
isUpper Char
c = String -> Text
T.pack ['_', 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
== '_') (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
}
parse :: PersistSettings -> Text -> [EntityDef]
parse :: PersistSettings -> Text -> [EntityDef]
parse ps :: 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
data Token = Spaces !Int
| Token Text
| Text
deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq)
tokenize :: Text -> [Token]
tokenize :: Text -> [Token]
tokenize t :: Text
t
| Text -> Bool
T.null Text
t = []
| "-- | " Text -> Text -> Bool
`T.isPrefixOf` Text
t = [Text -> Token
DocComment Text
t]
| "--" Text -> Text -> Bool
`T.isPrefixOf` Text
t = []
| "#" Text -> Text -> Bool
`T.isPrefixOf` Text
t = []
| Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '"' = 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
== '(' = Int -> Text -> ([Text] -> [Text]) -> [Token]
parens 1 (Text -> Text
T.tail Text
t) [Text] -> [Text]
forall a. a -> a
id
| Char -> Bool
isSpace (Text -> Char
T.head Text
t) =
let (spaces :: Text
spaces, rest :: 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
| Just (beforeEquals :: Text
beforeEquals, afterEquals :: Text
afterEquals) <- Text -> Maybe (Text, Text)
findMidToken Text
t
, Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isSpace Text
beforeEquals)
, Token next :: Text
next : rest :: [Token]
rest <- Text -> [Token]
tokenize Text
afterEquals =
Text -> Token
Token ([Text] -> Text
T.concat [Text
beforeEquals, "=", Text
next]) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
rest
| Bool
otherwise =
let (token :: Text
token, rest :: 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 t' :: Text
t' =
case (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '=') Text
t' of
(x :: Text
x, Int -> Text -> Text
T.drop 1 -> Text
y)
| "\"" Text -> Text -> Bool
`T.isPrefixOf` Text
y Bool -> Bool -> Bool
|| "(" Text -> Text -> Bool
`T.isPrefixOf` Text
y -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
x, Text
y)
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
quotes :: Text -> ([Text] -> [Text]) -> [Token]
quotes t' :: Text
t' front :: [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
$
"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
== '"' = 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
== '\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 =
Text -> ([Text] -> [Text]) -> [Token]
quotes (Int -> Text -> Text
T.drop 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 1 (Int -> Text -> Text
T.drop 1 Text
t')Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
| Bool
otherwise =
let (x :: Text
x, y :: Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['\\','\"']) 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 count :: Int
count t' :: Text
t' front :: [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
$
"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
== ')' =
if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (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
- 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]
forall a. a -> [a] -> [a]
:))
| Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '(' =
Int -> Text -> ([Text] -> [Text]) -> [Token]
parens (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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]
forall a. a -> [a] -> [a]
:))
| Text -> Char
T.head Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\' Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 =
Int -> Text -> ([Text] -> [Text]) -> [Token]
parens Int
count (Int -> Text -> Text
T.drop 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 1 (Int -> Text -> Text
T.drop 1 Text
t')Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
| Bool
otherwise =
let (x :: Text
x, y :: Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['\\','(',')']) 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]
:))
empty :: [Token] -> Bool
empty :: [Token] -> Bool
empty [] = Bool
True
empty [Spaces _] = Bool
True
empty _ = Bool
False
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 k :: forall x. f x -> g x
k (Line i :: Int
i t :: 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 k :: forall x. f x -> t (g x)
k (Line i :: Int
i xs :: 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' []
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 i :: Int
i:rest :: [Token]
rest) = Int -> [Token] -> Line
toLine' Int
i [Token]
rest
toLine xs :: [Token]
xs = Int -> [Token] -> Line
toLine' 0 [Token]
xs
toLine' :: Int -> [Token] -> Line
toLine' i :: 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 t :: Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
fromToken (DocComment t :: Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
fromToken Spaces{} = Maybe Text
forall a. Maybe a
Nothing
parseLines :: PersistSettings -> [Line] -> [EntityDef]
parseLines :: PersistSettings -> [Line] -> [EntityDef]
parseLines ps :: PersistSettings
ps lines :: [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 lwc :: LinesWithComments
lwc =
let Line _ (name :: Text
name :| entAttribs :: [Text]
entAttribs) :| rest :: [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
xs :: Text
xs =
Text -> Text -> Maybe Text
T.stripPrefix "-- | " Text
xs
data =
{ LinesWithComments -> NonEmpty (Line' NonEmpty)
lwcLines :: NonEmpty (Line' NonEmpty)
, :: [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)
appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments
appendLwc a :: LinesWithComments
a b :: 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 l :: 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 l :: Line' NonEmpty
l lwc :: 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
l :: Text
l lwc :: 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 lines :: [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 :: Line' NonEmpty
line linesWithComments :: [LinesWithComments]
linesWithComments =
case [LinesWithComments]
linesWithComments of
[] ->
[Line' NonEmpty -> LinesWithComments
newLine Line' NonEmpty
line]
(lwc :: LinesWithComments
lwc : lwcs :: [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 comment :: 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
_ ->
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 lwc :: LinesWithComments
lwc [] =
[LinesWithComments
lwc]
combine lwc :: LinesWithComments
lwc (lwc' :: LinesWithComments
lwc' : lwcs :: [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
[] = UnboundEntityDef -> UnboundEntityDef
forall a. a -> a
id
setComments comments :: [Text]
comments =
(EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overUnboundEntityDef (\ed :: 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 unEnts :: [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 (\e :: EntityDef
e -> (EntityDef -> HaskellName
entityHaskell EntityDef
e, EntityDef
e)) [EntityDef]
ents
fixForeignKeys :: UnboundEntityDef -> EntityDef
fixForeignKeys :: UnboundEntityDef -> EntityDef
fixForeignKeys (UnboundEntityDef foreigns :: [UnboundForeignDef]
foreigns ent :: 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 }
fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef
fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef
fixForeignKey ent :: EntityDef
ent (UnboundForeignDef foreignFieldTexts :: [Text]
foreignFieldTexts fdef :: ForeignDef
fdef) =
let pentError :: EntityDef
pentError =
String -> EntityDef
forall a. HasCallStack => String -> a
error (String -> EntityDef) -> String -> EntityDef
forall a b. (a -> b) -> a -> b
$ "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]
++ " 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]
++ " 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]
++ "\n\nents=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [EntityDef] -> String
forall a. Show a => a -> String
show [EntityDef]
ents
pent :: EntityDef
pent =
EntityDef -> Maybe EntityDef -> EntityDef
forall a. a -> Maybe a -> a
fromMaybe EntityDef
pentError (Maybe EntityDef -> EntityDef) -> Maybe EntityDef -> EntityDef
forall a b. (a -> b) -> a -> b
$ HaskellName -> Map HaskellName EntityDef -> Maybe EntityDef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ForeignDef -> HaskellName
foreignRefTableHaskell ForeignDef
fdef) Map HaskellName EntityDef
entLookup
in
case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
pent of
Just pdef :: CompositeDef
pdef ->
if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
foreignFieldTexts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [FieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef)
then
CompositeDef -> ForeignDef
lengthError CompositeDef
pdef
else
let
fds_ffs :: [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
fds_ffs =
(Text
-> FieldDef
-> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName))))
-> [Text]
-> [FieldDef]
-> [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (EntityDef
-> Text
-> FieldDef
-> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
toForeignFields EntityDef
pent)
[Text]
foreignFieldTexts
(CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef)
dbname :: Text
dbname =
DBName -> Text
unDBName (EntityDef -> DBName
entityDB EntityDef
pent)
oldDbName :: Text
oldDbName =
DBName -> Text
unDBName (ForeignDef -> DBName
foreignRefTableDBName ForeignDef
fdef)
in ForeignDef
fdef
{ foreignFields :: [((HaskellName, DBName), (HaskellName, DBName))]
foreignFields = ((FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
-> ((HaskellName, DBName), (HaskellName, DBName)))
-> [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
-> [((HaskellName, DBName), (HaskellName, DBName))]
forall a b. (a -> b) -> [a] -> [b]
map (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
-> ((HaskellName, DBName), (HaskellName, DBName))
forall a b. (a, b) -> b
snd [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
fds_ffs
, foreignNullable :: Bool
foreignNullable = [FieldDef] -> Bool
setNull ([FieldDef] -> Bool) -> [FieldDef] -> Bool
forall a b. (a -> b) -> a -> b
$ ((FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
-> FieldDef)
-> [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
-> [FieldDef]
forall a b. (a -> b) -> [a] -> [b]
map (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
-> FieldDef
forall a b. (a, b) -> a
fst [(FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))]
fds_ffs
, foreignRefTableDBName :: DBName
foreignRefTableDBName =
Text -> DBName
DBName Text
dbname
, foreignConstraintNameDBName :: DBName
foreignConstraintNameDBName =
Text -> DBName
DBName
(Text -> DBName) -> (DBName -> Text) -> DBName -> DBName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
oldDbName Text
dbname (Text -> Text) -> (DBName -> Text) -> DBName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBName -> Text
unDBName
(DBName -> DBName) -> DBName -> DBName
forall a b. (a -> b) -> a -> b
$ ForeignDef -> DBName
foreignConstraintNameDBName ForeignDef
fdef
}
Nothing ->
String -> ForeignDef
forall a. HasCallStack => String -> a
error (String -> ForeignDef) -> String -> ForeignDef
forall a b. (a -> b) -> a -> b
$ "no explicit primary key fdef="String -> ShowS
forall a. [a] -> [a] -> [a]
++ForeignDef -> String
forall a. Show a => a -> String
show ForeignDef
fdefString -> ShowS
forall a. [a] -> [a] -> [a]
++ " ent="String -> ShowS
forall a. [a] -> [a] -> [a]
++EntityDef -> String
forall a. Show a => a -> String
show EntityDef
ent
where
setNull :: [FieldDef] -> Bool
setNull :: [FieldDef] -> Bool
setNull [] = String -> Bool
forall a. HasCallStack => String -> a
error "setNull: impossible!"
setNull (fd :: FieldDef
fd:fds :: [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
$ "foreign key columns must all be nullable or non-nullable"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show ((FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HaskellName -> Text
unHaskellName (HaskellName -> Text)
-> (FieldDef -> HaskellName) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> HaskellName
fieldHaskell) (FieldDef
fdFieldDef -> [FieldDef] -> [FieldDef]
forall a. a -> [a] -> [a]
:[FieldDef]
fds))
isNull :: FieldDef -> Bool
isNull = (IsNullable
NotNullable IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
/=) (IsNullable -> Bool)
-> (FieldDef -> IsNullable) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> IsNullable
nullable ([Text] -> IsNullable)
-> (FieldDef -> [Text]) -> FieldDef -> IsNullable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> [Text]
fieldAttrs
toForeignFields :: EntityDef
-> Text
-> FieldDef
-> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
toForeignFields pent :: EntityDef
pent fieldText :: Text
fieldText pfd :: FieldDef
pfd =
case FieldDef
-> HaskellName -> [FieldDef] -> HaskellName -> Maybe String
chktypes FieldDef
fd HaskellName
haskellField (EntityDef -> [FieldDef]
entityFields EntityDef
pent) HaskellName
pfh of
Just err :: String
err -> String
-> (FieldDef, ((HaskellName, DBName), (HaskellName, DBName)))
forall a. HasCallStack => String -> a
error String
err
Nothing -> (FieldDef
fd, ((HaskellName
haskellField, FieldDef -> DBName
fieldDB FieldDef
fd), (HaskellName
pfh, DBName
pfdb)))
where
fd :: FieldDef
fd = [FieldDef] -> HaskellName -> FieldDef
getFd (EntityDef -> [FieldDef]
entityFields EntityDef
ent) HaskellName
haskellField
haskellField :: HaskellName
haskellField = Text -> HaskellName
HaskellName Text
fieldText
(pfh :: HaskellName
pfh, pfdb :: DBName
pfdb) = (FieldDef -> HaskellName
fieldHaskell FieldDef
pfd, FieldDef -> DBName
fieldDB FieldDef
pfd)
chktypes :: FieldDef -> HaskellName -> [FieldDef] -> HaskellName -> Maybe String
chktypes :: FieldDef
-> HaskellName -> [FieldDef] -> HaskellName -> Maybe String
chktypes ffld :: FieldDef
ffld _fkey :: HaskellName
_fkey pflds :: [FieldDef]
pflds pkey :: HaskellName
pkey =
if FieldDef -> FieldType
fieldType FieldDef
ffld FieldType -> FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== FieldDef -> FieldType
fieldType FieldDef
pfld then Maybe String
forall a. Maybe a
Nothing
else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ "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 -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldType -> String
forall a. Show a => a -> String
show (FieldDef -> FieldType
fieldType FieldDef
pfld)
where
pfld :: FieldDef
pfld = [FieldDef] -> HaskellName -> FieldDef
getFd [FieldDef]
pflds HaskellName
pkey
entName :: HaskellName
entName = EntityDef -> HaskellName
entityHaskell EntityDef
ent
getFd :: [FieldDef] -> HaskellName -> FieldDef
getFd [] t :: HaskellName
t = String -> FieldDef
forall a. HasCallStack => String -> a
error (String -> FieldDef) -> String -> FieldDef
forall a b. (a -> b) -> a -> b
$ "foreign key constraint for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (HaskellName -> Text
unHaskellName HaskellName
entName)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ " unknown column: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HaskellName -> String
forall a. Show a => a -> String
show HaskellName
t
getFd (f :: FieldDef
f:fs :: [FieldDef]
fs) t :: HaskellName
t
| FieldDef -> HaskellName
fieldHaskell FieldDef
f HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== HaskellName
t = FieldDef
f
| Bool
otherwise = [FieldDef] -> HaskellName -> FieldDef
getFd [FieldDef]
fs HaskellName
t
lengthError :: CompositeDef -> ForeignDef
lengthError pdef :: CompositeDef
pdef = String -> ForeignDef
forall a. HasCallStack => String -> a
error (String -> ForeignDef) -> String -> ForeignDef
forall a b. (a -> b) -> a -> b
$ "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]
++ " fkeys and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([FieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CompositeDef -> [FieldDef]
compositeFields CompositeDef
pdef)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " 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]
++ " pdef=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CompositeDef -> String
forall a. Show a => a -> String
show CompositeDef
pdef
data UnboundEntityDef = UnboundEntityDef
{ UnboundEntityDef -> [UnboundForeignDef]
_unboundForeignDefs :: [UnboundForeignDef]
, UnboundEntityDef -> EntityDef
unboundEntityDef :: EntityDef
}
overUnboundEntityDef
:: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overUnboundEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef
overUnboundEntityDef f :: EntityDef -> EntityDef
f ubed :: 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 key :: 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` "="
lookupPrefix :: Text -> [Text] -> Maybe Text
lookupPrefix :: Text -> [Text] -> Maybe Text
lookupPrefix prefix :: 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)
mkEntityDef :: PersistSettings
-> Text
-> [Attr]
-> [Line]
-> UnboundEntityDef
mkEntityDef :: PersistSettings -> Text -> [Text] -> [Line] -> UnboundEntityDef
mkEntityDef ps :: PersistSettings
ps name :: Text
name entattribs :: [Text]
entattribs lines :: [Line]
lines =
[UnboundForeignDef] -> EntityDef -> UnboundEntityDef
UnboundEntityDef [UnboundForeignDef]
foreigns (EntityDef -> UnboundEntityDef) -> EntityDef -> UnboundEntityDef
forall a b. (a -> b) -> a -> b
$
$WEntityDef :: HaskellName
-> DBName
-> FieldDef
-> [Text]
-> [FieldDef]
-> [UniqueDef]
-> [ForeignDef]
-> [Text]
-> Map Text [[Text]]
-> Bool
-> Maybe Text
-> EntityDef
EntityDef
{ entityHaskell :: HaskellName
entityHaskell = HaskellName
entName
, entityDB :: DBName
entityDB = Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
name' [Text]
entattribs
, entityId :: FieldDef
entityId = (Maybe CompositeDef -> FieldDef -> FieldDef
setComposite Maybe CompositeDef
primaryComposite (FieldDef -> FieldDef) -> FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$ FieldDef -> Maybe FieldDef -> FieldDef
forall a. a -> Maybe a -> a
fromMaybe FieldDef
autoIdField Maybe FieldDef
idField)
, entityAttrs :: [Text]
entityAttrs = [Text]
entattribs
, entityFields :: [FieldDef]
entityFields = [FieldDef]
cols
, entityUniques :: [UniqueDef]
entityUniques = [UniqueDef]
uniqs
, entityForeigns :: [ForeignDef]
entityForeigns = []
, entityDerives :: [Text]
entityDerives = [Text]
derives
, entityExtra :: Map Text [[Text]]
entityExtra = Map Text [[Text]]
extras
, entitySum :: Bool
entitySum = Bool
isSum
, entityComments :: Maybe Text
entityComments = Maybe Text
forall a. Maybe a
comments
}
where
comments :: Maybe a
comments = Maybe a
forall a. Maybe a
Nothing
entName :: HaskellName
entName = Text -> HaskellName
HaskellName Text
name'
(isSum :: Bool
isSum, name' :: Text
name') =
case Text -> Maybe (Char, Text)
T.uncons Text
name of
Just ('+', x :: Text
x) -> (Bool
True, Text
x)
_ -> (Bool
False, Text
name)
(attribs :: [[Text]]
attribs, extras :: 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 -> Maybe Text
attribPrefix "id" = String -> Maybe Text
forall a. HasCallStack => String -> a
error "id= is deprecated, ad a field named 'Id' and use sql="
| Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
(idField :: Maybe FieldDef
idField, primaryComposite :: Maybe CompositeDef
primaryComposite, uniqs :: [UniqueDef]
uniqs, foreigns :: [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' (\(mid :: Maybe FieldDef
mid, mp :: Maybe CompositeDef
mp, us :: [UniqueDef]
us, fs :: [UnboundForeignDef]
fs) attr :: [Text]
attr ->
let (i :: Maybe FieldDef
i, p :: Maybe CompositeDef
p, u :: Maybe UniqueDef
u, f :: 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 xs :: [a]
xs m :: Maybe a
m = [a]
xs [a] -> [a] -> [a]
forall a. Monoid a => a -> a -> a
`mappend` Maybe a -> [a]
forall a. Maybe a -> [a]
maybeToList Maybe a
m
in (Maybe FieldDef -> Maybe FieldDef -> Maybe FieldDef
forall x. Show x => Maybe x -> Maybe x -> Maybe x
just1 Maybe FieldDef
mid Maybe FieldDef
i, Maybe CompositeDef -> Maybe CompositeDef -> Maybe CompositeDef
forall x. Show x => Maybe x -> Maybe x -> Maybe x
just1 Maybe CompositeDef
mp Maybe CompositeDef
p, [UniqueDef] -> Maybe UniqueDef -> [UniqueDef]
forall a. [a] -> Maybe a -> [a]
squish [UniqueDef]
us Maybe UniqueDef
u, [UnboundForeignDef]
-> Maybe UnboundForeignDef -> [UnboundForeignDef]
forall a. [a] -> Maybe a -> [a]
squish [UnboundForeignDef]
fs Maybe UnboundForeignDef
f)) (Maybe FieldDef
forall a. Maybe a
Nothing, Maybe CompositeDef
forall a. Maybe a
Nothing, [],[]) [[Text]]
attribs
derives :: [Text]
derives = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ ([Text] -> Maybe [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Text] -> Maybe [Text]
takeDerives [[Text]]
attribs
cols :: [FieldDef]
cols :: [FieldDef]
cols = [FieldDef] -> [FieldDef]
forall a. [a] -> [a]
reverse ([FieldDef] -> [FieldDef])
-> ([[Text]] -> [FieldDef]) -> [[Text]] -> [FieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FieldDef], [Text]) -> [FieldDef]
forall a b. (a, b) -> a
fst (([FieldDef], [Text]) -> [FieldDef])
-> ([[Text]] -> ([FieldDef], [Text])) -> [[Text]] -> [FieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> ([FieldDef], [Text]) -> ([FieldDef], [Text]))
-> ([FieldDef], [Text]) -> [[Text]] -> ([FieldDef], [Text])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Text] -> ([FieldDef], [Text]) -> ([FieldDef], [Text])
k ([], []) ([[Text]] -> [FieldDef]) -> [[Text]] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [[Text]]
forall a. [a] -> [a]
reverse [[Text]]
attribs
k :: [Text] -> ([FieldDef], [Text]) -> ([FieldDef], [Text])
k x :: [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 comment :: Text
comment ->
([FieldDef]
acc, Text
comment Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
comments)
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 [] x :: FieldDef
x = FieldDef
x
setFieldComments xs :: [Text]
xs fld :: 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 "Primary Key") Maybe CompositeDef
primaryComposite
setComposite :: Maybe CompositeDef -> FieldDef -> FieldDef
setComposite Nothing fd :: FieldDef
fd = FieldDef
fd
setComposite (Just c :: CompositeDef
c) fd :: 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
x) (Just y :: x
y) = String -> Maybe x
forall a. HasCallStack => String -> a
error (String -> Maybe x) -> String -> Maybe x
forall a b. (a -> b) -> a -> b
$ "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 -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` x -> String
forall a. Show a => a -> String
show x
y
just1 x :: Maybe x
x y :: 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 ps :: PersistSettings
ps entName :: HaskellName
entName idName :: Maybe DBName
idName idSqlType :: SqlType
idSqlType = $WFieldDef :: HaskellName
-> DBName
-> FieldType
-> SqlType
-> [Text]
-> Bool
-> ReferenceDef
-> Maybe Text
-> FieldDef
FieldDef
{ fieldHaskell :: HaskellName
fieldHaskell = Text -> HaskellName
HaskellName "Id"
, 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
, fieldReference :: ReferenceDef
fieldReference = HaskellName -> FieldType -> ReferenceDef
ForeignRef HaskellName
entName FieldType
defaultReferenceTypeCon
, fieldAttrs :: [Text]
fieldAttrs = []
, fieldStrict :: Bool
fieldStrict = Bool
True
, fieldComments :: Maybe Text
fieldComments = Maybe Text
forall a. Maybe a
Nothing
}
defaultReferenceTypeCon :: FieldType
defaultReferenceTypeCon :: FieldType
defaultReferenceTypeCon = Maybe Text -> Text -> FieldType
FTTypeCon (Text -> Maybe Text
forall a. a -> Maybe a
Just "Data.Int") "Int64"
keyConName :: Text -> Text
keyConName :: Text -> Text
keyConName entName :: Text
entName = Text
entName Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` "Id"
splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]])
[] = ([], Map Text [[Text]]
forall k a. Map k a
M.empty)
splitExtras (Line indent :: Int
indent [name :: Text
name]:rest :: [Line]
rest)
| Bool -> Bool
not (Text -> Bool
T.null Text
name) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head Text
name) =
let (children :: [Line]
children, rest' :: [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
(x :: [[Text]]
x, y :: 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 _ ts :: [Text]
ts:rest :: [Line]
rest) =
let (x :: [[Text]]
x, y :: 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
(\ft :: Text
ft perr :: String
perr -> String -> Maybe FieldDef
forall a. HasCallStack => String -> a
error (String -> Maybe FieldDef) -> String -> Maybe FieldDef
forall a b. (a -> b) -> a -> b
$ "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 -> 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 _ _ ("deriving":_) = Maybe FieldDef
forall a. Maybe a
Nothing
takeCols onErr :: Text -> String -> Maybe FieldDef
onErr ps :: PersistSettings
ps (n' :: Text
n':typ :: Text
typ:rest :: [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 err :: String
err -> Text -> String -> Maybe FieldDef
onErr Text
typ String
err
Right ft :: FieldType
ft -> FieldDef -> Maybe FieldDef
forall a. a -> Maybe a
Just $WFieldDef :: HaskellName
-> DBName
-> FieldType
-> SqlType
-> [Text]
-> Bool
-> ReferenceDef
-> Maybe Text
-> FieldDef
FieldDef
{ fieldHaskell :: HaskellName
fieldHaskell = Text -> HaskellName
HaskellName Text
n
, fieldDB :: DBName
fieldDB = Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> [Text] -> Text
getDbName PersistSettings
ps Text
n [Text]
rest
, fieldType :: FieldType
fieldType = FieldType
ft
, fieldSqlType :: SqlType
fieldSqlType = Text -> SqlType
SqlOther (Text -> SqlType) -> Text -> SqlType
forall a b. (a -> b) -> a -> b
$ "SqlType unset for " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
n
, fieldAttrs :: [Text]
fieldAttrs = [Text]
rest
, fieldStrict :: Bool
fieldStrict = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (PersistSettings -> Bool
psStrictFields PersistSettings
ps) Maybe Bool
mstrict
, fieldReference :: ReferenceDef
fieldReference = ReferenceDef
NoReference
, fieldComments :: Maybe Text
fieldComments = Maybe Text
forall a. Maybe a
Nothing
}
where
(mstrict :: Maybe Bool
mstrict, n :: Text
n)
| Just x :: Text
x <- Text -> Text -> Maybe Text
T.stripPrefix "!" Text
n' = (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True, Text
x)
| Just x :: Text
x <- Text -> Text -> Maybe Text
T.stripPrefix "~" 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 _ _ _ = Maybe FieldDef
forall a. Maybe a
Nothing
getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName :: PersistSettings -> Text -> [Text] -> Text
getDbName ps :: PersistSettings
ps n :: Text
n [] = PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
n
getDbName ps :: PersistSettings
ps n :: Text
n (a :: Text
a:as :: [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 "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 ps :: PersistSettings
ps tableName :: Text
tableName defs :: [FieldDef]
defs (n :: Text
n:rest :: [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
== "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
== "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
== "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
== "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 "" [FieldDef]
defs (Text
nText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest), Maybe UnboundForeignDef
forall a. Maybe a
Nothing)
takeConstraint _ _ _ _ = (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)
takeId :: PersistSettings -> Text -> [Text] -> FieldDef
takeId :: PersistSettings -> Text -> [Text] -> FieldDef
takeId ps :: PersistSettings
ps tableName :: Text
tableName (n :: Text
n:rest :: [Text]
rest) = FieldDef -> Maybe FieldDef -> FieldDef
forall a. a -> Maybe a -> a
fromMaybe (String -> FieldDef
forall a. HasCallStack => String -> a
error "takeId: impossible!") (Maybe FieldDef -> FieldDef) -> Maybe FieldDef -> FieldDef
forall a b. (a -> b) -> a -> b
$ Maybe FieldDef -> Maybe FieldDef
setFieldDef (Maybe FieldDef -> Maybe FieldDef)
-> Maybe FieldDef -> Maybe FieldDef
forall a b. (a -> b) -> a -> b
$
(Text -> String -> Maybe FieldDef)
-> PersistSettings -> [Text] -> Maybe FieldDef
takeCols (\_ _ -> Maybe FieldDef
addDefaultIdType) PersistSettings
ps (Text
fieldText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
rest [Text] -> [Text] -> [Text]
forall a. Monoid a => a -> a -> a
`mappend` [Text]
setIdName)
where
field :: Text
field = case Text -> Maybe (Char, Text)
T.uncons Text
n of
Nothing -> String -> Text
forall a. HasCallStack => String -> a
error "takeId: empty field"
Just (f :: Char
f, ield :: Text
ield) -> Char -> Char
toLower Char
f Char -> Text -> Text
`T.cons` Text
ield
addDefaultIdType :: Maybe FieldDef
addDefaultIdType = PersistSettings -> [Text] -> Maybe FieldDef
takeColsEx PersistSettings
ps (Text
field Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
keyCon Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest [Text] -> [Text] -> [Text]
forall a. Monoid a => a -> a -> a
`mappend` [Text]
setIdName)
setFieldDef :: Maybe FieldDef -> Maybe FieldDef
setFieldDef = (FieldDef -> FieldDef) -> Maybe FieldDef -> Maybe FieldDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\fd :: FieldDef
fd ->
let refFieldType :: FieldType
refFieldType = if FieldDef -> FieldType
fieldType FieldDef
fd FieldType -> FieldType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text -> Text -> FieldType
FTTypeCon Maybe Text
forall a. Maybe a
Nothing Text
keyCon
then FieldType
defaultReferenceTypeCon
else FieldDef -> FieldType
fieldType FieldDef
fd
in FieldDef
fd { fieldReference :: ReferenceDef
fieldReference = HaskellName -> FieldType -> ReferenceDef
ForeignRef (Text -> HaskellName
HaskellName Text
tableName) (FieldType -> ReferenceDef) -> FieldType -> ReferenceDef
forall a b. (a -> b) -> a -> b
$ FieldType
refFieldType
})
keyCon :: Text
keyCon = Text -> Text
keyConName Text
tableName
setIdName :: [Text]
setIdName = ["sql=" Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` PersistSettings -> Text
psIdName PersistSettings
ps]
takeId _ tableName :: Text
tableName _ = String -> FieldDef
forall a. HasCallStack => String -> a
error (String -> FieldDef) -> String -> FieldDef
forall a b. (a -> b) -> a -> b
$ "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 fields :: [FieldDef]
fields pkcols :: [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
(_, attrs :: [Text]
attrs) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ("!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
pkcols
getDef :: [FieldDef] -> Text -> FieldDef
getDef [] t :: Text
t = String -> FieldDef
forall a. HasCallStack => String -> a
error (String -> FieldDef) -> String -> FieldDef
forall a b. (a -> b) -> a -> b
$ "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 (d :: FieldDef
d:ds :: [FieldDef]
ds) t :: Text
t
| FieldDef -> HaskellName
fieldHaskell FieldDef
d HaskellName -> HaskellName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> HaskellName
HaskellName Text
t =
if [Text] -> IsNullable
nullable (FieldDef -> [Text]
fieldAttrs FieldDef
d) IsNullable -> IsNullable -> Bool
forall a. Eq a => a -> a -> Bool
/= IsNullable
NotNullable
then String -> FieldDef
forall a. HasCallStack => String -> a
error (String -> FieldDef) -> String -> FieldDef
forall a b. (a -> b) -> a -> b
$ "primary key column cannot be nullable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
else FieldDef
d
| Bool
otherwise = [FieldDef] -> Text -> FieldDef
getDef [FieldDef]
ds Text
t
takeUniq :: PersistSettings
-> Text
-> [FieldDef]
-> [Text]
-> UniqueDef
takeUniq :: PersistSettings -> Text -> [FieldDef] -> [Text] -> UniqueDef
takeUniq ps :: PersistSettings
ps tableName :: Text
tableName defs :: [FieldDef]
defs (n :: Text
n:rest :: [Text]
rest)
| Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Char
T.head Text
n)
= HaskellName
-> DBName -> [(HaskellName, DBName)] -> [Text] -> UniqueDef
UniqueDef
(Text -> HaskellName
HaskellName Text
n)
DBName
dbName
((Text -> (HaskellName, DBName))
-> [Text] -> [(HaskellName, DBName)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> HaskellName
HaskellName (Text -> HaskellName)
-> (Text -> DBName) -> Text -> (HaskellName, DBName)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [FieldDef] -> Text -> DBName
getDBName [FieldDef]
defs) [Text]
fields)
[Text]
attrs
where
isAttr :: Text -> Bool
isAttr a :: Text
a =
"!" Text -> Text -> Bool
`T.isPrefixOf` Text
a
isSqlName :: Text -> Bool
isSqlName a :: Text
a =
"sql=" Text -> Text -> Bool
`T.isPrefixOf` Text
a
isNonField :: Text -> Bool
isNonField a :: Text
a =
Text -> Bool
isAttr Text
a
Bool -> Bool -> Bool
|| Text -> Bool
isSqlName Text
a
(fields :: [Text]
fields, nonFields :: [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
Nothing ->
Maybe DBName
forall a. Maybe a
Nothing
(Just t :: Text
t) ->
case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop 1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn "=" Text
t of
(x :: Text
x : _) -> DBName -> Maybe DBName
forall a. a -> Maybe a
Just (Text -> DBName
DBName Text
x)
_ -> 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 [] t :: Text
t =
String -> DBName
forall a. HasCallStack => String -> a
error (String -> DBName) -> String -> DBName
forall a b. (a -> b) -> a -> b
$ "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 -> 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
attrs
getDBName (d :: FieldDef
d:ds :: [FieldDef]
ds) t :: 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 _ tableName :: Text
tableName _ xs :: [Text]
xs =
String -> UniqueDef
forall a. HasCallStack => String -> a
error (String -> UniqueDef) -> String -> UniqueDef
forall a b. (a -> b) -> a -> b
$ "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]
++ "] expecting an uppercase constraint name xs="
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
xs
data UnboundForeignDef = UnboundForeignDef
{ UnboundForeignDef -> [Text]
_unboundFields :: [Text]
, UnboundForeignDef -> ForeignDef
_unboundForeignDef :: ForeignDef
}
takeForeign :: PersistSettings
-> Text
-> [FieldDef]
-> [Text]
-> UnboundForeignDef
takeForeign :: PersistSettings
-> Text -> [FieldDef] -> [Text] -> UnboundForeignDef
takeForeign ps :: PersistSettings
ps tableName :: Text
tableName _defs :: [FieldDef]
_defs (refTableName :: Text
refTableName:n :: Text
n:rest :: [Text]
rest)
| Bool -> Bool
not (Text -> Bool
T.null Text
n) Bool -> Bool -> Bool
&& Char -> Bool
isLower (Text -> Char
T.head Text
n)
= [Text] -> ForeignDef -> UnboundForeignDef
UnboundForeignDef [Text]
fields (ForeignDef -> UnboundForeignDef)
-> ForeignDef -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ $WForeignDef :: HaskellName
-> DBName
-> HaskellName
-> DBName
-> [((HaskellName, DBName), (HaskellName, DBName))]
-> [Text]
-> Bool
-> ForeignDef
ForeignDef
{ foreignRefTableHaskell :: HaskellName
foreignRefTableHaskell =
Text -> HaskellName
HaskellName Text
refTableName
, foreignRefTableDBName :: DBName
foreignRefTableDBName =
Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps Text
refTableName
, foreignConstraintNameHaskell :: HaskellName
foreignConstraintNameHaskell =
Text -> HaskellName
HaskellName Text
n
, foreignConstraintNameDBName :: DBName
foreignConstraintNameDBName =
Text -> DBName
DBName (Text -> DBName) -> Text -> DBName
forall a b. (a -> b) -> a -> b
$ PersistSettings -> Text -> Text
psToDBName PersistSettings
ps (Text
tableName Text -> Text -> Text
`T.append` Text
n)
, foreignFields :: [((HaskellName, DBName), (HaskellName, DBName))]
foreignFields =
[]
, foreignAttrs :: [Text]
foreignAttrs =
[Text]
attrs
, foreignNullable :: Bool
foreignNullable =
Bool
False
}
where
(fields :: [Text]
fields,attrs :: [Text]
attrs) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ("!" Text -> Text -> Bool
`T.isPrefixOf`) [Text]
rest
takeForeign _ tableName :: Text
tableName _ xs :: [Text]
xs = String -> UnboundForeignDef
forall a. HasCallStack => String -> a
error (String -> UnboundForeignDef) -> String -> UnboundForeignDef
forall a b. (a -> b) -> a -> b
$ "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]
++ "] expecting a lower case constraint name xs=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
xs
takeDerives :: [Text] -> Maybe [Text]
takeDerives :: [Text] -> Maybe [Text]
takeDerives ("deriving":rest :: [Text]
rest) = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
rest
takeDerives _ = Maybe [Text]
forall a. Maybe a
Nothing
nullable :: [Text] -> IsNullable
nullable :: [Text] -> IsNullable
nullable s :: [Text]
s
| "Maybe" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
s = WhyNullable -> IsNullable
Nullable WhyNullable
ByMaybeAttr
| "nullable" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
s = WhyNullable -> IsNullable
Nullable WhyNullable
ByNullableAttr
| Bool
otherwise = IsNullable
NotNullable