diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for exigo-schema + +## Unreleased changes + +## 0.1.0.0 + +- initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + 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/config/exigo.persistentmodels b/config/exigo.persistentmodels new file mode 100644 --- /dev/null +++ b/config/exigo.persistentmodels @@ -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 + diff --git a/exigo-schema.cabal b/exigo-schema.cabal new file mode 100644 --- /dev/null +++ b/exigo-schema.cabal @@ -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 +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 + diff --git a/src/Exigo/Persistent/Schema.hs b/src/Exigo/Persistent/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Exigo/Persistent/Schema.hs @@ -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 + diff --git a/src/Exigo/Persistent/TH.hs b/src/Exigo/Persistent/TH.hs new file mode 100644 --- /dev/null +++ b/src/Exigo/Persistent/TH.hs @@ -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 + diff --git a/src/Exigo/Persistent/TH/Internal.hs b/src/Exigo/Persistent/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Exigo/Persistent/TH/Internal.hs @@ -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 + diff --git a/src/Exigo/Types.hs b/src/Exigo/Types.hs new file mode 100644 --- /dev/null +++ b/src/Exigo/Types.hs @@ -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 + +