{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE RankNTypes #-}
-- {-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}
-- overlapping instances is for automatic lifting
-- while avoiding an orphan of Lift for Text
{-# LANGUAGE OverlappingInstances #-}
-- | This module provides utilities for creating backends. Regular users do not
-- need to use this module.
module Database.LPersist.TH
    ( -- * Parse entity defs
      lPersistWith
    , lPersistUpperCase
    , lPersistLowerCase
    , lPersistFileWith
--       -- * Turn @EntityDef@s into types
--     , mkPersist
--     , MkPersistSettings
--     , mpsBackend
--     , mpsGeneric
--     , mpsPrefixFields
--     , mpsEntityJSON
--     , mpsGenerateLenses
--     , EntityJSON(..)
--     , mkPersistSettings
--     , sqlSettings
--     , sqlOnlySettings
--       -- * Various other TH functions
--     , mkMigrate
--     , mkSave
--     , mkDeleteCascade
--     , share
--     , derivePersistField
--     , derivePersistFieldJSON
--     , persistFieldFromEntity
--       -- * Internal
--     , packPTH
--     , lensPTH
    ) where

import Prelude hiding ((++), take, concat, splitAt, exp)
import Database.Persist
-- import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql, IsSqlKey (..))
import Database.Persist.Quasi
import Database.LPersist.Quasi
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
-- import Data.Char (toLower, toUpper)
-- import Control.Monad (forM, (<=<), mzero)
import qualified System.IO as SIO
import Data.Text (pack, Text, unpack, concat, stripPrefix, stripSuffix)
-- import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.IO as TIO
-- import Data.List (foldl')
import Data.Maybe (isJust, listToMaybe, mapMaybe)
-- import Data.Monoid (mappend, mconcat)
-- import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident))
import qualified Data.Map as M
-- import qualified Data.HashMap.Strict as HM
-- import Data.Aeson
--     ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object
--     , Value (Object), (.:), (.:?)
--     , eitherDecodeStrict'
--     )
-- import Control.Applicative (pure, (<$>), (<*>))
import Database.Persist.Sql (sqlType)
import Data.Proxy (Proxy (Proxy))
-- import Web.PathPieces (PathPiece, toPathPiece, fromPathPiece)
-- import GHC.Generics (Generic)
-- import qualified Data.Text.Encoding as TE

-- | Converts a quasi-quoted syntax into a list of entity definitions, to be
-- used as input to the template haskell generation code (mkPersist).
lPersistWith :: PersistSettings -> QuasiQuoter
lPersistWith ps = QuasiQuoter
    { quoteExp = parseReferences ps . pack
    }

-- | Apply 'persistWith' to 'upperCaseSettings'.
lPersistUpperCase :: QuasiQuoter
lPersistUpperCase = lPersistWith upperCaseSettings

-- | Apply 'persistWith' to 'lowerCaseSettings'.
lPersistLowerCase :: QuasiQuoter
lPersistLowerCase = lPersistWith lowerCaseSettings

-- | Same as 'persistWith', but uses an external file instead of a
-- quasiquotation.
lPersistFileWith :: PersistSettings -> FilePath -> Q Exp
lPersistFileWith ps fp = do
#ifdef GHC_7_4
    qAddDependentFile fp
#endif
    h <- qRunIO $ SIO.openFile fp SIO.ReadMode
    qRunIO $ SIO.hSetEncoding h SIO.utf8_bom
    s <- qRunIO $ TIO.hGetContents h
    parseReferences ps s

-- calls parse to Quasi.parse individual entities in isolation
-- afterwards, sets references to other entities
parseReferences :: PersistSettings -> Text -> Q Exp
parseReferences ps s = lift $
     map (mkEntityDefSqlTypeExp entityMap) entsWithEmbeds
  where
    -- every EntityDef could reference each-other (as an EmbedRef)
    -- let Haskell tie the knot
    entityMap = M.fromList $ map (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) entsWithEmbeds
    entsWithEmbeds = map setEmbedEntity rawEnts
    setEmbedEntity ent = ent
      { entityFields = map (setEmbedField entityMap) $ entityFields ent
      }
    rawEnts = lParse ps s


stripId :: FieldType -> Maybe Text
stripId (FTTypeCon Nothing t) = stripSuffix "Id" t
stripId _ = Nothing

-- foreignReference :: FieldDef -> Maybe HaskellName
-- foreignReference field = case fieldReference field of
--     ForeignRef ref _ -> Just ref
--     _              -> Nothing


-- fieldSqlType at parse time can be an Exp
-- This helps delay setting fieldSqlType until lift time
data EntityDefSqlTypeExp = EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp]
                           deriving Show

data SqlTypeExp = SqlTypeExp FieldType
                | SqlType' SqlType
                deriving Show

instance Lift SqlTypeExp where
    lift (SqlType' t)       = lift t
    lift (SqlTypeExp ftype) = return st
      where
        typ = ftToType ftype
        mtyp = (ConT ''Proxy `AppT` typ)
        typedNothing = SigE (ConE 'Proxy) mtyp
        st = VarE 'sqlType `AppE` typedNothing

data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp]

instance Lift FieldsSqlTypeExp where
    lift (FieldsSqlTypeExp fields sqlTypeExps) =
        lift $ zipWith FieldSqlTypeExp fields sqlTypeExps

data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp
instance Lift FieldSqlTypeExp where
    lift (FieldSqlTypeExp (FieldDef{..}) sqlTypeExp) =
      [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference|]

instance Lift EntityDefSqlTypeExp where
    lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =
        [|ent { entityFields = $(lift $ FieldsSqlTypeExp (entityFields ent) sqlTypeExps)
              , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)
              }
        |]

instance Lift ReferenceDef where
    lift NoReference = [|NoReference|]
    lift (ForeignRef name ft) = [|ForeignRef name ft|]
    lift (EmbedRef em) = [|EmbedRef em|]
    lift (CompositeRef cdef) = [|CompositeRef cdef|]
    lift (SelfReference) = [|SelfReference|]

instance Lift EmbedEntityDef where
    lift (EmbedEntityDef name fields) = [|EmbedEntityDef name fields|]

instance Lift EmbedFieldDef where
    lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|]

type EntityMap = M.Map HaskellName EmbedEntityDef
mEmbedded :: EntityMap -> FieldType -> Maybe EmbedEntityDef
mEmbedded _ (FTTypeCon Just{} _) = Nothing
mEmbedded ents (FTTypeCon Nothing n) = let name = HaskellName n in
    M.lookup name ents
mEmbedded ents (FTList x) = mEmbedded ents x
mEmbedded ents (FTApp x y) = maybe (mEmbedded ents y) Just (mEmbedded ents x)

setEmbedField :: EntityMap -> FieldDef -> FieldDef
setEmbedField allEntities field = field
  { fieldReference = case fieldReference field of
      NoReference -> case mEmbedded allEntities (fieldType field) of
          Nothing -> case stripId $ fieldType field of
              Nothing -> NoReference
              Just name -> if M.member (HaskellName name) allEntities
                  then ForeignRef (HaskellName name)
                                  -- the EmebedEntityDef does not contain FieldType information
                                  -- but we shouldn't need this anyway
                                  (FTTypeCon Nothing $ pack $ nameBase ''Int)
                  else NoReference
          Just em -> EmbedRef em
      existing@_   -> existing
  }

mkEntityDefSqlTypeExp :: EntityMap -> EntityDef -> EntityDefSqlTypeExp
mkEntityDefSqlTypeExp allEntities ent = EntityDefSqlTypeExp ent
    (getSqlType $ entityId ent)
    $ (map getSqlType $ entityFields ent)
  where
    getSqlType field = maybe
        (defaultSqlTypeExp field)
        (SqlType' . SqlOther)
        (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field)


    -- In the case of embedding, there won't be any datatype created yet.
    -- We just use SqlString, as the data will be serialized to JSON.
    defaultSqlTypeExp field
        | isJust (mEmbedded allEntities ftype) = SqlType' SqlString
        | otherwise = case fieldReference field of
            ForeignRef _ ft  -> SqlTypeExp ft
            CompositeRef _  -> SqlType' $ SqlOther "Composite Reference"
            _ -> case ftype of
                    -- In the case of lists, we always serialize to a string
                    -- value (via JSON).
                    --
                    -- Normally, this would be determined automatically by
                    -- SqlTypeExp. However, there's one corner case: if there's
                    -- a list of entity IDs, the datatype for the ID has not
                    -- yet been created, so the compiler will fail. This extra
                    -- clause works around this limitation.
                    FTList _ -> SqlType' SqlString
                    _ -> SqlTypeExp ftype
      where
        ftype = fieldType field

-- -- | Create data types and appropriate 'PersistEntity' instances for the given
-- -- 'EntityDef's. Works well with the persist quasi-quoter.
-- mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
-- mkPersist mps ents' = do
--     x <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents
--     y <- fmap mconcat $ mapM (mkEntity mps) ents
--     z <- fmap mconcat $ mapM (mkJSON mps) ents
--     return $ mconcat [x, y, z]
--   where
--     ents = map fixEntityDef ents'
-- 
-- -- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'.
-- -- For example, strip out any fields marked as MigrationOnly.
-- fixEntityDef :: EntityDef -> EntityDef
-- fixEntityDef ed =
--     ed { entityFields = filter keepField $ entityFields ed }
--   where
--     keepField fd = "MigrationOnly" `notElem` fieldAttrs fd &&
--                    "SafeToRemove" `notElem` fieldAttrs fd
-- 
-- -- | Settings to be passed to the 'mkPersist' function.
-- data MkPersistSettings = MkPersistSettings
--     { mpsBackend :: Type
--     -- ^ Which database backend we\'re using.
--     --
--     -- When generating data types, each type is given a generic version- which
--     -- works with any backend- and a type synonym for the commonly used
--     -- backend. This is where you specify that commonly used backend.
--     , mpsGeneric :: Bool
--     -- ^ Create generic types that can be used with multiple backends. Good for
--     -- reusable code, but makes error messages harder to understand. Default:
--     -- True.
--     , mpsPrefixFields :: Bool
--     -- ^ Prefix field names with the model name. Default: True.
--     , mpsEntityJSON :: Maybe EntityJSON
--     -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's
--     -- @Nothing@, no instances will be generated. Default:
--     --
--     -- @
--     --  Just EntityJSON
--     --      { entityToJSON = 'keyValueEntityToJSON
--     --      , entityFromJSON = 'keyValueEntityFromJSON
--     --      }
--     -- @
--     , mpsGenerateLenses :: !Bool
--     -- ^ Instead of generating normal field accessors, generator lens-style accessors.
--     --
--     -- Default: False
--     --
--     -- Since 1.3.1
--     }
-- 
-- data EntityJSON = EntityJSON
--     { entityToJSON :: Name
--     -- ^ Name of the @toJSON@ implementation for @Entity a@.
--     , entityFromJSON :: Name
--     -- ^ Name of the @fromJSON@ implementation for @Entity a@.
--     }
-- 
-- -- | Create an @MkPersistSettings@ with default values.
-- mkPersistSettings :: Type -- ^ Value for 'mpsBackend'
--                   -> MkPersistSettings
-- mkPersistSettings t = MkPersistSettings
--     { mpsBackend = t
--     , mpsGeneric = False
--     , mpsPrefixFields = True
--     , mpsEntityJSON = Just EntityJSON
--         { entityToJSON = 'entityIdToJSON
--         , entityFromJSON = 'entityIdFromJSON
--         }
--     , mpsGenerateLenses = False
--     }
-- 
-- -- | Use the 'SqlPersist' backend.
-- sqlSettings :: MkPersistSettings
-- sqlSettings = mkPersistSettings $ ConT ''SqlBackend
-- 
-- -- | Same as 'sqlSettings'.
-- --
-- -- Since 1.1.1
-- sqlOnlySettings :: MkPersistSettings
-- sqlOnlySettings = sqlSettings
-- {-# DEPRECATED sqlOnlySettings "use sqlSettings" #-}
-- 
-- recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text
-- recNameNoUnderscore mps dt f
--   | mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft
--   | otherwise           = lowerFirst ft
--   where ft = unHaskellName f
-- 
-- recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text
-- recName mps dt f =
--     addUnderscore $ recNameNoUnderscore mps dt f
--   where
--     addUnderscore
--         | mpsGenerateLenses mps = ("_" ++)
--         | otherwise = id
-- 
-- lowerFirst :: Text -> Text
-- lowerFirst t =
--     case uncons t of
--         Just (a, b) -> cons (toLower a) b
--         Nothing -> t
-- 
-- upperFirst :: Text -> Text
-- upperFirst t =
--     case uncons t of
--         Just (a, b) -> cons (toUpper a) b
--         Nothing -> t
-- 
-- dataTypeDec :: MkPersistSettings -> EntityDef -> Dec
-- dataTypeDec mps t =
--     DataD [] nameFinal paramsFinal constrs
--     $ map (mkName . unpack) $ entityDerives t
--   where
--     mkCol x fd@FieldDef {..} =
--         (mkName $ unpack $ recName mps x fieldHaskell,
--          if fieldStrict then IsStrict else NotStrict,
--          maybeIdType mps fd Nothing Nothing
--         )
--     (nameFinal, paramsFinal)
--         | mpsGeneric mps = (nameG, [PlainTV backend])
--         | otherwise = (name, [])
--     nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Generic"
--     name = mkName $ unpack $ unHaskellName $ entityHaskell t
--     cols = map (mkCol $ entityHaskell t) $ entityFields t
--     backend = backendName
-- 
--     constrs
--         | entitySum t = map sumCon $ entityFields t
--         | otherwise = [RecC name cols]
-- 
--     sumCon fd = NormalC
--         (sumConstrName mps t fd)
--         [(NotStrict, maybeIdType mps fd Nothing Nothing)]
-- 
-- sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
-- sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat
--     [ if mpsPrefixFields mps
--         then unHaskellName $ entityHaskell t
--         else ""
--     , upperFirst $ unHaskellName fieldHaskell
--     , "Sum"
--     ]
-- 
-- uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec
-- uniqueTypeDec mps t =
--     DataInstD [] ''Unique
--         [genericDataType mps (entityHaskell t) backendT]
--             (map (mkUnique mps t) $ entityUniques t)
--             []
-- 
-- mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con
-- mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) =
--     NormalC (mkName $ unpack constr) types
--   where
--     types = map (go . flip lookup3 (entityFields t))
--           $ map (unHaskellName . fst) fields
-- 
--     force = "!force" `elem` attrs
-- 
--     go :: (FieldDef, IsNullable) -> (Strict, Type)
--     go (_, Nullable _) | not force = error nullErrMsg
--     go (fd, y) = (NotStrict, maybeIdType mps fd Nothing (Just y))
-- 
--     lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable)
--     lookup3 s [] =
--         error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr
--     lookup3 x (fd@FieldDef {..}:rest)
--         | x == unHaskellName fieldHaskell = (fd, nullable fieldAttrs)
--         | otherwise = lookup3 x rest
-- 
--     nullErrMsg =
--       mconcat [ "Error:  By default we disallow NULLables in an uniqueness "
--               , "constraint.  The semantics of how NULL interacts with those "
--               , "constraints is non-trivial:  two NULL values are not "
--               , "considered equal for the purposes of an uniqueness "
--               , "constraint.  If you understand this feature, it is possible "
--               , "to use it your advantage.    *** Use a \"!force\" attribute "
--               , "on the end of the line that defines your uniqueness "
--               , "constraint in order to disable this check. ***" ]
-- 
-- maybeIdType :: MkPersistSettings
--            -> FieldDef
--            -> Maybe Name -- ^ backend
--            -> Maybe IsNullable
--            -> Type
-- maybeIdType mps fd mbackend mnull = maybeTyp mayNullable idtyp
--   where
--     mayNullable = case mnull of
--         (Just (Nullable ByMaybeAttr)) -> True
--         _ -> maybeNullable fd
--     idtyp = idType mps fd mbackend
-- 
-- backendDataType :: MkPersistSettings -> Type
-- backendDataType mps
--     | mpsGeneric mps = backendT
--     | otherwise = mpsBackend mps
-- 
-- genericDataType :: MkPersistSettings
--                 -> HaskellName -- ^ entity name
--                 -> Type -- ^ backend
--                 -> Type
-- genericDataType mps (HaskellName typ') backend
--     | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend
--     | otherwise = ConT $ mkName $ unpack typ'
-- 
-- idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type
-- idType mps fd mbackend =
--     case foreignReference fd of
--         Just typ ->
--             ConT ''Key
--             `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend)
--         Nothing -> ftToType $ fieldType fd
-- 
-- degen :: [Clause] -> [Clause]
-- degen [] =
--     let err = VarE 'error `AppE` LitE (StringL
--                 "Degenerate case, should never happen")
--      in [normalClause [WildP] err]
-- degen x = x
-- 
-- mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec
-- mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do
--     clauses <-
--         if isSum
--             then sequence $ zipWith goSum fields [1..]
--             else fmap return go
--     return $ FunD 'toPersistFields clauses
--   where
--     go :: Q Clause
--     go = do
--         xs <- sequence $ replicate fieldCount $ newName "x"
--         let pat = ConP (mkName constr) $ map VarP xs
--         sp <- [|SomePersistField|]
--         let bod = ListE $ map (AppE sp . VarE) xs
--         return $ normalClause [pat] bod
-- 
--     fieldCount = length fields
-- 
--     goSum :: FieldDef -> Int -> Q Clause
--     goSum fd idx = do
--         let name = sumConstrName mps ed fd
--         enull <- [|SomePersistField PersistNull|]
--         let beforeCount = idx - 1
--             afterCount = fieldCount - idx
--             before = replicate beforeCount enull
--             after = replicate afterCount enull
--         x <- newName "x"
--         sp <- [|SomePersistField|]
--         let body = ListE $ mconcat
--                 [ before
--                 , [sp `AppE` VarE x]
--                 , after
--                 ]
--         return $ normalClause [ConP name [VarP x]] body
-- 
-- 
-- mkToFieldNames :: [UniqueDef] -> Q Dec
-- mkToFieldNames pairs = do
--     pairs' <- mapM go pairs
--     return $ FunD 'persistUniqueToFieldNames $ degen pairs'
--   where
--     go (UniqueDef constr _ names _) = do
--         names' <- lift names
--         return $
--             normalClause
--                 [RecP (mkName $ unpack $ unHaskellName constr) []]
--                 names'
-- 
-- mkUniqueToValues :: [UniqueDef] -> Q Dec
-- mkUniqueToValues pairs = do
--     pairs' <- mapM go pairs
--     return $ FunD 'persistUniqueToValues $ degen pairs'
--   where
--     go :: UniqueDef -> Q Clause
--     go (UniqueDef constr _ names _) = do
--         xs <- mapM (const $ newName "x") names
--         let pat = ConP (mkName $ unpack $ unHaskellName constr) $ map VarP xs
--         tpv <- [|toPersistValue|]
--         let bod = ListE $ map (AppE tpv . VarE) xs
--         return $ normalClause [pat] bod
-- 
-- isNotNull :: PersistValue -> Bool
-- isNotNull PersistNull = False
-- isNotNull _ = True
-- 
-- mapLeft :: (a -> c) -> Either a b -> Either c b
-- mapLeft _ (Right r) = Right r
-- mapLeft f (Left l)  = Left (f l)
-- 
-- fieldError :: Text -> Text -> Text
-- fieldError fieldName err = "field " `mappend` fieldName `mappend` ": " `mappend` err
-- 
-- mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]
-- mkFromPersistValues _ t@(EntityDef { entitySum = False }) =
--     fromValues t "fromPersistValues" entE $ entityFields t
--   where
--     entE = ConE $ mkName $ unpack entName
--     entName = unHaskellName $ entityHaskell t
-- 
-- mkFromPersistValues mps t@(EntityDef { entitySum = True }) = do
--     nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]
--     clauses <- mkClauses [] $ entityFields t
--     return $ clauses `mappend` [normalClause [WildP] nothing]
--   where
--     entName = unHaskellName $ entityHaskell t
--     mkClauses _ [] = return []
--     mkClauses before (field:after) = do
--         x <- newName "x"
--         let null' = ConP 'PersistNull []
--             pat = ListP $ mconcat
--                 [ map (const null') before
--                 , [VarP x]
--                 , map (const null') after
--                 ]
--             constr = ConE $ sumConstrName mps t field
--         fs <- [|fromPersistValue $(return $ VarE x)|]
--         let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x
--         let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) []
--         clauses <- mkClauses (field : before) after
--         return $ clause : clauses
-- 
-- type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
-- 
-- lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b
-- lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s)
-- 
-- fmapE :: Exp
-- fmapE = VarE 'fmap
-- 
-- mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause]
-- mkLensClauses mps t = do
--     lens' <- [|lensPTH|]
--     getId <- [|entityKey|]
--     setId <- [|\(Entity _ value) key -> Entity key value|]
--     getVal <- [|entityVal|]
--     dot <- [|(.)|]
--     keyVar <- newName "key"
--     valName <- newName "value"
--     xName <- newName "x"
--     let idClause = normalClause
--             [ConP (keyIdName t) []]
--             (lens' `AppE` getId `AppE` setId)
--     if entitySum t
--         then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields t)
--         else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields t)
--   where
--     toClause lens' getVal dot keyVar valName xName f = normalClause
--         [ConP (filterConName mps t f) []]
--         (lens' `AppE` getter `AppE` setter)
--       where
--         fieldName = mkName $ unpack $ recName mps (entityHaskell t) (fieldHaskell f)
--         getter = InfixE (Just $ VarE fieldName) dot (Just getVal)
--         setter = LamE
--             [ ConP 'Entity [VarP keyVar, VarP valName]
--             , VarP xName
--             ]
--             $ ConE 'Entity `AppE` VarE keyVar `AppE` RecUpdE
--                 (VarE valName)
--                 [(fieldName, VarE xName)]
-- 
--     toSumClause lens' keyVar valName xName f = normalClause
--         [ConP (filterConName mps t f) []]
--         (lens' `AppE` getter `AppE` setter)
--       where
--         emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) []
--         getter = LamE
--             [ ConP 'Entity [WildP, VarP valName]
--             ] $ CaseE (VarE valName)
--             $ Match (ConP (sumConstrName mps t f) [VarP xName]) (NormalB $ VarE xName) []
-- 
--             -- FIXME It would be nice if the types expressed that the Field is
--             -- a sum type and therefore could result in Maybe.
--             : if length (entityFields t) > 1 then [emptyMatch] else []
--         setter = LamE
--             [ ConP 'Entity [VarP keyVar, WildP]
--             , VarP xName
--             ]
--             $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName)
-- 
-- 
-- 
-- -- | declare the key type and associated instances
-- -- a PathPiece instance is only generated for a Key with one field
-- mkKeyTypeDec :: MkPersistSettings -> EntityDef -> Q (Dec, [Dec])
-- mkKeyTypeDec mps t = do
--     (instDecs, i) <-
--       if mpsGeneric mps
--         then if not useNewtype
--                then do pfDec <- pfInstD
--                        return (pfDec, [''Generic])
--                else do gi <- genericInstances
--                        return (gi, [])
--         else if not useNewtype
--                then do pfDec <- pfInstD
--                        return (pfDec, [''Show, ''Read, ''Eq, ''Ord, ''Generic])
--                 else do
--                     let addIsSqlKey = if not useSqlKey then id else (''IsSqlKey :)
--                     return ([], addIsSqlKey [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON])
-- 
--     let kd = if useNewtype
--                then NewtypeInstD [] k [recordType] dec i
--                else DataInstD    [] k [recordType] [dec] i
--     return (kd, instDecs)
--   where
--     useSqlKey = mpsBackend mps == ConT ''SqlBackend
--              && (fieldSqlType (entityId t) `elem` [SqlInt64, SqlInt32])
-- 
--     dec = RecC (keyConName t) keyFields
--     k = ''Key
--     recordType = genericDataType mps (entityHaskell t) backendT
--     pfInstD = -- FIXME: generate a PersistMap instead of PersistList
--       [d|instance PersistField (Key $(pure recordType)) where
--             toPersistValue = PersistList . keyToValues
--             fromPersistValue (PersistList l) = keyFromValues l
--             fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got
--          instance PersistFieldSql (Key $(pure recordType)) where
--             sqlType _ = SqlString
--          instance ToJSON (Key $(pure recordType))
--          instance FromJSON (Key $(pure recordType))
--       |]
-- 
--     keyStringL = StringL . keyString
--     -- ghc 7.6 cannot parse the left arrow Ident $() <- lexP
--     keyPattern = BindS (ConP 'Ident [LitP $ keyStringL t])
-- 
--     -- truly unfortunate that TH doesn't support standalone deriving
--     -- https://ghc.haskell.org/trac/ghc/ticket/8100
--     genericInstances = do
--       instances <- [|lexP|] >>= \lexPE -> [| step readPrec >>= return . ($(pure $ ConE $ keyConName t) )|] >>= \readE ->
--         [d|instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) where
--               showsPrec i x = showParen (i > app_prec) $
--                 (showString $ $(pure $ LitE $ keyStringL t) `mappend` " ") .
--                 showsPrec i ($(return $ VarE $ unKeyName t) x)
--                 where app_prec = (10::Int)
--            instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) where
--               readPrec = parens $ (prec app_prec $ $(pure $ DoE [keyPattern lexPE, NoBindS readE]))
--                 where app_prec = (10::Int)
--            instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) where
--               x == y =
--                   ($(return $ VarE $ unKeyName t) x) ==
--                   ($(return $ VarE $ unKeyName t) y)
--               x /= y =
--                   ($(return $ VarE $ unKeyName t) x) ==
--                   ($(return $ VarE $ unKeyName t) y)
--            instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) where
--               compare x y = compare
--                   ($(return $ VarE $ unKeyName t) x)
--                   ($(return $ VarE $ unKeyName t) y)
--            instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) where
--               toPathPiece = toPathPiece . $(return $ VarE $ unKeyName t)
--               fromPathPiece = fmap $(return $ ConE $ keyConName t) . fromPathPiece
--            instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) where
--               toPersistValue = toPersistValue . $(return $ VarE $ unKeyName t)
--               fromPersistValue = fmap $(return $ ConE $ keyConName t) . fromPersistValue
--            instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) where
--               sqlType = sqlType . fmap $(return $ VarE $ unKeyName t)
--            instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) where
--               toJSON = toJSON . $(return $ VarE $ unKeyName t)
--            instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) where
--               parseJSON = fmap $(return $ ConE $ keyConName t) . parseJSON
--         |]
--       if not useSqlKey then return instances else do
--         sqlKeyInst <-
--           [d| instance IsSqlKey (BackendKey $(pure backendT)) => IsSqlKey (Key $(pure recordType)) where
--                 toSqlKey = $(return $ ConE $ keyConName t) . toSqlKey
--                 fromSqlKey = fromSqlKey . $(return $ VarE $ unKeyName t)
--           |]
--         return $ instances `mappend` sqlKeyInst
-- 
--     useNewtype = length keyFields < 2
--     keyFields = case entityPrimary t of
--       Just pdef -> map primaryKeyVar $ (compositeFields pdef)
--       -- TODO: an ADT for the entityId
--       Nothing   -> if fieldType (entityId t) == FTTypeCon Nothing (keyIdText t)
--         then [idKeyVar backendKeyType]
--         else [idKeyVar $ ftToType $ fieldType $ entityId t]
-- 
--     primaryKeyVar fd = (keyFieldName t fd, NotStrict, ftToType $ fieldType fd)
--     idKeyVar ft = (unKeyName t, NotStrict, ft)
-- 
--     backendKeyType
--         | mpsGeneric mps = ConT ''BackendKey `AppT` backendT
--         | otherwise      = ConT ''BackendKey `AppT` mpsBackend mps
-- 
-- keyIdName :: EntityDef -> Name
-- keyIdName = mkName . unpack . keyIdText
-- 
-- keyIdText :: EntityDef -> Text
-- keyIdText t = (unHaskellName $ entityHaskell t) `mappend` "Id"
-- 
-- unKeyName :: EntityDef -> Name
-- unKeyName t = mkName $ "un" `mappend` keyString t
-- 
-- backendT :: Type
-- backendT = VarT backendName
-- 
-- backendName :: Name
-- backendName = mkName "backend"
-- 
-- keyConName :: EntityDef -> Name
-- keyConName = mkName . keyString
-- 
-- keyString :: EntityDef -> String
-- keyString = unpack . keyText
-- 
-- keyText :: EntityDef -> Text
-- keyText t = unHaskellName (entityHaskell t) ++ "Key"
-- 
-- keyFieldName :: EntityDef -> FieldDef -> Name
-- keyFieldName t fd = mkName $ unpack $ lowerFirst (keyText t) `mappend` (unHaskellName $ fieldHaskell fd)
-- 
-- mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec
-- mkKeyToValues _mps t = do
--     (p, e) <- case entityPrimary t of
--         Nothing  ->
--           ([],) <$> [|(:[]) . toPersistValue . $(return $ VarE $ unKeyName t)|]
--         Just pdef ->
--           return $ toValuesPrimary pdef
--     return $ FunD 'keyToValues $ return $ normalClause p e
--   where
--     toValuesPrimary pdef =
--       ( [VarP recordName]
--       , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName t fd) `AppE` VarE recordName)) $ compositeFields pdef
--       )
--     recordName = mkName "record"
-- 
-- normalClause :: [Pat] -> Exp -> Clause
-- normalClause p e = Clause p (NormalB e) []
-- 
-- mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec
-- mkKeyFromValues _mps t = do
--     clauses <- case entityPrimary t of
--         Nothing  -> do
--             e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
--             return $ [normalClause [] e]
--         Just pdef ->
--             fromValues t "keyFromValues" keyConE (compositeFields pdef)
--     return $ FunD 'keyFromValues clauses
--   where
--     keyConE = ConE (keyConName t)
-- 
-- headNote :: [PersistValue] -> PersistValue
-- headNote (x:[]) = x
-- headNote xs = error $ "mkKeyFromValues: expected a list of one element, got: "
--   `mappend` show xs
-- 
-- 
-- fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause]
-- fromValues t funName conE fields = do
--     x <- newName "x"
--     let funMsg = entityText t `mappend` ": " `mappend` funName `mappend` " failed on: "
--     patternMatchFailure <-
--       [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]
--     suc <- patternSuccess fields
--     return [ suc, normalClause [VarP x] patternMatchFailure ]
--   where
--     patternSuccess [] = do
--       rightE <- [|Right|]
--       return $ normalClause [ListP []] (rightE `AppE` conE)
--     patternSuccess fieldsNE = do
--         x1 <- newName "x1"
--         restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fieldsNE]
--         (fpv1:mkPersistValues) <- mapM mkPvFromFd fieldsNE
--         app1E <- [|(<$>)|]
--         let conApp = infixFromPersistValue app1E fpv1 conE x1
--         applyE <- [|(<*>)|]
--         let applyFromPersistValue = infixFromPersistValue applyE
-- 
--         return $ normalClause
--             [ListP $ map VarP (x1:restNames)]
--             (foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues))
--         where
--           infixFromPersistValue applyE fpv exp name =
--               UInfixE exp applyE (fpv `AppE` VarE name)
--           mkPvFromFd = mkPersistValue . unHaskellName . fieldHaskell
--           mkPersistValue fieldName = [|mapLeft (fieldError fieldName) . fromPersistValue|]
-- 
-- 
-- mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec]
-- mkEntity mps t = do
--     t' <- lift t
--     let nameT = unHaskellName entName
--     let nameS = unpack nameT
--     let clazz = ConT ''PersistEntity `AppT` genericDataType mps entName backendT
--     tpf <- mkToPersistFields mps nameS t
--     fpv <- mkFromPersistValues mps t
--     utv <- mkUniqueToValues $ entityUniques t
--     puk <- mkUniqueKeys t
--     fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t
-- 
--     let primaryField = entityId t
--     
--     fields <- mapM (mkField mps t) $ primaryField : entityFields t
--     toFieldNames <- mkToFieldNames $ entityUniques t
-- 
--     (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t
--     keyToValues' <- mkKeyToValues mps t
--     keyFromValues' <- mkKeyFromValues mps t
-- 
--     let addSyn -- FIXME maybe remove this
--             | mpsGeneric mps = (:) $
--                 TySynD (mkName nameS) [] $
--                     genericDataType mps entName $ mpsBackend mps
--             | otherwise = id
-- 
--     lensClauses <- mkLensClauses mps t
-- 
--     lenses <- mkLenses mps t
--     let instanceConstraint = if not (mpsGeneric mps) then [] else
--           [ClassP ''PersistStore [backendT]]
-- 
--     return $ addSyn $
--        dataTypeDec mps t : mconcat fkc `mappend`
--       ([ TySynD (keyIdName t) [] $
--             ConT ''Key `AppT` ConT (mkName nameS)
--       , InstanceD instanceConstraint clazz $
--         [ uniqueTypeDec mps t
--         , keyTypeDec
--         , keyToValues'
--         , keyFromValues'
--         , FunD 'entityDef [normalClause [WildP] t']
--         , tpf
--         , FunD 'fromPersistValues fpv
--         , toFieldNames
--         , utv
--         , puk
--         , DataInstD
--             []
--             ''EntityField
--             [ genDataType
--             , VarT $ mkName "typ"
--             ]
--             (map fst fields)
--             []
--         , FunD 'persistFieldDef (map snd fields)
--         , TySynInstD
--             ''PersistEntityBackend
-- #if MIN_VERSION_template_haskell(2,9,0)
--             (TySynEqn
--                [genDataType]
--                (backendDataType mps))
-- #else
--             [genDataType]
--             (backendDataType mps)
-- #endif
--         , FunD 'persistIdField [normalClause [] (ConE $ keyIdName t)]
--         , FunD 'fieldLens lensClauses
--         ]
--       ] `mappend` lenses) `mappend` keyInstanceDecs
--   where
--     genDataType = genericDataType mps entName backendT
--     entName = entityHaskell t
-- 
-- entityText :: EntityDef -> Text
-- entityText = unHaskellName . entityHaskell
-- 
-- mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec]
-- mkLenses mps _ | not (mpsGenerateLenses mps) = return []
-- mkLenses _ ent | entitySum ent = return []
-- mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do
--     let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)
--         lensName = mkName $ unpack lensName'
--         fieldName = mkName $ unpack $ "_" ++ lensName'
--     needleN <- newName "needle"
--     setterN <- newName "setter"
--     fN <- newName "f"
--     aN <- newName "a"
--     yN <- newName "y"
--     let needle = VarE needleN
--         setter = VarE setterN
--         f = VarE fN
--         a = VarE aN
--         y = VarE yN
--         fT = mkName "f"
--         -- FIXME if we want to get really fancy, then: if this field is the
--         -- *only* Id field present, then set backend1 and backend2 to different
--         -- values
--         backend1 = backendName
--         backend2 = backendName
--         aT = maybeIdType mps field (Just backend1) Nothing
--         bT = maybeIdType mps field (Just backend2) Nothing
--         mkST backend = genericDataType mps (entityHaskell ent) (VarT backend)
--         sT = mkST backend1
--         tT = mkST backend2
--         t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2
--         vars = PlainTV fT
--              : (if mpsGeneric mps then [PlainTV backend1{-, PlainTV backend2-}] else [])
--     return
--         [ SigD lensName $ ForallT vars [ClassP ''Functor [VarT fT]] $
--             (aT `arrow` (VarT fT `AppT` bT)) `arrow`
--             (sT `arrow` (VarT fT `AppT` tT))
--         , FunD lensName $ return $ Clause
--             [VarP fN, VarP aN]
--             (NormalB $ fmapE
--                 `AppE` setter
--                 `AppE` (f `AppE` needle))
--             [ FunD needleN [normalClause [] (VarE fieldName `AppE` a)]
--             , FunD setterN $ return $ normalClause
--                 [VarP yN]
--                 (RecUpdE a
--                     [ (fieldName, y)
--                     ])
--             ]
--         ]
-- 
-- mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]
-- mkForeignKeysComposite mps t ForeignDef {..} = do
--    let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f
--    let fname = fieldName foreignConstraintNameHaskell
--    let reftableString = unpack $ unHaskellName $ foreignRefTableHaskell
--    let reftableKeyName = mkName $ reftableString `mappend` "Key"
--    let tablename = mkName $ unpack $ entityText t
--    recordName <- newName "record"
--    
--    let fldsE = map (\((foreignName, _),_) -> VarE (fieldName $ foreignName)
--                  `AppE` VarE recordName) foreignFields
--    let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE
--    let fn = FunD fname [normalClause [VarP recordName] mkKeyE]
--    
--    let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString)
--    let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2
--    return [sig, fn]
-- 
-- maybeExp :: Bool -> Exp -> Exp
-- maybeExp may exp | may = fmapE `AppE` exp
--                  | otherwise = exp
-- maybeTyp :: Bool -> Type -> Type
-- maybeTyp may typ | may = ConT ''Maybe `AppT` typ
--                  | otherwise = typ
-- 
-- 
-- 
-- -- | produce code similar to the following:
-- --
-- -- @
-- --   instance PersistEntity e => PersistField e where
-- --      toPersistValue = PersistMap $ zip columNames (map toPersistValue . toPersistFields)
-- --      fromPersistValue (PersistMap o) = 
-- --          let columns = HM.fromList o
-- --          in fromPersistValues $ map (\name ->
-- --            case HM.lookup name columns of
-- --              Just v -> v
-- --              Nothing -> PersistNull
-- --      fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x
-- --      sqlType _ = SqlString
-- -- @
-- persistFieldFromEntity :: MkPersistSettings -> EntityDef -> Q [Dec]
-- persistFieldFromEntity mps e = do
--     ss <- [|SqlString|]
--     obj <- [|\ent -> PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields ent)|]
--     fpv <- [|\x -> let columns = HM.fromList x
--                     in fromPersistValues $ map
--                          (\(name) ->
--                             case HM.lookup (pack name) columns of
--                                 Just v -> v
--                                 Nothing -> PersistNull)
--                          $ columnNames
--           |]
-- 
--     compose <- [|(<=<)|]
--     getPersistMap' <- [|getPersistMap|]
--     return
--         [ persistFieldInstanceD (mpsGeneric mps) typ
--             [ FunD 'toPersistValue [ normalClause [] obj ]
--             , FunD 'fromPersistValue
--                 [ normalClause [] (InfixE (Just fpv) compose $ Just getPersistMap')
--                 ]
--             ]
--         , persistFieldSqlInstanceD (mpsGeneric mps) typ
--             [ sqlTypeFunD ss
--             ]
--         ]
--     where
--       typ = genericDataType mps (entityHaskell e) backendT
--       entFields = entityFields e
--       columnNames  = map (unpack . unHaskellName . fieldHaskell) entFields
-- 
-- -- | Apply the given list of functions to the same @EntityDef@s.
-- --
-- -- This function is useful for cases such as:
-- --
-- -- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|]
-- share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]
-- share fs x = fmap mconcat $ mapM ($ x) fs
-- 
-- -- | Save the @EntityDef@s passed in under the given name.
-- mkSave :: String -> [EntityDef] -> Q [Dec]
-- mkSave name' defs' = do
--     let name = mkName name'
--     defs <- lift defs'
--     return [ SigD name $ ListT `AppT` ConT ''EntityDef
--            , FunD name [normalClause [] defs]
--            ]
-- 
-- data Dep = Dep
--     { depTarget :: HaskellName
--     , depSourceTable :: HaskellName
--     , depSourceField :: HaskellName
--     , depSourceNull  :: IsNullable
--     }
-- 
-- -- | Generate a 'DeleteCascade' instance for the given @EntityDef@s.
-- mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec]
-- mkDeleteCascade mps defs = do
--     let deps = concatMap getDeps defs
--     mapM (go deps) defs
--   where
--     getDeps :: EntityDef -> [Dep]
--     getDeps def =
--         concatMap getDeps' $ entityFields $ fixEntityDef def
--       where
--         getDeps' :: FieldDef -> [Dep]
--         getDeps' field@FieldDef {..} =
--             case foreignReference field of
--                 Just name ->
--                      return Dep
--                         { depTarget = name
--                         , depSourceTable = entityHaskell def
--                         , depSourceField = fieldHaskell
--                         , depSourceNull  = nullable fieldAttrs
--                         }
--                 Nothing -> []
--     go :: [Dep] -> EntityDef -> Q Dec
--     go allDeps EntityDef{entityHaskell = name} = do
--         let deps = filter (\x -> depTarget x == name) allDeps
--         key <- newName "key"
--         let del = VarE 'delete
--         let dcw = VarE 'deleteCascadeWhere
--         just <- [|Just|]
--         filt <- [|Filter|]
--         eq <- [|Eq|]
--         left <- [|Left|]
--         let mkStmt :: Dep -> Stmt
--             mkStmt dep = NoBindS
--                 $ dcw `AppE`
--                   ListE
--                     [ filt `AppE` ConE filtName
--                            `AppE` (left `AppE` val (depSourceNull dep))
--                            `AppE` eq
--                     ]
--               where
--                 filtName = filterConName' mps (depSourceTable dep) (depSourceField dep)
--                 val (Nullable ByMaybeAttr) = just `AppE` VarE key
--                 val _                      =             VarE key
-- 
-- 
-- 
--         let stmts :: [Stmt]
--             stmts = map mkStmt deps `mappend`
--                     [NoBindS $ del `AppE` VarE key]
-- 
--         let entityT = genericDataType mps name backendT
-- 
--         return $
--             InstanceD
--             [ ClassP ''PersistQuery [backendT]
--             , EqualP (ConT ''PersistEntityBackend `AppT` entityT) backendT
--             ]
--             (ConT ''DeleteCascade `AppT` entityT `AppT` backendT)
--             [ FunD 'deleteCascade
--                 [normalClause [VarP key] (DoE stmts)]
--             ]
-- 
-- mkUniqueKeys :: EntityDef -> Q Dec
-- mkUniqueKeys def | entitySum def =
--     return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])]
-- mkUniqueKeys def = do
--     c <- clause
--     return $ FunD 'persistUniqueKeys [c]
--   where
--     clause = do
--         xs <- forM (entityFields def) $ \fd -> do
--             let x = fieldHaskell fd
--             x' <- newName $ '_' : unpack (unHaskellName x)
--             return (x, x')
--         let pcs = map (go xs) $ entityUniques def
--         let pat = ConP
--                 (mkName $ unpack $ unHaskellName $ entityHaskell def)
--                 (map (VarP . snd) xs)
--         return $ normalClause [pat] (ListE pcs)
-- 
--     go :: [(HaskellName, Name)] -> UniqueDef -> Exp
--     go xs (UniqueDef name _ cols _) =
--         foldl' (go' xs) (ConE (mkName $ unpack $ unHaskellName name)) (map fst cols)
-- 
--     go' :: [(HaskellName, Name)] -> Exp -> HaskellName -> Exp
--     go' xs front col =
--         let Just col' = lookup col xs
--          in front `AppE` VarE col'
-- 
-- sqlTypeFunD :: Exp -> Dec
-- sqlTypeFunD st = FunD 'sqlType
--                 [ normalClause [WildP] st ]
-- 
-- typeInstanceD :: Name
--               -> Bool -- ^ include PersistStore backend constraint
--               -> Type -> [Dec] -> Dec
-- typeInstanceD clazz hasBackend typ =
--     InstanceD ctx (ConT clazz `AppT` typ)
--   where
--     ctx
--         | hasBackend = [ClassP ''PersistStore [backendT]]
--         | otherwise = []
-- 
-- persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint
--                       -> Type -> [Dec] -> Dec
-- persistFieldInstanceD = typeInstanceD ''PersistField
-- 
-- persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint
--                          -> Type -> [Dec] -> Dec
-- persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql
-- 
-- -- | Automatically creates a valid 'PersistField' instance for any datatype
-- -- that has valid 'Show' and 'Read' instances. Can be very convenient for
-- -- 'Enum' types.
-- derivePersistField :: String -> Q [Dec]
-- derivePersistField s = do
--     ss <- [|SqlString|]
--     tpv <- [|PersistText . pack . show|]
--     fpv <- [|\dt v ->
--                 case fromPersistValue v of
--                     Left e -> Left e
--                     Right s' ->
--                         case reads $ unpack s' of
--                             (x, _):_ -> Right x
--                             [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|]
--     return
--         [ persistFieldInstanceD False (ConT $ mkName s)
--             [ FunD 'toPersistValue
--                 [ normalClause [] tpv
--                 ]
--             , FunD 'fromPersistValue
--                 [ normalClause [] (fpv `AppE` LitE (StringL s))
--                 ]
--             ]
--         , persistFieldSqlInstanceD False (ConT $ mkName s)
--             [ sqlTypeFunD ss
--             ]
--         ]
-- 
-- -- | Automatically creates a valid 'PersistField' instance for any datatype
-- -- that has valid 'ToJSON' and 'FromJSON' instances. For a datatype @T@ it
-- -- generates instances similar to these:
-- -- 
-- -- @
-- --    instance PersistField T where
-- --        toPersistValue = PersistByteString . L.toStrict . encode
-- --        fromPersistValue = (left T.pack) . eitherDecodeStrict' <=< fromPersistValue
-- --    instance PersistFieldSql T where
-- --        sqlType _ = SqlString
-- -- @
-- derivePersistFieldJSON :: String -> Q [Dec]
-- derivePersistFieldJSON s = do
--     ss <- [|SqlString|]
--     tpv <- [|PersistText . toJsonText|]
--     fpv <- [|\dt v -> do
--                 text <- fromPersistValue v
--                 let bs' = TE.encodeUtf8 text
--                 case eitherDecodeStrict' bs' of
--                     Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs'
--                     Right x -> Right x|]
--     return
--         [ persistFieldInstanceD False (ConT $ mkName s)
--             [ FunD 'toPersistValue
--                 [ normalClause [] tpv
--                 ]
--             , FunD 'fromPersistValue
--                 [ normalClause [] (fpv `AppE` LitE (StringL s))
--                 ]
--             ]
--         , persistFieldSqlInstanceD False (ConT $ mkName s)
--             [ sqlTypeFunD ss
--             ]
--         ]
-- 
-- -- | Creates a single function to perform all migrations for the entities
-- -- defined here. One thing to be aware of is dependencies: if you have entities
-- -- with foreign references, make sure to place those definitions after the
-- -- entities they reference.
-- mkMigrate :: String -> [EntityDef] -> Q [Dec]
-- mkMigrate fun allDefs = do
--     body' <- body
--     return
--         [ SigD (mkName fun) typ
--         , FunD (mkName fun) [normalClause [] body']
--         ]
--   where
--     defs = filter isMigrated allDefs
--     isMigrated def = not $ "no-migrate" `elem` entityAttrs def
--     typ = ConT ''Migration
--     body :: Q Exp
--     body =
--         case defs of
--             [] -> [|return ()|]
--             _  -> do
--               defsName <- newName "defs"
--               defsStmt <- do
--                 defs' <- mapM lift defs
--                 let defsExp = ListE defs'
--                 return $ LetS [ValD (VarP defsName) (NormalB defsExp) []]
--               stmts <- mapM (toStmt $ VarE defsName) defs
--               return (DoE $ defsStmt : stmts)
--     toStmt :: Exp -> EntityDef -> Q Stmt
--     toStmt defsExp ed = do
--         u <- lift ed
--         m <- [|migrate|]
--         return $ NoBindS $ m `AppE` defsExp `AppE` u
-- 
instance Lift EntityDef where
    lift EntityDef{..} =
        [|EntityDef
            entityHaskell
            entityDB
            entityId
            entityAttrs
            entityFields
            entityUniques
            entityForeigns
            entityDerives
            entityExtra
            entitySum
            |]
instance Lift FieldDef where
    lift (FieldDef a b c d e f g) = [|FieldDef a b c d e f g|]
instance Lift UniqueDef where
    lift (UniqueDef a b c d) = [|UniqueDef a b c d|]
instance Lift CompositeDef where
    lift (CompositeDef a b) = [|CompositeDef a b|]
instance Lift ForeignDef where
    lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|]

-- | A hack to avoid orphans.
class Lift' a where
    lift' :: a -> Q Exp
instance Lift' Text where
    lift' = liftT
instance Lift' a => Lift' [a] where
    lift' xs = do { xs' <- mapM lift' xs; return (ListE xs') }
instance (Lift' k, Lift' v) => Lift' (M.Map k v) where
    lift' m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|]

-- auto-lifting, means instances are overlapping
instance Lift' a => Lift a where
    lift = lift'

packPTH :: String -> Text
packPTH = pack
#if !MIN_VERSION_text(0, 11, 2)
{-# NOINLINE packPTH #-}
#endif

liftT :: Text -> Q Exp
liftT t = [|packPTH $(lift (unpack t))|]

liftPair :: (Lift' k, Lift' v) => (k, v) -> Q Exp
liftPair (k, v) = [|($(lift' k), $(lift' v))|]

instance Lift HaskellName where
    lift (HaskellName t) = [|HaskellName t|]
instance Lift DBName where
    lift (DBName t) = [|DBName t|]
instance Lift FieldType where
    lift (FTTypeCon Nothing t)  = [|FTTypeCon Nothing t|]
    lift (FTTypeCon (Just x) t) = [|FTTypeCon (Just x) t|]
    lift (FTApp x y) = [|FTApp x y|]
    lift (FTList x) = [|FTList x|]
-- 
-- instance Lift PersistFilter where
--     lift Eq = [|Eq|]
--     lift Ne = [|Ne|]
--     lift Gt = [|Gt|]
--     lift Lt = [|Lt|]
--     lift Ge = [|Ge|]
--     lift Le = [|Le|]
--     lift In = [|In|]
--     lift NotIn = [|NotIn|]
--     lift (BackendSpecificFilter x) = [|BackendSpecificFilter x|]
-- 
-- instance Lift PersistUpdate where
--     lift Assign = [|Assign|]
--     lift Add = [|Add|]
--     lift Subtract = [|Subtract|]
--     lift Multiply = [|Multiply|]
--     lift Divide = [|Divide|]
-- 
instance Lift SqlType where
    lift SqlString = [|SqlString|]
    lift SqlInt32 = [|SqlInt32|]
    lift SqlInt64 = [|SqlInt64|]
    lift SqlReal = [|SqlReal|]
    lift (SqlNumeric x y) =
        [|SqlNumeric (fromInteger x') (fromInteger y')|]
      where
        x' = fromIntegral x :: Integer
        y' = fromIntegral y :: Integer
    lift SqlBool = [|SqlBool|]
    lift SqlDay = [|SqlDay|]
    lift SqlTime = [|SqlTime|]
    lift SqlDayTime = [|SqlDayTime|]
    lift SqlBlob = [|SqlBlob|]
    lift (SqlOther a) = [|SqlOther a|]

-- -- Ent
-- --   fieldName FieldType
-- --
-- -- forall . typ ~ FieldType => EntFieldName
-- --
-- -- EntFieldName = FieldDef ....
-- mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause)
-- mkField mps et cd = do
--     let con = ForallC
--                 []
--                 [EqualP (VarT $ mkName "typ") $ maybeIdType mps cd Nothing Nothing]
--                 $ NormalC name []
--     bod <- lift cd
--     let cla = normalClause
--                 [ConP name []]
--                 bod
--     return (con, cla)
--   where
--     name = filterConName mps et cd
-- 
-- maybeNullable :: FieldDef -> Bool
-- maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr
-- 
-- filterConName :: MkPersistSettings
--               -> EntityDef
--               -> FieldDef
--               -> Name
-- filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field)
-- 
-- filterConName' :: MkPersistSettings
--                -> HaskellName -- ^ table
--                -> HaskellName -- ^ field
--                -> Name
-- filterConName' mps entity field = mkName $ unpack $ concat
--     [ if mpsPrefixFields mps || field == HaskellName "Id"
--         then unHaskellName entity
--         else ""
--     , upperFirst $ unHaskellName field
--     ]

ftToType :: FieldType -> Type
ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t
ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t]
ftToType (FTApp x y) = ftToType x `AppT` ftToType y
ftToType (FTList x) = ListT `AppT` ftToType x

-- infixr 5 ++
-- (++) :: Text -> Text -> Text
-- (++) = append
-- 
-- mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec]
-- mkJSON _ def | not ("json" `elem` entityAttrs def) = return []
-- mkJSON mps def = do
--     pureE <- [|pure|]
--     apE' <- [|(<*>)|]
--     packE <- [|pack|]
--     dotEqualE <- [|(.=)|]
--     dotColonE <- [|(.:)|]
--     dotColonQE <- [|(.:?)|]
--     objectE <- [|object|]
--     obj <- newName "obj"
--     mzeroE <- [|mzero|]
-- 
--     xs <- mapM (newName . unpack . unHaskellName . fieldHaskell)
--         $ entityFields def
-- 
--     let conName = mkName $ unpack $ unHaskellName $ entityHaskell def
--         typ = genericDataType mps (entityHaskell def) backendT
--         toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON']
--         toJSON' = FunD 'toJSON $ return $ normalClause
--             [ConP conName $ map VarP xs]
--             (objectE `AppE` ListE pairs)
--         pairs = zipWith toPair (entityFields def) xs
--         toPair f x = InfixE
--             (Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f)))
--             dotEqualE
--             (Just $ VarE x)
--         fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON']
--         parseJSON' = FunD 'parseJSON
--             [ normalClause [ConP 'Object [VarP obj]]
--                 (foldl'
--                     (\x y -> InfixE (Just x) apE' (Just y))
--                     (pureE `AppE` ConE conName)
--                     pulls
--                 )
--             , normalClause [WildP] mzeroE
--             ]
--         pulls = map toPull $ entityFields def
--         toPull f = InfixE
--             (Just $ VarE obj)
--             (if maybeNullable f then dotColonQE else dotColonE)
--             (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f)
--     case mpsEntityJSON mps of
--         Nothing -> return [toJSONI, fromJSONI]
--         Just entityJSON -> do
--             entityJSONIs <- if mpsGeneric mps
--               then [d|
-- #if MIN_VERSION_base(4, 6, 0)
--                 instance PersistStore backend => ToJSON (Entity $(pure typ)) where
--                     toJSON = $(varE (entityToJSON entityJSON))
--                 instance PersistStore backend => FromJSON (Entity $(pure typ)) where
--                     parseJSON = $(varE (entityFromJSON entityJSON))
-- #endif
--                 |]
--               else [d|
--                 instance ToJSON (Entity $(pure typ)) where
--                     toJSON = $(varE (entityToJSON entityJSON))
--                 instance FromJSON (Entity $(pure typ)) where
--                     parseJSON = $(varE (entityFromJSON entityJSON))
--                 |]
--             return $ toJSONI : fromJSONI : entityJSONIs

-- entityUpdates :: EntityDef -> [(HaskellName, FieldType, IsNullable, PersistUpdate)]
-- entityUpdates =
--     concatMap go . entityFields
--   where
--     go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound]

-- mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec
-- mkToUpdate name pairs = do
--     pairs' <- mapM go pairs
--     return $ FunD (mkName name) $ degen pairs'
--   where
--     go (constr, pu) = do
--         pu' <- lift pu
--         return $ normalClause [RecP (mkName constr) []] pu'


-- mkToFieldName :: String -> [(String, String)] -> Dec
-- mkToFieldName func pairs =
--         FunD (mkName func) $ degen $ map go pairs
--   where
--     go (constr, name) =
--         normalClause [RecP (mkName constr) []] (LitE $ StringL name)

-- mkToValue :: String -> [String] -> Dec
-- mkToValue func = FunD (mkName func) . degen . map go
--   where
--     go constr =
--         let x = mkName "x"
--          in normalClause [ConP (mkName constr) [VarP x]]
--                    (VarE 'toPersistValue `AppE` VarE x)