Skip to content

Commit dfb73e2

Browse files
snoybergsnoyberg
committed
New nested FieldType
1 parent 803ee75 commit dfb73e2

3 files changed

Lines changed: 78 additions & 74 deletions

File tree

‎persistent/Database/Persist/EntityDef.hs‎

Lines changed: 5 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,6 @@ module Database.Persist.EntityDef
77
, EntityDef (..)
88
, FieldDef (..)
99
, FieldType (..)
10-
, isEmbedded
1110
, UniqueDef (..)
1211
, ExtraLine
1312
) where
@@ -36,40 +35,11 @@ newtype DBName = DBName { unDBName :: Text }
3635

3736
type Attr = Text
3837

39-
-- | EmbedNone signifies a simple type (Text, Int64, etc) that can already be persisted.
40-
-- An embeddded type is one that you also define in your persistent schema.
41-
-- So we have a schema like:
42-
--
43-
-- @
44-
-- [persistUpperCase|
45-
--
46-
-- Embedded no-migrate
47-
-- name String
48-
--
49-
-- HasEmbeds
50-
-- name String
51-
-- simple Embedded
52-
-- list [Embedded]
53-
-- set Set Embedded
54-
-- @
55-
--
56-
-- Note the use of the no-migrate flag to tell SQL not to generate a migration for the embedded entity.
57-
-- In our schema we demonstrate the different supported types:
58-
--
59-
-- * EmbedSimple: just embed a single entity
60-
-- * EmbedList: embed a list of entities
61-
-- * EmbedSet: embed a set of entities
62-
data FieldType = EmbedNone { unFieldType :: Text }
63-
| EmbedSimple { unFieldType :: Text }
64-
| EmbedList { unFieldType :: Text }
65-
| EmbedSet { unFieldType :: Text }
66-
deriving (Show, Eq, Read, Ord)
67-
68-
isEmbedded :: FieldDef -> Bool
69-
isEmbedded fd = isEmbeddedType (fieldType fd)
70-
where
71-
isEmbeddedType (EmbedNone _) = False
72-
isEmbeddedType _ = True
38+
data FieldType
39+
= FTTypeCon (Maybe Text) Text -- ^ optional module, name
40+
| FTApp FieldType FieldType
41+
| FTList FieldType
42+
deriving (Show, Eq, Read, Ord)
7343

7444
data FieldDef = FieldDef
7545
{ fieldHaskell :: HaskellName

‎persistent/Database/Persist/Quasi.hs‎

Lines changed: 53 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Database.Persist.Quasi
88
#if TEST
99
, Token (..)
1010
, tokenize
11+
, parseFieldType
1112
#endif
1213
) where
1314

@@ -19,7 +20,42 @@ import Data.Text (Text)
1920
import qualified Data.Text as T
2021
import Control.Arrow ((&&&))
2122
import qualified Data.Map as M
22-
import qualified Data.Set as S
23+
import Data.List (foldl')
24+
25+
data ParseState a = PSDone | PSFail | PSSuccess a Text
26+
27+
parseFieldType :: Text -> Maybe FieldType
28+
parseFieldType t0 =
29+
case go1 $ T.concat ["(", t0, ")"] of
30+
PSSuccess ft t'
31+
| T.all isSpace t' -> Just ft
32+
_ -> Nothing
33+
where
34+
go1 t =
35+
case T.uncons t of
36+
Nothing -> PSDone
37+
Just (c, t')
38+
| isSpace c -> go1 $ T.dropWhile isSpace t'
39+
| c == '(' ->
40+
case goMany id t' of
41+
PSSuccess (ft:fts) t'' ->
42+
case T.uncons $ T.dropWhile isSpace t'' of
43+
Just (')', t''') -> PSSuccess (foldl' FTApp ft fts) t'''
44+
_ -> PSFail
45+
_ -> PSFail
46+
| isUpper c ->
47+
let (a, b) = T.break (\c -> isSpace c || c `elem` "()") t
48+
in PSSuccess (getCon a) b
49+
| otherwise -> PSFail
50+
getCon t =
51+
case T.breakOnEnd "." t of
52+
(_, "") -> FTTypeCon Nothing t
53+
("", _) -> FTTypeCon Nothing t
54+
(a, b) -> FTTypeCon (Just $ T.init a) b
55+
goMany front t =
56+
case go1 t of
57+
PSSuccess x t' -> goMany (front . (x:)) t'
58+
_ -> PSSuccess (front []) t
2359

2460
data PersistSettings = PersistSettings
2561
{ psToDBName :: Text -> Text
@@ -120,28 +156,21 @@ removeSpaces =
120156
-- | Divide lines into blocks and make entity definitions.
121157
parseLines :: PersistSettings -> [Line] -> [EntityDef]
122158
parseLines ps lines =
123-
let entNames = S.fromList $ mapMaybe entName lines
124-
in toEntities entNames
159+
toEnts lines
125160
where
126-
entName (Line _ (name:_)) = Just name
127-
entName _ = Nothing
128-
129-
toEntities entNames = toEnts lines
130-
where
131-
toEnts (Line indent (name:entattribs) : rest) =
132-
let (x, y) = span ((> indent) . lineIndent) rest
133-
in mkEntityDef ps entNames name entattribs x : toEnts y
134-
toEnts (Line _ []:rest) = toEnts rest
135-
toEnts [] = []
161+
toEnts (Line indent (name:entattribs) : rest) =
162+
let (x, y) = span ((> indent) . lineIndent) rest
163+
in mkEntityDef ps name entattribs x : toEnts y
164+
toEnts (Line _ []:rest) = toEnts rest
165+
toEnts [] = []
136166

137167
-- | Construct an entity definition.
138168
mkEntityDef :: PersistSettings
139-
-> S.Set Text -- ^ Entity names
140169
-> Text -- ^ name
141170
-> [Attr] -- ^ entity attributes
142171
-> [Line] -- ^ indented lines
143172
-> EntityDef
144-
mkEntityDef ps entityNames name entattribs lines =
173+
mkEntityDef ps name entattribs lines =
145174
EntityDef
146175
(HaskellName name)
147176
(DBName $ psToDBName ps name)
@@ -159,19 +188,9 @@ mkEntityDef ps entityNames name entattribs lines =
159188
derives = case mapMaybe takeDerives attribs of
160189
[] -> ["Show", "Read", "Eq"]
161190
x -> concat x
191+
162192
cols :: [FieldDef]
163-
cols = map toSimple noSimpleCols
164-
where
165-
toSimple fd@FieldDef { fieldType = (EmbedNone t) }
166-
| S.member t entityNames = fd { fieldType = (EmbedSimple t) }
167-
toSimple n = n
168-
169-
noSimpleCols :: [FieldDef]
170-
noSimpleCols = mapMaybe (takeCols ps) attribs
171-
{-embedNoneStr x =-}
172-
{-case x of-}
173-
{-EmbedNone str -> Just str-}
174-
{-_ -> Nothing-}
193+
cols = mapMaybe (takeCols ps) attribs
175194

176195
splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]])
177196
splitExtras [] = ([], M.empty)
@@ -188,19 +207,14 @@ takeCols :: PersistSettings -> [Text] -> Maybe FieldDef
188207
takeCols _ ("deriving":_) = Nothing
189208
takeCols ps (n:typ:rest)
190209
| not (T.null n) && isLower (T.head n) =
191-
let (rst, ft) = checkEmbed
192-
in Just $ FieldDef
193-
(HaskellName n)
194-
(DBName $ db rest)
195-
ft
196-
rst
210+
case parseFieldType typ of
211+
Nothing -> error $ "Invalid field type: " ++ show typ
212+
Just ft -> Just $ FieldDef
213+
(HaskellName n)
214+
(DBName $ db rest)
215+
ft
216+
rest
197217
where
198-
checkEmbed | T.head typ == '[' && T.last typ == ']' =
199-
(rest, EmbedList (T.init $ T.tail typ))
200-
| typ == "Set" = (tail rest, EmbedSet (head rest))
201-
-- don't know yet if it is an EmbedSimple
202-
| otherwise = (rest, EmbedNone typ)
203-
204218
db [] = psToDBName ps n
205219
db (a:as) =
206220
case T.stripPrefix "sql=" a of

‎persistent/test/main.hs‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@ import Test.Hspec.HUnit ()
44
import Test.HUnit
55

66
import Database.Persist.Quasi
7+
import Database.Persist.EntityDef
78

89
main :: IO ()
910
main = hspecX $ do
@@ -45,3 +46,22 @@ main = hspecX $ do
4546
, Spaces 2
4647
, Token "baz\""
4748
]
49+
describe "parseFieldType" $ do
50+
it "simple types" $
51+
parseFieldType "FooBar" @?= Just (FTTypeCon Nothing "FooBar")
52+
it "module types" $
53+
parseFieldType "Data.Map.FooBar" @?= Just (FTTypeCon (Just "Data.Map") "FooBar")
54+
it "application" $
55+
parseFieldType "Foo Bar" @?= Just (
56+
FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
57+
it "application multiple" $
58+
parseFieldType "Foo Bar Baz" @?= Just (
59+
(FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
60+
`FTApp` FTTypeCon Nothing "Baz"
61+
)
62+
it "parens" $ do
63+
let foo = FTTypeCon Nothing "Foo"
64+
bar = FTTypeCon Nothing "Bar"
65+
baz = FTTypeCon Nothing "Baz"
66+
parseFieldType "Foo (Bar Baz)" @?= Just (
67+
foo `FTApp` (bar `FTApp` baz))

0 commit comments

Comments
 (0)