hCM-0.1.0.0: app/Example.hs

{-# LANGUAGE RecordWildCards #-}

module Example where

import Data.Maybe

import CM.Metamodel
import CM.Visualization
import CM.Validity
import CM.Helpers

wrapString :: String -> String
wrapString x = "\"" ++ x ++ "\""

shortenString :: String -> String
shortenString x = if length x < 35 then x else take 32 x ++ "..."

toInts :: [String] -> [Int]
toInts = map read

data Student = Student { stUsername :: String
                       , stFirstname :: String
                       , stLastname :: String
                       }
             deriving (Show, Read)

instance Identifiable Student where
  identifier = stUsername

instance CMElement Student where
  toMeta = toMetaEntity

instance Entity Student where
  entityAttributes Student {..} =
    map tupleToAttribute
      [ ("username", "String", wrapString stUsername)
      , ("firstname", "String", wrapString stFirstname)
      , ("lastname", "String", wrapString stLastname)
      , ("email", "String", wrapString $ stUsername ++ "@fit.cvut.cz")
      ]

data Course = Course { crsCode :: String
                     , crsCredits :: Int
                     , crsName :: String
                     , crsDesc :: String
                     }
           deriving (Show, Read)

instance Identifiable Course where
  identifier = crsCode

creditsNonNegative :: Course -> Validity
creditsNonNegative Course {..} =
  newConstraint (crsCredits >= 0) "Negative credits"

instance CMElement Course where
  toMeta = toMetaEntity
  simpleConstraints = [creditsNonNegative]

instance Entity Course where
  entityAttributes Course {..} =
    map tupleToAttribute
      [ ("code", "String", wrapString crsCode)
      , ("name", "String", wrapString crsName)
      , ("credits", "Int", show crsCredits)
      , ("descrition", "String", wrapString . shortenString $ crsDesc)
      ]

data Enrollment = Enrollment { enrlSince :: (Int, Int, Int)
                             , enrlUntil :: Maybe (Int, Int, Int)
                             }
               deriving (Show, Read)

instance Identifiable Enrollment

toDateStr :: (Int, Int, Int) -> String
toDateStr (d,m,y) = show d ++ "/" ++ show m ++ "/" ++ show y

sinceBeforeUntil :: Enrollment -> Validity
sinceBeforeUntil Enrollment {enrlUntil = Nothing, ..} = Valid
sinceBeforeUntil Enrollment {enrlSince = a, enrlUntil = Just b} =
  newConstraint (a < b) "Since is not before until"

instance CMElement Enrollment where
  toMeta = toMetaEntity
  simpleConstraints = [sinceBeforeUntil]

instance Entity Enrollment where
  entityAttributes Enrollment {..} =
    map tupleToAttribute
      [ ("since", "DateTime", toDateStr enrlSince)
      , ("until", "Maybe DateTime", maybe "N/A" toDateStr enrlUntil)
      ]

data IsEnrolled = IsEnrolled { ieWho :: Student
                             , ieWhat :: Course
                             , ieTruth :: Enrollment
                             }
                deriving (Show, Read)

instance Identifiable IsEnrolled

max2Enrollments :: (ConceptualModel m) => m -> IsEnrolled -> Validity
max2Enrollments model r =
  newConstraint (same <= 2) "Student can enroll same course only twice"
  where same = length . filter areSame $ enrolledRelationships
        areSame e = (sameCourse e) && (sameStudent e)
        sameCourse e = (getCourseId e) == (identifier . ieWhat $ r)
        sameStudent e = (getStudentId e) == (identifier . ieWho $ r)
        enrolledRelationships = filter isIsEnrolled $ cmodelElements model
        getCourseId MetaRelationship {..} = findParticipantId mrParticipations "Course"
        getCourseId _ = ""
        getStudentId MetaRelationship {..} = findParticipantId mrParticipations "Student"
        getStudentId _ = ""
        isIsEnrolled MetaRelationship {mrName = "IsEnrolled", ..} = True
        isIsEnrolled _ = False

instance CMElement IsEnrolled where
  toMeta = toMetaRelationship
  complexConstaints = [max2Enrollments]

instance Relationship IsEnrolled where
  relationshipName _ = "enrolled"
  relationshipParticipations IsEnrolled {..} =
    map tupleToParticipation
      [ ("who", "Student", identifier ieWho, Optional Unlimited)
      , ("what", "Course", identifier ieWhat, Optional Unlimited)
      , ("truthmaker", "Enrollment", identifier ieTruth, Mandatory Unique)
      ]

studM = Student { stUsername = "suchama4"
                , stFirstname = "Marek"
                , stLastname = "Suchánek"
                }

courseDIP = Course { crsCode = "MI-DIP"
                   , crsCredits = 23
                   , crsName = "Diploma Project"
                   , crsDesc = ""
                   }

courseRRI = Course { crsCode = "MI-RRI.0"
                   , crsCredits = -5
                   , crsName = "Risk Management in Informatics"
                   , crsDesc = "Information security is very often considered as one of main objectives to secure targets of information processing. "
                   }

enrlMxDIP = Enrollment { enrlSince = (20,2,2017)
                       , enrlUntil = Just (1,6,2016)
                       }

enrlMxRRI = Enrollment { enrlSince = (20,2,2017)
                       , enrlUntil = Nothing
                       }

ienrlMxDIP = IsEnrolled { ieWho = studM, ieWhat = courseDIP, ieTruth = enrlMxDIP }
ienrlMxRRI = IsEnrolled { ieWho = studM, ieWhat = courseRRI, ieTruth = enrlMxRRI }

data ExampleModel = ExampleModel { mStudents :: [Student]
                                 , mCourses :: [Course]
                                 , mEnrollments :: [Enrollment]
                                 , mIsEnrolled :: [IsEnrolled]
                                 }
                  deriving (Show, Read)

instance CMElement ExampleModel where
  toMeta = toMetaModel

instance ConceptualModel ExampleModel where
  cmodelElements m = (map (toMeta m) $ mStudents m)
                  ++ (map (toMeta m) $ mCourses m)
                  ++ (map (toMeta m) $ mEnrollments m)
                  ++ (map (toMeta m) $ mIsEnrolled m)

model = ExampleModel { mStudents = [studM]
                     , mCourses = [courseDIP, courseRRI]
                     , mEnrollments = [enrlMxDIP, enrlMxRRI]
                     , mIsEnrolled = [ienrlMxDIP, ienrlMxRRI]
                     }