packages feed

hCM (empty) → 0.1.0.0

raw patch · 13 files changed

+785/−0 lines, 13 filesdep +basedep +hCMdep +hashablesetup-changed

Dependencies added: base, hCM, hashable, haskell-src

Files

+ CHANGELOG.md view
@@ -0,0 +1,16 @@+# Change Log+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/)+and this project adheres to [Semantic Versioning](http://semver.org/).++## [0.1.0.0] - 2017-05-08++First prototype of conceptual modelling support for Haskell as entry for future development and enhancements.++### Added+- Metamodel as type classes and data types provided with helper functions and validity handling+- Visualization via to DOT translation of meta level elements+++[0.1.0.0] https://github.com/MarekSuchanek/hCM/releases/tag/v0.1.0.0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Marek Suchánek (suchama4@fit.cvut.cz)++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.
+ README.md view
@@ -0,0 +1,34 @@+# hCM++*Conceptual modelling support library for Haskell.*++[![License](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)+[![Build Status](https://travis-ci.org/MarekSuchanek/hCM.svg?branch=master)](https://travis-ci.org/MarekSuchanek/hCM)++## Introduction++This library is the result of finding a suitable way how to support conceptual modelling within Haskell programming language in the most simple but smart manner. hCM should allow you to build conceptual model with Haskell freely without any restrictions about selected representation of entities, relationships and model itself.++Advantages gained by applying *hCM* are:++- **Compiler-driven modelling** = [GHC](https://www.haskell.org/ghc/) guides you through implementing conceptual model via writing instances and mandatory functions.+- **Visualization** = you can generate visualization of model and its instances (DOT format, see [Graphviz](http://www.graphviz.org))+- **Verification** = correctness of model-implementation consistency is guaranteed by using conceptual model as part of implementation (model-is-a-code)+- **Validation** = you can validate the conceptual model with domain expert thanks to visualization, instance generation (use [QuickCheck](https://hackage.haskell.org/package/QuickCheck)'s [Arbitrary](https://hackage.haskell.org/package/QuickCheck-2.9.2/docs/Test-QuickCheck-Arbitrary.html)) and easy constraint construction as pure functions++## Installation++-  Use standard Haskell way with [stack](https://www.haskellstack.org/).+-  Optionally you can use prepared [Makefile](Makefile).++## Usage++There is very simple example of trivial model within [app/Example.hs](app/Example.hs) file. For more complex example, try to check [hCM-CaseStudy](https://github.com/MarekSuchanek/hCM-CaseStudy).++If you have used this library and want to share your project, feel free to let me know via [issues](https://github.com/MarekSuchanek/hCM/issue).++Sharing **ideas** and reporting **bugs** is more than welcome as well via [issues](https://github.com/MarekSuchanek/hCM/issue)!++## License++This project is licensed under the MIT license - see the [LICENSE](LICENSE) file for more details.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Example.hs view
@@ -0,0 +1,179 @@+{-# 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]+                     }
+ app/Main.hs view
@@ -0,0 +1,15 @@+module Main where++import System.Environment++import qualified Example+import CM.Visualization+import CM.Metamodel++main :: IO ()+main = do+  --args <- getArgs+  --filecontent <- readFile . head $ args+  --putStrLn . modelToDot $ filecontent+  --putStrLn . elementToDotModel $ model+  putStrLn . modelToDotInstance $ Example.model
+ hCM.cabal view
@@ -0,0 +1,54 @@+name:                hCM+version:             0.1.0.0+synopsis:            Conceptual modelling support for Haskell+homepage:            https://github.com/MarekSuchanek/hCM+license:             MIT+license-file:        LICENSE+author:              Marek Suchánek <suchama4@fit.cvut.cz>+maintainer:          suchama4@fit.cvut.cz+description:+  hCM is the result of finding a suitable way how to support conceptual+  modelling within Haskell programming language in the most simple but smart manner.+  hCM should allow you to build conceptual model with Haskell freely without any+  restrictions about selected representation of entities, relationships and model+  itself.+copyright:           2017 Marek Suchánek+category:            Model, Development, Data Structures+build-type:          Simple+extra-source-files:  README.md stack.yaml CHANGELOG.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     CM.Metamodel+                     , CM.Visualization+                     , CM.Validity+                     , CM.Helpers+  build-depends:       base >= 4.7 && < 5+                     , haskell-src+                     , hashable+  default-language:    Haskell2010++executable hCM+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  other-modules:       Example+  build-depends:       base+                     , hCM+                     , hashable+  default-language:    Haskell2010++test-suite hCM-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , hCM+                     , hashable+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/MarekSuchanek/hCM
+ src/CM/Helpers.hs view
@@ -0,0 +1,41 @@+{-|+Module      : CM.Helpers+Description : Helper constructs for conceptual modelling+Copyright   : (c) Marek Suchánek, 2017+License     : MIT++Helper constructs for conceptual modelling that are making+modelling with library easier or can be used often in different+way.+-}+module CM.Helpers where++import CM.Metamodel+++-- |Convert 'ParticipationQuantity' to simple string representation+pquantShow :: ParticipationQuantity -> String+pquantShow (Limited x) = show x+pquantShow Unlimited = "*"+pquantShow Unique = "1"++-- |Convert 'ParticipationType' to simple string representation+ptypeShow :: ParticipationType -> String+ptypeShow pt = case pt of+              (Mandatory Unique) -> "1"+              (Optional Unique) -> "0..1"+              (Mandatory x) -> "1.." ++ pquantShow x+              (Optional x) -> "0.." ++ pquantShow x+              (Custom x y) -> pquantShow x ++ ".." ++ pquantShow y++-- |Find value of attribute with given name+findAttributeValue :: [MetaAttribute] -> String -> String+findAttributeValue [] _ = ""+findAttributeValue (x:xs) a = if a == maName x then maValue x+                                               else findAttributeValue xs a++-- |Find identifier of participant with given name+findParticipantId :: [MetaParticipation] -> String -> String+findParticipantId [] _ = ""+findParticipantId (x:xs) a = if a == mpName x then mpIdentifier x+                                              else findParticipantId xs a
+ src/CM/Metamodel.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE RecordWildCards #-}+{-|+Module      : CM.Metamodel+Description : Conceptual model metamodel+Copyright   : (c) Marek Suchánek, 2017+License     : MIT++Metamodel used to create actual models within system provides simple+way for compiler-driven modelling without restricting usage of various+Haskell constructs of structure and behavior coding.+-}+module CM.Metamodel where++import Data.Maybe+import CM.Validity++-- |Type synonym for identifier use+type Identifier = String++-- |Class encapsulating the identity principle+class (Show i) => Identifiable i where+  -- |Get identifier of element (default: show)+  identifier :: i -> Identifier+  identifier = show+  -- |Check if two elements are identic+  identic :: i -> i -> Bool+  identic x y = identifier x == identifier y++-- |Generic element of conceptual model+class (Show e, Read e) => CMElement e where+  -- |List of simple contraints (no need to know its model)+  simpleConstraints :: [e -> Validity]+  simpleConstraints = []+  -- |List of complex (model-aware) contraints+  complexConstaints :: (ConceptualModel m) => [m -> e -> Validity]+  complexConstaints = []+  -- |List of all contraints (default: simple + complex)+  constraints :: (ConceptualModel m) => m -> [e -> Validity]+  constraints model = simpleConstraints ++ map (\f -> f model) complexConstaints+  -- |Evaluate all contraints and get list of 'Validity' as result+  evalConstraints :: (ConceptualModel m) => m -> e -> [Validity]+  evalConstraints model x = map ($ x) $ constraints model+  -- |Check if element is valid (conforms all constraints)+  valid :: (ConceptualModel m) => m -> e -> Bool+  valid model x = all isValid (evalConstraints model x)+  -- |Get list of all constraints violations (empty list if valid)+  violations :: (ConceptualModel m) => m -> e -> [String]+  violations model x = mapMaybe violationMessage $ evalConstraints model x+  -- |Name of element type (default is derived by 'show')+  elementName :: e -> String+  elementName = takeWhile (/= ' ') . show+  -- |Convert element to 'MetaElement' (recommended: use functions from subclasses)+  toMeta :: (ConceptualModel m) => m -> e -> MetaElement+  -- |Optional function from converting back from 'MetaElement'+  fromMeta :: e -> MetaElement -> Maybe e+  fromMeta _ _ = Nothing++-- |Whole conceptual model class+class (CMElement a) => ConceptualModel a where+  -- |Get all elements of the model+  cmodelElements :: a -> [MetaElement]+  -- |Check whether all elements in model are valid and is valid itself+  validModel :: a -> Bool+  validModel m = validSelf && validElements+                where validSelf = valid m m+                      validElements = all metaElementValid (cmodelElements m)+  -- |Name of model type (default: 'elementName')+  cmodelName :: a -> String+  cmodelName = elementName+  -- |Convert to 'MetaModel' with use of 'cmodelName' and 'cmodelElements'+  toMetaModel :: (ConceptualModel b) => b -> a -> MetaElement+  toMetaModel _ m = MetaModel { mmName = Just $ cmodelName m+                              , mmElements = cmodelElements m+                              , mmIdentifier = Nothing+                              , mmValid = validModel m+                              }++-- |Entities for representing concepts+class (CMElement a, Identifiable a) => Entity a where+  -- |Get all attributes of the entity+  entityAttributes :: a -> [MetaAttribute]+  -- |Name of entity type (default: 'elementName')+  entityName :: a -> String+  entityName = elementName+  -- |Name of supertypes (default: '[]')+  entitySuperNames :: a -> [String]+  entitySuperNames _ = []+  -- |Names of subtypes (default: '[]')+  entitySubNames :: a -> [String]+  entitySubNames _ = []+  -- |Convert to 'MetaEntity' with use of 'entityName', 'entityAttributes' and others+  toMetaEntity :: (ConceptualModel m) => m -> a -> MetaElement+  toMetaEntity m x = MetaEntity { meName = entityName x+                                , meAttributes = entityAttributes x+                                , meIdentifier = identifier x+                                , meValid = valid m x+                                , meSuperNames = entitySuperNames x+                                , meSubNames = entitySubNames x+                                }++-- |Relationship that connects multiple entities+class (CMElement a, Identifiable a) => Relationship a where+  -- |Get all participations in the relationship+  relationshipParticipations :: a -> [MetaParticipation]+  -- |Name of relationship type (default: 'elementName')+  relationshipName :: a -> String+  relationshipName = elementName+  -- |Convert to 'MetaRelationship' with use of 'relationshipName' and 'relationshipParticipations'+  toMetaRelationship :: (ConceptualModel m) => m -> a -> MetaElement+  toMetaRelationship m x = MetaRelationship { mrName = relationshipName x+                                            , mrParticipations = relationshipParticipations x+                                            , mrIdentifier = identifier x+                                            , mrValid = valid m x+                                            }+--------------------------------------------------------------------------------+-- |Quantity of participation type+data ParticipationQuantity+  = Limited Word -- ^ Quantity limited by positive number+  | Unlimited    -- ^ Unlimited quantity (i.e. infinity)+  | Unique       -- ^ Special unique (i.e. always must be exactly 1)+  deriving (Show, Read, Eq, Ord)++-- |Type of participation (i.e. multiplicity)+data ParticipationType+  = Mandatory ParticipationQuantity                    -- ^ Type for mandatory relationship (1..N)+  | Optional ParticipationQuantity                     -- ^ Type for optional relationship (0..N)+  | Custom ParticipationQuantity ParticipationQuantity -- ^ Type for custom relationship (X..Y)+  deriving (Show, Read, Eq)++-- |Attribute representation in meta level+data MetaAttribute = MetaAttribute { maName :: String+                                   , maType :: String+                                   , maValue :: String+                                   } deriving (Show, Read, Eq)++-- |Participation representation in meta level+data MetaParticipation = MetaParticipation { mpName       :: String+                                           , mpType       :: String+                                           , mpIdentifier :: String+                                           , mpPType      :: ParticipationType+                                           } deriving (Show, Read, Eq)++-- |'CMElement' representation in meta level+data MetaElement+  -- |'Entity' representation in meta level+  = MetaEntity { meName       :: String+               , meIdentifier :: String+               , meAttributes :: [MetaAttribute]+               , meValid      :: Bool+               , meSuperNames :: [String]+               , meSubNames   :: [String]+               }+  -- |'Relationship' representation in meta level+  | MetaRelationship { mrName           :: String+                     , mrIdentifier     :: String+                     , mrParticipations :: [MetaParticipation]+                     , mrValid          :: Bool+                     }+  -- |'ConceptualModel' representation in meta level+  | MetaModel { mmName       :: Maybe String+              , mmIdentifier :: Maybe String+              , mmElements   :: [MetaElement]+              , mmValid      :: Bool+              }+  deriving (Show, Read, Eq)++-- |Get element name from any 'MetaElement'+metaElementName :: MetaElement -> String+metaElementName MetaEntity {..} = meName+metaElementName MetaRelationship {..} = mrName+metaElementName MetaModel {..} = fromMaybe "" mmName++-- |Get identifier from any 'MetaElement'+metaElementIdentifier :: MetaElement -> String+metaElementIdentifier MetaEntity {..} = meIdentifier+metaElementIdentifier MetaRelationship {..} = mrIdentifier+metaElementIdentifier MetaModel {..} = fromMaybe "" mmIdentifier++-- |Check if any 'MetaElement' is valid+metaElementValid :: MetaElement -> Bool+metaElementValid MetaEntity {..} = meValid+metaElementValid MetaRelationship {..} = mrValid+metaElementValid MetaModel {..} = mmValid++-- |Convert tuple to 'MetaAttribute'+tupleToAttribute :: (String, String, String) -> MetaAttribute+tupleToAttribute (a, b, c) = MetaAttribute {maName = a, maType = b, maValue = c}++-- |Convert tuple to 'MetaParticipation'+tupleToParticipation :: (String, String, String, ParticipationType) -> MetaParticipation+tupleToParticipation (a, b, c, t) = MetaParticipation {mpName = a, mpType = b, mpIdentifier = c, mpPType = t}++instance CMElement MetaElement where+  toMeta _ = id+  elementName MetaEntity {..} = meName+  elementName MetaRelationship {..} = mrName+  elementName MetaModel {..} = fromMaybe "" mmName++instance Identifiable MetaElement where+  identifier MetaEntity {..} = meIdentifier+  identifier MetaRelationship {..} = mrIdentifier+  identifier MetaModel {..} = fromMaybe "" mmIdentifier++instance Entity MetaElement where+  entityAttributes MetaEntity {..} =+    map tupleToAttribute+      [ ("name", "String", meName)+      , ("attributes", "[MetaAttribute]", show meAttributes)+      ]+  entityAttributes MetaRelationship {..} =+    map tupleToAttribute+      [ ("name", "String", mrName)+      , ("participants", "[MetaParticipation]", show mrParticipations)+      ]+  entityAttributes MetaModel {..} =+    map tupleToAttribute+      [ ("name", "String", fromMaybe "" mmName)+      , ("elements", "[MetaElement]", show mmElements)+      ]
+ src/CM/Validity.hs view
@@ -0,0 +1,27 @@+{-|+Module      : CM.Validity+Description : Tools for working with validity+Copyright   : (c) Marek Suchánek, 2017+License     : MIT++Constructions for working with conceptual model elements validity and+constraints.+-}+module CM.Validity where++-- |Type showing validity of some contruct (similar to 'Maybe')+data Validity = Valid | Invalid String deriving (Show, Read, Eq)++-- |Check if 'Validity' signals valid or invalid+isValid :: Validity -> Bool+isValid Valid = True+isValid _     = False++-- |Convert 'Validity' to 'Maybe' with message+violationMessage :: Validity -> Maybe String+violationMessage (Invalid msg) = Just msg+violationMessage _             = Nothing++-- |Construct constraint with boolean value and message+newConstraint :: Bool -> String -> Validity+newConstraint b msg = if b then Valid else Invalid msg
+ src/CM/Visualization.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RecordWildCards #-}+{-|+Module      : CM.Visualization+Description : Conceptual model simple visulization functions+Copyright   : (c) Marek Suchánek, 2017+License     : MIT++Conceptual model simple visulization functions via DOT format.+-}+module CM.Visualization where++import Data.Maybe+import Data.List+import Data.Hashable+import CM.Metamodel+import CM.Helpers++-- |Helper function for converting new lines to HTML.+nl2br        :: String -> String+nl2br []     = ""+nl2br (x:xs) = if x == '\n' then "<BR/>" ++ nl2br xs else x : nl2br xs++-- |Convert 'MetaElement' to DOT code fragment for the model visualization.+metaElementToDotModel :: (ConceptualModel m) => m -> MetaElement -> String+metaElementToDotModel model MetaEntity { .. } = "\"" ++ meName ++ "\" [shape=none, margin=0, label=<\n" ++ table ++ "\n>];\n" ++ supers ++ subs+  where table = start ++ header ++ rows ++ end+        start = "\t<table border=\"0\" cellborder=\"1\" cellspacing=\"0\" cellpadding=\"4\">\n"+        header = "\t\t<tr><td colspan=\"3\" bgcolor=\"lightblue\">" ++ meName ++ "</td></tr>\n"+        rows = concatMap metaAttributeToRow meAttributes+        end = "\t</table>"+        supers = intercalate "\n" . map superToModelLink $ meSuperNames+        superToModelLink x = meName ++ " -> " ++ x ++ " [arrowhead=empty];"+        subs = intercalate "\n" . map subToModelLink $ meSubNames+        subToModelLink x =  x ++ " -> " ++ meName ++ " [arrowhead=empty];"+        metaAttributeToRow MetaAttribute { .. } = "\t\t<tr><td align=\"left\">" ++ maName ++ "</td><td>::</td><td align=\"left\">" ++ maType ++ "</td></tr>\n"+metaElementToDotModel model MetaRelationship { .. } = "\"" ++ mrName ++ "\" [shape=diamond];\n" ++ participationLinks+  where participationLinks = concatMap metaParticipationToModelLink mrParticipations+        metaParticipationToModelLink MetaParticipation { .. } = "\"" ++ mrName ++ "\" -> \"" ++ mpType ++ "\" [label=\""++ mpName ++" \\n ["++ ptypeShow mpPType ++"]\"];\n"+metaElementToDotModel model MetaModel { .. } = "digraph CM_model {\n" ++ graphset ++ nodeset ++ edgeset ++ content ++ "}\n"+  where graphset = "graph[rankdir=TD, overlap=false, splines=true, label=\"" ++ fromMaybe "" mmName ++ "\"];\n"+        nodeset  = "node [shape=record, fontsize=10, fontname=\"Verdana\"];\n"+        edgeset  = "edge [arrowhead=none, fontsize=10];\n\n"+        content  =  intercalate "\n" . map (elementToDotModel model) . filterEntitiesType $ mmElements++-- |Filtering 'MetaElements' by type names, i.e. every entity type will be just once.+filterEntitiesType :: [MetaElement] -> [MetaElement]+filterEntitiesType = filterHelper []+  where filterHelper seen [] = seen+        filterHelper seen (x:xs)+          | xTypeSeen = filterHelper seen xs+          | otherwise = filterHelper (seen ++ [x]) xs+          where xTypeSeen = any (\e -> elementName x == elementName e) seen++-- |Convert element in model to DOT for model visualization.+elementToDotModel :: (ConceptualModel m, CMElement e) => m -> e -> String+elementToDotModel model element = metaElementToDotModel model (toMeta model element)++-- |Convert whole model to DOT for model visualization.+modelToDotModel :: (ConceptualModel m) => m -> String+modelToDotModel model = elementToDotModel model model++-- |Convert 'MetaElement' to DOT code fragment for the instance visualization.+metaElementToDotInstance :: (ConceptualModel m) => m -> MetaElement -> String+metaElementToDotInstance model MetaEntity { .. } = "\"" ++ dotId ++ "\" [shape=none, margin=0, label=<\n" ++ table ++ "\n>];\n"+  where table = start ++ header ++ rows ++ end+        start = "\t<table border=\"0\" cellborder=\"1\" cellspacing=\"0\" cellpadding=\"4\">\n"+        header = "\t\t<tr><td colspan=\"3\" bgcolor=\"" ++ color ++ "\"><u>" ++ displayId ++ ":" ++ meName ++ "</u></td></tr>\n"+        rows = concatMap metaAttributeToRow meAttributes+        end = "\t</table>"+        color = if meValid then "lightgreen" else "darksalmon"+        dotId = makeDotId meIdentifier+        displayId = makeDisplayId meIdentifier+        metaAttributeToRow MetaAttribute { .. } = "\t\t<tr><td align=\"left\">" ++ maName ++ "</td><td>=</td><td align=\"left\">" ++ nl2br maValue ++ "</td></tr>\n"+metaElementToDotInstance model MetaRelationship { .. } = "\"" ++ dotId ++ "\" [shape=diamond, label=<<u>" ++ displayId ++ ":" ++ mrName ++ "</u>>, style=\"filled\", fillcolor=\"" ++ color ++ "\"];\n" ++ participationLinks+  where participationLinks = concatMap metaParticipationToLink mrParticipations+        metaParticipationToLink MetaParticipation { .. } = "\"" ++ dotId ++ "\" -> \"" ++ makeDotId mpIdentifier ++ "\" [label=\"" ++ mpName ++ "\"];\n"+        dotId = makeDotId mrIdentifier+        displayId = makeDisplayId mrIdentifier+        color = if mrValid then "lightgreen" else "darksalmon"+metaElementToDotInstance model MetaModel { .. } = "digraph CM_instance {\n" ++ graphset ++ nodeset ++ edgeset ++ content ++ "}\n"+  where graphset = "graph[rankdir=TD, overlap=false, splines=true, label=<<u>" ++ fromMaybe "" mmIdentifier ++ ":" ++ fromMaybe "" mmName ++ "</u>>];\n"+        nodeset  = "node [shape=record, fontsize=10, fontname=\"Verdana\"];\n"+        edgeset  = "edge [arrowhead=none, fontsize=10];\n\n"+        content  =  intercalate "\n" . map (metaElementToDotInstance model) . filterEntitiesInstance $ mmElements++-- |Create DOT identifier based on given string.+makeDotId :: String -> String+makeDotId s = if length s > 20 then "h" ++ (show . hash $ s) else s++-- |Create showable identifier based on given string.+makeDisplayId :: String -> String+makeDisplayId s = if length s > 20 then "" else s++-- |Filtering 'MetaElements' by identifier, i.e. every instance will be just once.+filterEntitiesInstance :: [MetaElement] -> [MetaElement]+filterEntitiesInstance = filterHelper []+  where filterHelper seen [] = seen+        filterHelper seen (x:xs)+          | xTypeSeen = filterHelper seen xs+          | otherwise = filterHelper (seen ++ [x]) xs+          where xTypeSeen = any (\e -> identifier x == identifier e) seen++-- |Convert element in model to DOT for instance visualization.+elementToDotInstance :: (ConceptualModel m, CMElement e) => m -> e -> String+elementToDotInstance model element = metaElementToDotInstance model (toMeta model element)++-- |Convert whole model to DOT for instance visualization.+modelToDotInstance :: (ConceptualModel m) => m -> String+modelToDotInstance model = elementToDotInstance model model
+ stack.yaml view
@@ -0,0 +1,66 @@+# This file was automatically generated by 'stack init'+#+# Some commonly used options have been documented as comments in this file.+# For advanced use and comprehensive documentation of the format, please see:+# http://docs.haskellstack.org/en/stable/yaml_configuration/++# Resolver to choose a 'specific' stackage snapshot or a compiler version.+# A snapshot resolver dictates the compiler version and the set of packages+# to be used for project dependencies. For example:+#+# resolver: lts-3.5+# resolver: nightly-2015-09-21+# resolver: ghc-7.10.2+# resolver: ghcjs-0.1.0_ghc-7.10.2+# resolver:+#  name: custom-snapshot+#  location: "./custom-snapshot.yaml"+resolver: lts-8.8++# User packages to be built.+# Various formats can be used as shown in the example below.+#+# packages:+# - some-directory+# - https://example.com/foo/bar/baz-0.0.2.tar.gz+# - location:+#    git: https://github.com/commercialhaskell/stack.git+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a+#   extra-dep: true+#  subdirs:+#  - auto-update+#  - wai+#+# A package marked 'extra-dep: true' will only be built if demanded by a+# non-dependency (i.e. a user package), and its test suites and benchmarks+# will not be run. This is useful for tweaking upstream packages.+packages:+- '.'+# Dependency packages to be pulled from upstream that are not in the resolver+# (e.g., acme-missiles-0.3)+extra-deps: []++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true+#+# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: ">=1.4"+#+# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64+#+# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]+#+# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"