diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,7 @@
+Copyright 2014 James Parker.
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
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/lmonad-yesod.cabal b/lmonad-yesod.cabal
new file mode 100644
--- /dev/null
+++ b/lmonad-yesod.cabal
@@ -0,0 +1,95 @@
+-- Initial lmonad-yesod.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+-- The name of the package.
+name:                lmonad-yesod
+
+-- The package version.  See the Haskell package versioning policy (PVP) 
+-- for standards guiding when and how versions should be incremented.
+-- http://www.haskell.org/haskellwiki/Package_versioning_policy
+-- PVP summary:      +-+------- breaking API changes
+--                   | | +----- non-breaking API additions
+--                   | | | +--- code changes with no API change
+version:             0.1.0.0
+
+-- A short (one-line) description of the package.
+synopsis:            LMonad for Yesod integrates LMonad's IFC with Yesod web applications.
+
+-- A longer description of the package.
+description:         LMonad for Yesod integrates LMonad's IFC with Yesod web applications. You can define custom security policies by modifying the database model file. 
+
+-- The license under which the package is released.
+license:             MIT
+
+-- The file containing the license text.
+license-file:        LICENSE
+
+-- The package author(s).
+author:              James Parker
+
+-- An email address to which users can send suggestions, bug reports, and 
+-- patches.
+maintainer:          dev@jamesparker.me
+
+-- A copyright notice.
+-- copyright:           
+
+category:            Security, Web, Yesod
+
+build-type:          Simple
+
+-- Constraint on the version of Cabal needed to build this package.
+cabal-version:       >=1.8
+
+
+library
+  -- Modules exported by the library.
+  exposed-modules:     
+      Database.LEsqueleto
+    , Database.LPersist
+    , Database.LPersist.Labeler
+    , Database.LPersist.TH
+    , LMonad.Yesod
+  
+  -- Modules included in this library but not exported.
+  other-modules:       
+      Database.LPersist.Quasi
+      Database.LEsqueleto.LSql
+    , Internal
+  
+  hs-source-dirs:
+      src
+  
+  ghc-options:
+      -Wall -fno-warn-name-shadowing
+
+  extensions:
+      FunctionalDependencies
+      GADTs
+      RankNTypes
+      MultiParamTypeClasses
+
+  -- Other library packages from which modules are imported.
+  build-depends:
+      attoparsec
+    , base < 5
+    , blaze-html
+    , blaze-markup
+    , containers
+    , esqueleto
+    , haskell-src-meta
+    , lifted-base
+    , lmonad
+    , mtl
+    , persistent > 2.1.2
+    , shakespeare
+    , tagged
+    , template-haskell
+    , text
+    , transformers
+    , yesod-core
+    , yesod-persistent
+  
+source-repository head
+  type:              git
+  location:          https://github.com/jprider63/LMonad-Yesod
diff --git a/src/Database/LEsqueleto.hs b/src/Database/LEsqueleto.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/LEsqueleto.hs
@@ -0,0 +1,664 @@
+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+
+module Database.LEsqueleto (mkLSql, module Export) where
+
+import Control.Monad.Trans.Class (lift)
+import Data.Attoparsec.Text (parseOnly)
+import qualified Data.Char as Char
+import qualified Data.List as List
+import Data.Maybe (fromJust)
+import qualified Database.Esqueleto as Esq
+import Database.Esqueleto as Export (Value(..), SqlBackend)
+import Data.Maybe (isJust)
+import Database.Persist.Types
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Database.LPersist
+--import Database.Persist
+import qualified Language.Haskell.Meta.Parse as Meta
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+import LMonad.TCB
+
+import Database.LEsqueleto.LSql
+import Internal
+
+-- | Generate the quasiquoter function `lsql` that parses the esqueleto DSL.
+mkLSql :: [EntityDef] -> Q [Dec]
+mkLSql ents' = 
+    let lsql = mkName "lsql" in
+    let sig = SigD lsql (ConT ''QuasiQuoter) in
+    let ents = mkSerializedLEntityDefs $ map toLEntityDef ents' in
+    let def = ValD (VarP lsql) (NormalB (AppE (VarE 'lsqlHelper) ents)) [] in
+    let lsql' = mkName "lsql'" in
+    let sig' = SigD lsql' (ConT ''QuasiQuoter) in
+    let def' = ValD (VarP lsql') (NormalB (AppE (VarE 'lsqlHelper') ents)) [] in
+    return [ sig, def, sig', def']
+
+-- | Serialize LEntityDefs so that lsql can access them in other modules. 
+-- Ex:
+--
+-- [ LEntityDef "User" [LFieldDef "ident" (FTTypeCon "Text") True Nothing, ...], ...]
+mkSerializedLEntityDefs :: [LEntityDef] -> Exp
+mkSerializedLEntityDefs ents' = 
+    ListE $ List.map mkSerializedLEntityDef ents'
+
+    where
+        mkSerializedLEntityDef ent = 
+            let str = LitE $ StringL $ lEntityHaskell ent in
+            let fields = mkSerializedLFieldsDef $ lEntityFields ent in
+            -- if (lEntityHaskell ent) == "User" then
+            --     error $ show ent
+            -- else
+            AppE (AppE (ConE 'LEntityDef) str) fields
+
+        mkSerializedText t = SigE (LitE $ StringL $ Text.unpack t) (ConT ''Text)
+        mkSerializedFieldType typ = case typ of
+            FTTypeCon moduleM' name' ->
+                let moduleM = maybe (ConE 'Nothing) (\m -> AppE (ConE 'Just) (mkSerializedText m)) moduleM' in
+                let name = mkSerializedText name' in
+                AppE (AppE (ConE 'FTTypeCon) moduleM) name
+            FTApp typ1' typ2' ->
+                let typ1 = mkSerializedFieldType typ1' in
+                let typ2 = mkSerializedFieldType typ2' in
+                AppE (AppE (ConE 'FTApp) typ1) typ2
+            FTList typ' ->
+                let typ = mkSerializedFieldType typ' in
+                AppE (ConE 'FTList) typ
+        mkSerializedLabelAnnotation la = case la of 
+            LAId ->
+                ConE 'LAId
+            LAConst s ->
+                AppE (ConE 'LAConst) (LitE $ StringL s)
+            LAField s -> 
+                AppE (ConE 'LAField) (LitE $ StringL s)
+        mkSerializedLFieldsDef fields' = 
+            let helper field = 
+                  let name = LitE $ StringL $ lFieldHaskell field in
+                  let typ = mkSerializedFieldType $ lFieldType field in
+                  let strict = ConE $ if lFieldStrict field then 'True else 'False in
+                  let anns = maybe (ConE 'Nothing) (\( r', w', c') -> 
+                            let r = ListE $ map mkSerializedLabelAnnotation r' in
+                            let w = ListE $ map mkSerializedLabelAnnotation w' in
+                            let c = ListE $ map mkSerializedLabelAnnotation c' in
+                            AppE (ConE 'Just) $ TupE [ r, w, c]
+                        ) $ lFieldLabelAnnotations field 
+                  in
+                  AppE (AppE (AppE (AppE (ConE 'LFieldDef) name) typ) strict) anns
+            in
+            ListE $ map helper fields'
+
+lsqlHelper :: [LEntityDef] -> QuasiQuoter
+lsqlHelper ents = QuasiQuoter {
+        quoteExp = (generateSql ents) . Text.pack
+    }
+
+generateSql :: [LEntityDef] -> Text -> Q Exp
+generateSql lEntityDefs s = 
+    -- Parse the DSL. 
+    let ast = case parseOnly parseCommand s of
+          Left err ->
+            error $ "Error parsing lsql statement: " ++ err
+          Right res ->
+            res
+    in
+    let normalized = normalizeTerms ast in
+    let isTableOptional tableS =
+          let createAssoc (Tables ts join table _) lvl' =
+                let ( lvl, next, prev) = case join of
+                      LeftOuterJoin ->
+                        if lvl' == 0 then 
+                            ( 1, 0, 1)
+                        else
+                            ( lvl', lvl' - 1, 0)
+                      InnerJoin ->
+                        ( lvl', lvl', 0)
+                      RightOuterJoin -> 
+                        ( lvl', lvl' + 1, 0)
+                      FullOuterJoin ->
+                        ( lvl' + 1, lvl' + 1, 1)
+                in
+                let ( mapping, correction) = createAssoc ts next in
+                ( ( table, lvl + correction):mapping, prev + correction)
+              createAssoc (Table table) lvl = 
+                ( [( table, lvl)], 0)
+          in
+          let ( mapping, _) = createAssoc (commandTables normalized) (0 :: Int) in
+          -- error $ show mapping
+          maybe 
+            (error $ "Could not find table `" ++ tableS ++ "`") 
+            (> 0) 
+            $ List.lookup tableS mapping
+    in
+    let protected = (commandSelect normalized) == PSelect in
+    let terms = reqTermsCommand isTableOptional normalized in 
+    -- TODO: Add some check that all the table and field names used match up with existing things?? XXX
+    {-
+    ...
+    normalize terms
+    make map from tables -> isMaybe??
+    get all terms
+    get all dependency terms (or a map of terms -> [dependencies]??)
+    union terms and dependency terms
+    generate sql query
+    generate map over results
+        taintlabel or tolabeled result
+        return terms
+
+    ...
+    need to check if fields/tables are maybes???
+    -}
+    do
+    -- error $ show ast
+    res <- newName "res"
+    let query = 
+          let tables = commandTables normalized in
+          let returns = AppE (VarE 'return) $ TupE $ List.map (\rterm -> case rterm of
+                    ReqField table field _ _ ->
+                        mkExprTF (isTableOptional table) table field -- TODO: Does the option matter here??? XXX
+                        -- mkExprTF False table field -- TODO: Does the option matter here??? XXX
+                    ReqEntity ent _ _ -> 
+                        VarE $ varNameTable ent
+                ) terms 
+          in
+          BindS (VarP res) $ AppE (VarE 'Esq.select) $ AppE (VarE 'Esq.from) $ 
+            LamE [mkQueryPatternTables tables] $ DoE 
+                ((mkOnTables isTableOptional tables) 
+                ++ (mkWhere isTableOptional $ commandWhere normalized) 
+                ++ (mkOrderBy isTableOptional $ commandOrderBy normalized)
+                ++ (mkLimit $ commandLimit normalized)
+                ++ (mkOffset $ commandOffset normalized)
+                ++ [NoBindS returns])
+    let taint = 
+          let fun = 
+                let pat = TupP $ List.map ( \rterm -> 
+                        let constr = case rterm of
+                              ReqField table field _ _ ->
+                                ConP 'Value [VarP $ varNameTableField table field]
+                              ReqEntity table optional _ ->
+                                if optional then
+                                    VarP $ varNameTableField table "maybe"
+                                else
+                                    mkEntityPattern table
+                        in
+                        constr
+                      ) terms 
+                in
+                let body = 
+                      let getExpr table field = 
+                            let res = List.foldl' ( \acc rterm -> maybe ( case rterm of 
+                                    ReqField table' field' _ _
+                                      | table == table' && field == field' ->
+                                        Just $ VarE $ varNameTableField table field
+                                    ReqEntity table' optional _
+                                      | table == table' ->
+                                        -- TODO: implement this FIXME XXX
+                                        let expr = 
+                                              if field == "id" then
+                                                VarE $ varNameTableField table field
+                                              else
+                                                let getter = mkName $ (headToLower table) ++ (headToUpper field) in
+                                                AppE (VarE getter) $ VarE $ varNameTable table
+                                        in
+                                        Just $ if optional then
+                                            -- Here we assert that the field is not Nothing, since we know that is optional. Warning: If this assertion is wrong, things could fail at runtime. 
+                                            let body = AppE (VarE 'fromJust) (VarE $ varNameTableField table' "maybe") in
+                                            LetE [ValD (mkEntityPattern table') (NormalB body) []] expr
+                                        else
+                                            expr
+                                    _ ->
+                                        acc
+                                    
+                                  ) Just acc ) Nothing terms 
+                            in
+                            maybe (error $ "Could not find expression for table `"++table++"` and field `"++field++"`") id res
+                      in
+                      let taints = List.foldr (\rterm acc -> case rterm of
+                                ReqField _ _ False _ -> 
+                                    acc
+                                ReqField _ _ _ Nothing -> 
+                                    acc
+                                ReqField table field _returning (Just deps) -> 
+                                    let labeler = VarE $ mkName $ "readLabel" ++ (headToUpper table) ++ (headToUpper field) ++ "'" in
+                                    let label = List.foldl' (\acc (table',field') -> 
+                                            AppE acc $ getExpr table' field'
+                                          ) labeler deps
+                                    in
+                                    let stmt = if protected then
+                                            let vName = varNameTableFieldP table field in
+                                            let lName = mkName "_protected_label" in
+                                            let lDec = ValD (VarP lName) (NormalB label) [] in
+                                            BindS (VarP vName) $ LetE [lDec] $ AppE (AppE (VarE 'toLabeledTCB) (VarE lName)) $ DoE [
+                                                    NoBindS $ AppE (VarE 'taintLabel) (VarE lName),
+                                                    NoBindS $ AppE (VarE 'return) (VarE $ varNameTableField table field)
+                                                ]
+                                          else
+                                            NoBindS $ AppE (VarE 'taintLabel) label
+                                    in
+                                    stmt:acc
+                                ReqEntity _table _ False ->
+                                    acc
+                                ReqEntity table optional True ->
+                                    let optionCase base handler = AppE (AppE (AppE (VarE 'maybe) (AppE (VarE 'return) base)) handler) (VarE $ varNameTableField table "maybe") in
+                                    let nonoptionCase handler = AppE handler $ VarE $ varNameTableE table in
+                                    let stmt = if protected then
+                                            let vName = varNameTableP table in
+                                            BindS (VarP vName) $ if optional then
+                                                let tName = mkName "_tmp" in
+                                                optionCase (ConE 'Nothing) $ LamE [VarP tName] $ parenInfixE (AppE (VarE 'toProtected) (VarE tName)) (VarE '(>>=)) $ parenInfixE (VarE 'return) (VarE '(.)) (ConE 'Just)
+                                              else
+                                                nonoptionCase $ VarE 'toProtected
+                                          else
+                                            NoBindS $ if optional then
+                                                optionCase (ConE '()) $ VarE 'raiseLabelRead
+                                              else
+                                                nonoptionCase $ VarE 'raiseLabelRead
+                                    in
+                                    stmt:acc
+                            ) [] terms 
+                      in
+                      let returns = NoBindS $ AppE (VarE 'return) $ TupE $ List.foldr (\rterm acc -> case rterm of
+                                ReqField table field ret _ -> 
+                                    if ret then
+                                        let vName = (if protected then varNameTableFieldP else varNameTableField) table field in
+                                        (VarE vName):acc
+                                    else
+                                        acc
+                                ReqEntity table optional _ -> 
+                                    let name = if protected then
+                                            varNameTableP table
+                                          else
+                                            if optional then
+                                              varNameTableField table "maybe"
+                                            else
+                                              varNameTableE table
+                                    in
+                                    (VarE name):acc
+                            ) [] terms
+                      in
+                      DoE $ taints ++ [returns]
+                in
+                LamE [pat] body
+          in
+          NoBindS $ AppE (VarE 'lift)$ AppE (AppE (VarE 'mapM) fun) (VarE res)
+
+    -- error $ pprint $ DoE [ query, taint]
+    return $ DoE [ query, taint]
+
+    where
+        mkEntityPattern table = 
+            AsP (varNameTableE table) $ ConP 'Entity [ VarP $ varNameTableField table "id", VarP $ varNameTable table]
+
+        mkQueryPatternTables (Table table) = VarP $ varNameTable table
+        mkQueryPatternTables (Tables ts j table _) = 
+            let constr = case j of
+                  InnerJoin -> 'Esq.InnerJoin
+                  LeftOuterJoin -> 'Esq.LeftOuterJoin
+                  RightOuterJoin -> 'Esq.RightOuterJoin
+                  FullOuterJoin -> 'Esq.FullOuterJoin
+                  -- CrossJoin -> 'CrossJoin
+            in
+            ConP constr [ mkQueryPatternTables ts, VarP $ varNameTable table]
+
+        mkWhere _ Nothing = []
+        mkWhere isTableOptional (Just (Where expr)) = [NoBindS $ AppE (VarE 'Esq.where_) $ mkExprBExpr isTableOptional expr]
+
+        -- hasLabelsHelper tableS f = List.foldl' (\acc ent -> 
+        --     if acc || (lEntityHaskell ent) /= tableS then
+        --         acc 
+        --     else 
+        --         List.foldl' (\acc field ->
+        --             if acc || f field then
+        --                 acc
+        --             else
+        --                 maybe False (\_ -> True) $ lFieldLabelAnnotations field
+        --           ) False $ lEntityFields ent
+        --   ) False lEntityDefs
+        -- hasLabelsTable tableS = hasLabelsHelper tableS (\_ -> False)
+        -- hasLabelsTableField tableS fieldS = hasLabelsHelper tableS $ \f -> (lFieldHaskell f) /= fieldS
+
+        mkOrderBy _ Nothing = []
+        mkOrderBy isTableOptional (Just (OrderBy ords')) = 
+            let helper ord = 
+                  let ( op,( table, field)) = case ord of
+                        OrderAsc t -> ( 'Esq.asc, extractTableField t)
+                        OrderDesc t -> ( 'Esq.desc, extractTableField t)
+                  in
+                  AppE (VarE op) $ mkExprTF (isTableOptional table) table field
+                  -- AppE (VarE op) $ mkExprTF False table field
+            in
+            let ords = List.map helper ords' in
+            [NoBindS $ AppE (VarE 'Esq.orderBy) $ ListE ords]
+
+        mkLimit Nothing = []
+        mkLimit (Just (Limit limit)) = [NoBindS $ AppE (VarE 'Esq.limit) $ LitE $ IntegerL limit]
+        
+        mkOffset Nothing = []
+        mkOffset (Just (Offset offset)) = [NoBindS $ AppE (VarE 'Esq.offset) $ LitE $ IntegerL offset]
+
+        mkOnTables _ (Table _table) = []
+        mkOnTables isTableOptional (Tables ts _ _ bexpr@(BExprBinOp (BTerm _term1) BinEq (BTerm _term2))) = 
+            (NoBindS $ AppE (VarE 'Esq.on) $ mkExprBExpr isTableOptional bexpr):(mkOnTables isTableOptional ts)
+        mkOnTables _ (Tables _ _ table _) = error $ "mkOnTables: Invalid on expression for table `" ++ table ++ "`"
+
+        mkExprBExpr isTableOptional (BExprBinOp (BTerm term1) op' (BTerm term2)) = 
+            let (table1,field1) = extractTableField term1 in
+            let (table2,field2) = extractTableField term2 in
+            let tableOptional1 = isTableOptional table1 in -- TODO: This is probably incorrect?? Need to consider the relationship between the two tables? XXX
+            let tableOptional2 = isTableOptional table2 in
+            let expr1' = mkExprTF tableOptional1 table1 field1 in
+            let expr2' = mkExprTF tableOptional2 table2 field2 in
+            let fieldOptional1 = isTableFieldOptional table1 field1 in
+            let fieldOptional2 = isTableFieldOptional table2 field2 in
+            let optional1 = tableOptional1 || fieldOptional1 in
+            let optional2 = tableOptional2 || fieldOptional2 in
+            let ( expr1, expr2) = case ( optional1, optional2) of
+                  ( True, False) ->
+                    ( expr1', AppE (VarE 'Esq.just) expr2')
+                  ( False, True) ->
+                    ( AppE (VarE 'Esq.just) expr1', expr2')
+                  _ ->
+                    ( expr1', expr2')
+            in
+            let op = mkExprBOp op' in
+            --error $ (show tableOptional1) ++":"++ (show tableOptional2) ++":"++ (show optional1) ++":"++ (show optional2)
+            parenInfixE expr1 op expr2
+        mkExprBExpr isTableOptional (BExprBinOp b1 op b2) = parenInfixE
+            (mkExprB isTableOptional b1) (mkExprBOp op) (mkExprB isTableOptional b2)
+        mkExprBExpr isTableOptional (BExprAnd e1 e2) = parenInfixE 
+            (mkExprBExpr isTableOptional e1) (VarE '(Esq.&&.)) (mkExprBExpr isTableOptional e2)
+        mkExprBExpr isTableOptional (BExprOr e1 e2) = parenInfixE 
+            (mkExprBExpr isTableOptional e1) (VarE '(Esq.||.)) (mkExprBExpr isTableOptional e2)
+        mkExprBExpr isTableOptional (BExprNull t) = AppE (VarE 'Esq.isNothing) $ mkExprTerm isTableOptional t
+        mkExprBExpr isTableOptional (BExprNotNull t) = AppE (VarE 'Esq.not_) $ AppE (VarE 'Esq.isNothing) $ mkExprTerm isTableOptional t
+        mkExprBExpr isTableOptional (BExprNot expr) = AppE (VarE 'Esq.not_) $ mkExprBExpr isTableOptional expr
+
+        mkExprBOp BinEq = VarE '(Esq.==.)
+        mkExprBOp BinNEq = VarE '(Esq.!=.)
+        mkExprBOp BinGE = VarE '(Esq.>=.)
+        mkExprBOp BinG = VarE '(Esq.>.)
+        mkExprBOp BinLE = VarE '(Esq.<=.)
+        mkExprBOp BinL = VarE '(Esq.<.)
+
+        mkExprB isTableOptional (BTerm t) = mkExprTerm isTableOptional t
+        mkExprB _ (BAnti s) = case Meta.parseExp s of
+            Left e -> error e
+            Right e -> AppE (VarE 'Esq.val) $ e
+        mkExprB _ (BConst c) = mkExprConst c 
+
+        mkExprConst (CBool True) = AppE (VarE 'Esq.val) $ ConE 'True
+        mkExprConst (CBool False) = AppE (VarE 'Esq.val) $ ConE 'False
+        mkExprConst (CString s) = AppE (VarE 'Esq.val) $ LitE $ StringL s
+        mkExprConst (CInt i) = AppE (VarE 'Esq.val) $ LitE $ IntegerL i
+        mkExprConst (CDouble d) = AppE (VarE 'Esq.val) $ LitE $ DoublePrimL $ toRational d
+
+        mkExprTF tableOptional table field = 
+            let op = VarE $ if tableOptional then '(Esq.?.) else '(Esq.^.) in
+            let fieldName = constrNameTableField table field in
+            let var = varNameTable table in
+            parenInfixE (VarE var) op (ConE fieldName)
+
+        mkExprTerm isTableOptional term = 
+            let (tableS, fieldS) = extractTableField term in
+            mkExprTF (isTableOptional tableS) tableS fieldS
+
+        getLTable tableS = 
+            let findEntity [] = error $ "Could not find table `" ++ tableS ++ "`"
+                findEntity (h:t) = 
+                    if toLowerString (lEntityHaskell h) == toLowerString tableS then
+                        h
+                    else
+                        findEntity t
+            in
+            findEntity lEntityDefs
+
+        getLTableField tableS fieldS = 
+            if fieldS == "id" then
+                let typ = FTTypeCon Nothing (Text.pack $ tableS ++ "Id") in
+                LFieldDef fieldS typ True Nothing
+            else
+                let ent = getLTable tableS in
+                let findField [] = error $ "Could not find field `" ++ fieldS ++ "` for table `" ++ tableS ++ "`"
+                    findField (h:t) = 
+                        if toLowerString (lFieldHaskell h) == toLowerString fieldS then
+                            h
+                        else
+                            findField t
+                in
+                findField $ lEntityFields ent
+
+        isTableFieldOptional tableS fieldS =
+            case lFieldType $ getLTableField tableS fieldS of
+                FTApp (FTTypeCon _ "Maybe") _ ->
+                    True
+                _ ->
+                    False
+
+
+        extractTableField (TermTF t (Field f)) = ( t, f)
+        extractTableField (TermTF t FieldAll) = error $ "extractTableField: All fields requested for table `" ++ t ++ "`"
+        extractTableField (TermF f) = error $ "extractTableField: Invalid terminal field `TermF " ++ (show f) ++ "`"
+
+        toLowerString = List.map Char.toLower
+        varNameTable table = mkName $ '_':(toLowerString table)
+        varNameTableE table = mkName $ '_':'e':'_':(toLowerString table)
+        varNameTableP table = mkName $ '_':'p':'_':(toLowerString table)
+        varNameTableField table field = mkName $ '_':((toLowerString table) ++ ('_':(toLowerString field)))
+        varNameTableFieldP table field = mkName $ '_':'p':'_':((toLowerString table) ++ ('_':(toLowerString field)))
+        constrNameTableField table field = mkName $ (headToUpper table) ++ (headToUpper field)
+
+        reqTermsCommand isTableOptional (Command _ terms tables whereM orderByM _limitM _offsetM) = 
+            -- Get all requested terms
+            --    transform to ReqTerm
+            -- get the dependencies of all the other terms
+            --    union (and transform) into rest of dependency terms, requested false
+            let terms' = case terms of 
+                  Terms terms -> terms
+                  TermsAll -> error "reqTermsCommand: normalization failed"
+            in
+            let reqTerms = List.map (reqTermsTerm isTableOptional True) terms' in
+            let reqTerms' = reqTermsTables isTableOptional reqTerms tables in
+            let reqTerms'' = maybe reqTerms' (reqTermsWhere isTableOptional reqTerms') whereM in
+            maybe reqTerms'' (reqTermsOrderBy isTableOptional reqTerms'') orderByM
+            --let reqTerms''' = maybe reqTerms'' (reqTermsOrderBy reqTerms'') orderByM in
+            --let reqTerms'''' = maybe reqTerms''' (reqTermsLimit reqTerms''') limitM in
+            --maybe reqTerms'''' (reqTermsOffset reqTerms'''') offsetM
+
+        reqTermsOrderBy isTableOptional curTerms (OrderBy ords) = List.foldl' (\acc ord -> case ord of
+                OrderAsc t ->
+                    reqTermsTermMaybe isTableOptional acc t
+                OrderDesc t ->
+                    reqTermsTermMaybe isTableOptional acc t
+            ) curTerms ords
+
+        reqTermsWhere isTableOptional curTerms (Where bexpr) = reqTermsBExpr isTableOptional curTerms bexpr
+
+        reqTermsTables :: (String -> Bool) -> [ReqTerm] -> Tables -> [ReqTerm]
+        reqTermsTables isTableOptional curTerms (Tables ts _ _ bexpr) = 
+            reqTermsTables isTableOptional (reqTermsBExpr isTableOptional curTerms bexpr) ts
+        reqTermsTables _ curTerms (Table _) = curTerms
+
+        reqTermsBExpr :: (String -> Bool) -> [ReqTerm] -> BExpr -> [ReqTerm]
+        reqTermsBExpr isTableOptional curTerms (BExprAnd e1 e2) = reqTermsBExpr isTableOptional (reqTermsBExpr isTableOptional curTerms e1) e2
+        reqTermsBExpr isTableOptional curTerms (BExprOr e1 e2) = reqTermsBExpr isTableOptional (reqTermsBExpr isTableOptional curTerms e1) e2
+        reqTermsBExpr isTableOptional curTerms (BExprBinOp b1 _ b2) = reqTermsB isTableOptional (reqTermsB isTableOptional curTerms b1) b2
+        reqTermsBExpr isTableOptional curTerms (BExprNull t) = reqTermsTermMaybe isTableOptional curTerms t
+        reqTermsBExpr isTableOptional curTerms (BExprNotNull t) = reqTermsTermMaybe isTableOptional curTerms t
+        reqTermsBExpr isTableOptional curTerms (BExprNot e) = reqTermsBExpr isTableOptional curTerms e
+
+        reqTermsB :: (String -> Bool) -> [ReqTerm] -> B -> [ReqTerm]
+        reqTermsB isTableOptional curTerms (BTerm t) = reqTermsTermMaybe isTableOptional curTerms t
+        reqTermsB _ curTerms _ = curTerms
+
+        -- Union in new term. Term should never be an entity.
+        reqTermsTermMaybe :: (String -> Bool) -> [ReqTerm] -> Term -> [ReqTerm]
+        reqTermsTermMaybe isTableOptional curTerms term = 
+            let ( tableS, fieldS) = extractTableField term in
+            let reqTerm = reqTermsTerm isTableOptional False term in
+            let cons = List.foldl' (\acc term -> case term of
+                    ReqEntity tableS' _ _ ->
+                        if tableS == tableS' then
+                            False
+                        else
+                            acc
+                    ReqField tableS' fieldS' _returning _ ->
+                        if tableS == tableS' && fieldS == fieldS' then
+                            False
+                        else
+                            acc
+                  ) True curTerms
+            in
+            if cons then
+                reqTerm:curTerms
+            else
+                curTerms
+
+        reqTermsTerm isTableOptional returning (TermTF tableS field) = case field of
+            Field fieldS ->
+                let fieldDef = getLTableField tableS fieldS in
+                let dep = maybe Nothing (\( anns, _, _) -> Just $ List.foldl' (\acc ann -> case ann of
+                        LAId ->
+                            ( tableS, "id"):acc
+                        LAConst _s ->
+                            acc
+                        LAField f -> 
+                            ( tableS, f):acc
+                      ) [] anns ) $ lFieldLabelAnnotations fieldDef in
+                ReqField tableS fieldS returning dep
+            FieldAll ->
+                let hasDeps = 
+                      let ent = getLTable tableS in
+                      List.foldl' (\acc f -> acc || isJust (lFieldLabelAnnotations f)) False $ lEntityFields ent
+                in
+                let optional = isTableOptional tableS in
+                -- if (lEntityHaskell $ getLTable tableS) == "User" then
+                --     error $ show $ getLTable tableS
+                -- else
+                ReqEntity tableS optional hasDeps
+        reqTermsTerm _ _ (TermF _) = error "reqTermsTerm: normalization failed"
+
+        -- selectE = VarE $ mkName "select"
+        -- fromE = VarE $ mkName "from"
+        -- where_E = VarE $ mkName "where_"
+        -- onE = VarE $ mkName "on"
+        -- justE = VarE $ mkName "just"
+        -- carotE = VarE $ mkName "^."
+        -- questionE = VarE $ mkName "?."
+        -- eqE = VarE $ mkName "==."
+        -- geE = VarE $ mkName ">=."
+        -- gE = VarE $ mkName ">."
+        -- leE = VarE $ mkName "<=."
+        -- lE = VarE $ mkName "<."
+        -- innerJoin = VarE $ mkName "InnerJoin"
+        -- leftOuterJoin = VarE $ mkName "LeftOuterJoin"
+        -- rightOuterJoin = VarE $ mkName "RightOuterJoin"
+        -- fullOuterJoin = VarE $ mkName "FullOuterJoin"
+        -- crossJoin = VarE $ mkName "CrossJoin"
+
+data ReqTerm = 
+    ReqField {
+        _reqFieldTable :: String
+      , _reqFieldField :: String
+--      , _reqFieldIsOptional :: Bool
+      , _reqFieldReturning :: Bool
+      , _reqFieldDependencies :: Maybe [(String,String)] -- Contains ( table, field) dependencies.
+--      , _reqFieldIsDependency :: Bool
+    }
+  | ReqEntity {
+        _reqEntityTable :: String -- Implied returning is true
+      , _reqEntityIsOptional :: Bool
+      , _reqEntityHasLabels :: Bool
+    }
+
+    deriving (Show)
+
+-- | Normalize an AST by adding table name for all terms. Also expands out all the tables requested when TermsAll is applied. 
+normalizeTerms :: Command -> Command
+normalizeTerms (Command select terms tables whereM orderByM limitM offsetM) = 
+    -- Get the default table if there are no joins. 
+    let defTable = case tables of 
+          Table table ->
+            Just table
+          _ ->
+            Nothing
+    in
+    let terms' = case terms of
+          TermsAll ->
+            -- Expand all the tables out. 
+            let expander acc tables = case tables of
+                  Table table ->
+                    (TermTF table FieldAll):acc
+                  Tables tables _ table _ ->
+                    expander ((TermTF table FieldAll):acc) tables
+            in
+            Terms $ expander [] tables
+          Terms terms' -> 
+            -- Add table name to each term. 
+            Terms $ List.map (updateTerm defTable) terms'
+    in
+    -- This checks that terms should already have tables included. 
+    let tables' = updateTables defTable tables in
+    let whereM' = case whereM of 
+          Just (Where bexpr) -> 
+            Just $ Where $ updateBExpr defTable bexpr
+          Nothing -> 
+            Nothing
+    in
+    let orderByM' = case orderByM of
+          Just (OrderBy orders) -> 
+            let helper ord = case ord of
+                  OrderAsc t ->
+                    OrderAsc $ updateTerm defTable t
+                  OrderDesc t ->
+                    OrderDesc $ updateTerm defTable t
+            in
+            Just $ OrderBy $ List.map helper orders
+          Nothing -> 
+            Nothing
+    in
+    Command select terms' tables' whereM' orderByM' limitM offsetM
+
+    where
+        updateTerm defTable term = case term of
+            TermF field ->
+                maybe 
+                    (error $ "Could not infer table associated with field `" ++ (show field) ++ "`")
+                    (\table -> TermTF table field)
+                    defTable
+            _ ->
+                term
+        
+        updateTables defTable (Tables ts j table bexpr) =
+            Tables (updateTables defTable ts) j table $ updateBExpr defTable bexpr
+        updateTables _ t = t
+
+        updateBExpr defTable bexpr = case bexpr of
+            BExprAnd expr1 expr2 ->
+                BExprAnd (updateBExpr defTable expr1) (updateBExpr defTable expr2)
+            BExprOr expr1 expr2 ->
+                BExprOr (updateBExpr defTable expr1) (updateBExpr defTable expr2)
+            BExprBinOp b1 op b2 ->
+                BExprBinOp (updateB defTable b1) op (updateB defTable b2)
+            BExprNull t ->
+                BExprNull $ updateTerm defTable t
+            BExprNotNull t ->
+                BExprNotNull $ updateTerm defTable t
+            BExprNot expr ->
+                BExprNot $ updateBExpr defTable expr
+
+        updateB defTable (BTerm t) = BTerm $ updateTerm defTable t
+        updateB _ b = b
+
+parenInfixE :: Exp -> Exp -> Exp -> Exp
+parenInfixE e1 e2 e3 = ParensE $ UInfixE e1 e2 e3
+
+-- Debugging functions.
+
+lsqlHelper' :: [LEntityDef] -> QuasiQuoter
+lsqlHelper' ents = QuasiQuoter {
+        quoteExp = (generateSql' ents) . Text.pack
+    }
+    where 
+        generateSql' e s = do
+            res <- generateSql e s
+            error $ pprint res
diff --git a/src/Database/LEsqueleto/LSql.hs b/src/Database/LEsqueleto/LSql.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/LEsqueleto/LSql.hs
@@ -0,0 +1,315 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.LEsqueleto.LSql where
+
+import Control.Applicative
+import Data.Attoparsec.Text
+import qualified Data.Char as Char
+import qualified Data.Text as Text
+
+-- | Represent the AST for lsql statements. 
+data Command = Command {
+        commandSelect :: Select
+      , commandTerms :: Terms
+      , commandTables :: Tables
+      , commandWhere :: Maybe Where
+      , commandOrderBy :: Maybe OrderBy
+      , commandLimit :: Maybe Limit
+      , commandOffset :: Maybe Offset
+    }
+    deriving (Show)
+data Select = Select | PSelect
+    deriving (Eq, Show)
+
+--data Terms = Term Term | Terms Terms Term | TermsAll
+data Terms = Terms [Term] | TermsAll
+    deriving (Show)
+
+data Tables = Table String | Tables Tables Join String BExpr
+    deriving (Show)
+data Join = InnerJoin | LeftOuterJoin | RightOuterJoin | FullOuterJoin -- | CrossJoin
+    deriving (Show)
+
+data Where = Where BExpr
+    deriving (Show)
+
+data OrderBy = OrderBy [Order]
+    deriving (Show)
+
+data Order = OrderAsc Term | OrderDesc Term
+    deriving (Show)
+
+data Limit = Limit Integer
+    deriving (Show)
+
+data Offset = Offset Integer
+    deriving (Show)
+
+data Term = TermTF String TermField | TermF TermField
+    deriving (Show)
+data TermField = Field String | FieldAll
+
+data BExpr = BExprAnd BExpr BExpr | BExprOr BExpr BExpr | BExprBinOp B BinOp B | BExprNull Term | BExprNotNull Term | BExprNot BExpr
+    deriving (Show)
+
+data BinOp = BinEq | BinNEq | BinGE | BinG | BinLE | BinL
+    deriving (Show)
+
+data B = BTerm Term | BAnti String | BConst C
+    deriving (Show)
+data C = CBool Bool | CString String | CInt Integer | CDouble Double
+    deriving (Show)
+
+instance Show TermField where
+    show (Field s) = s
+    show (FieldAll) = "*"
+
+parseCommand :: Parser Command
+parseCommand = do
+    select <- parseSelect
+    terms <- parseTerms
+    _ <- parseFrom
+    tables <- parseTables
+    whereM <- parseWhere
+    orderByM <- parseOrderBy
+    limitM <- parseLimit
+    offsetM <- parseOffset
+    parseComma
+    return $ Command select terms tables whereM orderByM limitM offsetM
+
+    where
+        takeNonSpace = takeWhile1 (not . Char.isSpace)
+
+        takeAlphaNum = takeWhile1 Char.isAlphaNum
+        takeUpperAlphaNum = do
+            an <- takeAlphaNum
+            return $ Text.map Char.toUpper an
+
+        parseComma = do
+            skipSpace
+            -- Check for optional comma.
+            commaM <- peekChar
+            case commaM of
+                Nothing ->
+                    return ()
+                Just c ->
+                    if c == ';' then
+                        return ()
+                    else do
+                        rest <- takeText
+                        error $ "Error parsing from: `" ++ (Text.unpack rest) ++ "`"
+            -- maybe (return ()) 
+            -- try (char ';' >> skipSpace)
+            -- end <- atEnd
+            -- unless end $ do
+            --     rest <- takeText
+            --     error $ "Error parsing from: `"++ (Text.unpack rest) ++"`"
+
+        parseSelect = do
+            skipSpace
+            select <- takeUpperAlphaNum
+            case select of
+                "SELECT" ->
+                    return Select
+                "PSELECT" ->
+                    return PSelect
+                _ ->
+                    fail $ "Unknown keywork `" ++ (Text.unpack select) ++ "`. Use `SELECT` or `PSELECT`."
+
+        parseTerms = 
+            let parseTerms' = do
+                  head <- parseTerm
+                  tail <- (do
+                        skipSpace
+                        _ <- char ','
+                        parseTerms'
+                    ) <|> (return [])
+                  return $ head:tail
+            in
+            (skipSpace >> char '*' >> (return TermsAll)) <|> (parseTerms' >>= return . Terms)
+            
+        parseFrom = do
+            skipSpace
+            asciiCI "FROM"
+
+        parseTerm = do
+            skipSpace
+            ( do
+                table <- takeAlphaNum
+                _ <- char '.'
+                field <- parseField
+                return $ TermTF (Text.unpack table) field
+              ) <|> (parseField >>= (return . TermF))
+
+        -- Does not skip spaces!!
+        parseField = (char '*' >> (return FieldAll)) <|> 
+            ( takeAlphaNum >>= (return . Field. Text.unpack))
+
+        parseTables = 
+            let parseTables' acc = ( do
+                    skipSpace
+                    join <- ( asciiCI "INNER JOIN" >> (return InnerJoin)) <|> 
+                      ( asciiCI "OUTER JOIN" >> (return LeftOuterJoin)) <|>
+                      ( asciiCI "LEFT OUTER JOIN" >> (return LeftOuterJoin)) <|>
+                      ( asciiCI "RIGHT OUTER JOIN" >> (return RightOuterJoin)) <|>
+                      ( asciiCI "FULL OUTER JOIN" >> (return FullOuterJoin)) -- <|>
+                      --( asciiCI "CROSS JOIN" >> (return CrossJoin))
+                    skipSpace
+                    table <- takeAlphaNum
+                    skipSpace
+                    _ <- asciiCI "ON"
+                    bexpr <- parseBExpr
+                    parseTables' $ Tables acc join (Text.unpack table) bexpr
+                  ) <|> (return acc)
+            in
+            do
+            skipSpace
+            table <- takeAlphaNum
+            parseTables' $ Table $ Text.unpack table
+
+        parseWhere = ( do
+            skipSpace
+            _ <- asciiCI "WHERE"
+            bexp <- parseBExpr
+            return $ Just $ Where bexp
+          ) <|> (return Nothing)
+        
+        parseOrderBy = ( do
+            skipSpace
+            _ <- asciiCI "ORDER BY"
+            orders <- parseOrders
+            return $ Just $ OrderBy orders
+          ) <|> (return Nothing)
+            
+            where
+                parseOrders = do
+                    term <- parseTerm
+                    order <- ( skipSpace >> asciiCI "ASC" >> (return OrderAsc)) <|> 
+                        ( skipSpace >> asciiCI "DESC" >> (return OrderDesc)) <|> 
+                        ( return OrderAsc)
+                    tail <- ( do
+                        skipSpace
+                        _ <- asciiCI ","
+                        parseOrders
+                      ) <|> (return [])
+                    return $ (order term):tail
+
+        parseLimit = ( do
+            skipSpace
+            _ <- asciiCI "LIMIT"
+            skipSpace
+            limit <- decimal
+            return $ Just $ Limit limit
+          ) <|> (return Nothing)
+        
+        parseOffset = ( do
+            skipSpace
+            _ <- asciiCI "OFFSET"
+            skipSpace
+            limit <- decimal
+            return $ Just $ Offset limit
+          ) <|> (return Nothing)
+
+        parseBExpr = do
+            expr1 <- ( do
+                skipSpace
+                _ <- char '('
+                res <- parseBExpr
+                skipSpace
+                _ <- char ')'
+                return res
+              ) <|> ( do
+                skipSpace
+                _ <- asciiCI "NOT"
+                res <- parseBExpr
+                return $ BExprNot res
+              ) <|> ( do
+                term <- parseTerm
+                skipSpace
+                _ <- asciiCI "IS NULL"
+                return $ BExprNull term
+              ) <|> ( do
+                term <- parseTerm
+                skipSpace
+                _ <- asciiCI "IS NOT NULL"
+                return $ BExprNotNull term
+              ) <|> ( do
+                b1 <- parseB
+                op <- parseBOp
+                b2 <- parseB
+                return $ BExprBinOp b1 op b2
+              )
+            ( do
+                skipSpace
+                -- temp <- takeAlphaNum
+                -- when (temp /= "where" && temp /= "and") $ 
+                --     error $ "here: " ++ (show expr1) ++ " **** " ++ (Text.unpack temp)
+                constr <- (asciiCI "AND" >> (return BExprAnd)) <|>
+                    (asciiCI "OR" >> peekChar >>= (maybe (return BExprOr) $ \c -> 
+                        if Char.isSpace c then
+                            return BExprOr
+                        else
+                            fail "OR: Some other keyword"
+                      ))
+                expr2 <- parseBExpr
+                return $ constr expr1 expr2
+              ) <|> (return expr1)
+
+          where
+            parseSQLString = takeWhile1 (/= '\'')
+
+            parseConst = skipSpace >> 
+                ( asciiCI "TRUE" >> return (CBool True)) <|>
+                ( asciiCI "FALSE" >> return (CBool False)) <|>
+                ( do
+                    _ <- char '\'' 
+                    skipSpace
+                    str <- parseSQLString
+                    skipSpace
+                    _ <- char '\'' 
+                    return $ CString $ Text.unpack str
+                ) <|> ( do
+                    int <- signed decimal
+                    next <- peekChar
+                    case next of 
+                        Just '.' ->
+                            fail "this is a double"
+                        _ ->
+                            return $ CInt int
+                ) <|>
+                ( double >>= (return . CDouble))
+
+            parseB = ( do
+                skipSpace
+                _ <- asciiCI "#{"
+                skipSpace
+                var <- takeWhile1 (/= '}')--takeNonSpace -- TODO: maybe make this into a [String] and stop at '}'
+                skipSpace
+                _ <- char '}'
+                return $ BAnti $ Text.unpack var
+              ) <|> ( do
+                term <- parseTerm
+                return $ BTerm term
+              ) <|> ( do
+                c <- parseConst
+                return $ BConst c
+              )
+
+            parseBOp = do
+                skipSpace
+                op <- takeNonSpace
+                return $ case op of
+                    "==" -> BinEq
+                    "!=" -> BinNEq
+                    ">=" -> BinGE
+                    ">" -> BinG
+                    "<=" -> BinLE
+                    "<" -> BinL
+                    t -> 
+                        error $ "Invalid binop `" ++ (Text.unpack t) ++ "`"
+                -- >> ( asciiCI "==" >> return BinEq) <|> 
+                -- ( asciiCI ">=" >> return BinGE) <|>
+                -- ( char '>' >> return BinG) <|>
+                -- ( asciiCI "<=" >> return BinLE) <|>
+                -- ( char '<' >> return BinL) <|>
+                -- ( takeAlphaNum >>= \t -> fail $ "Invalid binop `" ++ (Text.unpack t) ++ "`")
diff --git a/src/Database/LPersist.hs b/src/Database/LPersist.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/LPersist.hs
@@ -0,0 +1,310 @@
+-- Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+--
+-- Permission is hereby granted, free of charge, to any person obtaining
+-- a copy of this software and associated documentation files (the
+-- "Software"), to deal in the Software without restriction, including
+-- without limitation the rights to use, copy, modify, merge, publish,
+-- distribute, sublicense, and/or sell copies of the Software, and to
+-- permit persons to whom the Software is furnished to do so, subject to
+-- the following conditions:
+--
+-- The above copyright notice and this permission notice shall be
+-- included in all copies or substantial portions of the Software.
+--
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+-- LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+-- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+-- WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+--
+-- Modified by James Parker in 2014. 
+
+{-# LANGUAGE TypeFamilies #-}
+
+module Database.LPersist (
+      LEntity(..)
+    , raiseLabelRead
+    , raiseLabelWrite
+    , raiseLabelCreate
+    , YesodLPersist (..)
+    , lDefaultRunDB
+    , ProtectedEntity(..)
+    , PEntity(..)
+    , get
+    , pGet
+    , insert
+    , insert_
+    , insertMany
+    , insertKey
+    , repsert
+    , replace
+    , delete
+    , update
+    , updateGet
+    , pUpdateGet
+    , getJust
+    , getBy
+    , pGetBy
+    , deleteBy
+    , insertUnique
+    , updateWhere
+    , deleteWhere
+    , selectFirst
+    , count
+    , selectList
+    , selectKeysList
+    ) where
+
+import Control.Exception.Lifted (throwIO)
+import Control.Monad
+import Control.Monad.Reader (ReaderT)
+import Database.Persist (Entity(..),PersistStore,PersistEntity,PersistEntityBackend, Key, Update, Unique, PersistUnique, SelectOpt, Filter, PersistQuery)
+import qualified Database.Persist as Persist
+import Database.Persist.Sql (SqlBackend, PersistConfig, PersistConfigPool, PersistConfigBackend)
+import qualified Database.Persist.Sql as Persist
+import qualified Data.Text as Text
+import LMonad
+import Yesod.Core
+import Yesod.Persist (YesodPersist(..))
+
+-- | `LEntity` typeclass to taint labels when reading, writing, and creating entity fields.
+-- Internally used to raise the current label on database calls. 
+-- `mkLabels` automatically generates instances of `LEntity` for your model. 
+class Label l => LEntity l e where
+    getLabelRead :: Entity e -> l
+    getLabelWrite :: Entity e -> l
+    getLabelCreate :: e -> l
+
+raiseLabelRead :: (Label l, LMonad m, LEntity l e) => Entity e -> LMonadT l m ()
+raiseLabelRead e = taintLabel $ getLabelRead e
+
+raiseLabelWrite :: (Label l, LMonad m, LEntity l e) => Entity e -> LMonadT l m ()
+raiseLabelWrite e = taintLabel $ getLabelWrite e
+
+raiseLabelCreate :: (Label l, LMonad m, LEntity l e) => e -> LMonadT l m ()
+raiseLabelCreate e = taintLabel $ getLabelCreate e
+
+-- | Typeclass for protected entities.
+-- `mkLabels` automatically generates these instances.
+class Label l => ProtectedEntity l e p | e -> p where
+    toProtected :: LMonad m => Entity e -> LMonadT l m p
+
+-- | ADT wrapper for protected entities. Analagous to Entity.
+data PEntity l e = forall p . (ProtectedEntity l e p) => PEntity (Key e) p
+
+-- | How to run database functions.
+
+class YesodPersist site => YesodLPersist site where
+    runDB :: (Label l, m ~ HandlerT site IO) => ReaderT (YesodPersistBackend site) (LMonadT l m) a -> LMonadT l m a
+
+lDefaultRunDB :: (Label l, PersistConfig c, LMonad m, m ~ HandlerT site IO) => (site -> c)
+                      -> (site -> PersistConfigPool c)
+                      -> PersistConfigBackend c (LMonadT l m) b
+                      -> LMonadT l m b
+lDefaultRunDB getConfig getPool f = do
+    master <- lLift getYesod
+    Persist.runPool
+        (getConfig master)
+        f
+        (getPool master)
+
+-- | Persist functions to interact with database. 
+
+get :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Key v -> ReaderT backend (LMonadT l m) (Maybe v)
+get key = do
+    res <- Persist.get key
+    whenJust res $ lift . raiseLabelRead . (Entity key)
+    return res
+
+pGet :: (ProtectedEntity l v p, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Key v -> ReaderT backend (LMonadT l m) (Maybe p)
+pGet key = do
+    res <- Persist.get key
+    maybe (return Nothing) handler res
+    where
+        handler val =
+            let ent = Entity key val in
+            do
+            protected <- lift $ toProtected ent
+            return $ Just protected
+
+insert :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => v -> ReaderT backend (LMonadT l m) (Key v)
+insert val = do
+    lift $ raiseLabelCreate val
+    Persist.insert val
+
+insert_ :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => v -> ReaderT backend (LMonadT l m) ()
+insert_ val = do
+    lift $ raiseLabelCreate val
+    Persist.insert_ val
+
+insertMany :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => [v] -> ReaderT backend (LMonadT l m) [Key v]
+insertMany vals = do
+    lift $ mapM_ raiseLabelCreate vals
+    Persist.insertMany vals
+
+insertKey :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> v -> ReaderT backend (LMonadT l m) ()
+insertKey key val = do
+    lift $ raiseLabelCreate val
+    Persist.insertKey key val
+
+repsert :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> v -> ReaderT backend (LMonadT l m) ()
+repsert key val = do
+    lift $ raiseLabelCreate val
+    res <- Persist.get key
+    whenJust res $ lift . raiseLabelWrite . (Entity key)
+    Persist.repsert key val
+
+replace :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> v -> ReaderT backend (LMonadT l m) ()
+replace key val = do
+    lift $ raiseLabelCreate val
+    res <- Persist.get key
+    whenJust res $ lift . raiseLabelWrite . (Entity key)
+    Persist.replace key val
+
+delete :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> ReaderT backend (LMonadT l m) ()
+delete key = do
+    res <- Persist.get key
+    whenJust res $ \val -> do
+        lift $ raiseLabelWrite $ Entity key val
+        Persist.delete key
+
+-- TODO: 
+--  Double check this!!
+-- | This function only works for SqlBackends since we need to be able to rollback transactions.
+update :: (backend ~ SqlBackend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> [Update v] -> ReaderT backend (LMonadT l m) ()
+update = updateHelper (return ()) $ \_ -> return ()
+
+updateGet :: (backend ~ SqlBackend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> [Update v] -> ReaderT backend (LMonadT l m) v
+updateGet key = updateHelper err return key
+    where
+        err = liftIO $ throwIO $ Persist.KeyNotFound $ Prelude.show key
+
+pUpdateGet :: (backend ~ SqlBackend, ProtectedEntity l v p, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> [Update v] -> ReaderT backend (LMonadT l m) p
+pUpdateGet key = updateHelper err (toProtected . (Entity key)) key
+    where
+        err = liftIO $ throwIO $ Persist.KeyNotFound $ Prelude.show key
+
+getJust :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> ReaderT backend (LMonadT l m) v
+getJust key = get key >>= maybe err return
+    where
+        err = liftIO $ throwIO $ Persist.PersistForeignConstraintUnmet $ Text.pack $ Prelude.show key
+
+-- TODO
+--
+-- belongsTo
+-- belongsToJust
+
+getBy :: (PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Unique v -> ReaderT backend (LMonadT l m) (Maybe (Entity v))
+getBy uniq = do
+    res <- Persist.getBy uniq
+    whenJust res $ lift . raiseLabelRead
+    return res
+
+pGetBy :: (ProtectedEntity l v p, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Unique v -> ReaderT backend (LMonadT l m) (Maybe (PEntity l v))
+pGetBy uniq = do
+    res <- Persist.getBy uniq
+    --maybe (return Nothing) (\(Entity key ent) -> lift . return . Just . (PEntity key) =<< toProtected ent) res
+    maybe (return Nothing) (\ent -> do
+        pEnt <- lift $ toProtected ent
+        return $ Just $ PEntity (entityKey ent) pEnt
+      ) res
+
+deleteBy :: (ProtectedEntity l v p, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Unique v -> ReaderT backend (LMonadT l m) ()
+deleteBy uniq = do
+    res <- Persist.getBy uniq
+    whenJust res $ \e -> do
+        lift $ raiseLabelWrite e
+        Persist.deleteBy uniq
+
+insertUnique :: (ProtectedEntity l v p, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => v -> ReaderT backend (LMonadT l m) (Maybe (Key v))
+insertUnique val = do
+    lift $ raiseLabelCreate val
+    Persist.insertUnique val
+
+-- TODO
+--  upsert
+--  getByValue
+--  insertBy
+--  replaceUnique
+--  checkUnique
+--  onlyUnique
+--
+--  selectSourceRes
+--  selectKeysRes
+
+updateWhere :: (backend ~ SqlBackend, PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => [Filter v] -> [Update v] -> ReaderT backend (LMonadT l m) ()
+updateWhere filts upts = do
+    res <- Persist.selectList filts []
+    -- `updateGet` should rollback transaction if any checks fail
+    mapM_ (\e -> 
+        let k = entityKey e in 
+        (lift $ raiseLabelWrite e) >> 
+            (updateGet (entityKey e) upts) >>=
+                (lift . raiseLabelWrite . (Entity k))
+      ) res
+
+deleteWhere :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => [Filter v] -> ReaderT backend (LMonadT l m) ()
+deleteWhere filts = do
+    res <- Persist.selectList filts []
+    lift $ mapM_ raiseLabelWrite res
+    Persist.deleteWhere filts
+
+selectFirst :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => [Filter v] -> [SelectOpt v] -> ReaderT backend (LMonadT l m) (Maybe (Entity v))
+selectFirst filts opts = do
+    res <- Persist.selectFirst filts opts
+    whenJust res $ lift . raiseLabelRead
+    return res
+
+count :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => [Filter v] -> ReaderT backend (LMonadT l m) Int
+count filts = do
+    res <- Persist.selectList filts []
+    lift $ foldM (\acc e -> (raiseLabelWrite e) >> (return $ acc + 1)) 0 res
+
+-- TODO
+--  selectSource
+--  selectKeys
+
+selectList :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => [Filter v] -> [SelectOpt v] -> ReaderT backend (LMonadT l m) [Entity v]
+selectList filts opts = do
+    l <- Persist.selectList filts opts
+    lift $ mapM_ raiseLabelRead l
+    return l
+
+selectKeysList :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => [Filter v] -> [SelectOpt v] -> ReaderT backend (LMonadT l m) [Key v]
+selectKeysList filts opts = do
+    l <- Persist.selectList filts opts
+    lift $ mapM_ raiseLabelRead l
+    return $ map entityKey l
+    
+-- TODO
+--  deleteCascade
+--  deleteCascadeWhere
+
+
+
+-- | Helper functions.
+
+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenJust m f = case m of
+    Just v ->
+        f v
+    Nothing ->
+        return ()
+
+updateHelper :: (backend ~ SqlBackend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (LMonadT l m a) -> (v -> LMonadT l m a) -> (Key v) -> [Update v] -> ReaderT backend (LMonadT l m) a
+updateHelper n j key updates = do
+    res <- Persist.get key
+    maybe (lift n) (\oldVal -> do
+        lift $ raiseLabelWrite $ Entity key oldVal
+        newVal <- Persist.updateGet key updates
+        let newL = getLabelWrite $ Entity key newVal
+        l <- lift $ lubCurrentLabel newL
+        guard <- lift $ canSetLabel l
+        unless guard
+            -- Rollback
+            Persist.transactionUndo
+        lift $ setLabel l
+        lift $ j newVal
+      ) res
diff --git a/src/Database/LPersist/Labeler.hs b/src/Database/LPersist/Labeler.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/LPersist/Labeler.hs
@@ -0,0 +1,362 @@
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+
+module Database.LPersist.Labeler (mkLabels, mkLabels') where
+
+import Control.Monad
+import qualified Data.Char as Char
+import qualified Data.List as List
+import qualified Data.Text as Text
+import Database.Persist.Types
+import Language.Haskell.TH
+import Prelude
+
+import Internal
+
+-- | Functions that use TH to generate labeling code. 
+-- All examples in this documentation reference the following Persist model:
+--
+--   User
+--       ident Text
+--       password Text
+--       email Text <Const Admin || Id, Id, _>
+--       admin Bool
+--   
+--       UniqueEmail email
+--       deriving Typeable
+
+mkLabels :: String -> [EntityDef] -> Q [Dec]
+mkLabels labelS ents = 
+    let entsL = map toLEntityDef ents in
+    let labelFs' = concat $ map (mkLabelEntity' labelType) entsL in
+    do
+    labelFs <- mapM (mkLabelEntity labelType) entsL
+    lEntityInstance <- mapM (mkLEntityInstance labelType) entsL
+    protected <- mapM (mkProtectedEntity labelType) entsL
+    protectedInstance <- mapM (mkProtectedEntityInstance labelType) entsL
+--    let serializedLEntityDef = mkSerializedLEntityDefs entsL
+    return $ concat [concat labelFs, labelFs', lEntityInstance, protected, protectedInstance] -- , serializedLEntityDef]
+
+    where
+        labelType = 
+            case Text.words $ Text.pack labelS of
+                [] ->
+                    error $ "Label `" ++ labelS ++ "` not found"
+                conT:rest ->
+                    if Text.length conT <= 1 || Char.isLower (Text.head conT) then
+                        error $ "Invalid label type constructor `" ++ (Text.unpack conT) ++ "`"
+                    else
+                        let con = ConT $ mkName $ Text.unpack conT in
+                        List.foldl' (\acc typ -> AppT acc (ConT (mkName (Text.unpack typ)))) con rest
+
+
+
+-- | Helper function that prints out the code generated at compilation.
+mkLabels' :: String -> [EntityDef] -> Q [Dec]
+mkLabels' labelS ents = do
+    labels <- mkLabels labelS ents
+    fail $ show $ pprint labels
+
+
+-- | Create protected ADTs for the models in Persist's DSL. 
+-- Ex: ProtectedUser is created for protected version of User.
+--
+-- data ProtectedUser = ProtectedUser {
+--         pUserIdent :: Text
+--       , pUserPassword :: Text
+--       , pUserEmail :: Labeled (DCLabel Principal) Text
+--       , pUserAdmin :: Bool
+--     }
+
+mkProtectedEntity :: Type -> LEntityDef -> Q Dec
+mkProtectedEntity labelType ent =
+    let pFields = map mkProtectedField (lEntityFields ent) in
+    return $ DataD [] pName [] [RecC pName pFields] []
+
+    where
+        eName = lEntityHaskell ent
+        pName = mkName $ "Protected" ++ eName
+        mkProtectedField field = 
+            let fName = mkName $ 'p':(eName ++ (headToUpper (lFieldHaskell field))) in
+            let strict = if lFieldStrict field then IsStrict else NotStrict in
+            let rawType = fieldTypeToType $ lFieldType field in
+            let typ = case lFieldLabelAnnotations field of
+                  Nothing ->
+                    rawType
+                  Just _ ->
+                    AppT (AppT (ConT (mkName "Labeled")) labelType) rawType
+            in
+            (fName, strict, typ)
+
+
+
+-- | Create LEntity instance for a given entity. Joins all field label calls
+-- Ex:
+--
+-- instance LEntity (DCLabel Principal) User where
+--     getLabelRead _e = 
+--         readLabelUserEmail _e
+--     getLabelWrite _e =
+--         writeLabelUserEmail _e
+--     getLabelCreate _e =
+--         createLabelUserEmail _e
+
+mkLEntityInstance :: Type -> LEntityDef -> Q Dec
+mkLEntityInstance labelType ent = 
+    let expr = List.foldl' mkStmts Nothing (lEntityFields ent) in
+    let (rExpr, wExpr, cExpr) = case expr of 
+          Nothing ->
+            ( bottom, bottom, bottom)
+          Just exprs ->
+            exprs
+    in
+    let funcs = [
+            FunD (mkName "getLabelRead") [Clause [VarP e] (NormalB rExpr) []],
+            FunD (mkName "getLabelWrite") [Clause [VarP e] (NormalB wExpr) []],
+            FunD (mkName "getLabelCreate") [Clause [VarP e] (NormalB cExpr) []]
+          ]
+    in
+    return $ InstanceD [] (AppT (AppT (ConT (mkName "LEntity")) labelType) (ConT (mkName eName))) funcs
+
+    where
+        eName = lEntityHaskell ent
+        e = mkName "_e"
+        bottom = VarE $ mkName "bottom"
+        appJoin = AppE . (AppE (VarE (mkName "lub")))
+        mkStmts acc field = case lFieldLabelAnnotations field of
+            Nothing -> 
+                acc
+            _ -> 
+                let baseName = eName ++ (headToUpper (lFieldHaskell field)) in
+                let rExpr = AppE (VarE (mkName ("readLabel"++baseName))) (VarE e) in
+                let wExpr = AppE (VarE (mkName ("writeLabel"++baseName))) (VarE e) in
+                let cExpr = AppE (VarE (mkName ("createLabel"++baseName))) (VarE e) in
+                Just $ case acc of
+                    Nothing ->
+                        ( rExpr, wExpr, cExpr)
+                    Just (rAcc, wAcc, cAcc) ->
+                        ( appJoin rExpr rAcc, appJoin wExpr wAcc, appJoin cExpr cAcc)
+
+
+
+-- | Creates functions that get labels for each field in an entity. 
+-- Ex:
+--
+-- readLabelUserEmail :: Entity User -> DCLabel Principal
+-- readLabelUserEmail (Entity _eId _entity) =
+--     ((toConfidentialityLabel "Admin") `glb` (toConfidentialityLabel _eId))
+--
+-- createLabelUserEmail :: Entity User -> DCLabel Principal
+-- createLabelUserEmail (Entity _eId _entity) = 
+--     toIntegrityLabel _eId
+--
+-- writeLabelUserEmail :: Entity User -> DCLabel Principal
+-- writeLabelUserEmail (Entity _eId _entity) = 
+--     bottom
+
+mkLabelEntity :: Type -> LEntityDef -> Q [Dec]
+mkLabelEntity labelType ent = 
+    let labelFs = map mkLabelField (lEntityFields ent) in
+    return $ concat labelFs
+    
+    where
+        eName = lEntityHaskell ent
+        toConfLabel = VarE $ mkName "toConfidentialityLabel"
+        toIntegLabel = VarE $ mkName "toIntegrityLabel"
+        bottom = VarE $ mkName "bottom"
+        appMeet = AppE . (AppE (VarE (mkName "glb")))
+        combAnnotations f eId e l = case l of
+            [] ->
+                bottom
+            h:t -> 
+                let appF ann = case ann of
+                      LAId ->
+                        AppE f $ VarE eId
+                      LAConst c ->
+                        AppE f $ SigE (LitE $ StringL c) $ ConT $ mkName "String"
+                      LAField fName ->
+                        let getter = VarE $ mkName $ (headToLower eName) ++ (headToUpper fName) in
+                        AppE f $ AppE getter $ VarE e
+                in
+                List.foldl' (\acc ann -> appMeet acc $ appF ann) (appF h) t
+            
+        mkLabelField field = 
+            case lFieldLabelAnnotations field of
+                Nothing ->
+                    []
+                Just ( readAnns, writeAnns, createAnns) ->
+                    let eId = mkName "_eId" in
+                    let e = mkName "_entity" in
+                    let baseName = eName ++ (headToUpper (lFieldHaskell field)) in
+                    let readName = mkName $ "readLabel" ++ baseName in
+                    let writeName = mkName $ "writeLabel" ++ baseName in
+                    let createName = mkName $ "createLabel" ++ baseName in
+                    let readSig = SigD readName $ AppT (AppT ArrowT (AppT (ConT (mkName "Entity")) (ConT (mkName eName)))) labelType in
+                    let rBody = combAnnotations toConfLabel eId e readAnns in
+                    let readDef = FunD readName [Clause [ConP (mkName "Entity") [VarP eId, VarP e]] (NormalB rBody) []] in
+                    let writeSig = SigD writeName $ AppT (AppT ArrowT (AppT (ConT (mkName "Entity")) (ConT (mkName eName)))) labelType in
+                    let wBody = combAnnotations toIntegLabel eId e writeAnns in
+                    let writeDef = FunD writeName [Clause [ConP (mkName "Entity") [VarP eId, VarP e]] (NormalB wBody) []] in
+                    let createSig = SigD createName $ AppT (AppT ArrowT ( ConT (mkName eName))) labelType in
+                    let cBody = combAnnotations toIntegLabel eId e createAnns in
+                    let createDef = FunD createName [Clause [VarP e] (NormalB cBody) []] in
+                    [readSig,readDef,writeSig,writeDef,createSig,createDef]
+
+
+
+-- | Similar to mkLabelEntity, except this function creates code that returns the labels given what the label depends on instead of the entire entity. 
+-- Ex:
+--
+-- readLabelUserEmail' :: UserId -> DCLabel Principal
+-- readLabelUserEmail' uId = 
+--     ((toConfidentialityLabel "Admin") `glb` (toConfidentialityLabel uId))
+--
+-- writeLabelUserEmail' :: UserId -> DCLabel Principal
+-- writeLabelUserEmail' uId = 
+--     (toIntegrityLabel uId)
+--
+-- createLabelUserEmail' :: DCLabel Principal
+-- createLabelUserEmail' = 
+--     bottom
+
+mkLabelEntity' :: Type -> LEntityDef -> [Dec]
+mkLabelEntity' labelType ent =
+    let labelFs = map mkLabelField' (lEntityFields ent) in
+    concat labelFs
+
+    where
+        eName = lEntityHaskell ent
+        toConfLabel = VarE $ mkName "toConfidentialityLabel"
+        toIntegLabel = VarE $ mkName "toIntegrityLabel"
+        bottom = VarE $ mkName "bottom"
+        appMeet = AppE . (AppE (VarE (mkName "glb")))
+        mkType =
+            let helper annotation acc = case annotation of
+                  LAConst _ ->
+                    acc
+                  LAId ->
+                    let name = mkName $ eName ++ "Id" in
+                    AppT (AppT ArrowT (ConT name)) acc
+                  LAField s -> 
+                    let typ = getLEntityFieldType ent s in
+                    AppT (AppT ArrowT typ) acc
+            in
+            List.foldr helper labelType
+        mkPattern = 
+            let helper annotation acc = case annotation of
+                  LAConst _ ->
+                    acc
+                  LAId -> 
+                    (VarP $ mkName "_id"):acc
+                  LAField s ->
+                    (VarP $ mkName $ "_" ++ s):acc
+            in
+            List.foldr helper []
+        mkBody f anns = case anns of
+            [] -> 
+                bottom
+            h:t -> 
+                let appF ann = case ann of
+                      LAId ->
+                        AppE f $ VarE $ mkName "_id"
+                      LAConst c ->
+                        AppE f $ SigE (LitE $ StringL c) $ ConT $ mkName "String"
+                      LAField fName ->
+                        AppE f $ VarE $ mkName $ "_" ++ fName
+                in
+                List.foldl' (\acc ann -> appMeet acc $ appF ann) (appF h) t
+        mkLabelField' field = 
+            case lFieldLabelAnnotations field of
+                Nothing ->
+                    []
+                Just ( readAnns, writeAnns, createAnns) ->
+                    let baseName = eName ++ (headToUpper (lFieldHaskell field)) in
+                    let readName = mkName $ "readLabel" ++ baseName ++ "'" in
+                    let writeName = mkName $ "writeLabel" ++ baseName ++ "'" in
+                    let createName = mkName $ "createLabel" ++ baseName ++ "'" in
+                    let readSig = SigD readName $ mkType readAnns in
+                    let readDef = FunD readName [Clause (mkPattern readAnns) (NormalB $ mkBody toConfLabel readAnns) []] in
+                    let writeSig = SigD writeName $ mkType writeAnns in
+                    let writeDef = FunD writeName [Clause (mkPattern writeAnns) (NormalB $ mkBody toIntegLabel writeAnns) []] in
+                    let createSig = SigD createName $ mkType createAnns in
+                    let createDef = FunD createName [Clause (mkPattern createAnns) (NormalB $ mkBody toIntegLabel createAnns) []] in
+                    [readSig, readDef, writeSig, writeDef, createSig, createDef]
+
+
+
+-- | Create ProtectedEntity instance for given entity.
+-- Ex:
+--
+-- instance ProtectedEntity (DCLabel Principal) User ProtectedUser where
+--     toProtected _entity@(Entity _eId _e) = do
+--         let ident = userIdent _e
+--         let password = userPassword _e
+--         email <- 
+--             let l = readLabelUserEmail _entity in
+--             toLabeledTCB l $ do
+--                 taintLabel l
+--                 return $ userEmail _e
+--          let admin = userAdmin _e
+--          return $ ProtectedUser ident password email admin
+
+mkProtectedEntityInstance :: Type -> LEntityDef -> Q Dec
+mkProtectedEntityInstance labelType ent = do
+    ( fStmts, fExps) <- foldM mkProtectedFieldInstance ([],[]) $ lEntityFields ent
+    let recordCons = RecConE (mkName pName) fExps
+    let body = DoE $ fStmts ++ [NoBindS (AppE (VarE (mkName "return")) recordCons)]
+    let toProtected = FunD (mkName "toProtected") [Clause [AsP entity (ConP (mkName "Entity") [VarP eId,VarP e])] (NormalB body) []]
+    return $ InstanceD [] (AppT (AppT (AppT (ConT (mkName "ProtectedEntity")) labelType) (ConT (mkName eName))) (ConT (mkName pName))) [toProtected]
+
+    where 
+        eName = lEntityHaskell ent
+        pName = "Protected" ++ eName
+        e = mkName "_e"
+        eId = mkName "_eId"
+        entity = mkName "_entity"
+
+        mkProtectedFieldInstance :: ([Stmt],[FieldExp]) -> LFieldDef -> Q ([Stmt],[FieldExp])
+        mkProtectedFieldInstance (sAcc, fAcc) field = do
+            let fName = lFieldHaskell field
+            let getter = mkName $ (headToLower eName) ++ (headToUpper fName)
+            vName <- newName "v"
+            let setter = mkName $ 'p':(eName ++ (headToUpper fName))
+            let newF = (setter, VarE vName)
+            newS <- case lFieldLabelAnnotations field of
+                  Nothing ->
+                    return $ LetS [ValD (VarP vName) (NormalB (AppE (VarE getter) (VarE e))) []]
+                  Just _ -> do
+                    lName <- newName "l"
+                    let taintRead = mkName $ "readLabel" ++ eName ++ (headToUpper fName)
+                    let lDec = ValD (VarP lName) (NormalB (AppE (VarE taintRead) (VarE entity))) []
+                    return $ BindS (VarP vName) $ LetE [lDec] $ AppE (AppE (VarE (mkName "toLabeledTCB")) (VarE lName)) $ DoE [
+                            NoBindS $ AppE (VarE (mkName "taintLabel")) (VarE lName),
+                            NoBindS $ AppE (VarE (mkName "return")) (AppE (VarE getter) (VarE e))
+                          ]
+            return ( (newS:sAcc), (newF:fAcc))
+
+
+
+fieldTypeToType :: FieldType -> Type
+fieldTypeToType (FTTypeCon Nothing con) = 
+    ConT $ mkName $ Text.unpack con
+fieldTypeToType (FTTypeCon (Just mod) con) = 
+    ConT $ mkName $ (Text.unpack mod) ++ "." ++ Text.unpack con
+fieldTypeToType (FTApp f x) = 
+    AppT (fieldTypeToType f) (fieldTypeToType x)
+fieldTypeToType (FTList x) = 
+    AppT ListT $ fieldTypeToType x
+
+getLEntityFieldType :: LEntityDef -> String -> Type
+getLEntityFieldType ent fName = 
+    let ftype = List.foldl' (\acc f -> case (acc, lFieldHaskell f) of 
+            (Nothing, s) | s == fName -> 
+                Just $ fieldTypeToType $ lFieldType f
+            _ ->
+                acc
+          ) Nothing $ lEntityFields ent 
+    in
+    case ftype of 
+        Nothing ->
+            error $ "getLEntityFieldType: Could not find find field `" ++ fName ++"` in entity `"++ (lEntityHaskell ent) ++"`"
+        Just f ->
+            f
+
diff --git a/src/Database/LPersist/Quasi.hs b/src/Database/LPersist/Quasi.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/LPersist/Quasi.hs
@@ -0,0 +1,555 @@
+-- Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+--
+-- Permission is hereby granted, free of charge, to any person obtaining
+-- a copy of this software and associated documentation files (the
+-- "Software"), to deal in the Software without restriction, including
+-- without limitation the rights to use, copy, modify, merge, publish,
+-- distribute, sublicense, and/or sell copies of the Software, and to
+-- permit persons to whom the Software is furnished to do so, subject to
+-- the following conditions:
+--
+-- The above copyright notice and this permission notice shall be
+-- included in all copies or substantial portions of the Software.
+--
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+-- LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+-- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+-- WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+--
+-- Modified by James Parker in 2014. 
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Database.LPersist.Quasi
+    ( lParse
+--     , PersistSettings (..)
+--     , upperCaseSettings
+--     , lowerCaseSettings
+--     , nullable
+-- #if TEST
+--     , Token (..)
+--     , tokenize
+--     , parseFieldType
+-- #endif
+    ) where
+
+import Prelude hiding (lines)
+import Database.Persist.Quasi
+import Database.Persist.Types
+import Data.Char
+import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Control.Arrow ((&&&))
+import qualified Data.Map as M
+import Data.List (foldl')
+import Control.Monad (msum, mplus)
+
+data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show
+
+parseFieldType :: Text -> Either String FieldType
+parseFieldType t0 =
+    case parseApplyFT t0 of
+        PSSuccess ft t'
+            | T.all isSpace t' -> Right ft
+        PSFail err -> Left $ "PSFail " ++ err
+        other -> Left $ show other
+  where
+    parseApplyFT t =
+        case goMany id t of
+            PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t'
+            PSSuccess [] _ -> PSFail "empty"
+            PSFail err -> PSFail err
+            PSDone -> PSDone
+
+    parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType
+    parseEnclosed end ftMod t =
+      let (a, b) = T.break (== end) t
+      in case parseApplyFT a of
+          PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of
+              ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `mappend` t')
+              (x, y) -> PSFail $ show (b, x, y)
+          x -> PSFail $ show x
+
+    parse1 t =
+        case T.uncons t of
+            Nothing -> PSDone
+            Just (c, t')
+                | isSpace c -> parse1 $ T.dropWhile isSpace t'
+                | c == '(' -> parseEnclosed ')' id t'
+                | c == '[' -> parseEnclosed ']' FTList t'
+                | isUpper c ->
+                    let (a, b) = T.break (\x -> isSpace x || x `elem'` "()[]") t
+                     in PSSuccess (getCon a) b
+                | otherwise -> PSFail $ show (c, t')
+    getCon t =
+        case T.breakOnEnd "." t of
+            (_, "") -> FTTypeCon Nothing t
+            ("", _) -> FTTypeCon Nothing t
+            (a, b) -> FTTypeCon (Just $ T.init a) b
+    goMany front t =
+        case parse1 t of
+            PSSuccess x t' -> goMany (front . (x:)) t'
+            PSFail err -> PSFail err
+            PSDone -> PSSuccess (front []) t
+            -- _ -> 
+-- 
+-- data PersistSettings = PersistSettings
+--     { psToDBName :: !(Text -> Text)
+--     , psStrictFields :: !Bool
+--     -- ^ Whether fields are by default strict. Default value: @True@.
+--     --
+--     -- Since 1.2
+--     , psIdName :: !Text
+--     -- ^ The name of the id column. Default value: @id@
+--     -- The name of the id column can also be changed on a per-model basis
+--     -- <https://github.com/yesodweb/persistent/wiki/Persistent-entity-syntax>
+--     --
+--     -- Since 2.0
+--     }
+-- 
+-- defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings
+-- defaultPersistSettings = PersistSettings
+--     { psToDBName = id
+--     , psStrictFields = True
+--     , psIdName       = "id"
+--     }
+-- 
+-- upperCaseSettings = defaultPersistSettings
+-- 
+-- lowerCaseSettings = defaultPersistSettings
+--     { psToDBName =
+--         let go c
+--                 | isUpper c = T.pack ['_', toLower c]
+--                 | otherwise = T.singleton c
+--          in T.dropWhile (== '_') . T.concatMap go
+--     }
+
+-- | Parses a quasi-quoted syntax into a list of entity definitions.
+lParse :: PersistSettings -> Text -> [EntityDef]
+lParse ps = parseLines ps
+      . removeSpaces
+      . filter (not . empty)
+      . map tokenize
+      . T.lines
+
+-- | A token used by the parser.
+data Token = Spaces !Int   -- ^ @Spaces n@ are @n@ consecutive spaces.
+           | Token Text    -- ^ @Token tok@ is token @tok@ already unquoted.
+  deriving (Show, Eq)
+
+-- | Tokenize a string.
+tokenize :: Text -> [Token]
+tokenize t
+    | T.null t = []
+    | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line.
+    | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110)
+    | T.head t == '"' = quotes (T.tail t) id
+    | T.head t == '(' = parens 1 (T.tail t) id
+    | T.head t == '<' = chevrons (T.tail t) ("chevrons=":)
+    | isSpace (T.head t) =
+        let (spaces, rest) = T.span isSpace t
+         in Spaces (T.length spaces) : tokenize rest
+
+    -- support mid-token quotes and parens
+    | Just (beforeEquals, afterEquals) <- findMidToken t
+    , not (T.any isSpace beforeEquals)
+    , Token next : rest <- tokenize afterEquals =
+        Token (T.concat [beforeEquals, "=", next]) : rest
+
+    | otherwise =
+        let (token, rest) = T.break isSpace t
+         in Token token : tokenize rest
+  where
+    findMidToken t' =
+        case T.break (== '=') t' of
+            (x, T.drop 1 -> y)
+                | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y)
+            _ -> Nothing
+
+    quotes t' front
+        | T.null t' = error $ T.unpack $ T.concat $
+            "Unterminated quoted string starting with " : front []
+        | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t')
+        | T.head t' == '\\' && T.length t' > 1 =
+            quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):))
+        | otherwise =
+            let (x, y) = T.break (`elem'` "\\\"") t'
+             in quotes y (front . (x:))
+
+    parens count t' front
+        | T.null t' = error $ T.unpack $ T.concat $
+            "Unterminated parens string starting with " : front []
+        | T.head t' == ')' =
+            if count == (1 :: Int)
+                then Token (T.concat $ front []) : tokenize (T.tail t')
+                else parens (count - 1) (T.tail t') (front . (")":))
+        | T.head t' == '(' =
+            parens (count + 1) (T.tail t') (front . ("(":))
+        | T.head t' == '\\' && T.length t' > 1 =
+            parens count (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):))
+        | otherwise =
+            let (x, y) = T.break (`elem'` "\\()") t'
+             in parens count y (front . (x:))
+
+    chevrons t' front
+        | T.null t' = error $ T.unpack $ T.concat $ 
+            "Unterminated chevrons string starting with " : front []
+        | T.head t' == '>' = 
+            Token (T.concat $ front []) : tokenize (T.tail t')
+        | T.head t' == '\\' && T.length t' > 1 =
+            quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):))
+        | otherwise =
+            let (x, y) = T.break (`elem'` "\\>") t'
+            in chevrons y (front . (x:))
+
+-- | A string of tokens is empty when it has only spaces.  There
+-- can't be two consecutive 'Spaces', so this takes /O(1)/ time.
+empty :: [Token] -> Bool
+empty []         = True
+empty [Spaces _] = True
+empty _          = False
+
+-- | A line.  We don't care about spaces in the middle of the
+-- line.  Also, we don't care about the ammount of indentation.
+data Line = Line { lineIndent :: Int
+                 , tokens     :: [Text]
+                 }
+
+-- | Remove leading spaces and remove spaces in the middle of the
+-- tokens.
+removeSpaces :: [[Token]] -> [Line]
+removeSpaces =
+    map toLine
+  where
+    toLine (Spaces i:rest) = toLine' i rest
+    toLine xs              = toLine' 0 xs
+
+    toLine' i = Line i . mapMaybe fromToken
+
+    fromToken (Token t) = Just t
+    fromToken Spaces{}  = Nothing
+
+-- | Divide lines into blocks and make entity definitions.
+parseLines :: PersistSettings -> [Line] -> [EntityDef]
+parseLines ps lines =
+    fixForeignKeysAll $ toEnts lines
+  where
+    toEnts (Line indent (name:entattribs) : rest) =
+        let (x, y) = span ((> indent) . lineIndent) rest
+        in  mkEntityDef ps name entattribs x : toEnts y
+    toEnts (Line _ []:rest) = toEnts rest
+    toEnts [] = []
+
+fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef]
+fixForeignKeysAll unEnts = map fixForeignKeys unEnts
+  where
+    ents = map unboundEntityDef unEnts
+    entLookup = M.fromList $ map (\e -> (entityHaskell e, e)) ents
+
+    fixForeignKeys :: UnboundEntityDef -> EntityDef
+    fixForeignKeys (UnboundEntityDef foreigns ent) =
+      ent { entityForeigns = map (fixForeignKey ent) foreigns }
+
+    -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns
+    fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef
+    fixForeignKey ent (UnboundForeignDef foreignFieldTexts fdef) =
+        case M.lookup (foreignRefTableHaskell fdef) entLookup of
+          Just pent -> case entityPrimary pent of
+             Just pdef ->
+                 if length foreignFieldTexts /= length (compositeFields pdef)
+                   then lengthError pdef
+                   else let fds_ffs = zipWith (toForeignFields pent)
+                                foreignFieldTexts
+                                (compositeFields pdef)
+                        in  fdef { foreignFields = map snd fds_ffs
+                                 , foreignNullable = setNull $ map fst fds_ffs
+                                 }
+             Nothing ->
+                 error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent
+          Nothing ->
+             error $ "could not find table " ++ show (foreignRefTableHaskell fdef)
+               ++ " fdef=" ++ show fdef ++ " allnames="
+               ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts)
+               ++ "\n\nents=" ++ show ents
+      where
+        setNull :: [FieldDef] -> Bool
+        setNull [] = error "setNull: impossible!"
+        setNull (fd:fds) = let nullSetting = isNull fd in
+          if all ((nullSetting ==) . isNull) fds then nullSetting
+            else error $ "foreign key columns must all be nullable or non-nullable"
+                   ++ show (map (unHaskellName . fieldHaskell) (fd:fds))
+        isNull = (NotNullable /=) . nullable . fieldAttrs
+
+        toForeignFields pent fieldText pfd =
+           case chktypes fd haskellField (entityFields pent) pfh of
+               Just err -> error err
+               Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb)))
+          where
+            fd = getFd (entityFields ent) haskellField
+
+            haskellField = HaskellName fieldText
+            (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd)
+
+            chktypes :: FieldDef -> HaskellName -> [FieldDef] -> HaskellName -> Maybe String
+            chktypes ffld _fkey pflds pkey =
+                if fieldType ffld == fieldType pfld then Nothing
+                  else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld)
+              where
+                pfld = getFd pflds pkey
+
+            entName = entityHaskell ent
+            getFd [] t = error $ "foreign key constraint for: " ++ show (unHaskellName entName)
+                           ++ " unknown column: " ++ show t
+            getFd (f:fs) t
+                | fieldHaskell f == t = f
+                | otherwise = getFd fs t
+
+        lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length (compositeFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef
+
+
+data UnboundEntityDef = UnboundEntityDef
+                        { _unboundForeignDefs :: [UnboundForeignDef]
+                        , unboundEntityDef :: EntityDef
+                        }
+
+
+lookupKeyVal :: Text -> [Text] -> Maybe Text
+lookupKeyVal key = lookupPrefix $ key `mappend` "="
+lookupPrefix :: Text -> [Text] -> Maybe Text
+lookupPrefix prefix = msum . map (T.stripPrefix prefix)
+
+-- | Construct an entity definition.
+mkEntityDef :: PersistSettings
+            -> Text -- ^ name
+            -> [Attr] -- ^ entity attributes
+            -> [Line] -- ^ indented lines
+            -> UnboundEntityDef
+mkEntityDef ps name entattribs lines =
+  UnboundEntityDef foreigns $
+    EntityDef
+        entName
+        (DBName $ getDbName ps name' entattribs)
+        -- idField is the user-specified Id
+        -- otherwise useAutoIdField
+        -- but, adjust it if the user specified a Primary
+        (setComposite primaryComposite $ fromMaybe autoIdField idField)
+        entattribs
+        cols
+        uniqs
+        []
+        derives
+        extras
+        isSum
+  where
+    entName = HaskellName name'
+    (isSum, name') =
+        case T.uncons name of
+            Just ('+', x) -> (True, x)
+            _ -> (False, name)
+    (attribs, extras) = splitExtras lines
+
+    attribPrefix = flip lookupKeyVal entattribs
+    idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql="
+           | otherwise = Nothing
+            
+    (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> 
+        let (i, p, u, f) = takeConstraint ps name' cols attr 
+            squish xs m = xs `mappend` maybeToList m
+        in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) attribs
+                                    
+    derives = concat $ mapMaybe takeDerives attribs
+
+    cols :: [FieldDef]
+    cols = mapMaybe (takeColsEx ps) attribs
+
+    autoIdField = mkAutoIdField ps entName (DBName `fmap` idName) idSqlType
+    idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite
+
+    setComposite Nothing fd = fd
+    setComposite (Just c) fd = fd { fieldReference = CompositeRef c }
+
+
+just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x
+just1 (Just x) (Just y) = error $ "expected only one of: "
+  `mappend` show x `mappend` " " `mappend` show y
+just1 x y = x `mplus` y
+                
+
+mkAutoIdField :: PersistSettings -> HaskellName -> Maybe DBName -> SqlType -> FieldDef
+mkAutoIdField ps entName idName idSqlType = FieldDef
+      { fieldHaskell = HaskellName "Id"
+      -- this should be modeled as a Maybe
+      -- but that sucks for non-ID field
+      -- TODO: use a sumtype FieldDef | IdFieldDef
+      , fieldDB = fromMaybe (DBName $ psIdName ps) idName
+      , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName
+      , fieldSqlType = idSqlType
+      -- the primary field is actually a reference to the entity
+      , fieldReference = ForeignRef entName (FTTypeCon Nothing "Int")
+      , fieldAttrs = []
+      , fieldStrict = True
+      }
+
+keyConName :: Text -> Text
+keyConName entName = entName `mappend` "Id"
+
+
+splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]])
+splitExtras [] = ([], M.empty)
+splitExtras (Line indent [name]:rest)
+    | not (T.null name) && isUpper (T.head name) =
+        let (children, rest') = span ((> indent) . lineIndent) rest
+            (x, y) = splitExtras rest'
+         in (x, M.insert name (map tokens children) y)
+splitExtras (Line _ ts:rest) =
+    let (x, y) = splitExtras rest
+     in (ts:x, y)
+
+takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef
+takeColsEx = takeCols (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr)
+
+takeCols :: (Text -> String -> Maybe FieldDef) -> PersistSettings -> [Text] -> Maybe FieldDef
+takeCols _ _ ("deriving":_) = Nothing
+takeCols onErr ps (n':typ:rest)
+    | not (T.null n) && isLower (T.head n) =
+        case parseFieldType typ of
+            Left err -> onErr typ err
+            Right ft -> Just FieldDef
+                { fieldHaskell = HaskellName n
+                , fieldDB = DBName $ getDbName ps n rest
+                , fieldType = ft
+                , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n
+                , fieldAttrs = rest
+                , fieldStrict = fromMaybe (psStrictFields ps) mstrict
+                , fieldReference = NoReference
+                }
+  where
+    (mstrict, n)
+        | Just x <- T.stripPrefix "!" n' = (Just True, x)
+        | Just x <- T.stripPrefix "~" n' = (Just False, x)
+        | otherwise = (Nothing, n')
+takeCols _ _ _ = Nothing
+
+getDbName :: PersistSettings -> Text -> [Text] -> Text
+getDbName ps n [] = psToDBName ps n
+getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a
+
+takeConstraint :: PersistSettings
+          -> Text
+          -> [FieldDef]
+          -> [Text]
+          -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef)
+takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint' 
+    where
+      takeConstraint' 
+            | n == "Unique"  = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing)
+            | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest)
+            | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing)
+            | n == "Id"      = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing)
+            | otherwise      = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint
+takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing)
+
+-- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName.
+-- need to re-work takeCols function
+takeId :: PersistSettings -> Text -> [Text] -> FieldDef
+takeId ps tableName (n:rest) = fromMaybe (error "takeId: impossible!") $ setFieldDef $
+    takeCols (\_ _ -> addDefaultIdType) ps (field:rest `mappend` setIdName)
+  where
+    field = case T.uncons n of
+      Nothing -> error "takeId: empty field"
+      Just (f, ield) -> toLower f `T.cons` ield
+    addDefaultIdType = takeColsEx ps (field : keyCon : rest `mappend` setIdName)
+    setFieldDef = fmap (\fd ->
+      let refFieldType = if fieldType fd == FTTypeCon Nothing keyCon
+              then FTTypeCon Nothing "Int"
+              else fieldType fd
+      in fd { fieldReference = ForeignRef (HaskellName tableName) $ refFieldType
+            })
+    keyCon = keyConName tableName
+    -- this will be ignored if there is already an existing sql=
+    -- TODO: I think there is a ! ignore syntax that would screw this up
+    setIdName = ["sql=" `mappend` psIdName ps]
+takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName
+
+    
+takeComposite :: [FieldDef]
+              -> [Text]
+              -> CompositeDef
+takeComposite fields pkcols
+        = CompositeDef
+            (map (getDef fields) pkcols)
+            attrs
+  where
+    (_, attrs) = break ("!" `T.isPrefixOf`) pkcols
+    getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t
+    getDef (d:ds) t
+        | nullable (fieldAttrs d) /= NotNullable = error $ "primary key column cannot be nullable: " ++ show t
+        | fieldHaskell d == HaskellName t = d
+        | otherwise = getDef ds t
+
+-- Unique UppercaseConstraintName list of lowercasefields    
+takeUniq :: PersistSettings
+          -> Text
+          -> [FieldDef]
+          -> [Text]
+          -> UniqueDef
+takeUniq ps tableName defs (n:rest)
+    | not (T.null n) && isUpper (T.head n)
+        = UniqueDef
+            (HaskellName n)
+            (DBName $ psToDBName ps (tableName `T.append` n))
+            (map (HaskellName &&& getDBName defs) fields)
+            attrs
+  where
+    (fields,attrs) = break ("!" `T.isPrefixOf`) rest
+    getDBName [] t = error $ "Unknown column in unique constraint: " ++ show t
+    getDBName (d:ds) t
+        | fieldHaskell d == HaskellName t = fieldDB d
+        | otherwise = getDBName ds t
+takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName ++ "] expecting an uppercase constraint name xs=" ++ show xs
+
+data UnboundForeignDef = UnboundForeignDef
+                         { _unboundFields :: [Text] -- ^ fields in other entity
+                         , _unboundForeignDef :: ForeignDef
+                         }
+
+takeForeign :: PersistSettings
+          -> Text
+          -> [FieldDef]
+          -> [Text]
+          -> UnboundForeignDef
+takeForeign ps tableName _defs (refTableName:n:rest)
+    | not (T.null n) && isLower (T.head n)
+        = UnboundForeignDef fields $ ForeignDef
+            (HaskellName refTableName)
+            (DBName $ psToDBName ps refTableName)
+            (HaskellName n)
+            (DBName $ psToDBName ps (tableName `T.append` n))
+            []
+            attrs
+            False
+  where
+    (fields,attrs) = break ("!" `T.isPrefixOf`) rest
+
+takeForeign _ tableName _ xs = error $ "invalid foreign key constraint on table[" ++ show tableName ++ "] expecting a lower case constraint name xs=" ++ show xs
+
+takeDerives :: [Text] -> Maybe [Text]
+takeDerives ("deriving":rest) = Just rest
+takeDerives _ = Nothing
+
+-- nullable :: [Text] -> IsNullable
+-- nullable s
+--     | "Maybe"    `elem` s = Nullable ByMaybeAttr
+--     | "nullable" `elem` s = Nullable ByNullableAttr
+--     | otherwise = NotNullable
+
+elem' :: Eq a => a -> [a] -> Bool
+elem' = elem
diff --git a/src/Database/LPersist/TH.hs b/src/Database/LPersist/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/LPersist/TH.hs
@@ -0,0 +1,1479 @@
+{-# 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)
diff --git a/src/Internal.hs b/src/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Internal.hs
@@ -0,0 +1,187 @@
+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+
+module Internal where
+
+import Control.Applicative
+import Data.Attoparsec.Text
+import qualified Data.Char as Char
+import qualified Data.List as List
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Database.Persist.Types
+
+data LabelAnnotation = 
+    LAId
+  | LAConst String
+  | LAField String
+    deriving (Show, Eq, Read, Ord)
+
+data LEntityDef = LEntityDef
+    { lEntityHaskell :: !String
+--     , lEntityDB      :: !String
+--     , lEntityId      :: !FieldDef
+--     , lEntityAttrs   :: ![Attr]
+    , lEntityFields  :: ![LFieldDef]
+--     , lEntityUniques :: ![UniqueDef]
+--     , lEntityForeigns:: ![ForeignDef]
+--     , lEntityDerives :: ![Text]
+--     , lEntityExtra   :: !(Map Text [ExtraLine])
+--     , lEntitySum     :: !Bool
+    }
+    deriving (Show, Eq, Read, Ord)
+
+data LFieldDef = LFieldDef
+    { lFieldHaskell   :: !String -- ^ name of the field
+--    , lFieldDB        :: !String
+    , lFieldType      :: !FieldType
+--    , lFieldSqlType   :: !SqlType
+--    , lFieldAttrs     :: ![Attr]    -- ^ user annotations for a field
+    , lFieldStrict    :: !Bool      -- ^ a strict field in the data type. Default: true
+--    , lFieldReference :: !ReferenceDef
+    , lFieldLabelAnnotations :: !(Maybe ([LabelAnnotation],[LabelAnnotation],[LabelAnnotation]))
+    }
+    deriving (Show, Eq, Read, Ord)
+
+headToUpper :: String -> String
+headToUpper (h:t) = (Char.toUpper h):t
+headToUpper s = error $ "Invalid name `" ++ s ++ "`"
+
+headToLower :: String -> String
+headToLower (h:t) = (Char.toLower h):t
+headToLower s = error $ "Invalid name `" ++ s ++ "`"
+
+toLEntityDef :: EntityDef -> LEntityDef
+toLEntityDef ent = LEntityDef {
+        lEntityHaskell = Text.unpack $ unHaskellName $ entityHaskell ent
+--      , lEntityDB = Text.unpack $ unDBName $ entityDB ent
+      , lEntityFields = map toLFieldDef (entityFields ent)
+    }
+
+--     where
+--         lookupField fields name = 
+--             let fieldM = List.foldl' (\acc field' -> case acc of
+--                     Just _ -> 
+--                         acc
+--                     Nothing -> 
+--                         if (lFieldHaskell field') == name then
+--                             Just field'
+--                         else
+--                             Nothing
+--                   ) Nothing fields
+--             in
+--             maybe (error $ "Could not find field `" ++ name ++ "`") id fieldM
+--         checkLabels fields = List.foldr (\field' acc -> 
+--                 if labelsContainsOption fields field' then
+--                     error $ "Field `" ++ (lFieldHaskell field') ++ "` cannot have a `Field` label annotation that points to an optional column."
+--                 else
+--                     field':acc
+--             ) [] fields
+--         labelsContainsOption fields field = maybe False (\(r,w,c) -> 
+--             (labelsContainsOption' fields r) 
+--                 || (labelsContainsOption' fields w) 
+--                 || (labelsContainsOption' fields c)
+--           ) (lFieldLabelAnnotations field)
+--         labelsContainsOption' _ [] = False
+--         labelsContainsOption' fields ((LAField name):t) = 
+--             let field = lookupField fields name in
+--             -- Check if it's optional. 
+--             case lFieldType field of
+--                 FTApp (FTTypeCon _ "Maybe") _ ->
+--                     True
+--                 _ ->
+--                     labelsContainsOption' fields t
+--         labelsContainsOption' fields (_:t) = labelsContainsOption' fields t
+
+
+toLFieldDef :: FieldDef -> LFieldDef
+toLFieldDef f = LFieldDef {
+        lFieldHaskell = Text.unpack $ unHaskellName $ fieldHaskell f
+--       , lFieldDB = Text.unpack $ unDBName $ fieldDB f
+      , lFieldType = typ
+      , lFieldStrict = fieldStrict f
+      , lFieldLabelAnnotations = labels
+    }
+
+    where
+        labels = 
+            let attrs = fieldAttrs f in
+            List.foldl' (\acc attr -> 
+                let ( prefix, affix) = Text.splitAt 9 attr in
+                if acc /= Nothing || prefix /= "chevrons=" then
+                    acc
+                else
+                    let labels@(_,_,createLabels) = parseChevrons affix in
+                    -- Check that create does not have id.
+                    if createContainsId createLabels then
+                        error $ "Field `" ++ (Text.unpack $ unHaskellName $ fieldHaskell f) ++ "` cannot have label `Id` in the create annotation."
+                    else
+                        Just labels
+              ) Nothing attrs
+        typ = if nullable (fieldAttrs f) then
+                FTApp (FTTypeCon Nothing "Maybe") $ fieldType f
+            else
+                fieldType f
+        nullable s 
+            | "Maybe" `elem` s = True
+            | "nullable" `elem` s = True
+            | otherwise = False
+        createContainsId [] = False
+        createContainsId (LAId:t) = True
+        createContainsId (_:t) = createContainsId t
+
+-- Parse chevrons
+-- C = < L , L , L >
+-- L = K | _
+-- K = A || K | A
+-- A = Id | Const name | Field name
+
+parseChevrons :: Text -> ([LabelAnnotation],[LabelAnnotation],[LabelAnnotation])
+parseChevrons s = case parseOnly parseC s of
+    Left err ->
+        error $ "Could not parse labels in chevrons: " ++ err
+    Right res ->
+        res
+
+    where
+        parseC = do
+            read <- parseL
+            skipSpace
+            _ <- char ','
+            write <- parseL
+            skipSpace
+            _ <- char ','
+            create <- parseL
+            return (read,write,create)
+
+        parseL = (skipSpace >> char '_' >> return []) <|> parseK
+        
+        parseK = do
+            la <- parseA
+            tail <- (do
+                skipSpace
+                _ <- char '|'
+                _ <- char '|'
+                parseK
+              ) <|> (return [])
+
+            return $ la:tail
+
+        parseA = do
+            skipSpace
+            constr <- takeAlphaNum
+            case constr of
+                "Id" -> 
+                    return LAId
+                "Const" -> do
+                    skipSpace
+                    name <- takeAlphaNum
+                    return $ LAConst $ Text.unpack name
+                "Field" -> do
+                    skipSpace
+                    name <- takeAlphaNum
+                    return $ LAField $ Text.unpack name
+                _ -> 
+                    fail $ "Unknown keyword `" ++ (Text.unpack constr) ++ "` in parseChevrons. Use `Id`, `Const`, `Field`, or `_`"
+        
+        takeAlphaNum = takeWhile1 Char.isAlphaNum
+            
diff --git a/src/LMonad/Yesod.hs b/src/LMonad/Yesod.hs
new file mode 100644
--- /dev/null
+++ b/src/LMonad/Yesod.hs
@@ -0,0 +1,195 @@
+-- TODO: Some licensing stuff (http://hackage.haskell.org/package/yesod-core-1.4.3/docs/src/Yesod-Core-Class-Yesod.html)
+
+
+
+{-# LANGUAGE FlexibleContexts, TemplateHaskell, QuasiQuotes, OverloadedStrings, TypeFamilies #-}
+module LMonad.Yesod where
+
+import Control.Monad (forM)
+import Data.List (foldl', nub)
+import qualified Data.Map as Map
+import Data.Monoid (Last(..), mempty)
+import Data.Text (Text)
+import Data.Text.Lazy.Builder (toLazyText)
+import Data.Text.Lazy.Encoding (encodeUtf8)
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+import LMonad
+import Text.Blaze ( customAttribute, textTag, toValue, (!))
+import qualified Text.Blaze.Html5 as TBH
+import Text.Julius
+import Yesod.Core
+import Yesod.Core.Types
+import qualified Yesod.Core.Widget as Yesod
+
+widgetToPageContent :: (Label l, LMonad (HandlerT site IO), LMonad (WidgetT site IO), Yesod site) => LMonadT l (WidgetT site IO) () -> LMonadT l (HandlerT site IO) (PageContent (Route site))
+widgetToPageContent = swapBase $ \w -> do
+    ( res, ((),new)) <- widgetToPageContent' w
+    return (res, new)
+    
+    where
+        widgetToPageContent' :: ((Eq (Route site)), (Yesod site)) => WidgetT site IO a -> HandlerT site IO (PageContent (Route site), a)
+        widgetToPageContent' w = do
+            master <- getYesod
+            hd <- HandlerT return
+            (res, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
+            let title = maybe mempty unTitle mTitle
+                scripts = runUniqueList scripts'
+                stylesheets = runUniqueList stylesheets'
+
+            render <- getUrlRenderParams
+            let renderLoc x =
+                    case x of
+                        Nothing -> Nothing
+                        Just (Left s) -> Just s
+                        Just (Right (u, p)) -> Just $ render u p
+            css <- forM (Map.toList style) $ \(mmedia, content) -> do
+                let rendered = toLazyText $ content render
+                x <- addStaticContent "css" "text/css; charset=utf-8"
+                   $ encodeUtf8 rendered
+                return (mmedia,
+                    case x of
+                        Nothing -> Left $ preEscapedToMarkup rendered
+                        Just y -> Right $ either id (uncurry render) y)
+            jsLoc <-
+                case jscript of
+                    Nothing -> return Nothing
+                    Just s -> do
+                        x <- addStaticContent "js" "text/javascript; charset=utf-8"
+                           $ encodeUtf8 $ renderJavascriptUrl render s
+                        return $ renderLoc x
+
+            -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
+            -- the asynchronous loader means your page doesn't have to wait for all the js to load
+            let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
+                regularScriptLoad = [hamlet|
+                    $newline never
+                    $forall s <- scripts
+                        ^{mkScriptTag s}
+                    $maybe j <- jscript
+                        $maybe s <- jsLoc
+                            <script src="#{s}">
+                        $nothing
+                            <script>^{jelper j}
+                |]
+
+                headAll = [hamlet|
+                    $newline never
+                    \^{head'}
+                    $forall s <- stylesheets
+                        ^{mkLinkTag s}
+                    $forall s <- css
+                        $maybe t <- right $ snd s
+                            $maybe media <- fst s
+                                <link rel=stylesheet media=#{media} href=#{t}>
+                            $nothing
+                                <link rel=stylesheet href=#{t}>
+                        $maybe content <- left $ snd s
+                            $maybe media <- fst s
+                                <style media=#{media}>#{content}
+                            $nothing
+                                <style>#{content}
+                    $case jsLoader master
+                      $of BottomOfBody
+                      $of BottomOfHeadAsync asyncJsLoader
+                          ^{asyncJsLoader asyncScripts mcomplete}
+                      $of BottomOfHeadBlocking
+                          ^{regularScriptLoad}
+                |]
+            let bodyScript = [hamlet|
+                    $newline never
+                    ^{body}
+                    ^{regularScriptLoad}
+                |]
+
+            return (( PageContent title headAll $
+                    case jsLoader master of
+                        BottomOfBody -> bodyScript
+                        _ -> body
+                ), res)
+
+        renderLoc' render' (Local url) = render' url []
+        renderLoc' _ (Remote s) = s
+
+        addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
+        mkScriptTag (Script loc attrs) render' =
+            foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
+        mkLinkTag (Stylesheet loc attrs) render' =
+            foldl' addAttr TBH.link
+                ( ("rel", "stylesheet")
+                : ("href", renderLoc' render' loc)
+                : attrs
+                )
+
+        runUniqueList :: Eq x => UniqueList x -> [x]
+        runUniqueList (UniqueList x) = nub $ x []
+
+        jelper :: JavascriptUrl url -> HtmlUrl url
+        jelper = fmap jsToHtml
+
+        jsToHtml :: Javascript -> Html
+        jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
+        
+        left :: Either a b -> Maybe a
+        left (Left x) = Just x
+        left _ = Nothing
+        
+        right :: Either a b -> Maybe b
+        right (Right x) = Just x
+        right _ = Nothing
+
+        asyncHelper :: (url -> [x] -> Text)
+                 -> [Script (url)]
+                 -> Maybe (JavascriptUrl (url))
+                 -> Maybe Text
+                 -> (Maybe (HtmlUrl url), [Text])
+        asyncHelper render scripts jscript jsLoc =
+            (mcomplete, scripts'')
+          where
+            scripts' = map goScript scripts
+            scripts'' =
+                case jsLoc of
+                    Just s -> scripts' ++ [s]
+                    Nothing -> scripts'
+            goScript (Script (Local url) _) = render url []
+            goScript (Script (Remote s) _) = s
+            mcomplete =
+                case jsLoc of
+                    Just{} -> Nothing
+                    Nothing ->
+                        case jscript of
+                            Nothing -> Nothing
+                            Just j -> Just $ jelper j
+
+handlerToWidget :: (Label l, LMonad (HandlerT site IO), LMonad (WidgetT site IO)) => LMonadT l (HandlerT site IO) a -> LMonadT l (WidgetT site IO) a
+handlerToWidget = swapBase Yesod.handlerToWidget
+
+whamlet = QuasiQuoter { quoteExp = \s -> quoteExp Yesod.whamlet s >>= return . (AppE (VarE 'lLift)) }
+
+extractWidget :: (Label l, LMonad (WidgetT site IO)) => LMonadT l (WidgetT site IO) () -> LMonadT l (WidgetT site IO) (WidgetT site IO ())
+extractWidget = swapBase f
+    where
+        f :: (WidgetT site IO ((), l)) -> WidgetT site IO (WidgetT site IO (), l)
+        -- f (WidgetT w) = WidgetT $ \h -> do
+        --     (((), s),g) <- w h
+        --     return ((WidgetT (\i -> do
+        --             (((),_),h) <- w i
+        --             return ((),mappend h g)
+        --         ), s), g)
+        f (WidgetT w) = WidgetT $ \h -> do
+            (((), s),g) <- w h
+            return ((WidgetT (\_ -> do
+                    -- (((),_),g) <- w i
+                    return ((),g)
+                ), s), mempty)
+
+instance (MonadResource m, Label l, LMonad m) => MonadResource (LMonadT l m) where
+    liftResourceT = lLift . liftResourceT
+
+instance (MonadHandler m, Label l, LMonad m) => MonadHandler (LMonadT l m) where
+    type HandlerSite (LMonadT l m) = HandlerSite m
+    liftHandlerT = lLift . liftHandlerT
+
+instance (MonadWidget m, Label l, LMonad m) => MonadWidget (LMonadT l m) where
+    liftWidgetT = lLift . liftWidgetT
+