persistent 2.10.5 → 2.10.5.1
raw patch · 4 files changed
+799/−30 lines, 4 files
Files
- ChangeLog.md +6/−0
- Database/Persist/Quasi.hs +393/−29
- persistent.cabal +1/−1
- test/main.hs +399/−0
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for persistent +## 2.10.5.1++* [#1024](https://github.com/yesodweb/persistent/pull/1024)+ * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. + * Add Haddock explainers for some of the supported entity syntax in `Database.Persist.Quasi`+ ## 2.10.5 * Add the `EntityWithPrefix` type to allow users to specify a custom prefix for raw SQL queries. [#1018](https://github.com/yesodweb/persistent/pull/1018)
Database/Persist/Quasi.hs view
@@ -1,6 +1,243 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-}++{-|+This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities.++The basic structure of the syntax looks like this:++> TableName+> fieldName FieldType+> otherField String+> nullableField Int Maybe++You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type.++@persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL:++> CREATE TABLE table_name (+> id SERIAL PRIMARY KEY,+> field_name field_type NOT NULL,+> other_field varchar NOT NULL,+> nullable_field int NULL+> );++Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function.++It generates a Haskell datatype with the following form:++@+data TableName = TableName+ { tableNameFieldName :: FieldType+ , tableNameOtherField :: String+ , tableNameNullableField :: Maybe Int+ }+@++As with the SQL generated, the specifics of this are customizable.+See the @persistent-template@ package for details.++= Deriving++You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that.+Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses.++> User+> name String+> age Int+> deriving Eq Show+> deriving Ord++= Unique Keys++You can define a uniqueness key on a table with the following format:++> User+> name String+> age Int+>+> UniqueUserName name++This will put a unique index on the @user@ table and the @name@ field.++= Setting defaults++You can use a @default=${sql expression}@ clause to set a default for a field.+The thing following the `=` is interpreted as SQL that will be put directly into the table definition.++@+User+ name Text+ admin Bool default=false+@++This creates a SQL definition like this:++> CREATE TABLE user (+> id SERIAL PRIMARY KEY,+> name VARCHAR NOT NULL,+> admin BOOL DEFAULT=false+> );++A restriction here is that you still need to provide a value when performing an `insert`, because the generated Haskell type has the form:++@+data User = User+ { userName :: Text+ , userAdmin :: Bool+ }+@++You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default.++= Custom ID column++If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field.+This @User@ has a @Text@ ID.++> User+> Id Text+> name Text+> age Int++If you do this, it's a good idea to set a default for the ID.+Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts.++@+'insertKey' (UserKey "Hello world!") (User "Bob" 32)+@++If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore.+So instead just use a default expression, like this:++@+User+ Id Text default=generate_user_id()+ name Text+ age Int+@++= Custom Primary Keys++Sometimes you don't want to have an ID column, and you want a different sort of primary key.+This is a table that stores unique email addresses, and the email is the primary key.+We store the first and second part (eg @first\@second@) separately.++@+Email+ firstPart Text+ secondPart Text++ Primary firstPart secondPart+@++This creates a table with the following form:++@+CREATE TABLE email (+ first_part varchar,+ second_part varchar,++ PRIMARY KEY (first_part, second_part)+@++You can specify 1 or more columns in the primary key.++= Overriding SQL++You can use a @sql=custom@ annotation to provide some customization on the entity and field.+For example, you might prefer to name a table differently than what @persistent@ will do by default.+You may also prefer to name a field differently.++@+User sql=big_user_table+ fullName String sql=name+ age Int+@++This will alter the generated SQL to be:++@+CREATE TABEL big_user_table (+ id SERIAL PRIMARY KEY,+ name VARCHAR,+ age INT+);+@++= Attributes++The QuasiQuoter allows you to provide arbitrary attributes to an entity or field.+This can be used to extend the code in ways that the library hasn't anticipated.+If you use this feature, we'd definitely appreciate hearing about it and potentially supporting your use case directly!++@+User !funny+ field String !sad+ good Dog !sogood+@++We can see the attributes using the 'entityAttrs' field and the 'fieldAttrs' field.++@+userAttrs = do+ let userDefinition = 'entityDef' ('Proxy' :: 'Proxy' User)+ let userAttributes = 'entityAttrs' userDefinition+ let fieldAttributes = 'map' 'fieldAttrs' ('entityFields' userDefinition)+ print userAttributes+-- ["funny"]+ print fieldAttributes+-- [["sad"],["sogood"]]+@++= Documentation Comments++The quasiquoter supports ordinary comments with @--@ and @#@.+Since @persistent-2.10.5.1@, it also supports documentation comments.+The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions:++1. Only the @-- | @ form is allowed.+2. You must put a space before and after the @|@ pipe character.+3. The comment must be indented at the same level as the entity or field it documents.++An example of the field documentation is:++@+-- | I am a doc comment for a User. Users are important+-- | to the application, and should be treasured.+User+ -- | Users have names. Call them by names.+ name String+ -- | A user can be old, or young, and we care about+ -- | this for some reason.+ age Int+@++The documentation is present on the `entityComments` field on the `EntityDef` for the entity:++@+>>> let userDefinition = entityDef (Proxy :: Proxy User)+>>> entityComments userDefinition+"I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n"+@++Likewise, the field documentation is present in the `fieldComments` field on the `FieldDef` present in the `EntityDef`:++@+>>> let userFields = entityFields userDefinition+>>> let comments = map fieldComments userFields+>>> mapM_ putStrLn comments+"Users have names. Call them by names."+"A user can be old, or young, and we care about\nthis for some reason."+@++Unfortunately, we can't use this to create Haddocks for you, because <https://gitlab.haskell.org/ghc/ghc/issues/5467 Template Haskell does not support Haddock yet>.+`persistent` backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions.++-} module Database.Persist.Quasi ( parse , PersistSettings (..)@@ -9,19 +246,28 @@ , 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)+import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe) import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T@@ -109,21 +355,26 @@ -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef]-parse ps = parseLines ps- . removeSpaces- . filter (not . empty)- . map tokenize- . T.lines+parse ps = parseLines ps . preparse +preparse :: Text -> [Line]+preparse =+ removeSpaces+ . filter (not . empty)+ . map tokenize+ . 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 (Show, Eq) -- | Tokenize a string. tokenize :: Text -> [Token] tokenize t | T.null t = []+ | "-- | " `T.isPrefixOf` t = [DocComment t] | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) | T.head t == '"' = quotes (T.tail t) id@@ -181,10 +432,23 @@ -- | 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 = Line { lineIndent :: Int- , tokens :: [Text]- }+data Line' f+ = Line+ { lineIndent :: Int+ , 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 k (Line i t) = Line i (k t)++traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g)+traverseLine k (Line i xs) = Line i <$> k xs++type Line = Line' []+ -- | Remove leading spaces and remove spaces in the middle of the -- tokens. removeSpaces :: [[Token]] -> [Line]@@ -197,6 +461,7 @@ toLine' i = Line i . mapMaybe fromToken fromToken (Token t) = Just t+ fromToken (DocComment t) = Just t fromToken Spaces{} = Nothing -- | Divide lines into blocks and make entity definitions.@@ -204,12 +469,88 @@ parseLines ps lines = fixForeignKeysAll $ toEnts lines where- toEnts (Line indent (name:entattribs) : rest) =- let (x, y) = span ((> indent) . lineIndent) rest- in mkEntityDef ps name entattribs x : toEnts y- toEnts (Line _ []:rest) = toEnts rest- toEnts [] = []+ toEnts :: [Line] -> [UnboundEntityDef]+ toEnts =+ map mk+ . associateLines+ . skipEmpty+ mk :: LinesWithComments -> UnboundEntityDef+ mk lwc =+ let Line _ (name :| entAttribs) :| rest = lwcLines lwc+ in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs (map (mapLine NEL.toList) rest) +isComment :: Text -> Maybe Text+isComment xs =+ T.stripPrefix "-- | " xs++data LinesWithComments = LinesWithComments+ { lwcLines :: NonEmpty (Line' NonEmpty)+ , lwcComments :: [Text]+ } deriving (Eq, 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 a b =+ LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b)++newLine :: Line' NonEmpty -> LinesWithComments+newLine l = LinesWithComments (pure l) []++firstLine :: LinesWithComments -> Line' NonEmpty+firstLine = NEL.head . lwcLines++consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments+consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) }++consComment :: Text -> LinesWithComments -> LinesWithComments+consComment l lwc = lwc { lwcComments = l : lwcComments lwc }++associateLines :: [Line' NonEmpty] -> [LinesWithComments]+associateLines lines =+ foldr combine [] $+ foldr toLinesWithComments [] lines+ where+ toLinesWithComments line linesWithComments =+ case linesWithComments of+ [] ->+ [newLine line]+ (lwc : lwcs) ->+ case isComment (NEL.head (tokens line)) of+ Just comment+ | lineIndent line == lowestIndent ->+ consComment comment lwc : lwcs+ _ ->+ if lineIndent line <= lineIndent (firstLine lwc)+ then+ consLine line lwc : lwcs+ else+ newLine line : lwc : lwcs++ lowestIndent = minimum . fmap lineIndent $ lines+ combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments]+ combine lwc [] =+ [lwc]+ combine lwc (lwc' : lwcs) =+ let minIndent = minimumIndentOf lwc+ otherIndent = minimumIndentOf lwc'+ in+ if minIndent < otherIndent then+ appendLwc lwc lwc' : lwcs+ else+ lwc : lwc' : lwcs+++ minimumIndentOf = minimum . fmap lineIndent . lwcLines++skipEmpty :: [Line' []] -> [Line' NonEmpty]+skipEmpty = mapMaybe (traverseLine NEL.nonEmpty)++setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef+setComments [] = id+setComments comments =+ overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) })+ fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] fixForeignKeysAll unEnts = map fixForeignKeys unEnts where@@ -282,7 +623,12 @@ , unboundEntityDef :: EntityDef } +overUnboundEntityDef+ :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef+overUnboundEntityDef f ubed =+ ubed { unboundEntityDef = f (unboundEntityDef ubed) } + lookupKeyVal :: Text -> [Text] -> Maybe Text lookupKeyVal key = lookupPrefix $ key `mappend` "=" lookupPrefix :: Text -> [Text] -> Maybe Text@@ -297,20 +643,21 @@ mkEntityDef ps name entattribs lines = UnboundEntityDef foreigns $ EntityDef- entName- (DBName $ getDbName ps name' entattribs)+ { entityHaskell = entName+ , entityDB = DBName $ getDbName ps name' entattribs -- idField is the user-specified Id -- otherwise useAutoIdField -- but, adjust it if the user specified a Primary- (setComposite primaryComposite $ fromMaybe autoIdField idField)- entattribs- cols- uniqs- []- derives- extras- isSum- comments+ , entityId = (setComposite primaryComposite $ fromMaybe autoIdField idField)+ , entityAttrs = entattribs+ , entityFields = cols+ , entityUniques = uniqs+ , entityForeigns = []+ , entityDerives = derives+ , entityExtra = extras+ , entitySum = isSum+ , entityComments = comments+ } where comments = Nothing entName = HaskellName name'@@ -332,7 +679,18 @@ derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef]- cols = mapMaybe (takeColsEx ps) attribs+ cols = reverse . fst . foldr k ([], []) $ reverse attribs+ k x (!acc, !comments) =+ case isComment =<< listToMaybe x of+ Just comment ->+ (acc, comment : comments)+ Nothing ->+ ( maybe id (:) (setFieldComments comments <$> takeColsEx ps x) acc+ , []+ )+ setFieldComments [] x = x+ setFieldComments xs fld =+ fld { fieldComments = Just (T.unlines xs) } autoIdField = mkAutoIdField ps entName (DBName `fmap` idName) idSqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite@@ -382,9 +740,15 @@ in (ts:x, y) takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef-takeColsEx = takeCols (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr)+takeColsEx =+ takeCols+ (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) -takeCols :: (Text -> String -> Maybe FieldDef) -> PersistSettings -> [Text] -> Maybe FieldDef+takeCols+ :: (Text -> String -> Maybe FieldDef)+ -> PersistSettings+ -> [Text]+ -> Maybe FieldDef takeCols _ _ ("deriving":_) = Nothing takeCols onErr ps (n':typ:rest) | not (T.null n) && isLower (T.head n) =
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.10.5+version: 2.10.5.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>
test/main.hs view
@@ -1,4 +1,10 @@+{-# language RecordWildCards #-}+ import Test.Hspec+import qualified Data.Text as T+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as Map import Database.Persist.Quasi import Database.Persist.Types@@ -74,6 +80,21 @@ , Spaces 1 , Token "baz=bin\"" ]+ describe "comments" $ do+ it "recognizes one line" $ do+ tokenize "-- | this is a comment" `shouldBe`+ [ DocComment "-- | this is a comment"+ ]+ it "map tokenize" $ do+ map tokenize ["Foo", "-- | Hello"]+ `shouldBe`+ [ [Token "Foo"]+ , [DocComment "-- | Hello"]+ ]+ it "works if comment is indented" $ do+ tokenize " -- | comment" `shouldBe`+ [ Spaces 2, DocComment "-- | comment"+ ] describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")@@ -100,3 +121,381 @@ baz = FTTypeCon Nothing "Baz" parseFieldType "Foo [Bar] Baz" `shouldBe` Right ( foo `FTApp` bars `FTApp` baz)++ describe "preparse" $ do+ it "recognizes entity" $ do+ preparse "Person\n name String\n age Int" `shouldBe`+ [ Line { lineIndent = 0, tokens = ["Person"] }+ , Line { lineIndent = 2, tokens = ["name", "String"] }+ , Line { lineIndent = 2, tokens = ["age", "Int"] }+ ]+ describe "recognizes comments" $ do+ let text = "Foo\n x X\n-- | Hello\nBar\n name String"+ linesText = T.lines text+ it "T.lines" $ do+ linesText+ `shouldBe`+ [ "Foo"+ , " x X"+ , "-- | Hello"+ , "Bar"+ , " name String"+ ]+ let tokens = map tokenize linesText+ it "map tokenize" $ do+ tokens `shouldBe`+ [ [ Token "Foo" ]+ , [ Spaces 2, Token "x", Spaces 1, Token "X"]+ , [ DocComment "-- | Hello" ]+ , [ Token "Bar" ]+ , [ Spaces 1, Token "name", Spaces 1, Token "String" ]+ ]+ let filtered = filter (not . empty) tokens+ it "filter (not . empty)" $ do+ filtered `shouldBe`+ [ [ Token "Foo" ]+ , [ Spaces 2, Token "x", Spaces 1, Token "X"]+ , [ DocComment "-- | Hello" ]+ , [ Token "Bar" ]+ , [ Spaces 1, Token "name", Spaces 1, Token "String" ]+ ]+ let spacesRemoved = removeSpaces filtered+ it "removeSpaces" $ do+ spacesRemoved `shouldBe`+ [ Line { lineIndent = 0, tokens = ["Foo"] }+ , Line { lineIndent = 2, tokens = ["x", "X"] }+ , Line { lineIndent = 0, tokens = ["-- | Hello"] }+ , Line { lineIndent = 0, tokens = ["Bar"] }+ , Line { lineIndent = 1, tokens = ["name", "String"] }+ ]++ it "preparse" $ do+ preparse text `shouldBe`+ [ Line { lineIndent = 0, tokens = ["Foo"] }+ , Line { lineIndent = 2, tokens = ["x", "X"] }+ , Line { lineIndent = 0, tokens = ["-- | Hello"] }+ , Line { lineIndent = 0, tokens = ["Bar"] }+ , Line { lineIndent = 1, tokens = ["name", "String"] }+ ]+ it "preparse indented" $ do+ let t = T.unlines+ [ " Foo"+ , " x X"+ , " -- | Comment"+ , " -- hidden comment"+ , " Bar"+ , " name String"+ ]+ preparse t `shouldBe`+ [ Line { lineIndent = 2, tokens = ["Foo"] }+ , Line { lineIndent = 4, tokens = ["x", "X"] }+ , Line { lineIndent = 2, tokens = ["-- | Comment"] }+ , Line { lineIndent = 2, tokens = ["Bar"] }+ , Line { lineIndent = 4, tokens = ["name", "String"] }+ ]+ it "preparse extra blocks" $ do+ let t = T.unlines+ [ "LowerCaseTable"+ , " name String"+ , " ExtraBlock"+ , " foo bar"+ , " baz"+ , " ExtraBlock2"+ , " something"+ ]+ preparse t `shouldBe`+ [ Line { lineIndent = 0, tokens = ["LowerCaseTable"] }+ , Line { lineIndent = 2, tokens = ["name", "String"] }+ , Line { lineIndent = 2, tokens = ["ExtraBlock"] }+ , Line { lineIndent = 4, tokens = ["foo", "bar"] }+ , Line { lineIndent = 4, tokens = ["baz"] }+ , Line { lineIndent = 2, tokens = ["ExtraBlock2"] }+ , Line { lineIndent = 4, tokens = ["something"] }+ ]+ it "field comments" $ do+ let text = T.unlines+ [ "-- | Model"+ , "Foo"+ , " -- | Field"+ , " name String"+ ]+ preparse text `shouldBe`+ [ Line { lineIndent = 0, tokens = ["-- | Model"] }+ , Line { lineIndent = 0, tokens = ["Foo"] }+ , Line { lineIndent = 2, tokens = ["-- | Field"] }+ , Line { lineIndent = 2, tokens = ["name", "String"] }+ ]++ describe "empty" $ do+ it "doesn't dispatch comments" $ do+ [DocComment "-- | hello"] `shouldSatisfy` (not . empty)+ it "removes spaces" $ do+ [Spaces 3] `shouldSatisfy` empty++ describe "filter (not . empty)" $ do+ let subject = filter (not . empty)+ it "keeps comments" $ do+ subject [[DocComment "-- | Hello"]]+ `shouldBe`+ [[DocComment "-- | Hello"]]+ it "omits lines with only spaces" $ do+ subject [[Spaces 3, Token "indented"], [Spaces 2]]+ `shouldBe`+ [[Spaces 3, Token "indented"]]++ describe "removeSpaces" $ do+ it "sets indentation level for a line" $ do+ removeSpaces [[Spaces 3, Token "hello", Spaces 1, Token "goodbye"]]+ `shouldBe`+ [ Line { lineIndent = 3, tokens = ["hello", "goodbye"] }+ ]+ it "does not remove comments" $ do+ removeSpaces+ [ [ DocComment "-- | asdf" ]+ , [ Token "Foo" ]+ , [ Spaces 2, Token "name", Spaces 1, Token "String" ]+ ]+ `shouldBe`+ [ Line { lineIndent = 0, tokens = ["-- | asdf"] }+ , Line { lineIndent = 0, tokens = ["Foo"] }+ , Line { lineIndent = 2, tokens = ["name", "String"] }+ ]++ describe "associateLines" $ do+ let foo = Line { lineIndent = 0, tokens = pure "Foo" }+ name'String = Line { lineIndent = 2, tokens = "name" :| ["String"] }+ comment = Line { lineIndent = 0, tokens = pure "-- | comment" }+ it "works" $ do+ associateLines+ [ comment+ , foo+ , name'String+ ]+ `shouldBe`+ [ LinesWithComments+ { lwcComments = ["comment"]+ , lwcLines = foo :| [name'String]+ }+ ]+ let bar = Line { lineIndent = 0, tokens = "Bar" :| ["sql", "=", "bars"] }+ age'Int = Line { lineIndent = 1, tokens = "age" :| ["Int"] }+ it "works when used consecutively" $ do+ associateLines+ [ bar+ , age'Int+ , comment+ , foo+ , name'String+ ]+ `shouldBe`+ [ LinesWithComments+ { lwcComments = []+ , lwcLines = bar :| [age'Int]+ }+ , LinesWithComments+ { lwcComments = ["comment"]+ , lwcLines = foo :| [name'String]+ }+ ]+ it "works with textual input" $ do+ let text = "Foo\n x X\n-- | Hello\nBar\n name String"+ parsed = preparse text+ allFull = skipEmpty parsed+ associateLines allFull+ `shouldBe`+ [ LinesWithComments+ { lwcLines =+ Line {lineIndent = 0, tokens = "Foo" :| []}+ :| [ Line {lineIndent = 2, tokens = "x" :| ["X"]} ]+ , lwcComments =+ []+ }+ , LinesWithComments+ { lwcLines =+ Line {lineIndent = 0, tokens = "Bar" :| []}+ :| [ Line {lineIndent = 1, tokens = "name" :| ["String"]}]+ , lwcComments =+ ["Hello"]+ }+ ]+ it "works with extra blocks" $ do+ let text = skipEmpty . preparse . T.unlines $+ [ "LowerCaseTable"+ , " Id sql=my_id"+ , " fullName Text"+ , " ExtraBlock"+ , " foo bar"+ , " baz"+ , " bin"+ , " ExtraBlock2"+ , " something"+ ]+ associateLines text `shouldBe`+ [ LinesWithComments+ { lwcLines =+ Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :|+ [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] }+ , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] }+ , Line { lineIndent = 4, tokens = pure "ExtraBlock" }+ , Line { lineIndent = 8, tokens = "foo" :| ["bar"] }+ , Line { lineIndent = 8, tokens = pure "baz" }+ , Line { lineIndent = 8, tokens = pure "bin" }+ , Line { lineIndent = 4, tokens = pure "ExtraBlock2" }+ , Line { lineIndent = 8, tokens = pure "something" }+ ]+ , lwcComments = []+ }+ ]++ it "works with extra blocks twice" $ do+ let text = skipEmpty . preparse . T.unlines $+ [ "IdTable"+ , " Id Day default=CURRENT_DATE"+ , " name Text"+ , ""+ , "LowerCaseTable"+ , " Id sql=my_id"+ , " fullName Text"+ , " ExtraBlock"+ , " foo bar"+ , " baz"+ , " bin"+ , " ExtraBlock2"+ , " something"+ ]+ associateLines text `shouldBe`+ [ LinesWithComments+ { lwcLines = Line 0 (pure "IdTable") :|+ [ Line 4 ("Id" :| ["Day", "default=CURRENT_DATE"])+ , Line 4 ("name" :| ["Text"])+ ]+ , lwcComments = []+ }+ , LinesWithComments+ { lwcLines =+ Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :|+ [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] }+ , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] }+ , Line { lineIndent = 4, tokens = pure "ExtraBlock" }+ , Line { lineIndent = 8, tokens = "foo" :| ["bar"] }+ , Line { lineIndent = 8, tokens = pure "baz" }+ , Line { lineIndent = 8, tokens = pure "bin" }+ , Line { lineIndent = 4, tokens = pure "ExtraBlock2" }+ , Line { lineIndent = 8, tokens = pure "something" }+ ]+ , lwcComments = []+ }+ ]+++ it "works with field comments" $ do+ let text = skipEmpty . preparse . T.unlines $+ [ "-- | Model"+ , "Foo"+ , " -- | Field"+ , " name String"+ ]+ associateLines text `shouldBe`+ [ LinesWithComments+ { lwcLines =+ Line { lineIndent = 0, tokens = "Foo" :| [] } :|+ [ Line { lineIndent = 2, tokens = pure "-- | Field" }+ , Line { lineIndent = 2, tokens = "name" :| ["String"] }+ ]+ , lwcComments =+ ["Model"]+ }+ ]++++ describe "parseLines" $ do+ let lines =+ T.unlines+ [ "-- | Comment"+ , "Foo"+ , " -- | Field"+ , " name String"+ , " age Int"+ , " Extra"+ , " foo bar"+ , " baz"+ , " Extra2"+ , " something"+ ]+ let [subject] = parse lowerCaseSettings lines+ it "produces the right name" $ do+ entityHaskell subject `shouldBe` HaskellName "Foo"+ describe "entityFields" $ do+ let fields = entityFields subject+ it "has the right field names" $ do+ map fieldHaskell fields `shouldMatchList`+ [ HaskellName "name"+ , HaskellName "age"+ ]+ it "has comments" $ do+ map fieldComments fields `shouldBe`+ [ Just "Field\n"+ , Nothing+ ]+ it "has the comments" $ do+ entityComments subject `shouldBe`+ Just "Comment\n"+ it "combines extrablocks" $ do+ entityExtra subject `shouldBe` Map.fromList+ [ ("Extra", [["foo", "bar"], ["baz"]])+ , ("Extra2", [["something"]])+ ]+ describe "works with extra blocks" $ do+ let [_, lowerCaseTable, idTable] =+ parse lowerCaseSettings $ T.unlines+ [ ""+ , "IdTable"+ , " Id Day default=CURRENT_DATE"+ , " name Text"+ , ""+ , "LowerCaseTable"+ , " Id sql=my_id"+ , " fullName Text"+ , " ExtraBlock"+ , " foo bar"+ , " baz"+ , " bin"+ , " ExtraBlock2"+ , " something"+ , ""+ , "IdTable"+ , " Id Day default=CURRENT_DATE"+ , " name Text"+ , ""+ ]+ describe "idTable" $ do+ let EntityDef {..} = idTable+ it "has no extra blocks" $ do+ entityExtra `shouldBe` mempty+ it "has the right name" $ do+ entityHaskell `shouldBe` HaskellName "IdTable"+ it "has the right fields" $ do+ map fieldHaskell entityFields `shouldMatchList`+ [ HaskellName "name"+ ]+ describe "lowerCaseTable" $ do+ let EntityDef {..} = lowerCaseTable+ it "has the right name" $ do+ entityHaskell `shouldBe` HaskellName "LowerCaseTable"+ it "has the right fields" $ do+ map fieldHaskell entityFields `shouldMatchList`+ [ HaskellName "fullName"+ ]+ it "has ExtraBlock" $ do+ Map.lookup "ExtraBlock" entityExtra+ `shouldBe` Just+ [ ["foo", "bar"]+ , ["baz"]+ , ["bin"]+ ]+ it "has ExtraBlock2" $ do+ Map.lookup "ExtraBlock2" entityExtra+ `shouldBe` Just+ [ ["something"]+ ]