diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for persistent-parser + +## 0.1.0.0 -- 2016-09-08 + +* Parse persistent files into a syntax tree. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, James M.C. Haver II + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of James M.C. Haver II nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# persistent-parser + +persistent-parser provides functions and types to parse a Persistent file or Haskell file with Persistent QuasiQuoters and store the data in a tree structure. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/persistent-parser.cabal b/persistent-parser.cabal new file mode 100644 --- /dev/null +++ b/persistent-parser.cabal @@ -0,0 +1,41 @@ +name: persistent-parser +version: 0.1.0.0 +synopsis: Parse persistent model files +description: Parse persistent model files +license: BSD3 +license-file: LICENSE +author: James M.C. Haver II +maintainer: mchaver@gmail.com +category: Database, Yesod, Persistent +stability: Beta +build-type: Simple +extra-source-files: ChangeLog.md README.md +cabal-version: >=1.10 + +library + exposed-modules: Database.Persist.Parser + , Database.Persist.Internal.Parser + , Database.Persist.Syntax.Types + build-depends: base >=4.8 && <4.9 + , attoparsec + , text + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Spec.hs + default-language: Haskell2010 + hs-source-dirs: tests + + ghc-options: -threaded -O0 -Wall + build-depends: base >=4.8 && < 5 + , attoparsec + , hspec + , persistent-parser + , text + + +source-repository head + type: git + location: https://github.com/mchaver/persistent-parser diff --git a/src/Database/Persist/Internal/Parser.hs b/src/Database/Persist/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Internal/Parser.hs @@ -0,0 +1,430 @@ +{-| +Module : Database.Persist.Internal.Parser +Description : Persistent model file parsing functions +Copyright : (c) James M.C. Haver II +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : Beta + +Use Internal modules at your own risk. +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Database.Persist.Internal.Parser where + +import Control.Applicative +import Control.Monad + +import Data.Attoparsec.ByteString.Char8 (isSpace) +import Data.Attoparsec.Combinator +import Data.Attoparsec.Text + +import Data.List (delete,nub) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T + +import Database.Persist.Syntax.Types + +import Prelude hiding (takeWhile) + +import Text.Read (readMaybe) + + +-- handling indented text appropriately + +-- | Parse a Persistent models file. +parseModelsFile :: Text -> Either String ModelsFile +parseModelsFile = parseOnly parseEntities + +-- | Parse Persistent QuasiQuoters from a Haskell file. +parseQuasiQuotersFile :: Text -> Either String ModelsFile +parseQuasiQuotersFile = parseOnly parsePersistQuasiQuoters + + +-- | Parse Persist Models that are in quasi-quoters in a Haskell file. +parsePersistQuasiQuoters :: Parser ModelsFile +parsePersistQuasiQuoters = do + _ <- manyTill' anyChar (string "[persistLowerCase|" <|> string "[persistUpperCase|") + manyTill' ( ModelsFileEntity <$> parseEntity + <|> ModelsFileWhiteSpace <$> collectWhiteSpace + <|> ModelsFileComment <$> singleLineComment) (string "|]") + +-- | Parse a Persist Models file. +parseEntities :: Parser ModelsFile +parseEntities = do + many' ( ModelsFileEntity <$> parseEntity + <|> ModelsFileWhiteSpace <$> collectWhiteSpace + <|> ModelsFileComment <$> singleLineComment) + +-- | Parse a single Persist Entity. +parseEntity :: Parser Entity +parseEntity = do + + entityNam <- haskellTypeNameWithoutPrefix + _ <- many' spaceNoNewLine + derivesJson <- (string "json" *> pure True) <|> pure False + _ <- many' spaceNoNewLine + mSqlTable <- (Just <$> parseEntitySqlTable) <|> pure Nothing + _ <- takeTill isEndOfLine + endOfLine <|> endOfInput + + entityChildrn <- many' ( EntityChildEntityField <$> parseEntityField + <|> EntityChildEntityDerive <$> parseEntityDerive + <|> EntityChildEntityPrimary <$> parseEntityPrimary + <|> EntityChildEntityForeign <$> parseEntityForeign + <|> EntityChildEntityUnique <$> parseEntityUnique + <|> EntityChildWhiteSpace <$> collectWhiteSpace + <|> EntityChildComment <$> singleLineComment) + + return $ Entity entityNam derivesJson mSqlTable entityChildrn + +-- | Parse the user defined SQL table name. +parseEntitySqlTable :: Parser Text +parseEntitySqlTable = do + _ <- string "sql" + _ <- many' spaceNoNewLine + _ <- char '=' + _ <- many' spaceNoNewLine + -- take while not space + text <- many' (digit <|> letter <|> underline) + return $ T.pack text + +-- helper functions + +-- | Wrap a Parser in 'Maybe' because it might fail. Useful for making choices. +maybeOption :: Parser a -> Parser (Maybe a) +maybeOption p = option Nothing (Just <$> p) + +-- | Parse a lowercase 'Char'. +lowerCase :: Parser Char +lowerCase = satisfy (\c -> c >= 'a' && c <= 'z') + +-- | Parse an uppercase 'Char'. +upperCase :: Parser Char +upperCase = satisfy (\c -> c >= 'A' && c <= 'Z') + +-- | Parse an underline. +underline :: Parser Char +underline = satisfy (== '_') + +-- | Parse strict marker "!" for haskellTypeName. +exclamationMark :: Parser Char +exclamationMark = satisfy (== '!') + +-- | Parse lazy marker "~" for haskellTypeName. +tilde :: Parser Char +tilde = satisfy (== '~') + + +-- | Parse any space 'Char' excluding "\n". +spaceNoNewLine :: Parser Char +spaceNoNewLine = satisfy (\x -> isSpace x && not (isEndOfLine x)) "spaceNoNewLine" + +-- | Parse a Haskell function name. It starts with underscore or lowercase letter then +-- is followed by a combination of underscores, single quotes, letters and digits. +-- E.g., "get", "_get", "get_1", etc. +haskellFunctionName :: Parser Text +haskellFunctionName = do + first <- lowerCase <|> underline + rest <- many' (digit <|> letter <|> underline) + lookAhead ((space *> pure ()) <|> (char ']' *> pure ()) <|> endOfInput) + return $ T.pack ([first] ++ rest) + +-- | Parse a Haskell type name. It starts with an uppercase letter then +-- is followed by a combination of underscores, single quotes, letters and digits. +-- E.g., "Person", "Address", "PhoneNumber", etc. +haskellTypeName :: Parser Text +haskellTypeName = do + _ <- (Just <$> exclamationMark) <|> (Just <$> tilde) <|> pure Nothing + haskellTypeNameWithoutPrefix + +-- | Parse a Haskell Type name that does not have a prefix. +haskellTypeNameWithoutPrefix :: Parser Text +haskellTypeNameWithoutPrefix = do + first <- upperCase + rest <- many' (digit <|> letter <|> underline) + -- check for ']' because it could be in a list + lookAhead ((space *> pure ()) <|> (char ']' *> pure ()) <|> endOfInput) + return $ T.pack ([first] ++ rest) + + + +-- | Parse a comment that starts with "--". +singleLineComment :: Parser Comment +singleLineComment = do + _ <- string "--" + commnt <- takeTill isEndOfLine + endOfLine + return $ Comment ("--" <> commnt <> "\n") + +-- | Parse and collect white space. +collectWhiteSpace :: Parser WhiteSpace +collectWhiteSpace = do + whiteSpac <- takeWhile (\x -> isSpace x && not (isEndOfLine x)) + endOfLine + return $ WhiteSpace (whiteSpac <> "\n") + + +-- | Parse and collect an Entity name. +parseEntityName :: Parser Text +parseEntityName = do + name <- haskellTypeName + _ <- takeTill isEndOfLine + endOfLine <|> endOfInput + return name + +-- | Parse and collect an EntityField. +parseEntityField :: Parser EntityField +parseEntityField = do + efn <- parseEntityFieldName + eft <- parseEntityFieldType + + ms <- parseMigrationOnlyAndSafeToRemove [] <|> pure [] + rs <- parseEntityFieldLastItem [] <|> pure [] + + _ <- takeTill isEndOfLine + endOfLine <|> endOfInput + + return $ EntityField efn + eft + (elem MigrationOnly ms) + (elem SafeToRemove ms) + (getFieldDefault rs) + (getFieldSqlRow rs) + (getFieldSqlType rs) + (getFieldMaxLen rs) + + +-- | Delete elements from the second list that exist in the first list. Removes +-- any duplicates. +deleteItems :: (Eq a) => [a] -> [a] -> [a] +deleteItems (x:xs) ys = deleteItems xs $ delete x ys +deleteItems _ ys = nub ys + +-- | Parse 'MigrationOnly'. +parseMigrationOnly :: Parser MigrationOnlyAndSafeToRemoveOption +parseMigrationOnly = string "MigrationOnly" *> pure MigrationOnly + +-- | Parse 'SafeToRemove'. +parseSafeToRemove :: Parser MigrationOnlyAndSafeToRemoveOption +parseSafeToRemove = string "SafeToRemove" *> pure SafeToRemove + +-- | Match one of the parsers. +getMigrationOnlyAndSafeToRemoveOption :: MigrationOnlyAndSafeToRemoveOption -> Parser MigrationOnlyAndSafeToRemoveOption +getMigrationOnlyAndSafeToRemoveOption MigrationOnly = parseMigrationOnly +getMigrationOnlyAndSafeToRemoveOption SafeToRemove = parseSafeToRemove + +-- | Parse 'MigrationOnly' and 'SafeToRemove'. The occur in the same spot. +parseMigrationOnlyAndSafeToRemove :: [MigrationOnlyAndSafeToRemoveOption] -> Parser [MigrationOnlyAndSafeToRemoveOption] +parseMigrationOnlyAndSafeToRemove parserOps = do + _ <- many1 spaceNoNewLine + let parsers = deleteItems parserOps [MigrationOnly,SafeToRemove] + mResult <- (Just <$> choice (map getMigrationOnlyAndSafeToRemoveOption parsers)) <|> pure Nothing + case mResult of + Nothing -> return parserOps + Just result -> parseMigrationOnlyAndSafeToRemove (parserOps ++ [result]) <|> pure (parserOps ++ [result]) + +-- | Match 'FieldDefault' constructor, get its 'Text' value. +getFieldDefault :: [EntityFieldLastItem] -> Maybe Text +getFieldDefault (x:xs) = + case x of + (FieldDefault y) -> Just y + _ -> getFieldDefault xs +getFieldDefault _ = Nothing + +-- | Match 'FieldSqlRow' constructor, get its 'Text' value. +getFieldSqlRow :: [EntityFieldLastItem] -> Maybe Text +getFieldSqlRow (x:xs) = + case x of + (FieldSqlRow y) -> Just y + _ -> getFieldSqlRow xs +getFieldSqlRow _ = Nothing + +-- | Match 'FieldSqlType' constructor, get its 'Text' value. +getFieldSqlType :: [EntityFieldLastItem] -> Maybe Text +getFieldSqlType (x:xs) = + case x of + (FieldSqlType y) -> Just y + _ -> getFieldSqlType xs +getFieldSqlType _ = Nothing + +-- | Match 'FieldMaxLen' constructor, get its 'Text' value. +getFieldMaxLen :: [EntityFieldLastItem] -> Maybe Int +getFieldMaxLen (x:xs) = + case x of + (FieldMaxLen y) -> Just y + _ -> getFieldMaxLen xs +getFieldMaxLen _ = Nothing + +-- | Get parser based on constructor match. +getEntityFieldLastItemParser :: EntityFieldLastItem -> Parser EntityFieldLastItem +getEntityFieldLastItemParser (FieldDefault _) = parseFieldDefault +getEntityFieldLastItemParser (FieldSqlRow _) = parseFieldSqlRow +getEntityFieldLastItemParser (FieldSqlType _) = parseFieldSqlType +getEntityFieldLastItemParser (FieldMaxLen _) = parseFieldMaxLen + +-- | Parse FieldDefault. +parseFieldDefault :: Parser EntityFieldLastItem +parseFieldDefault = do + _ <- string "default" + _ <- many' spaceNoNewLine + _ <- char '=' + _ <- many' spaceNoNewLine + -- take while not space + text <- many' (digit <|> letter <|> underline) + return $ FieldDefault $ T.pack text + +-- | Parse FieldSqlRow. +parseFieldSqlRow :: Parser EntityFieldLastItem +parseFieldSqlRow = do + _ <- string "sql" + _ <- many' spaceNoNewLine + _ <- char '=' + _ <- many' spaceNoNewLine + -- take while not space + text <- many' (digit <|> letter <|> underline) + return $ FieldSqlRow $ T.pack text + +-- | Parse FieldSqlType. +parseFieldSqlType :: Parser EntityFieldLastItem +parseFieldSqlType = do + _ <- string "sqltype" + _ <- many' spaceNoNewLine + _ <- char '=' + _ <- many' spaceNoNewLine + -- take while not space + text <- many' (digit <|> letter <|> underline) + return $ FieldSqlType $ T.pack text + +-- | Parse FieldMaxLen. +parseFieldMaxLen :: Parser EntityFieldLastItem +parseFieldMaxLen = do + _ <- string "maxlen" + _ <- many' spaceNoNewLine + _ <- char '=' + _ <- many' spaceNoNewLine + -- take while not space + intString <- many1 digit + + case readMaybe intString :: Maybe Int of + Nothing -> fail "fieldMaxLen" + Just int -> return $ FieldMaxLen int + +-- | Parse EntityFieldLastItem. +parseEntityFieldLastItem :: [EntityFieldLastItem] -> Parser [EntityFieldLastItem] +parseEntityFieldLastItem parserOps = do + _ <- many1 spaceNoNewLine + let parsers = deleteItems parserOps [FieldDefault "", FieldSqlType "", FieldSqlRow "", FieldMaxLen 0] + mResult <- (Just <$> choice (map getEntityFieldLastItemParser parsers)) <|> pure Nothing + + case mResult of + Nothing -> return parserOps + Just result -> parseEntityFieldLastItem (parserOps ++ [result]) <|> pure (parserOps ++ [result]) + + +-- | Parse Entity Field name. +parseEntityFieldName :: Parser Text +parseEntityFieldName = do + _ <- many1 spaceNoNewLine + name <- haskellFunctionName + + case name == "deriving" of + True -> fail "deriving" + False -> return name + +-- | Parse type 'Strictness'. +parseStrictness :: Parser Strictness +parseStrictness = + (string "!" *> pure ExplicitStrict) <|> (string "~" *> pure Lazy) <|> pure Strict + +-- | Parse EntityFieldType. +parseEntityFieldType :: Parser EntityFieldType +parseEntityFieldType = do + _ <- many1 spaceNoNewLine + mLeftBracket <- maybeOption (char '[') + strictness <- parseStrictness + name <- haskellTypeName + + case mLeftBracket of + Nothing -> do + mybe <- (parseMaybe *> pure True) <|> pure False + return $ EntityFieldType name strictness False mybe + Just _ -> do + _ <- char ']' + mybe <- (parseMaybe *> pure True) <|> pure False + return $ EntityFieldType name strictness True mybe + +-- | Parse Maybe qualifier for a Field Type. +parseMaybe :: Parser () +parseMaybe = do + _ <- many1 spaceNoNewLine + void $ string "Maybe" + +-- | Parse EntityUnique. +parseEntityUnique :: Parser EntityUnique +parseEntityUnique = do + eun <- parseEntityUniqueName + euefn <- parseEntityUniqueEntityFieldName + _ <- takeTill isEndOfLine + endOfLine <|> endOfInput + return $ EntityUnique eun euefn + +-- | Parse Entity UniqueName +parseEntityUniqueName :: Parser Text +parseEntityUniqueName = do + _ <- many1 spaceNoNewLine + haskellTypeName + +-- | Parse EntityUniqueEntityFieldName +parseEntityUniqueEntityFieldName :: Parser [Text] +parseEntityUniqueEntityFieldName = do + _ <- many1 spaceNoNewLine + many1 haskellFunctionName + + +-- | Parse EntityDerive. +parseEntityDerive :: Parser EntityDerive +parseEntityDerive = do + _ <- many1 spaceNoNewLine + _ <- string "deriving" + -- _ <- many1 spaceNoNewLine + names <- many1 (many1 spaceNoNewLine *> haskellTypeName) + + _ <- takeTill isEndOfLine + endOfLine <|> endOfInput + + return $ EntityDerive names + +-- | Parse EntityPrimary. +parseEntityPrimary :: Parser EntityPrimary +parseEntityPrimary = do + _ <- many1 spaceNoNewLine + _ <- string "Primary" + names <- many1 (many1 spaceNoNewLine *> haskellFunctionName) + _ <- takeTill isEndOfLine + endOfLine <|> endOfInput + + return $ EntityPrimary names + +-- | Parse EntityForeign. +parseEntityForeign :: Parser EntityForeign +parseEntityForeign = do + _ <- many1 spaceNoNewLine + _ <- string "Foreign" + _ <- many1 spaceNoNewLine + foreignTable <- haskellTypeName + names <- many1 (many1 spaceNoNewLine *> haskellFunctionName) + + _ <- takeTill isEndOfLine + endOfLine <|> endOfInput + + return $ EntityForeign foreignTable names + +-- | Parse ForeignKeyType +parseForeignKeyType :: Parser () +parseForeignKeyType = void $ manyTill anyChar (string "Id" *> endOfInput) diff --git a/src/Database/Persist/Parser.hs b/src/Database/Persist/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Parser.hs @@ -0,0 +1,15 @@ +{-| +Module : Database.Persist.Parser +Description : Persistent model file parsing functions +Copyright : (c) James M.C. Haver II +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : Beta +-} + +module Database.Persist.Parser ( + parseModelsFile + , parseQuasiQuotersFile + ) where + +import Database.Persist.Internal.Parser diff --git a/src/Database/Persist/Syntax/Types.hs b/src/Database/Persist/Syntax/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Syntax/Types.hs @@ -0,0 +1,161 @@ +{-| +Module : Database.Persist.Syntax.Types +Description : Syntax tree for representing elements in Persistent model files +Copyright : (c) James M.C. Haver II +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : Beta + +Attempt to represent all possible Persistent data in a syntax tree. + +https://github.com/yesodweb/persistent/wiki/Persistent-entity-syntax +contains relatively up to date information about Persistent syntax. + +https://github.com/yesodweb/persistent/tree/master/persistent-test/src +gives clues about newer syntax elements that have not been added to the wiki. + +It is recommended that you import this qualified. +@import qualified Database.Persist.Syntax.Types as PST@ +-} + +{-# LANGUAGE DeriveGeneric #-} + +module Database.Persist.Syntax.Types where + +import Data.Text (Text) +import GHC.Generics + +-- | The root of the Persistent syntax tree. A collection of data types with +-- which you can recontruct a Persist Model file or create an altered version. +type ModelsFile = [ModelsFilePiece] + +-- | Top level pieces of a Persistent Model file. +data ModelsFilePiece = ModelsFileEntity Entity | + ModelsFileComment Comment | + ModelsFileWhiteSpace WhiteSpace + deriving (Eq,Read,Show,Generic) + +-- | A single Persist Model Entity. +data Entity = Entity { + entityName :: Text -- ^ @Person@ +, entityDeriveJson :: Bool -- ^ @Person json@ +, entitySqlTable :: Maybe Text -- ^ @Person sql=people@ +, entityChildren :: [EntityChild] +} deriving (Eq,Read,Show,Generic) + + +-- | All of the child elements of a Persist Model Entity. +-- | They are all indented in the Model File. +data EntityChild = EntityChildEntityField EntityField | + EntityChildEntityUnique EntityUnique | + EntityChildEntityDerive EntityDerive | + EntityChildEntityPrimary EntityPrimary | + EntityChildEntityForeign EntityForeign | + EntityChildComment Comment | + EntityChildWhiteSpace WhiteSpace + deriving (Eq,Read,Show,Generic) + +-- | An EntityField corresponds to a column in SQL or a key-value pair in MongoDB. +-- The minimal definition of an EntityField in Persistent has a name and a type. +data EntityField = EntityField { + entityFieldName :: Text -- ^ @name@, @address@, @age@ +, entityFieldType :: EntityFieldType -- ^ @Text@, @[Text]@, @Text Maybe@, @~Int@ +, entityFieldIsMigrationOnly :: Bool -- ^ @MigrationOnly@ +, entityFieldIsSafeToRemove :: Bool -- ^ @SafeToRemove@ +, entityFieldDefault :: Maybe Text -- ^ @default=Nothing@, @default=now()@, @default=CURRENT_DATE@ +, entityFieldSqlRow :: Maybe Text -- ^ @sql=my_id_name@ +, entityFieldSqlType :: Maybe Text -- ^ @sqltype=varchar(255)@ +, entityFieldMaxLen :: Maybe Int -- ^ @maxlen=3@ +} deriving (Eq,Read,Show,Generic) + + +-- | Table rows can be strict or lazy +data Strictness + -- | Persist Model types are strict without any notation + = Strict + -- | "!" can be used to reemphasize that a type is strict + | ExplicitStrict + -- | "~" means that a type is Lazy + | Lazy + deriving (Eq,Show,Read,Generic) + +-- | An entity data row's type. +data EntityFieldType = EntityFieldType { + entityFieldTypeText :: Text -- ^ Text, Int, Double +, entityFieldStrictness :: Strictness -- ^ ~Text, !Text, Text +, entityFieldTypeList :: Bool -- ^ [Text], [Int], [Double] +, entityFieldTypeMaybe :: Bool -- ^ Text Maybe, Int Maybe, Double Maybe +} deriving (Eq,Read,Show,Generic) + + +-- | A unique idenfitier for an Entity: @UniqueUserName userIdent@, +-- @UniqueNameAndAge name age@. +data EntityUnique = EntityUnique { + entityUniqueName :: Text -- ^@UniqueUserName@ +, entityUniqueEntityFieldName :: [Text] -- ^@userIdent@ +} deriving (Eq,Show,Read,Generic) + +-- | @deriving Eq@, @deriving Show@, etc. +-- There may be custom generic typeclasses +-- so there is no restriction on what the type might be +-- , other than it starts with a capital letter. +data EntityDerive = EntityDerive { + entityDeriveTypes :: [Text] -- ^ deriving Eq, deriving Show +} deriving (Eq,Show,Read,Generic) + +-- | 'Primary name' +data EntityPrimary = EntityPrimary { + entityPrimaryType :: [Text] +} deriving (Eq,Show,Read,Generic) + +-- | 'Foreign Tree fkparent parent' +data EntityForeign = EntityForeign { + entityForeignTable :: Text +, entityForeignTypes :: [Text] +} deriving (Eq,Show,Read,Generic) + +-- | White space found in the Persistent file or QuasiQuoter. Need to save the +-- white space in case you want to reproduce the original file or an altered version +-- of the file from the Persist Syntax Tree. +data WhiteSpace = WhiteSpace { + whiteSpace :: Text +} deriving (Eq,Show,Read,Generic) + +-- | Haskell style comments that start with @-- @ in Persistent. +data Comment = Comment { + comment :: Text +} deriving (Eq,Show,Read,Generic) + +-- | 'MigrationOnly' persistent-template \>= 1.2.0 marks a field that is ignored +-- by normal processing but retained for migration purposes. Useful for +-- implementing columns that other tools may need but Persistent does not. +-- 'SafeToRemove' is used to deprecate a field after 'MigrationOnly' has been +-- used. The field will be removed from the database if it is present. This is +-- a destructive change which is marked as safe by the user. +data MigrationOnlyAndSafeToRemoveOption = MigrationOnly + | SafeToRemove + deriving (Eq,Read,Show,Generic) + +-- | These items may occur at the very end of a Field's line and in any order. +data EntityFieldLastItem = FieldDefault Text + | FieldSqlRow Text + | FieldSqlType Text + | FieldMaxLen Int + deriving (Read,Show,Generic) + +-- | Define equality to match based only on the type constructor. +instance Eq EntityFieldLastItem where + (FieldDefault _) == (FieldDefault _) = True + (FieldSqlRow _) == (FieldSqlRow _) = True + (FieldSqlType _) == (FieldSqlType _) = True + (FieldMaxLen _) == (FieldMaxLen _) = True + _ == _ = False + +{- +eqConstructor :: EntityFieldLastItem -> EntityFieldLastItem -> Bool +eqConstructor (FieldDefault _) (FieldDefault _) = True +eqConstructor (FieldSqlRow _) (FieldSqlRow _) = True +eqConstructor (FieldSqlType _) (FieldSqlType _) = True +eqConstructor (FieldMaxLen _) (FieldMaxLen _) = True +eqConstructor _ _ = False +-} diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}