persistent-parser (empty) → 0.1.0.0

raw patch · 9 files changed

+688/−0 lines, 9 filesdep +attoparsecdep +basedep +hspecsetup-changed

Dependencies added: attoparsec, base, hspec, persistent-parser, text

Files

ChangeLog.md +5/−0
LICENSE +30/−0
README.md +3/−0
Setup.hs +2/−0
persistent-parser.cabal +41/−0
src/Database/Persist/Internal/Parser.hs +430/−0
src/Database/Persist/Parser.hs +15/−0
src/Database/Persist/Syntax/Types.hs +161/−0
tests/Spec.hs +1/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for persistent-parser++## 0.1.0.0  -- 2016-09-08++* Parse persistent files into a syntax tree.

+ LICENSE view

@@ -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.

+ README.md view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ persistent-parser.cabal view

@@ -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

+ src/Database/Persist/Internal/Parser.hs view

@@ -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)

+ src/Database/Persist/Parser.hs view

@@ -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

+ src/Database/Persist/Syntax/Types.hs view

@@ -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+-}

+ tests/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}