diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -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 . +`persistent` backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the 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) = diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.10.5 +version: 2.10.5.1 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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"] + ]