exigo-schema (empty) → 0.1.0.0
raw patch · 10 files changed
+464/−0 lines, 10 filesdep +aesondep +basedep +binarysetup-changed
Dependencies added: aeson, base, binary, bytestring, persistent, persistent-template, template-haskell, text, th-lift-instances
Files
- ChangeLog.md +7/−0
- LICENSE +24/−0
- README.md +7/−0
- Setup.hs +2/−0
- config/exigo.persistentmodels +26/−0
- exigo-schema.cabal +48/−0
- src/Exigo/Persistent/Schema.hs +79/−0
- src/Exigo/Persistent/TH.hs +22/−0
- src/Exigo/Persistent/TH/Internal.hs +207/−0
- src/Exigo/Types.hs +42/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for exigo-schema++## Unreleased changes++## 0.1.0.0++- initial release
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright 2020 phlummox++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED+TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,7 @@+# exigo-schema++Database schema for assessment/marking programs.++Plus a few Template Haskell utility functions for adding to the schema+and using it.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ config/exigo.persistentmodels view
@@ -0,0 +1,26 @@++Student+ studNo Text+ Primary studNo+ name Text+ deriving Show+ deriving Eq+ deriving Generic++Submission+ student StudentId+ Primary student+ studentLogin Text+ path FilePath+ deriving Show+ deriving Eq+ deriving Generic++LatePenalty+ student StudentId+ Primary student+ daysLate Int+ deriving Show+ deriving Eq+ deriving Generic+
+ exigo-schema.cabal view
@@ -0,0 +1,48 @@+cabal-version: 1.12++name: exigo-schema+version: 0.1.0.0+category: Database+synopsis: database schema for exigo marking/assessment tools+description: Please see the README on GitHub at <https://github.com/phlummox/exigo-schema#readme>+homepage: https://github.com/phlummox/exigo-schema#readme+bug-reports: https://github.com/phlummox/exigo-schema/issues+author: phlummox+maintainer: exigo-schema@phlummox.dev+copyright: 2020 phlummox+license: BSD2+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md+ config/exigo.persistentmodels++source-repository head+ type: git+ location: https://github.com/phlummox/exigo-schema++library+ exposed-modules:+ Exigo.Types+ Exigo.Persistent.TH+ Exigo.Persistent.TH.Internal+ Exigo.Persistent.Schema+ hs-source-dirs:+ src+ build-depends:+ base >=4.0 && <5+ , aeson+ , binary+ , bytestring+ , persistent+ , persistent-template+ , template-haskell+ , text+ , th-lift-instances+ default-language: Haskell2010+ ghc-options:+ -Wall -Wextra -Wcompat -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wredundant-constraints -fwarn-tabs+ -Wno-name-shadowing -Wno-type-defaults+
+ src/Exigo/Persistent/Schema.hs view
@@ -0,0 +1,79 @@++{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++{- |++Basic database schema for exigo tools.++The assumption is that the schema will actually be composed+of this, base, schema, plus subsidiary ones for+individual assessments.++-}++module Exigo.Persistent.Schema+ (+ -- | Represents a student+ Student+ -- | A student ID+ , StudentId+ -- | Submission made by a 'Student'.+ , Submission+ -- | 'Submission' ID+ , SubmissionId+ -- | A late penalty applied+ , LatePenalty+ -- | 'LatePenalty' ID+ , LatePenaltyId+ -- | Saved entities from this schema+ , savedMainModel+ )+ where++import Data.Aeson+import Data.Binary+import Data.Text (Text)+import Database.Persist.TH (+ mkPersist+ , mkSave+ , persistFileWith+ , share+ , sqlSettings+ )+import Database.Persist.Quasi+import Database.Persist.Class+import GHC.Generics++share [+ mkSave "savedMainModel"+ , mkPersist sqlSettings+ ]+ $(persistFileWith lowerCaseSettings "config/exigo.persistentmodels")++instance Binary Student where++deriving instance Generic (Key Student)++instance Binary (Key Student) where+instance Binary Submission where+instance Binary LatePenalty where++instance FromJSON Student where+instance FromJSON Submission where+instance FromJSON LatePenalty where++instance ToJSON Student where+instance ToJSON Submission where+instance ToJSON LatePenalty where+
+ src/Exigo/Persistent/TH.hs view
@@ -0,0 +1,22 @@+{- |++Template Haskell functions that allow all+questions and comments for an assessment to be+easily accessed.++It's assumed assessments will have their own add-on database+schemas, and will define an entity "Marks" itemizing+what marks can be awarded and what comments an assessor+might make.++-}+module Exigo.Persistent.TH+ (+ mkSaveAssessmentMetadata+ , mkQuestionFieldsAccessor+ , mkCommentFieldsAccessor+ )+ where++import Exigo.Persistent.TH.Internal+
+ src/Exigo/Persistent/TH/Internal.hs view
@@ -0,0 +1,207 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++{- |++Unstable, may change without warning.++Utility funcs to support "Exigo.Persistent.TH".++-}++module Exigo.Persistent.TH.Internal+ where++import Database.Persist ( FieldDef(..)+ , EntityDef(..)+ , FieldType(FTTypeCon)+ , HaskellName(..) )+import Data.Char+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) #-}++-- | create a function which returns at runtime the+-- assessment metadata passed in at compile-time.+--+-- i.e., if @mkSaveAssessmentMetadata myFunc mData@ is called,+-- it creates a function like+--+-- @+-- myFunc :: AssessmentMetadata+-- myFunc = mData+-- @+mkSaveAssessmentMetadata :: String -> AssessmentMetadata -> Q [Dec]+mkSaveAssessmentMetadata name' mData' = do+ let name = mkName name'+ mData <- lift mData'+ return [ SigD name $ ConT ''AssessmentMetadata+ , FunD name [normalClause [] mData]+ ]++-- | create a function which returns all the question-type field+-- accessors for Marks.+--+-- i.e., @mkQuestionFieldsAccessor sqlSettings myName@+-- in a call to @share@+-- should produce a result something like+--+-- @+-- myNHame :: [Marks -> Double]+-- myName = [ marksQ1a, marksQ1b, marksQ1c .. ]+-- @+--+-- where the accessors are in the order they appear+-- in the EntityDef.+mkQuestionFieldsAccessor :: MkPersistSettings -> String -> [EntityDef] -> Q [Dec]+mkQuestionFieldsAccessor 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'+ -- the various field accessors: q1a, q1b, etc+ 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 ]+++ -- does this look like a "q1a" etc field?+ -- viz., it starts with a 'q', and doesn't contain+ -- the string "Comments" in its name, and+ -- is of type Double+ 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"+++-- | create a function which returns all the comment-type field+-- accessors for Marks.+--+-- i.e., @mkCommentFieldsAccessor myName@+--+-- should produce a result something like+--+-- @+-- myNHame :: [Marks -> Maybe Text]+-- myName = [ marksQ1aComments, marksQ1bComments, marksQ1cComments .. ]+-- @+--+-- where the accessors are in the order they appear+-- in the EntityDef.+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'+ -- the various field accessors: marksQ1aComments, etc+ 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 ]++ -- does this look like a "q1a" etc field?+ -- viz., it starts with a 'q', and doesn't contain+ -- the string "Comments" in its name, and+ -- is of type Double+ 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+++-- | given some field from an entty def -- e.g. "q1a" --+-- get the actual accessor name (i.e. "marksQ1a")+accessorName :: MkPersistSettings -> Text -> String+accessorName mpSettings f =+ T.unpack $ recName mpSettings (HaskellName "Marks") (HaskellName f)++-- | is this the "Marks" entity?+isMarks :: EntityDef -> Bool+isMarks e = let eNm = unHaskellName $ entityHaskell e+ in eNm == "Marks"++fName :: FieldDef -> Text+fName = unHaskellName . fieldHaskell++-- the "Marks" type+marksT :: Type+marksT = ConT $ mkName "Marks"++-- given type X, construct type [X]+x_to_listXT :: Type -> Type+x_to_listXT = AppT ListT++-- given type X, construct type [X]+x_to_maybeXT :: Type -> Type+x_to_maybeXT = AppT (ConT ''Maybe)++-- the type "Marks -> x"+marks_to_xT :: Type -> Type+marks_to_xT = AppT (AppT ArrowT marksT)++normalClause :: [Pat] -> Exp -> Clause+normalClause p e = Clause p (NormalB e) []++-- make first letter lowercase+lowerFirst :: Text -> Text+lowerFirst t =+ case uncons t of+ Just (a, b) -> cons (toLower a) b+ Nothing -> t++-- make first letter uppercase+upperFirst :: Text -> Text+upperFirst t =+ case uncons t of+ Just (a, b) -> cons (toUpper a) b+ Nothing -> t++-- make a ... record name for a field, with no underscore?+recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text+recNameNoUnderscore mps dt f+ | mpsPrefixFields mps = lowerFirst (unHaskellName dt) <> upperFirst ft+ | otherwise = lowerFirst ft+ where+ ft = unHaskellName f++-- | name for a record field+--+-- If we call @recName datatypeName fieldName@+-- this returns a 'qualified field name' (i.e. data type name+-- is prepended, and the whole thing is camelCased.+--+-- i.e.+-- @+-- recName "MyType" "myfield" == "myTypeMyField"+-- @+-- (modulo name constructors).+recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text+recName mps dt f =+ addUnderscore $ recNameNoUnderscore mps dt f+ where+ addUnderscore+ | mpsGenerateLenses mps = ("_" <>)+ | otherwise = id+
+ src/Exigo/Types.hs view
@@ -0,0 +1,42 @@++{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveGeneric #-}++{- |++Types used in exigo programs.++-}++module Exigo.Types where++import Data.Aeson+import Data.Text ( Text )+import GHC.Generics+import Language.Haskell.TH.Syntax (Lift)+import Instances.TH.Lift ()++-- | a question (smallest assessable unit)+-- in an assessment+data Question = Question {+ qid :: Text -- ^ textual id, e.g. 1(a)+ , qDesc :: Text -- ^ possible descriptive text+ , qMarks :: Int -- ^ maximum marks+ }+ deriving (Eq, Show, Lift, Generic)+ -- Lift instance is so we can convert questions+ -- from "compile time" to actual values.++-- | metadata about an assessment.+data AssessmentMetadata = AssessmentMetadata {+ assessmentTitle :: Text+ , assessmentQuestions :: [Question]+ }+ deriving (Eq, Show, Lift, Generic)++instance FromJSON Question where+instance ToJSON Question where+instance FromJSON AssessmentMetadata where+instance ToJSON AssessmentMetadata where++