{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Exigo.Persistent.TH.Internal
where
import Database.Persist ( FieldDef(..)
, EntityDef(..)
, FieldType(FTTypeCon)
, HaskellName(..) )
import Data.Char
import Data.Monoid ( (<>) )
import qualified Data.Text as T
import Data.Text ( Text, cons, uncons )
import Database.Persist.TH ( MkPersistSettings(..) )
import Language.Haskell.TH.Syntax
import Exigo.Types ( AssessmentMetadata(..) )
{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
mkSaveAssessmentMetadata :: String -> AssessmentMetadata -> Q [Dec]
mkSaveAssessmentMetadata name' mData' = do
let name = mkName name'
mData <- lift mData'
return [ SigD name $ ConT ''AssessmentMetadata
, ValD (VarP name) (NormalB mData) []
]
mkQuestionFieldsAccessor :: MkPersistSettings -> String -> [EntityDef] -> Q [Dec]
mkQuestionFieldsAccessor mpSettings nm es = do
let es' = filter isMarks es
case es' of
[] -> error "no entities with name 'Marks' - did you call mkQuestionFieldsAccessor intentionally?"
[_] -> concat <$> mapM (mkAcc nm) es'
_ -> error "multiple entities with name 'Marks' - did you call mkQuestionFieldsAccessor intentionally?"
where
mkAcc :: String -> EntityDef -> Q [Dec]
mkAcc name' e = do
let name = mkName name'
qFields = map (VarE . mkName . accessorName mpSettings . fName) $
filter isQField $ entityFields e
funcType = x_to_listXT (marks_to_xT (ConT ''Double))
funcSig = SigD name funcType
func = FunD name [normalClause [] (ListE qFields)]
return [ funcSig, func ]
isQField :: FieldDef -> Bool
isQField f = let n = unHaskellName $ fieldHaskell f
in "q" `T.isPrefixOf` n
&& not ("comments" `T.isInfixOf` n)
&& fieldType f == FTTypeCon Nothing "Double"
mkCommentFieldsAccessor ::
MkPersistSettings -> String -> [EntityDef] -> Q [Dec]
mkCommentFieldsAccessor mpSettings nm es =
let es' = filter isMarks es
in concat <$> mapM (mkAcc nm) es'
where
mkAcc :: String -> EntityDef -> Q [Dec]
mkAcc name' e = do
let name = mkName name'
qFields = map (VarE . mkName . accessorName mpSettings . fName) $
filter isCommentsField $ entityFields e
funcType = x_to_listXT (marks_to_xT ( x_to_maybeXT $ ConT ''Text ))
funcSig = SigD name funcType
func = FunD name [normalClause [] (ListE qFields)]
return [ funcSig, func ]
isCommentsField :: FieldDef -> Bool
isCommentsField f = let n = unHaskellName $ fieldHaskell f
in "comments" `T.isInfixOf` T.map toLower n
&& fieldType f == FTTypeCon Nothing "Text"
&& "Maybe" `elem` fieldAttrs f
accessorName :: MkPersistSettings -> Text -> String
accessorName mpSettings f =
T.unpack $ recName mpSettings (HaskellName "Marks") (HaskellName f)
isMarks :: EntityDef -> Bool
isMarks e = let eNm = unHaskellName $ entityHaskell e
in eNm == "Marks"
fName :: FieldDef -> Text
fName = unHaskellName . fieldHaskell
marksT :: Type
marksT = ConT $ mkName "Marks"
x_to_listXT :: Type -> Type
x_to_listXT = AppT ListT
x_to_maybeXT :: Type -> Type
x_to_maybeXT = AppT (ConT ''Maybe)
marks_to_xT :: Type -> Type
marks_to_xT = AppT (AppT ArrowT marksT)
normalClause :: [Pat] -> Exp -> Clause
normalClause p e = Clause p (NormalB e) []
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
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