packages feed

HaskellAnalysisProgram (empty) → 0.1.0

raw patch · 48 files changed

+3478/−0 lines, 48 filesdep +HUnitdep +basedep +bytestringsetup-changed

Dependencies added: HUnit, base, bytestring, cassava, containers, csv, directory, fgl, filepath, graphviz, haskell-src-exts, pretty, split, syb, text, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,4 @@+# Changelog for HaskellAnalysisProgram++## v 0.1.0+First public release.
+ HaskellAnalysisProgram.cabal view
@@ -0,0 +1,165 @@+cabal-version: 1.12++name:           HaskellAnalysisProgram+version:        0.1.0+synopsis:       Haskell source code analysis program+description:+                The Haskell analysis program is a prototype Haskell source code analyzer.+                It offers functionality to convert Haskell source code into an equivalent meta-model.+                It supports the calculation of three structural metrics, module size (LOC), module cohesion (LCOM)+                and module coupling (CBO).+                Several aggregation methods are supported, such as average, median,+                Gini coefficient and ideal value deviation.++category:       Source Code Analysis+homepage:       https://SaKa1979@bitbucket.org/SaKa1979/haskellanalysisprogram#readme+bug-reports:    https://SaKa1979@bitbucket.org/SaKa1979/haskellanalysisprogram/issues+author:         Henrie Vos, Sander Kamps+maintainer:     sanderkamps79@gmail.com+copyright:      2019 Sander Kamps+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://SaKa1979@bitbucket.org/SaKa1979/haskellanalysisprogram++executable HaskellAnalysisProgram+  main-is: Main.hs+  other-modules:+      Analyse+      CsvData+      FileOperation+      MetaHS.DataModel.Extractor.Module.Contains+      MetaHS.DataModel.Extractor.Module.Imports+      MetaHS.DataModel.Extractor.Module.Source+      MetaHS.DataModel.Extractor.Module.Uses+      MetaHS.DataModel.Extractor.Program.Contains+      MetaHS.DataModel.MetaModel+      MetaHS.DataModel.Utils+      MetaHS.DataModel.Utils.File.FileUtils+      MetaHS.DataModel.Utils.Find+      MetaHS.DataModel.Utils.Language.Haskell.Exts.SrcLoc+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.ConDecl+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Decl+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.DeclHead+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName+      MetaHS.DataModel.Utils.Name+      MetaHS.DataModel.Utils.NameResolution+      MetaHS.EDSL+      MetaHS.EDSL.Graph+      MetaHS.EDSL.Graph.Types+      MetaHS.EDSL.Graph.UsesGraph+      MetaHS.EDSL.Graph.Utils+      MetaHS.EDSL.MetaModel+      MetaHS.EDSL.Utils+      MetaHS.Extensions.CBO+      MetaHS.Extensions.LCOM+      MetaHS.Extensions.LOC+      MetaHS.Extensions.MacroLevelAggregation.Average+      MetaHS.Extensions.MacroLevelAggregation.Distribution+      MetaHS.Extensions.MacroLevelAggregation.GiniCoefficient+      MetaHS.Extensions.MacroLevelAggregation.IdealValueDeviation+      MetaHS.Extensions.MacroLevelAggregation.Median+      MetaHS.Extensions.MacroLevelAggregation.Population+      MetaHS.Extensions.MacroLevelAggregation.Utils+      ModuleLevelAnalysis+      ProgramLevelAnalysis+      Settings+      Paths_HaskellAnalysisProgram+  hs-source-dirs:+      src+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.9.1 && <5+    , bytestring >=0.10 && <0.11+    , cassava >=0.5 && <0.6+    , containers >=0.6 && <0.7+    , csv >=0.1.2 && <0.2+    , directory >=1.3 && <1.4+    , fgl >=5.7 && <5.8+    , filepath >=1.4.1 && <1.5+    , graphviz >=2999.20.0 && <2999.21+    , haskell-src-exts >=1.20 && <1.21+    , pretty >=1.1.3 && <1.2+    , split >=0.2.3 && <0.3+    , syb >=0.7 && <0.8+    , text >=1.2.3 && <1.3+    , vector >=0.12.0 && <0.13+  default-language: Haskell2010++test-suite test-metahs+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Analyse+      CsvData+      FileOperation+      Main+      MetaHS.DataModel.Extractor.Module.Contains+      MetaHS.DataModel.Extractor.Module.Imports+      MetaHS.DataModel.Extractor.Module.Source+      MetaHS.DataModel.Extractor.Module.Uses+      MetaHS.DataModel.Extractor.Program.Contains+      MetaHS.DataModel.MetaModel+      MetaHS.DataModel.Utils+      MetaHS.DataModel.Utils.File.FileUtils+      MetaHS.DataModel.Utils.Find+      MetaHS.DataModel.Utils.Language.Haskell.Exts.SrcLoc+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.ConDecl+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Decl+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.DeclHead+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name+      MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName+      MetaHS.DataModel.Utils.Name+      MetaHS.DataModel.Utils.NameResolution+      MetaHS.EDSL+      MetaHS.EDSL.Graph+      MetaHS.EDSL.Graph.Types+      MetaHS.EDSL.Graph.UsesGraph+      MetaHS.EDSL.Graph.Utils+      MetaHS.EDSL.MetaModel+      MetaHS.EDSL.Utils+      MetaHS.Extensions.CBO+      MetaHS.Extensions.LCOM+      MetaHS.Extensions.LOC+      MetaHS.Extensions.MacroLevelAggregation.Average+      MetaHS.Extensions.MacroLevelAggregation.Distribution+      MetaHS.Extensions.MacroLevelAggregation.GiniCoefficient+      MetaHS.Extensions.MacroLevelAggregation.IdealValueDeviation+      MetaHS.Extensions.MacroLevelAggregation.Median+      MetaHS.Extensions.MacroLevelAggregation.Population+      MetaHS.Extensions.MacroLevelAggregation.Utils+      ModuleLevelAnalysis+      ProgramLevelAnalysis+      Settings+      Paths_HaskellAnalysisProgram+  hs-source-dirs:+      test+      src+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      HUnit+    , base >=4.9.1 && <5+    , bytestring >=0.10.8 && <0.11+    , cassava >=0.5.1 && <0.6+    , containers >=0.6 && <0.7+    , csv >=0.1.2 && <0.2+    , directory >=1.3.0 && <1.4+    , fgl >=5.7.0 && <5.8+    , filepath >=1.4.1 && <1.5+    , graphviz >=2999.20.0 && <2999.21+    , haskell-src-exts >=1.20 && <1.21+    , pretty >=1.1.3 && <1.2+    , split >=0.2.3 && <0.3+    , syb >=0.7 && <0.8+    , text >=1.2.3 && <1.3+    , vector >=0.12.0 && <0.13+  default-language: Haskell2010
+ LICENSE view
@@ -0,0 +1,53 @@+Apache License++Version 2.0, January 2004++http://www.apache.org/licenses/++TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++1. Definitions.++"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document.++"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License.++"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity.++"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License.++"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files.++"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types.++"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below).++"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof.++"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution."++"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work.++2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form.++3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed.++4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions:++You must give any other recipients of the Work or Derivative Works a copy of this License; and+You must cause any modified files to carry prominent notices stating that You changed the files; and+You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and+If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License.++You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License.+5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions.++6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License.++8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages.++9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability.++END OF TERMS AND CONDITIONS
+ README.md view
@@ -0,0 +1,22 @@+DESCRIPTION:+The Haskell analysis program is a prototype Haskell source code analyzer. +It offers functionality to convert Haskell source code into an equivalent meta-model. +It supports the calculation of three structural metrics, module size (LOC), module cohesion (LCOM) and module coupling (CBO). +Several aggregation methods are supported, such as average, median, Gini coefficient and ideal value deviation.++This software is developed as part of the research described in the paper+"Assessing the quality of evolving Haskell systems by measuring structural inequality",+published in the proceedings of the ACM SIGPLAN Haskell Symposium 2020 conference.+https://doi.org/10.1145/3406088.3409014++EXECUTABLE:+Currently the application 'looks' for the project-to-analyse in the <project-root>/dataset/input folder. Therefore, the HaskellAnalysisProgram executable must be run from the <project-root> location. The project-to-analyse must be entered into the <project-root>/dataset/input folder. The analysis start by calling; HaskellAnalysisProgram <project-to-analyse> (e.g., HaskellAnalysisProgram programX).+Run HaskellAnalysisProgram without arguments to see the various options to use the HaskellAnalysisProgram.++AUTHORS:+Henrie Vos+Sander Kamps++CREDITS:+Bastiaan Heeren+
+ Setup.hs view
@@ -0,0 +1,1 @@+main = defaultMain
+ src/Analyse.hs view
@@ -0,0 +1,136 @@+{-|+Module      : Analyse+Description : Main test module for program analysis+Copyright   : Copyright (C) 2019 S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}+module Analyse+    (analyse+    ) where++import qualified Control.Monad              as Monad+import           CsvData+import qualified Data.Set                   as Set+import           FileOperation+import qualified MetaHS.DataModel.MetaModel as MetaModel+import           MetaHS.EDSL+import           MetaHS.Extensions.CBO+import           MetaHS.Extensions.LCOM+import           MetaHS.Extensions.LOC+import qualified ModuleLevelAnalysis        as ModuleLevel+import qualified ProgramLevelAnalysis       as ProgramLevel+import           Settings+import           System.Directory           (createDirectory,+                                             doesDirectoryExist, doesFileExist,+                                             removeDirectoryRecursive,+                                             removeFile)+import           System.FilePath.Posix      ((</>))+import           Text.Printf++-- | Start analysis based on the type of required information.+-- | Type of analysis is either Evolution or Distribution.+-- | Type of metric is either LCOM, LOC or CBO+analyse :: Settings  -- ^ The settings required for the Implementation Under Test.+        -> IO ()+analyse settings@(Settings  _ _ _ Evolution LCOM) = do+  setupOutputDirectory settings+  metaModel <- generate settings+  let metaModelCompl = lcomAggregator metaModel+  analyseEvo settings metaModelCompl+analyse settings@(Settings  _ _ _ Evolution CBO) = do+  setupOutputDirectory settings+  metaModel <- generate settings+  let metaModelCompl = cboAggregator metaModel+  analyseEvo settings metaModelCompl+analyse settings@(Settings  _ _ _ Evolution LOC) = do+  setupOutputDirectory settings+  metaModel <- generate settings+  let metaModelCompl = locAggregator metaModel+  analyseEvo settings metaModelCompl++analyse settings@(Settings  _ _ _ Distribution LCOM) = do+  setupOutputDirectory settings+  metaModel <- generate settings+  let metaModelCompl = lcomAggregator metaModel+  analyseDist settings metaModelCompl+analyse settings@(Settings  _ _ _ Distribution CBO) = do+  setupOutputDirectory settings+  metaModel <- generate settings+  let metaModelCompl = cboAggregator metaModel+  analyseDist settings metaModelCompl+analyse settings@(Settings  _ _ _ Distribution LOC) = do+  setupOutputDirectory settings+  metaModel <- generate settings+  let metaModelCompl = locAggregator metaModel+  analyseDist settings metaModelCompl++-- | Analysis for information on program level. For instance to plot package evolution.+analyseEvo :: Settings  -- ^ The settings required for the Implementation Under Test.+           -> MetaModel.MetaModel -- ^ Metamodel complemented with specific metric+           -> IO ()+analyseEvo settings mm = do+  let iutName = programName settings+  let metricName = show $ metricType settings+  let id = versionHashId settings++  let avg =     ProgramLevel.calculateAverage id metricName mm+  let median =  ProgramLevel.calculateMedian id metricName mm+  let gini =    ProgramLevel.calculateGiniCoefficient id metricName mm+  let cg =      ProgramLevel.calculateCG id metricName mm+  let ivd =     ProgramLevel.calculateIvd id (metricType settings) mm+  let cgTimesIvd = ivd * cg+  let metricDetailInfo = ModuleLevel.extractMetricData id metricName mm++  appendItemToFile settings ((iutName ++ "_" ++ metricName) ++ "_Detailinfo") metricDetailInfo+  appendItemToFile settings ((iutName ++ "_" ++ metricName) ++ "_Average") [avg]+  appendItemToFile settings ((iutName ++ "_" ++ metricName) ++ "_Median") [median]+  appendItemToFile settings ((iutName ++ "_" ++ metricName) ++ "_Gini") [gini]+  appendItemToFile settings ((iutName ++ "_" ++ metricName) ++ "_CG") [cg]+  appendItemToFile settings ((iutName ++ "_" ++ metricName) ++ "_IVD") [ivd]+  appendItemToFile settings ((iutName ++ "_" ++ metricName) ++ "_CgTimesIvd") [cgTimesIvd]++  printf "Analysis output located in  %s\n" $ show $ outputDirectory settings+  return ()++-- | Analysis for information about metric's module distribution.+analyseDist :: Settings  -- ^ The settings required for the Implementation Under Test.+           -> MetaModel.MetaModel -- ^ Metamodel complemented with specific metric+           -> IO ()+analyseDist settings mm = do+  setupOutputDirectory settings++  let metricName = show $ metricType settings+  printf "Analysing %s.\n" metricName+  printf "\n"+  writeMetaModeltoFile settings mm+  let distList = ProgramLevel.calculateDistribution (commitHash settings) metricName mm+  let popList = ProgramLevel.calculatePopulation (commitHash settings) metricName mm+  mapM_ (f settings) distList+  mapM_ (g settings) popList+  printf "Analysis output located in  %s\n" $ show $ outputDirectory settings+  return ()++-- | helper for writing distribution to .csv file.+f :: Settings -> (Int,Int) -> IO ()+f s x = do+  let z = DistPair x+  appendDistToFile s ("Distribution " ++ show (metricType s)) z++  -- | helper for writing population to .csv file.+g :: Settings -> Int -> IO ()+g s x = do+  appendPopToFile s ("population " ++ show (metricType s)) x++-- | Generates the MetaModel based on the provided Settings.+generate :: Settings                -- ^ The settings required for the Implementation Under Test.+         -> IO MetaModel.MetaModel  -- ^ The generated MetaModel.+generate settings = generateMetaModel pn sd pef+  where+    pn = programName settings+    sd = sourcesDirectory settings+    pef = parseErrorsFile settings++versionHashId :: Settings -> String+versionHashId s = version s ++ "," ++ commitHash s
+ src/CsvData.hs view
@@ -0,0 +1,208 @@+{-|+Module      : CsvData+Description : Writing to csv file format+Copyright   : Copyright (C) 2019 S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}+{-# LANGUAGE OverloadedStrings #-}++module CsvData+  (encodeItemsToFile+  ,appendItemToFile+  ,appendDistToFile+  ,appendPopToFile+  ,MetricInfo (..)+  ,DistPair (..)+  )+  where++-- bytestring+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteString+import FileOperation+-- cassava+import Data.Csv+  ( DefaultOrdered(headerOrder)+  , Header+  , ToField(toField)+  , ToNamedRecord(toNamedRecord)+  , ToRecord (toRecord)+  , (.:)+  , (.=)+  )+import qualified Data.Csv as Cassava+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEnc+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Settings (Settings)++-- | Contains the metric information+data MetricInfo = MetricInfo+    { identifier :: !String  -- ^ The unique identifier of this data (TODO would be nice if this could be a list)+    , relationKey :: !String -- ^ The key to this specific metric relation (E.g., LCOM)+    , value :: !Double       -- ^ The actual value associated with the identifier.+    } deriving (Show)++instance Num MetricInfo where+  (MetricInfo id1 k1 v1) * (MetricInfo _ _ v2) = MetricInfo id1 k1 (v1 * v2)++newtype DistPair = DistPair { getPair :: (Int, Int) }+  deriving (Show)++---------------------------cassava instances metric info on program level++instance ToRecord MetricInfo where+  toRecord (MetricInfo identifier relationKey value) =+    Cassava.record+      [ toField identifier+      , toField relationKey+      , toField value+      ]++instance ToNamedRecord MetricInfo where+  toNamedRecord (MetricInfo identifier relationKey value) =+    Cassava.namedRecord+      [ "Id" .= Text.pack identifier+      , "Metric" .= Text.pack relationKey+      , "Value" .= value+      ]++instance DefaultOrdered MetricInfo where+  headerOrder _ =+    Cassava.header+      [ "Id"+      , "Metric"+      , "Value"+      ]+---------------------------encode metric info on program level++-- | encode MetricInfo item to csv formatted ByteSting without header+encodeItems :: [MetricInfo]+            -> ByteString+encodeItems = Cassava.encode++-- | encode MetricInfo item to csv formatted ByteSting with header+encodeHeaderItems :: [MetricInfo]+                  -> ByteString+encodeHeaderItems = Cassava.encodeDefaultOrderedByName++-- | Creates a new file and writes supplied MetricInfo data.+encodeItemsToFile+  :: Settings     -- ^ File system settings.+  -> String       -- ^ A name. E.g., LCOM, Gini+  -> [MetricInfo] -- ^ Contains the metric information+  -> IO ()+encodeItemsToFile settings metricName mis = do+  let outputFile = metricOutputFile settings metricName+  ByteString.writeFile outputFile $ encodeHeaderItems mis++-- | Append MetricInfo to file. If supplied file does not exist, one will be created.+appendItemToFile+  :: Settings     -- ^ File system settings.+  -> String       -- ^ A name. E.g., LCOM, Gini+  -> [MetricInfo] -- ^ Contains the metric information+  -> IO ()+appendItemToFile settings metricName mi = do+  let outputFile = metricOutputFile settings metricName+  ft <- isFileThere outputFile+  if ft+    then ByteString.appendFile outputFile $ encodeItems mi+    else ByteString.writeFile outputFile $ encodeHeaderItems mi++---------------------------cassava instances metric distribution++instance ToNamedRecord DistPair where+  toNamedRecord pair =+    Cassava.namedRecord+      [ "Frequentie" .= fst (getPair pair)+      , "Value" .= snd (getPair pair)+      ]++instance DefaultOrdered DistPair where+  headerOrder _ =+    Cassava.header+      [ "Frequentie"+      , "Value"+      ]++instance ToRecord DistPair where+  toRecord pair =+    Cassava.record+      [toField (fst $ getPair pair)+      ,toField (snd $ getPair pair)+      ]++---------------------------encode metric distribution++-- | encode DistPair item to csv formatted ByteSting without header+encodeDist :: [DistPair]+            -> ByteString+encodeDist = Cassava.encode++-- | encode DistPair item to csv formatted ByteSting with header+encodeHeaderDist :: [DistPair]+                  -> ByteString+encodeHeaderDist = Cassava.encodeDefaultOrderedByName++-- | Creates a new file and writes supplied DistInfo data.+encodeDistToFile+  :: Settings -- ^ File system settings.+  -> String   -- ^ A name. E.g., LCOM, CBO, LOC+  -> DistPair -- ^ Contains the metric distribution information+  -> IO ()+encodeDistToFile settings metricName dis = do+  let outputFile = metricOutputFile settings metricName+  ByteString.writeFile outputFile $ encodeHeaderDist [dis]++-- | Append DistInfo to file. If supplied file does not exist, one will be created.+appendDistToFile+  :: Settings -- ^ File system settings.+  -> String   -- ^ A name. E.g., LCOM, CBO, LOC+  -> DistPair -- ^ Contains the metric distribution information+  -> IO ()+appendDistToFile settings metricName di = do+  let outputFile = metricOutputFile settings metricName+  ft <- isFileThere outputFile+  if ft+    then ByteString.appendFile outputFile $ encodeDist [di]+    else ByteString.writeFile outputFile $ encodeHeaderDist [di]++---------------------------cassava instances metric population++instance ToRecord Int where+  toRecord v =+    Cassava.record+      [toField v]++---------------------------encode metric population++-- | encode Int item to csv formatted ByteSting without header+encodePop :: [Int]+            -> ByteString+encodePop = Cassava.encode++-- | Creates a new file and writes supplied Int data.+encodePopToFile+  :: Settings -- ^ File system settings.+  -> String   -- ^ A name. E.g., LCOM, CBO, LOC+  -> Int   -- ^ Contains the metric metric value+  -> IO ()+encodePopToFile settings metricName pop = do+  let outputFile = metricOutputFile settings metricName+  ByteString.writeFile outputFile $ encodePop [pop]++-- | Append Int to file. If supplied file does not exist, one will be created.+appendPopToFile+  :: Settings -- ^ File system settings.+  -> String   -- ^ A name. E.g., LCOM, CBO, LOC+  -> Int -- ^ Contains the metric value+  -> IO ()+appendPopToFile settings metricName pop = do+  let outputFile = metricOutputFile settings metricName+  ft <- isFileThere outputFile+  if ft+    then ByteString.appendFile outputFile $ encodePop [pop]+    else ByteString.writeFile outputFile $ encodePop [pop]
+ src/FileOperation.hs view
@@ -0,0 +1,122 @@+{-|+Module      : FileOperation+Description : For operations regarding file system io+Copyright   : Copyright (C) 2019 S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}++module FileOperation+  where++import Control.Monad (when, forM, forM_)+import System.FilePath.Posix ((</>))+import System.Directory (doesDirectoryExist, removeDirectoryRecursive ,createDirectory, doesFileExist, removeFile)++import Settings++import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.EDSL.MetaModel (writeMetaModel, writeMetaModelPretty, readMetaModel)++-- | Cleans the output directory based on the provided Settings.+mrproper :: Settings -- ^ IUT settings.+          -> IO ()   -- ^ Nothing is returned.+mrproper settings = do+    do+        let d = outputDirectory settings+        needsRemoval <- doesDirectoryExist d+        Control.Monad.when needsRemoval $ removeDirectoryRecursive d++    createDirectory $ outputDirectory settings+    return ()++-- | Checks whether the analysis output directory exists. If not it will be created.+setupOutputDirectory :: Settings -- ^ IUT settings.+                     -> IO ()+setupOutputDirectory settings = do+  let d = outputDirectory settings+  mkdir <- doesDirectoryExist d+  if mkdir+    then return ()+    else createDirectory $ outputDirectory settings+  return ()++-- | Checks whether the file exists.+isFileThere :: FilePath -- ^ IUT settings.+            -> IO Bool+isFileThere filePath = do+  let f = filePath+  needsRemoval <- doesFileExist f+  if needsRemoval+    then return True+    else return False+++-- | Stores the MetaModel to two files based on the provided Settings.+writeMetaModeltoFile :: Settings               -- ^ File system settings.+                        -> MetaModel.MetaModel -- ^ The MetaModel to write.+                        -> IO ()               -- ^ Nothing is returned.+writeMetaModeltoFile settings metaModel = do+    writeMetaModel metaModel $ metaModelFile settings+    writeMetaModelPretty metaModel $ metaModelPrettyFile settings+    return ()+++-- | Reads the MetaModel from a file based on the provided Settings.+readMetaModelFromFile :: Settings                -- ^ File system settings.+                      -> IO MetaModel.MetaModel  -- ^ The MetaModel.+readMetaModelFromFile settings = readMetaModel $ metaModelFile settings+++-- | Returns the project directory.+datasetDirectory :: FilePath  -- ^ The FilePath for the projects directory.+datasetDirectory  = "dataset"+++-- | Returns the input directory for the implementation-under-test based on the provided Settings.+inputDirectory :: Settings    -- ^ File system settings.+                 -> FilePath  -- ^ The FilePath for the projects directory.+inputDirectory settings =+    datasetDirectory </> "inputIUT" </> programName settings+++-- | Determines the FilePath for the implementation-under-test sources directory.+sourcesDirectory :: Settings  -- ^ File system settings.+                 -> FilePath  -- ^ The FilePath for the sources sub-directory of the projects directory.+sourcesDirectory = inputDirectory -- </> sourceSubDirectory settings+++-- | Determines the FilePath for the graphs output directory.+outputDirectory :: Settings -- ^ File system settings.+                -> FilePath -- ^ The FilePath for the output directory.+outputDirectory settings =+    datasetDirectory </> "outputIUT" </> programName settings+++-- | Determines the FilePath for the MetaModel file.+metaModelFile :: Settings -- ^ File system settings.+              -> FilePath -- ^ The FilePath for the MetaModel file.+metaModelFile settings =+    outputDirectory settings </> "metaModel.txt"+++-- | Determines the FilePath for the pretty printed MetaModel file.+metaModelPrettyFile :: Settings -- ^ File system settings.+                    -> FilePath -- ^ The FilePath for the pretty printed MetaModel file.+metaModelPrettyFile settings =+    outputDirectory settings </> "metaModel_pretty.txt"+++-- | Determines the FilePath for the parse error file.+parseErrorsFile :: Settings -- ^ File system settings.+                -> FilePath -- ^ The FilePath for the parse errors file.+parseErrorsFile settings =+    outputDirectory settings </> "parseErrors.txt"++-- | Determines the FilePath for the metric data file.+metricOutputFile :: Settings -- ^ File system settings.+                 -> String   -- ^ Metrics's name (aka key)+                 -> FilePath -- ^ The FilePath for the metric data file.+metricOutputFile settings metricName =+    outputDirectory settings </> metricName ++ ".csv"
+ src/Main.hs view
@@ -0,0 +1,35 @@+{-|+Module      : Main+Description : Main module for compilation.+Copyright   : Copyright (C) 2019 S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}+module Main+    where++import Settings+import Analyse+import FileOperation+import Text.Printf++-- | Settings for the Implementation Under Test.+runSettings :: String ->+                    String ->+                    String ->+                    AnalysisType ->+                    MetricType ->+                    Settings+runSettings programName version commitHash analysisType metricType =+  Settings+    { programName = programName+    , version = version+    , commitHash = commitHash+    , analysis = analysisType+    , metricType = metricType+    }++-- | Main function for profiling purposes.+main :: IO ()+main = getSettings >>= analyse
+ src/MetaHS/DataModel/Extractor/Module/Contains.hs view
@@ -0,0 +1,194 @@+{-|+Module      : MetaHS.DataModel.Extractor.Module.Contains+Description : The MetaHS extractor for contains relations+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS extractor for module level contains relations+-}+module MetaHS.DataModel.Extractor.Module.Contains+    ( contains+    ) where++import Data.Set (fromList, empty)+import Language.Haskell.Exts+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.DataModel.Utils+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module+    as Module+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Decl+    as Decl+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName+    as QName+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.DeclHead+    as DeclHead++-- | Create MetaModel.Relations for top-level declarations of a module.+contains :: Module SrcSpanInfo  -- ^ The module to analyze+         -> MetaModel.Relation  -- ^ list of Element `Contains` Element+contains m = case Module.name m of+  Just mn -> fromList $ mlhr ++ mli ++ mle ++ dlr+    where+      mlhr = containsModuleHead mn m                                          -- mlhr = ModuleHead-Location Relation+      mli = concat [containsImportDecl mn d | d <- Module.imports m]          -- mli = ImportDecl-Location Relation+      mle = concat [containsExportSpec mn d | d <- Module.getModuleExports m] -- mle = ExportSpec-Location Relation+      dlr = concat [containsDecl mn d | d <- Module.declarations m]           -- dlr = Decl-Location Relation+  Nothing -> empty++-- | Creates a list of (Module "m",Module head "mh") pair for the ModuleHead+containsModuleHead :: String                                  -- ^ The module (head) name.+                   -> Module SrcSpanInfo                      -- ^ The Declaration with var l.+                   -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "m",Module head "mh") pairs+containsModuleHead mn mod = [(m,mh)]+  where m = MetaModel.Module mn+        mh = MetaModel.ModuleHead $ makeQualifiedId mn mn++-- | Creates a list of (Module "m",ModuleImport "mi") pair for the ImportDecl+containsImportDecl :: String                                  -- ^ The module name.+                   -> ImportDecl SrcSpanInfo                  -- ^ The Declaration with var l.+                   -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "m",ModuleImport "mi") pairs+containsImportDecl mn ImportDecl{importModule=im} = [(m,mi)]+  where m = MetaModel.Module mn+        mi = MetaModel.ModuleImport $ makeQualifiedId mn $ hn im+        hn (ModuleName _ x) = x++-- | Creates a (Module "m",ModuleExport "me") pair for the ExportSpec+containsExportSpec :: String                                  -- ^ The module name.+                   -> ExportSpec SrcSpanInfo                  -- ^ The Declaration with var l.+                   -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "m",ModuleExport "me") pairs+containsExportSpec mn (EVar _ qnm) = case QName.name qnm of+  Just es -> [(m,me)]+    where m =  MetaModel.Module mn+          me = MetaModel.ModuleExport $ makeQualifiedId mn es+  Nothing -> []+containsExportSpec _ _ = []++-- | Analyzes a declaration for location information.+containsDecl :: String                                  -- ^ The name of the Module.+             -> Decl SrcSpanInfo                        -- ^ The declaration to analyze.+             -> [(MetaModel.Element,MetaModel.Element)] -- ^ The resulting list of (Element,Element) pairs.+containsDecl mn td@TypeDecl{} = containsType mn td+containsDecl mn dd@DataDecl{} = containsData mn dd+containsDecl mn dd@GDataDecl{} = containsData mn dd+containsDecl mn pb@PatBind{} = containsPattern mn pb+containsDecl mn fb@FunBind{} = containsFunction mn fb+containsDecl mn ts@TypeSig{} = containsTypeSig mn ts+containsDecl mn tc@ClassDecl{} = containsTypeClass mn tc+containsDecl mn id@InstDecl{} = containsInstance mn id+containsDecl mn id@InlineSig{} = containsInlineSig mn id+containsDecl _ _ = []++-- | Creates a list of (Module "mn",TypeSynonym "tsn") pairs for a top-level+-- type (TypeDecl) declarations.+containsType :: String                                  -- ^ Name of the module+             -> Decl SrcSpanInfo                        -- ^ The top-level declaration+             -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "mn",TypeSynonym "tsn") pairs+containsType mn d = case d of+  (TypeDecl _ h _) -> [(p,c)]+    where+      p = MetaModel.Module mn+      c = MetaModel.TypeSynonym $ makeQualifiedId mn $ DeclHead.name h+  _ -> []++-- | Creates a list of (Element,Element) pairs for a top-level data (DataDecl)+-- declaration.+containsData :: String                                  -- ^ Name of the module+             -> Decl SrcSpanInfo                        -- ^ The top-level declaration+             -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Element,Element) pairs+containsData mn d =  case Decl.dataConstructor d of+    Just a -> cdc a+      where+        me  = MetaModel.Module mn                                               -- module element+        dcn = Decl.dataConstructorName a                                        -- dcn  = data constructor name+        dce = MetaModel.DataType $ makeQualifiedId mn dcn                       -- dce  = data constructor element++        -- Creates `Contain` relation for the data constructor.+        cdc :: Decl.DataConstructor -> [(MetaModel.Element,MetaModel.Element)]  -- cdc = contains data constructor+        cdc dc = (me,dce) : cvcs+          where+            vcs  = Decl.valueConstructors dc                                    -- vcs  = value constructors+            cvcs = concat [cvc vc | vc <- vcs]                                  -- cvcs = `Contains` relation for sub value constructors++        -- Creates `Contain` relation for the value constructor.+        cvc :: Decl.ValueConstructor -> [(MetaModel.Element,MetaModel.Element)] -- cvc = contains value constructor+        cvc vc = mvcr : dvcr : cfs+          where+            mvcr = (me,vce)                                                     -- Module `Contains` value constructor relation+            dvcr = (dce,vce)                                                    -- Data `Contains` value constructor relation+            vce = MetaModel.Function $ makeQualifiedId mn vcn                                -- vce = value constructor element+            vcn = Decl.valueConstructorName vc                                  -- vcn = value constructor name+            cfs = concat [cf f | f <- Decl.valueConstructorFields vc]           -- cfs = `Contains` relation for sub fields (if present)++        -- Creates `Contain` relation for the supplied field+        cf :: Decl.Field -> [(MetaModel.Element,MetaModel.Element)]+        cf f = mfr ++ dfr+          where+            mfr = [(me,fe) | fe <- fes]                                                     -- Module `Contains` field relation+            dfr = [(dce,fe) | fe <- fes]                                                    -- Data `Contains` field relation+            fes = [MetaModel.Function (makeQualifiedId mn n) | n <- Decl.fieldNames f]      -- fes = field elements+    Nothing -> []++-- | Creates a list of (Module "mn",Function "fn") pairs for a top-level pattern+-- (PatBind) declaration.+containsPattern :: String                                   -- ^ Name of the module+                -> Decl SrcSpanInfo                         -- ^ The top-level declaration+                -> [(MetaModel.Element,MetaModel.Element)]  -- ^ list of (Module "mn",Function "fn") pairs+containsPattern mn pb@PatBind{} = case Decl.patternName pb of+    Just pn -> [(p,c)]+      where+        p = MetaModel.Module mn+        c = MetaModel.Function $ makeQualifiedId mn pn+    Nothing -> []++-- | Creates a list of (Module "mn",Function "fn") pairs for a top-level+-- function (FunBind) declaration.+containsFunction :: String                                   -- ^ Name of the module+                 -> Decl SrcSpanInfo                         -- ^ The top-level declaration+                 -> [(MetaModel.Element,MetaModel.Element)]  -- ^ list of (Module "mn",Function "fn") pairs+containsFunction mn fb@FunBind{} = case Decl.functionName fb of+    Just pn -> [(p,c)]+      where+        p = MetaModel.Module mn+        c = MetaModel.Function $ makeQualifiedId mn pn+    Nothing -> []++-- | Creates a list of (Module "m", TypeSignature "ts") pairs for TypeSignature declarations.+containsTypeSig :: String                                  -- ^ The module name.+                -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "m", TypeSignature "ts") pairs.+containsTypeSig mn tysig@TypeSig{} = case Decl.typeSigName tysig of+  Just tsn -> [(m,ts)]+    where m = MetaModel.Module mn+          ts = MetaModel.TypeSignature $ makeQualifiedId mn tsn+  Nothing -> []++-- | Creates a list of (Module "m",TypeClass "tc") pairs for TypeClass declarations.+containsTypeClass :: String                                  -- ^ The module name.+                  -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                  -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "m",TypeClass "tc") pairs.+containsTypeClass mn tycla@ClassDecl{} = case Decl.typeClassName tycla of+  Just tcn -> [(m,tc)]+    where m = MetaModel.Module mn+          tc = MetaModel.TypeClass $ makeQualifiedId mn tcn+  Nothing -> []++-- | Creates a list of (Module "m",Instance "i") pairs for Instance declarations.+containsInstance :: String                                   -- ^ The module name.+                  -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                  -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "m",Instance "i") pairs.+containsInstance mn inst@InstDecl{} = case Decl.instanceName inst of+  Just inm -> [(m,i)]+    where m = MetaModel.Module mn+          i = MetaModel.Instance $ makeQualifiedId mn inm+  Nothing -> []++-- | Creates a list of (Module "m",Pragma "p") pairs for Instance declarations.+containsInlineSig :: String                                   -- ^ The module name.+                  -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                  -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "m",Pragma "p") pairs.+containsInlineSig mn inlsig@InlineSig{} = case Decl.inlineSigName inlsig of+  Just inm -> [(m,i)]+    where m = MetaModel.Module mn+          i = MetaModel.Pragma $ makeQualifiedId mn inm+  Nothing -> []
+ src/MetaHS/DataModel/Extractor/Module/Imports.hs view
@@ -0,0 +1,38 @@+{-|+Module      : MetaHS.DataModel.Extractor.Module.Imports+Description : The MetaHS extractor for import relations.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS extractor for module level import relations.+Currently only (Module,Module) relations are created from+ImportDecl-importModule.+-}+module MetaHS.DataModel.Extractor.Module.Imports+  (imports)+  where++import           Language.Haskell.Exts+import qualified MetaHS.DataModel.MetaModel as MetaModel+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module+    as Module+import MetaHS.DataModel.Utils.Name (makeQualifiedId)+import Data.Set (empty, fromList)++-- | Creates Location relations for all supported top-level declarations in the+-- | provided Module.+imports :: Module SrcSpanInfo  -- ^ The Module to analyze.+        -> MetaModel.Relation  -- ^ The resulting MetaModel.Relation items.+imports m = case Module.name m of+  Just mn -> fromList [importsModule mn id | id <- Module.imports m]+  Nothing -> empty++-- | Creates module parent - child pair.+importsModule::String                                 -- ^ The module name.+             -> ImportDecl SrcSpanInfo                -- ^ The Declaration with var l.+             -> (MetaModel.Element,MetaModel.Element) -- ^ The resulting MetaModel.Element.+importsModule mn ImportDecl{importModule=im} = (mp,mc) where+  mp = MetaModel.Module mn+  mc = MetaModel.Module $ makeQualifiedId mn $ hn im+  hn (ModuleName _ x) = x
+ src/MetaHS/DataModel/Extractor/Module/Source.hs view
@@ -0,0 +1,175 @@+{-|+Module      : MetaHS.DataModel.Extractor.Module.Source+Description : The MetaHS extractor for source relations+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS extractor for module level source relations+-}+module MetaHS.DataModel.Extractor.Module.Source+    ( source+    ) where++import           Data.Maybe                                                   (fromMaybe)+import           Data.Set                                                     (empty,+                                                                               fromList)+import           Language.Haskell.Exts+import qualified MetaHS.DataModel.MetaModel                                   as MetaModel+import           MetaHS.DataModel.Utils+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.SrcLoc          as SrcLoc+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Decl     as Decl+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.DeclHead as DeclHead+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module   as Module+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName    as QName++-- | Creates Location relations for all supported top-level declarations in the+-- provided Module.+source :: Module SrcSpanInfo  -- ^ The Module to analyze.+       -> MetaModel.Relation  -- ^ The resulting MetaModel.Relation items.+source m = case Module.name m of+  Just mn -> fromList $ mlr ++ mlhr ++ mli ++ mle ++ dlr+    where+      mlr = locationModule mn m                                               -- mlr = Module-Location Relation+      mlhr = locationModuleHead mn m                                          -- mlhr = ModuleHead-Location Relation+      mli = concat [locationImportDecl mn d | d <- Module.imports m]          -- mli = ImportDecl-Location Relation+      mle = concat [locationExportSpec mn d | d <- Module.getModuleExports m] -- mle = ExportSpec-Location Relation+      dlr = concat [locationDecl mn d | d <- Module.declarations m]           -- dlr = Decl-Location Relation+  Nothing -> empty++-- | Creates a Module "m",Location "ml" pair for the whole module+locationModule :: String                                  -- ^ The module (head) name.+               -> Module SrcSpanInfo                      -- ^ The Declaration with var l.+               -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module "mn",Location) pairs+locationModule mn (Module l _ _ _ _) = [(m,ml)]+  where m =  MetaModel.Module mn+        ml = SrcLoc.srcSpanInfoToLocationElement l+locationModule _ _ = []++-- | Creates a list of (Module head "mh",Location "mhl") pair for the ModuleHead+locationModuleHead :: String                                  -- ^ The module (head) name.+                   -> Module SrcSpanInfo                      -- ^ The Declaration with var l.+                   -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Module head "mh",Location "mhl") pairs+locationModuleHead mn (Module _ (Just (ModuleHead l _ _ _)) _ _ _) = [(mh,mhl)]+                       where mh =  MetaModel.ModuleHead $ makeQualifiedId mn mn+                             mhl = SrcLoc.srcSpanInfoToLocationElement l+locationModuleHead _ _ = []++-- | Creates a list of (imported Module "mi",Location "mil") pair for the ImportDecl+locationImportDecl :: String                                  -- ^ The module name.+                   -> ImportDecl SrcSpanInfo                  -- ^ The Declaration with var l.+                   -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (imported Module "mi",Location "mil") pairs+locationImportDecl mn ImportDecl{importAnn=ia, importModule=im} = [(mi,mil)]+                      where mi = MetaModel.ModuleImport $ makeQualifiedId mn $ hn im+                            mil = SrcLoc.srcSpanInfoToLocationElement ia+                            hn (ModuleName _ x) = x++-- | Creates a (exported Modules "me",Location "mel") pair for the ExportSpec+locationExportSpec :: String                                  -- ^ The module name.+                   -> ExportSpec SrcSpanInfo                  -- ^ The Declaration with var l.+                   -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (exported Modules "me",Location "mel") pairs+locationExportSpec mn (EVar l qnm) = case QName.name qnm of+    Just es -> [(me,mel)]+      where me = MetaModel.ModuleExport $ makeQualifiedId mn es+            mel = SrcLoc.srcSpanInfoToLocationElement l+    Nothing -> []+locationExportSpec _ _ = []++-- | Creates a list of (Element,Location) pairs for a given top-level declaration.+locationDecl :: String                                  -- ^ The module name.+             -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+             -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Element "te", Location "tl") pairs.+locationDecl mn td@TypeDecl{}  = locationType mn td+locationDecl mn dd@DataDecl{}  = locationData mn dd+locationDecl mn dd@GDataDecl{} = locationData mn dd+locationDecl mn pb@PatBind{}   = locationPattern mn pb+locationDecl mn fb@FunBind{}   = locationFunction mn fb+locationDecl mn ts@TypeSig{}   = locationTypeSig mn ts+locationDecl mn tc@ClassDecl{} = locationTypeClass mn tc+locationDecl mn id@InstDecl{}  = locationInstance mn id+locationDecl mn is@InlineSig{} = locationInlineSig mn is+locationDecl _ _               = []++-- | Creates a list of (TypeSynonym qname "ts", Location "dl") pairs for (g)DataDecl declarations.+locationType :: String                                  -- ^ The module name.+             -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+             -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (TypeSynonym qname "ts", Location "dl") pairs.+locationType mn decl = case decl of+ (TypeDecl l h _) -> [(ts,tsl)]+    where+      ts = MetaModel.TypeSynonym $ makeQualifiedId mn $ DeclHead.name h+      tsl = SrcLoc.srcSpanInfoToLocationElement l+ _ -> []++-- | Creates a list of ((G)Dataconstructor qname "d", Location "dl") pairs for (g)DataDecl declarations.+locationData :: String                                  -- ^ The module name.+             -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+             -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of ((G)Dataconstructor qname "d", Location "dl") pairs.+locationData mn decl = case Decl.dataConstructor decl of+    Just dc -> [(d,dl)]+      where+        d = MetaModel.DataType $ makeQualifiedId mn $ Decl.dataConstructorName dc+        dl = SrcLoc.srcSpanInfoToLocationElement $ ann decl+    Nothing -> []++-- | Creates a list of (Pattern qname "p", Location "pl") pairs for PatBind declarations.+locationPattern :: String                                   -- ^ The module name.+                -> Decl SrcSpanInfo                         -- ^ The Declaration with var l.+                -> [(MetaModel.Element,MetaModel.Element)]  -- ^ list of (Pattern qname "p", Location "pl") pairs.+locationPattern mn patbin@PatBind{} = case Decl.patternName patbin of+    Just pn -> [(p,pl)]+      where+        p = MetaModel.Function $ makeQualifiedId mn pn+        pl = SrcLoc.srcSpanInfoToLocationElement $ ann patbin+    Nothing -> []++-- | Creates a list of (Module "mn",Location) pairs for FunBind declarations.+locationFunction :: String                                  -- ^ The module name.+                 -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                 -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Function qname "f", Location "fl") pairs.+locationFunction mn funbin@FunBind{} = case Decl.functionName funbin of+    Just fn -> [(f,fl)]+      where+        f = MetaModel.Function $ makeQualifiedId mn fn+        fl = SrcLoc.srcSpanInfoToLocationElement $ ann funbin+    Nothing -> []++-- | Creates a list of (TypeSignature "ts",Location "tsl") pairs for TypeSignature declarations.+locationTypeSig :: String                                  -- ^ The module name.+                -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (TypeSignature qname, "ts",Location "tsl") pairs.+locationTypeSig mn tysig@TypeSig{} = case Decl.typeSigName tysig of+  Just tsn -> [(ts,tsl)]+    where ts = MetaModel.TypeSignature $ makeQualifiedId mn tsn+          tsl = SrcLoc.srcSpanInfoToLocationElement $ ann tysig+  Nothing -> []++-- | Creates a list of (TypeClass "tc",Location "tcl") pairs for TypeClass declarations.+locationTypeClass :: String                                  -- ^ The module name.+                  -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                  -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (TypeClass qname, "tc",Location "tcl") pairs.+locationTypeClass mn tycla@ClassDecl{} = case Decl.typeClassName tycla of+  Just tcn -> [(tc,tcl)]+    where tc = MetaModel.TypeClass $ makeQualifiedId mn tcn+          tcl = SrcLoc.srcSpanInfoToLocationElement $ ann tycla+  Nothing -> []++-- | Creates a list of (Instance "i",Location "il") pairs for Instance declarations.+locationInstance :: String                                   -- ^ The module name.+                  -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                  -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Instance qname, "i",Location "il") pairs.+locationInstance mn inst@InstDecl{} = case Decl.instanceName inst of+  Just inm -> [(i,il)]+    where i = MetaModel.Instance $ makeQualifiedId mn inm+          il = SrcLoc.srcSpanInfoToLocationElement $ ann inst+  Nothing -> []++-- | Creates a list of (Pragma "p",Location "pl") pairs for InlineSig declarations.+locationInlineSig :: String                                   -- ^ The module name.+                  -> Decl SrcSpanInfo                        -- ^ The Declaration with var l.+                  -> [(MetaModel.Element,MetaModel.Element)] -- ^ list of (Pragma qname, "p",Location "pl") pairs.+locationInlineSig mn inlsig@InlineSig{} = case Decl.inlineSigName inlsig of+  Just isnm -> [(p,pl)]+    where p = MetaModel.Pragma $ makeQualifiedId mn isnm+          pl = SrcLoc.srcSpanInfoToLocationElement $ ann inlsig+  Nothing -> []
+ src/MetaHS/DataModel/Extractor/Module/Uses.hs view
@@ -0,0 +1,157 @@+{-|+Module      : MetaHS.DataModel.Extractor.Module.Uses+Description : The MetaHS extractor for uses relations+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS extractor for module level uses relations+-}+module MetaHS.DataModel.Extractor.Module.Uses+    ( uses+    ) where++import Data.Maybe( fromMaybe )+import Data.List (nub, (\\))+import Data.Set (fromList,empty)+import Language.Haskell.Exts+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.DataModel.Utils+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module+    as Module+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Decl+    as Decl+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name+    as Name+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.DeclHead+    as DeclHead++-- | Create MetaModel.Contains relations for top-level declarations of a module.+uses :: Module SrcSpanInfo  -- ^ The module to analyze+     -> MetaModel.Relation  -- ^ list of Element `Contains` Element+     -> MetaModel.Relation  -- ^ list of Element `Uses` Element+uses m rs = case Module.name m of+  Just mn -> fromList $ concat [usesDecl mn d nrms | d <- Module.declarations m]+    where+      nrms = createNameResolutionMaps mn rs         -- nrms = name resolution maps+  Nothing -> empty++-- | Analyzes a declaration for `Uses` information.+usesDecl :: String                                  -- ^ The name of the Module.+         -> Decl SrcSpanInfo                        -- ^ The declaration to analyze.+         -> NameResolutionMaps                      -- ^ The name resolution maps.+         -> [(MetaModel.Element,MetaModel.Element)] -- ^ The resulting list of (Element,Element) pairs.+usesDecl mn td@TypeDecl{} nrms  = usesType mn td nrms+usesDecl mn ts@TypeSig{} nrms   = usesTypeSig mn ts nrms+usesDecl mn dd@DataDecl{} nrms  = usesData mn dd nrms+usesDecl mn dd@GDataDecl{} nrms = usesData mn dd nrms+usesDecl mn pb@PatBind{} nrms  = usesPattern mn pb nrms+usesDecl mn fb@FunBind{} nrms   = usesFunction mn fb nrms+usesDecl _ _ _ = []++-- | Analyzes a type synonym declaration for `Uses` information.+usesType :: String                                  -- ^ The name of the Module.+         -> Decl SrcSpanInfo                        -- ^ The type synonym declaration to analyze.+         -> NameResolutionMaps                      -- ^ The name resolution maps.+         -> [(MetaModel.Element,MetaModel.Element)] -- ^ The resulting list of (Element,Element) pairs.+usesType mn d nrms = case d of+    (TypeDecl _ h t) -> rs+      where+        p = MetaModel.TypeSynonym $ makeQualifiedId mn $ DeclHead.name h        -- p = parent+        es = [resolveType tcns nrms | tcns <- findTyConNames t]                 -- es = elements, tcns = TyCon names+        rs = [(p,c) | c <- es]                                                  -- p = parent, c = child, rs = relations+    _ -> []++-- | Analyzes a type signature for `Uses` information.+usesTypeSig :: String                                   -- ^ The name of the Module.+            -> Decl SrcSpanInfo                         -- ^ The type signature to analyze.+            -> NameResolutionMaps                       -- ^ The name resolution maps.+            -> [(MetaModel.Element,MetaModel.Element)]  -- ^ The resulting list of (Element,Element) pairs.+usesTypeSig _ d nrms = case d of+    (TypeSig _ ns t) -> rs+      where+        ps = [resolveValue (Name.name n) nrms | n <- ns]                        -- ps = parents+        es = [resolveType tcns nrms | tcns <- findTyConNames t]                 -- es = elements, tcns = TyCon names+        rs = [(p,c) | p <- ps, c <- es]                                         -- p = parent, c = child, rs = relations+    _ -> []++-- | Analyzes a data declaration for `Uses` information.+usesData :: String                                  -- ^ The name of the Module.+         -> Decl SrcSpanInfo                        -- ^ The data declaration to analyze.+         -> NameResolutionMaps                      -- ^ The name resolution maps.+         -> [(MetaModel.Element,MetaModel.Element)] -- ^ The resulting list of (Element,Element) pairs.+usesData mn d nrms = case Decl.dataConstructor d of+    Just a -> udc a+      where+        dcn = Decl.dataConstructorName a                                        -- dcn  = data constructor name+        dce = MetaModel.DataType $ makeQualifiedId mn dcn                       -- dce  = data constructor element++        -- Creates `Uses` relation for the data constructor.+        udc :: Decl.DataConstructor -> [(MetaModel.Element,MetaModel.Element)]  -- udc = uses data constructor+        udc dc = uvcs+          where+            vcs  = Decl.valueConstructors dc                                    -- vcs  = value constructors+            uvcs = concat [uvc vc | vc <- vcs]                                  -- uvcs = `Uses` relation for sub value constructors++        -- Creates `Uses` relation for the value constructor.+        uvc :: Decl.ValueConstructor-> [(MetaModel.Element,MetaModel.Element)]  -- uvc = uses value constructor+        uvc vc = vcud : (vcrs ++ frs)+          where+            vcn = Decl.valueConstructorName vc                                  -- vcn = value constructor name+            vce = MetaModel.Function $ makeQualifiedId mn vcn                                -- vce = value constructor element+            vcud = (vce,dce)                                                    -- Value Constructor `Uses` DataType++            vcts = Decl.valueConstructorTypes vc                                -- vcts = value Constructor Types+            vces = [resolveType tcns nrms | tcns <- findTyConNames vcts]        -- vces = value Constructor elements, tcns = TyCon names+            vcrs = [(vce,c) | c <- vces]                                        -- c = child, rs = relations++            frs = concat [uf vce f | f <- Decl.valueConstructorFields vc]       -- frs = `Uses` relation for sub fields (if present)++        -- Creates `Uses` relation for the supplied field+        uf :: MetaModel.Element+           -> Decl.Field+           -> [(MetaModel.Element,MetaModel.Element)]+        uf vce f = rs+          where+            ps = vce : [resolveValue n nrms | n <- Decl.fieldNames f]           -- ps = parents+            es = dce : [resolveType tcns nrms | tcns <- findTyConNames fts]     -- es = elements, tcns = TyCon names+            rs = [(p,c) | p <- ps, c <- es]                                     -- p = parent, c = child, rs = relations+            fts = Decl.fieldTypes f                                             -- fts = field Types+    Nothing -> []++-- | Analyzes a PatBind declaration for `Uses` information.+usesPattern :: String                                   -- ^ The name of the Module.+            -> Decl SrcSpanInfo                         -- ^ The function declaration to analyze.+            -> NameResolutionMaps                       -- ^ The name resolution maps.+            -> [(MetaModel.Element,MetaModel.Element)]  -- ^ The resulting list of (Element,Element) pairs.+usesPattern mn pb@(PatBind _ (PVar _ _) rhs wheres) nrms = trs ++ vrs+  where+    pn = fromMaybe "" $ Decl.patternName pb                                     -- pn = pattern name+    p = MetaModel.Function $ makeQualifiedId mn pn                              -- p = parent+    tycons = findTyConNames rhs ++ findTyConNames wheres                        -- tycons = TyCon objects found+    qnames = findQNames rhs ++ findQNames wheres                                -- qnames = QName objects+    locals = findPatVars rhs ++ findPatVars wheres ++                           -- locals = local definitions+             findFunctionNames rhs ++ findFunctionNames wheres++    exts = nub (qnames \\ tycons) \\ locals                                     -- exts = external names found+    trs = [(p,resolveType c nrms) | c <- tycons]                                -- trs = types relations+    vrs = [(p,resolveValue c nrms) | c <- exts]                                 -- trs = values relations+usesPattern _ _ _ = []++-- | Analyzes a PatBind declaration for `Uses` information.+usesFunction :: String                                  -- ^ The name of the Module.+             -> Decl SrcSpanInfo                        -- ^ The function declaration to analyze.+             -> NameResolutionMaps                      -- ^ The name resolution maps.+             -> [(MetaModel.Element,MetaModel.Element)] -- ^ The resulting list of (Element,Element) pairs.+usesFunction mn fb@(FunBind _ matches) nrms = trs ++ vrs+  where+    fn = fromMaybe "" $ Decl.functionName fb                                    -- fn = function name+    p = MetaModel.Function $ makeQualifiedId mn fn                              -- p = parent+    tycons = findTyConNames matches                                             -- tycons = TyCon objects found+    qnames = findQNames matches                                                 -- qnames = QName objects+    locals = findPatVars matches ++ (nub (findFunctionNames matches) \\ [fn])   -- locals = local definitions++    exts = nub (qnames \\ tycons) \\ locals                      -- exts = external names found+    trs = [(p,resolveType c nrms) | c <- tycons]                 -- trs = types relations+    vrs = [(p,resolveValue c nrms) | c <- exts]                  -- trs = values relations+usesFunction _ _ _ = []
+ src/MetaHS/DataModel/Extractor/Program/Contains.hs view
@@ -0,0 +1,37 @@+{-|+Module      : MetaHS.DataModel.Extractor.Program.Contains+Description : The MetaHS extractor for contains relations+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS extractor for application level contains relations+-}+module MetaHS.DataModel.Extractor.Program.Contains+    ( contains+    ) where++import Data.Maybe (fromMaybe)+import Data.Set (fromList)+import Language.Haskell.Exts+import qualified MetaHS.DataModel.MetaModel as MetaModel+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module+    as Module++-- | Creates MetaModel.Relation set for the modules contained within the+-- program.+contains :: String                -- ^ The program name.+         -> [Module SrcSpanInfo]  -- ^ List of parsed Modules.+         -> MetaModel.Relation    -- ^ The resulting relation.+contains progName modules =+    fromList [createRelationPair progName m | m <- modules]++-- | Creates a (Program "pn",Module "m") pair.+createRelationPair :: String                                -- ^ The program name.+                   -> Module SrcSpanInfo                    -- ^ The parsed Module.+                   -> (MetaModel.Element,MetaModel.Element) -- ^ The resulting (Element,Element) pair.+createRelationPair pn m = (mmProg,mmM)+  where+    mmProg = MetaModel.Program pn+    mmM    = MetaModel.Module mn+    mn     = fromMaybe "?" (Module.name m)
+ src/MetaHS/DataModel/MetaModel.hs view
@@ -0,0 +1,190 @@+{-|+Module      : MetaHS.DataModel.MetaModel+Description : The MetaHS metamodel+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS metamodel+-}++{-# OPTIONS_GHC -funbox-strict-fields #-}++module MetaHS.DataModel.MetaModel+    ( Element(..)+    , Pair+    , Relation+    , MetaModel(..)+    , pPrint+    ) where++import qualified Data.Set as Set+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Text.PrettyPrint+import Text.PrettyPrint.HughesPJClass+import Prelude hiding ((<>))++-- | The various elements that can be used in the metamodel.+data Element+    = Program+        { name :: !String+        -- ^ The name of the program.+        }+    -- ^ Top level program+    | Module+        { name :: !String+        -- ^ The qualified name of the module.+        }+    -- ^ Represents a module+    | ModuleHead+        { name :: !String+        -- ^ The qualified name of the module.+        }+    -- ^ Represents a module head+    | ModuleImport+        { name :: !String+        -- ^ The qualified name of the imported module.+        }+    -- ^ Represents a module import+    | ModuleExport+        { name :: !String+        -- ^ The qualified name of the exported module.+        }+    -- ^ Represents a module export+    | Function+        { name :: !String+        -- ^ The qualified name of the function.+        }+    -- ^ Represents a function+    | DataType+        { name :: !String+        -- ^ The qualified name of the data declaration.+        }+    -- ^ Represents a datatype declaration.+    | TypeSynonym+        { name :: !String+        -- ^ The qualified name of the type synonym.+        }+    -- ^ Represents a type synonym.+    | TypeSignature+        { name :: !String+        -- ^ The qualified name of the type signature.+        }+        -- ^ Represents a type signature.+    | TypeClass+        { name :: !String+        -- ^ The qualified name of the type instance.+        }+        -- ^ Represents a type instance.+    | Instance+        { name :: !String+        -- ^ The qualified name of the type instance.+        }+    | Pragma+        { name :: !String+        -- ^ The qualified name of the inline Pragma.+        }+        -- ^ Represents an inline Pragma.+    | UnknownType+        { name :: !String+        -- ^ The "?" qualified name of the unknown type.+        }+    -- ^ Represents a type which is unknown.+    | Location+        { locationPath        :: !String+        -- ^ The path to the file containing the source code.+        , locationStartLine   :: !Int+        -- ^ The start line.+        , locationStartColumn :: !Int+        -- ^ The start column.+        , locationEndLine     :: !Int+        -- ^ The end line.+        , locationEndColumn   :: !Int+        -- ^ The end column.+        }+    -- ^ Represents a source code location.+    | StringValue+        { stringValue :: !String+        -- ^ The String value.+        }+    -- ^ Contains a generic String value.+    | IntValue+        { intValue :: !Int+        -- ^ The Int value.+        }+    -- ^ Contains a generic Int value.+    deriving (Show, Read, Eq, Ord)++-- | A Pair is defined as a tuple of Elements+type Pair = (Element,Element)++-- | A relation is defined as a set of Pair types.+--   E.g., _contains, _source, _uses, LCOM+type Relation = Set.Set (Element,Element)++-- | A metamodel is implemented as a mapping between a String and Relation.+--   The key string will denote the type of relation between the pairs in the+--   value relation.+type MetaModelImpl = Map.Map String Relation++-- | The MetaModel type.+newtype MetaModel = MetaModel { getMetaModelImpl :: MetaModelImpl }+    deriving (Read,Show)++-- | Pretty print instance for Elements.+instance Pretty Element where+    pPrint Program { name = n } = text "Program" <+> qt n+    pPrint Module { name = n } = text "Module" <+> qt n+    pPrint ModuleHead { name = n } = text "ModuleHead" <+> qt n+    pPrint ModuleImport { name = n } = text "ModuleImport" <+> qt n+    pPrint ModuleExport { name = n } = text "ModuleExport" <+> qt n+    pPrint Function { name = n } = text "Function" <+> qt n+    pPrint DataType { name = n } = text "DataType" <+> qt n+    pPrint TypeSynonym { name = n } = text "TypeSynonym" <+> qt n+    pPrint TypeSignature { name = n } = text "TypeSignature" <+> qt n+    pPrint TypeClass { name = n } = text "TypeClass" <+> qt n+    pPrint Instance { name = n } = text "Instance" <+> qt n+    pPrint Pragma { name = n } = text "Pragma" <+> qt n+    pPrint UnknownType { name = n } = text "UnknownType" <+> qt n+    pPrint Location { locationPath = p+                    , locationStartLine = sl+                    , locationStartColumn = sc+                    , locationEndLine = el+                    , locationEndColumn = ec+                    } = text "Location" <+> qt p <+> int sl <+> int sc+                        <+> int el <+> int ec+    pPrint StringValue { stringValue = v } = text "StringValue" <+> qt v+    pPrint IntValue { intValue = v } = text "IntValue" <+> qt (show v)++-- | Pretty print instance for the MetaModel.+instance Pretty MetaModel where+    pPrint metaModel =+        if null metaModelMap+        then+            text "MetaModel"+        else+            text "MetaModel" $$+            vcat ( map f (Map.keys metaModelMap) ) $$+            text ""+        where+            metaModelMap = getMetaModelImpl metaModel++            f :: String -> Doc+            f key = -- function f iterates through the keys+                text "  " <> text (show key) <> char ':' $$+                g ( fromMaybe Set.empty $ Map.lookup key metaModelMap)++            g :: Relation -> Doc+            g relation =+                if null relation+                then+                    text ""+                else+                    vcat . map (docLine "    ") $ Set.elems relation+                where+                    docLine prefix v = text prefix <> pPrint v++-- | Returns the provided String as a quoted Doc+qt :: String -> Doc+qt t = char '"' <> text t <> char '"'
+ src/MetaHS/DataModel/Utils.hs view
@@ -0,0 +1,16 @@+{-|+Module      : MetaHS.DataModel.Utils+Description : MetaHS data model layer utility functions+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS data model layer utility functions+-}+module MetaHS.DataModel.Utils+    ( module X+    ) where++import MetaHS.DataModel.Utils.Find as X+import MetaHS.DataModel.Utils.Name as X+import MetaHS.DataModel.Utils.NameResolution as X
+ src/MetaHS/DataModel/Utils/File/FileUtils.hs view
@@ -0,0 +1,46 @@+{-|+Module      : MetaHS.DataModel.Utils.File.FileUtils+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utility functions for files and directories.+-}+module MetaHS.DataModel.Utils.File.FileUtils+    ( filesInHierarchy+    , modulesInHierarchy+    ) where++import System.Directory+import System.FilePath+import Control.Monad+import Data.List (partition)+import Language.Haskell.Exts++-- | Flattens the hierarchy of a directory to a list of files.+filesInHierarchy :: FilePath      -- ^ The directory hierarchy to analyze.+                 -> IO [FilePath] -- ^ The files found in the directory hierarchy.+filesInHierarchy dir = do+  rawDirList <- listDirectory dir+  let dirList = map (dir </>) rawDirList+  files <- filterM doesFileExist dirList+  let pureHaskellModuleFiles = filter (\p -> takeExtension p == ".hs") dirList --todo how to exclude test directory?+  subDirs <- filterM doesDirectoryExist dirList+  subDirFiles <- mapM filesInHierarchy subDirs+  return $ pureHaskellModuleFiles ++ concat subDirFiles++-- | Attempts to extract modules for each file in the directory hierarchy+--   The returned tuple contains the successfully extracted modules and the+--   ParseResult information for those files where this extraction failed.+modulesInHierarchy :: FilePath                                                      -- ^ The directory hierarchy to analyze.+                   -> IO ([Module SrcSpanInfo], [ParseResult (Module SrcSpanInfo)]) -- ^ The successfully and unsuccessfully  parsed Module .+modulesInHierarchy directoryPath = do+    allFiles <- filesInHierarchy directoryPath+    parseResults <- mapM parseFile allFiles+    let (parsed, failed) = partition isParseOk parseResults+    let modules = map fromParseResult parsed+    return (modules, failed)+      where+        isParseOk :: ParseResult (Module SrcSpanInfo) -> Bool+        isParseOk ParseOk{}     = True+        isParseOk ParseFailed{} = False
+ src/MetaHS/DataModel/Utils/Find.hs view
@@ -0,0 +1,71 @@+{-|+Module      : MetaHS.DataModel.Utils.Find+Description : Generic SYB functions for finding certain nodes+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Generic SYB functions for finding certain nodes+-}+module MetaHS.DataModel.Utils.Find+    ( findTyConNames+    , findQNames+    , findPatVars+    , findFunctionNames+    ) where++import Data.List ((\\))+import Data.Generics( Data, everything, mkQ )+import Language.Haskell.Exts+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Decl+    as Decl+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name+    as Name+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName+    as QName++-- | SYB function that searches for TyCon nodes and returns their names.+findTyConNames :: Data a => a -- ^ The data structure to search.+               -> [String]    -- ^ The names of the TyCon nodes found.+findTyConNames = everything (++) ([] `mkQ` f)+  where+    f :: Type SrcSpanInfo -> [String]+    f (TyCon _ n) = case QName.name n of+        Just s -> [s]+        Nothing -> []+    f _ = []++-- | SYB function that searches for QName nodes (without TyCons) and returns+--   their names.+findQNames :: Data a => a -- ^ The data structure to search.+           -> [String]    -- ^ The names of the QNames nodes found.+findQNames d = qnames \\ tyconNames+  where+    qnames = everything (++) ([] `mkQ` f) d+    tyconNames = findTyConNames d+    f :: QName SrcSpanInfo -> [String]+    f x = case QName.name x of+        Just a -> [a]+        Nothing -> []++-- | SYB function that searches for Pat nodes that represent variables and+--   returns their names.+findPatVars :: Data a => a -- ^ The data structure to search.+            -> [String]    -- ^ The names of the Pat variables found.+findPatVars = everything (++) ([] `mkQ` f)+  where+    f :: Pat SrcSpanInfo -> [String]+    f (PVar _ x)     = [Name.name x]+    f (PAsPat _ x _) = [Name.name x]+    f _              = []++-- | SYB function that searches for functions and returns their names.+findFunctionNames :: Data a => a -- ^ The data structure to search.+                  -> [String]    -- ^ The function names found.+findFunctionNames = everything (++) ([] `mkQ` f)+  where+    f :: Decl SrcSpanInfo -> [String]+    f fb@FunBind{} = case Decl.functionName fb of+        Just fn -> [fn]+        Nothing -> []+    f _ = []
+ src/MetaHS/DataModel/Utils/Language/Haskell/Exts/SrcLoc.hs view
@@ -0,0 +1,44 @@+{-|+Module      : MetaHS.DataModel.Utils.Language.Haskell.Exts.SrcLoc+Description : Utility functions for SrcLoc and related objects.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utility functions for SrcLoc and related objects.+-}+module MetaHS.DataModel.Utils.Language.Haskell.Exts.SrcLoc+    where++import Language.Haskell.Exts.SrcLoc+import MetaHS.DataModel.MetaModel++-- | Creates a Location Element containing the information+--   of the SrcLoc object.+srcLocToLocationElement :: SrcLoc   -- ^ The SrcLoc object to analyze.+                        -> Element  -- ^ The resulting Element.+srcLocToLocationElement s = Location+    { locationPath        = srcFilename s+    , locationStartLine   = srcLine s+    , locationStartColumn = srcColumn s+    , locationEndLine     = srcLine s+    , locationEndColumn   = srcColumn s+    }++-- | Creates a Location Element containing the information+--   of the SrcSpan object.+srcSpanToLocationElement :: SrcSpan -- ^ The SrcSpan object to analyze.+                         -> Element -- ^ The resulting Element.+srcSpanToLocationElement s = Location+    { locationPath        = srcSpanFilename s+    , locationStartLine   = srcSpanStartLine s+    , locationStartColumn = srcSpanStartColumn s+    , locationEndLine     = srcSpanEndLine s+    , locationEndColumn   = srcSpanEndColumn s+    }++-- | Creates a Location Element containing the information+--   of the SrcSpanInfo object.+srcSpanInfoToLocationElement :: SrcSpanInfo -- ^ The SrcSpanInfo object to analyze.+                             -> Element     -- ^ The resulting Element.+srcSpanInfoToLocationElement = srcSpanToLocationElement . srcInfoSpan
+ src/MetaHS/DataModel/Utils/Language/Haskell/Exts/Syntax/ConDecl.hs view
@@ -0,0 +1,21 @@+{-|+Module      : MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName+Description : Utility functions for ConDecl objects.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utility functions for ConDecl objects.+-}+module MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.ConDecl+    where++import Language.Haskell.Exts.Syntax+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name as Name++-- | Returns the name for a ConDecl object.+name :: ConDecl l -- ^ The ConDecl object to analyze.+     -> String    -- ^ The name of the ConDecl object.+name (ConDecl _ x _)        = Name.name x+name (InfixConDecl _ _ x _) = Name.name x+name (RecDecl _ x _)        = Name.name x
+ src/MetaHS/DataModel/Utils/Language/Haskell/Exts/Syntax/Decl.hs view
@@ -0,0 +1,163 @@+{-|+Module      : MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Decl+Description : Utility functions for Decl objects.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utility functions for Decl objects.+-}+module MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Decl+    where++import Data.Maybe ()+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.SrcLoc+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name as Name+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName as QName+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.DeclHead as DeclHead++-- | Returns the SrcSpanInfo object associated with the Decl object.+srcSpanInfo :: Decl SrcSpanInfo -> SrcSpanInfo+srcSpanInfo = ann++-- | Represents the (simplified) information for a data constructor.+data DataConstructor+    = DataConstructor+        { dataConstructorName :: String+        -- ^ The name of the data constructor.+        , valueConstructors   :: [ValueConstructor]+        -- ^ The value constructors for this data constructor.+        }+    deriving (Show)++-- | Represents the information for a value constructor.+data ValueConstructor+    = ValueConstructor+        { valueConstructorName  :: String+        -- ^ The name of the value constructor.+        , valueConstructorTypes :: [Type SrcSpanInfo]+        -- ^ Contains the types used by this value constructor if this is not+        --   defined using record notation.+        --   For GADT data type declarations, this field will contain the final+        --   type irrespective of whether record notation is used for the+        --   preceeding types.+        , valueConstructorFields :: [Field]+        -- ^ In case the value constructor is defined using record notation,+        --   this field will contain the fields used by this value constructor.+        }+    deriving (Show)++-- | Represents a record field of a value constructor.+data Field+    = Field+        { fieldNames :: [String]+        -- ^ The name(s) for this field.+        , fieldTypes :: Type SrcSpanInfo+        -- ^ The types used by this field.+        }+    deriving (Show)++-- | Converts a Decl to a DataConstructor object if possible (DataDecl or+--   GDataDecl).+dataConstructor :: Decl SrcSpanInfo -> Maybe DataConstructor+dataConstructor (DataDecl _ _ _ dh qcds _) = Just DataConstructor+    { dataConstructorName = DeclHead.name dh+    , valueConstructors   = vcs+    }+  where+    vcs = [ createVC ds | (QualConDecl _ _ _ ds) <- qcds]+    createVC :: ConDecl SrcSpanInfo -> ValueConstructor+    createVC (ConDecl _ n ts) = ValueConstructor+        { valueConstructorName = Name.name n+        , valueConstructorTypes = ts+        , valueConstructorFields = []+        }+    createVC (InfixConDecl _ t1 n t2) = ValueConstructor+        { valueConstructorName = Name.name n+        , valueConstructorTypes = [t1, t2]+        , valueConstructorFields = []+        }+    createVC (RecDecl _ n fds) = ValueConstructor+        { valueConstructorName = Name.name n+        , valueConstructorTypes = []+        , valueConstructorFields = [createField fd | fd <- fds]+        }+    createField (FieldDecl _ ns t) = Field+        { fieldNames = [Name.name n | n <- ns]+        , fieldTypes = t+        }+dataConstructor (GDataDecl _ _ _ dh _ gds _) = Just DataConstructor             -- dh = (DeclHead l), gds = [GadtDecl l]+    { dataConstructorName = DeclHead.name dh+    , valueConstructors   = vcs+    }+  where+    vcs = [ createVC gd | gd <- gds]+    createVC :: GadtDecl SrcSpanInfo -> ValueConstructor+    createVC (GadtDecl _ n Nothing ts) = ValueConstructor                       -- n = (Name l), ts = (Type l)+        { valueConstructorName = Name.name n+        , valueConstructorTypes = [ts]+        , valueConstructorFields = []+        }+    createVC (GadtDecl _ n (Just fds) ts) = ValueConstructor                    -- n = (Name l), fds = [FieldDecl l], ts = (Type l)+        { valueConstructorName = Name.name n+        , valueConstructorTypes = [ts]+        , valueConstructorFields = [createField fd | fd <- fds]+        }+    createField (FieldDecl _ ns t) = Field+        { fieldNames = [Name.name n | n <- ns]+        , fieldTypes = t+        }+dataConstructor _ = Nothing+++-- | Returns the name of the PatBind if possible.+patternName :: Decl SrcSpanInfo+            -> Maybe String+patternName (PatBind _ (PVar _ n) _ _) = Just $ Name.name n+patternName _ = Nothing++-- | Returns the name of the FunBind if possible.+functionName :: Decl SrcSpanInfo+             -> Maybe String+functionName (FunBind _ []) = Nothing+functionName (FunBind _ ms) = Just . fn $ head ms+  where+    fn :: Match l -> String+    fn (Match _ x _ _ _)        = Name.name x+    fn (InfixMatch _ _ x _ _ _) = Name.name x+functionName _ = Nothing++-- | Returns the name of the TypeSig if possible.+typeSigName :: Decl SrcSpanInfo+            -> Maybe String+typeSigName (TypeSig _ [] _) = Nothing+typeSigName (TypeSig _ n _) = Just $ Name.name $ head n++-- | Returns the name of the typeClass if possible.+typeClassName :: Decl SrcSpanInfo+              -> Maybe String+typeClassName (ClassDecl _ _ (DHApp _ (DHead _ n) _) _ _) = Just $ Name.name n+typeClassName _ = Nothing++-- | Returns the name of the Instance (as "<type-class> <data-type>") if possible.+instanceName :: Decl SrcSpanInfo+              -> Maybe String+instanceName (InstDecl _ _ (IRule _ _ _ (IHApp _ ih t)) _) = fn ih t+  where fn :: InstHead l -> Type l -> Maybe String+        fn (IHCon _ qntc) ty = do+          qnt <- isTycon ty+          n1 <- QName.name qntc+          n2 <- QName.name qnt+          return $ "(" ++ n1 ++ " " ++ n2 ++ ")"+        fn _ _ = Nothing+        isTycon (TyCon _ qnt) = Just qnt+        isTycon (TyParen _ (TyCon _ qnt)) = Just qnt+        isTycon _ = Nothing+instanceName _ = Nothing++-- | Returns the name of the InlineSig if possible.+inlineSigName :: Decl SrcSpanInfo+              -> Maybe String+inlineSigName (InlineSig _ _ _ qn) = QName.name qn+inlineSigName _ = Nothing
+ src/MetaHS/DataModel/Utils/Language/Haskell/Exts/Syntax/DeclHead.hs view
@@ -0,0 +1,22 @@+{-|+Module      : MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name+Description : Utility functions for DeclHead objects.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utility functions for DeclHead objects.+-}+module MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.DeclHead+    where++import Language.Haskell.Exts.Syntax+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name as Name++-- | Returns the name for a DeclHead object.+name :: DeclHead l  -- ^ The DeclHead object to analyze.+     -> String      -- ^ The name of the DeclHead object.+name (DHead _ x)     = Name.name x+name (DHInfix _ _ x) = Name.name x+name (DHParen _ x)   = name x+name (DHApp _ x _)   = name x
+ src/MetaHS/DataModel/Utils/Language/Haskell/Exts/Syntax/Module.hs view
@@ -0,0 +1,90 @@+{-|+Module      : MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module+Description : Utility functions for Modules objects.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utility functions for Modules objects.+-}+module MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Module+    where++import Prelude hiding (head)+import Data.Maybe (fromMaybe)+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.SrcLoc (SrcSpanInfo)++-- | Returns the location information of a Module.+srcSpanInfo :: Module SrcSpanInfo -- ^ The Module to analyze.+            -> SrcSpanInfo        -- ^ The SrcSpanInfo for this Module.+srcSpanInfo = ann++-- | Returns the ModuleHead of a Module.+head :: Module l              -- ^ The Module to analyze.+     -> Maybe (ModuleHead l)  -- ^ The ModuleHead for this Module.+head (Module _ x _ _ _)            = x+head (XmlHybrid _ x _ _ _ _ _ _ _) = x+head _                             = Nothing++-- | Returns the name of the module contained in the ModuleHead.+headName :: ModuleHead l  -- ^ The ModuleHead to analyze.+         -> String        -- ^ The name of this ModuleHead.+headName (ModuleHead _ (ModuleName _ x) _ _) = x++-- | Returns the WarningText contained in the ModuleHead+headWarningText :: ModuleHead l           -- ^ The ModuleHead to analyze.+                -> Maybe (WarningText l)  -- ^ The WarningText for this ModuleHead.+headWarningText (ModuleHead _ _ x _) = x++-- | Return the ExportSpecList contained in the ModuleHead.+headExports :: ModuleHead l             -- ^ The ModuleHead to analyze.+            -> Maybe (ExportSpecList l) -- ^ The ExportSpecList for this ModuleHead.+headExports (ModuleHead _ _ _ x) = x++-- | Returns the name of a Module.+name :: Module l      -- ^ The Module to analyze.+     -> Maybe String  -- ^ The Name of this Module.+name m = headName <$> head m++-- | Returns the WarningText of a Module.+warningText :: Module l               -- ^ The Module to analyze.+            -> Maybe (WarningText l)  -- ^ The WarningText for this Module.+warningText m = f $ headWarningText <$> head m+  where+    f = fromMaybe Nothing++-- | Returns the ExportSpecList of a Module.+exports :: Module l                 -- ^ The Module to analyze.+        -> Maybe (ExportSpecList l) -- ^ The ExportSpecList for this Module.+exports m = f $ headExports <$> head m+  where+    f = fromMaybe Nothing++-- | Returns the ExportSpecList as list+getModuleExports :: Module l       -- ^ The Module to analyze.+                 -> [ExportSpec l] -- ^ The ExportSpecList for this Module.+getModuleExports m = case exports m of+  (Just (ExportSpecList _ es)) -> es+  Nothing -> []++-- | Returns the pragmas of a module.+pragmas :: Module l         -- ^ The Module to analyze.+        -> [ModulePragma l] -- ^ The list of ModulePragma objects for this Module.+pragmas (Module _ _ x _ _)            = x+pragmas (XmlHybrid _ _ x _ _ _ _ _ _) = x+pragmas _                             = []++-- | Returns the imports of a module+imports :: Module l       -- ^ The Module to analyze.+        -> [ImportDecl l] -- ^ The list of ImportDecl objects for this Module.+imports (Module _ _ _ x _)            = x+imports (XmlHybrid _ _ _ x _ _ _ _ _) = x+imports _                             = []++-- | Returns the Decl of a module+declarations :: Module l  -- ^ The Module to analyze.+             -> [Decl l]  -- ^ The list of Decl objects for this Module.+declarations (Module _ _ _ _ x)            = x+declarations (XmlHybrid _ _ _ _ x _ _ _ _) = x+declarations _                             = []
+ src/MetaHS/DataModel/Utils/Language/Haskell/Exts/Syntax/Name.hs view
@@ -0,0 +1,19 @@+{-|+Module      : MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name+Description : Utility functions for Name objects.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utility functions for Name objects.+-}+module MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name+    where++import Language.Haskell.Exts.Syntax++-- | Returns the name for a Name object.+name :: Name l  -- ^ The Name object to analyze.+     -> String  -- ^ The name of the Name object.+name (Ident _ x)  = x+name (Symbol _ x) = "(" ++ x ++ ")"
+ src/MetaHS/DataModel/Utils/Language/Haskell/Exts/Syntax/QName.hs view
@@ -0,0 +1,21 @@+{-|+Module      : MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName+Description : Utility functions for QName objects.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utility functions for QName objects.+-}+module MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.QName+    where++import Language.Haskell.Exts.Syntax+import qualified MetaHS.DataModel.Utils.Language.Haskell.Exts.Syntax.Name as Name++-- | Returns the name for a QName object.+name :: QName l       -- ^ The QName object to analyze.+     -> Maybe String  -- ^ The name of the QName object.+name (Qual _ (ModuleName _ m) n) = Just $ m ++ "." ++ Name.name n+name (UnQual _ n)                = Just $ Name.name n+name _                           = Nothing
+ src/MetaHS/DataModel/Utils/Name.hs view
@@ -0,0 +1,48 @@+{-|+Module      : MetaHS.DataModel.Utils.Name+Description : Utility functions for the MetaHS data model layer.+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Name utility functions for the MetaHS data model layer.+-}+module MetaHS.DataModel.Utils.Name+    ( makeQualifiedId+    , split+    , isLocal+    ) where++import Data.List (intercalate, isSuffixOf, elemIndex)+import Data.List.Split (splitOn)++-- | Qualify identifier+makeQualifiedId :: String   -- ^ The qualifier String (e.g. "MetaHS.DataModel.Extractor.Module.Source").+   -> String                -- ^ The local identifier String (e.g. "qn").+   -> String                -- ^ The resulting qualified String (e.g. "MetaHS.DataModel.Extractor.Module.Source.qn").+makeQualifiedId a b = a ++ "." ++ b++-- | Splits an identifier in the qualifier and name parts.+split :: String           -- ^ The qualified String to split.+      -> (String, String) -- ^ The qualified and name parts.+split qualName+    | isSymbol      = symbolSplit                                               -- qualName contains a symbol as identified by the presence of an '(' character.+    | unqualified   = ("",qualName)                                             -- qualName does not contain dots, therefore it is regarded as an unqualified name+    | otherwise     = (intercalate "." $ init dotParts, last dotParts)          -- split qualName over the qualifier and the unqualified name+  where+    isSymbol      = '(' `elem` qualName                                         -- isSymbol is True is qualName contains an '(' character.+    symbolSplit   = case '(' `elemIndex` qualName of                            -- split function suitable for symbols.+        Just n -> do+            let (a,b) = splitAt n qualName+            if "." `isSuffixOf` a+            then (init a, b)+            else (a,b)+        Nothing -> ("","")+    dotParts      = splitOn "." qualName                                        -- dotParts = splitted parts of qualName+    unqualified   = 1 == length dotParts                                        -- unqualified is True is qualName does not contain dots++-- | Determines whether a given qualified name is local to the given qualifier.+isLocal :: String -- ^ The qualifier.+        -> String -- ^ The qualified name.+        -> Bool   -- ^ True if the qualified name is local to the qualifier.+isLocal q qualName = (q ==) . fst $ split qualName
+ src/MetaHS/DataModel/Utils/NameResolution.hs view
@@ -0,0 +1,86 @@+{-|+Module      : MetaHS.DataModel.Utils.NameResolution+Description : The MetaHS extractor for uses relations+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+NameResolution functions+-}+module MetaHS.DataModel.Utils.NameResolution+    ( NameResolutionMap+    , NameResolutionMaps+    , createNameResolutionMaps+    , resolveType+    , resolveValue+    ) where++import Data.Maybe (fromMaybe)+import Data.Set (filter)+import qualified Data.Map as Map+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.DataModel.Utils.Name++-- | A NameResolutionMap is a Data.Map that map from plain identifiers to resolved MetaModel.Element (e.g. "sum" -> Function "M.N.sum").+type NameResolutionMap = Map.Map String MetaModel.Element++-- |  The NameResolutionMaps. The first Data.Map is applicable to types; the second Data.Map is applicable to values.+type NameResolutionMaps = (NameResolutionMap, NameResolutionMap)++-- | Creates the NameResolution Data.Map instances.+createNameResolutionMaps :: String              -- ^ Module name.+                         -> MetaModel.Relation  -- ^ The "Module mn `Contains` Element" Relations.+                         -> NameResolutionMaps  -- ^ The resulting NameResolutionMaps.+createNameResolutionMaps mn r = foldr f empty fcrs+      where+        fcrs = Data.Set.filter (isModuleNameContains mn) r                      -- fcrs = filtered contains relations. List of "Module mn `Contains` Element" Relations that are applicable to the current Module.+        empty = (Map.empty, Map.empty) :: NameResolutionMaps+        unqualifiedName = snd . split+        f (_,mmdt@(MetaModel.DataType mmdtn)) nrms =                            -- mmdt = MetaModel DataType, mmdtn = MetaModel DataType name, nrms = NameResolutionMaps+            (Map.insert key value $ fst nrms, snd nrms)+              where+                key = unqualifiedName mmdtn+                value = mmdt+        f (_,mmts@(MetaModel.TypeSynonym mmtsn)) nrms =                         -- mmts = MetaModel TypeSynonym, mmtsn = MetaModel TypeSynonym name, nrms = NameResolutionMaps+            (Map.insert key value $ fst nrms, snd nrms)+              where+                key = unqualifiedName mmtsn+                value = mmts+        f (_,mmf@(MetaModel.Function mmfn)) nrms =                              -- mmf = MetaModel Function, mmfn = MetaModel Function name, nrms = NameResolutionMaps+            (fst nrms, Map.insert key value $ snd nrms)+              where+                key = unqualifiedName mmfn+                value = mmf+        f _ nrms = nrms++-- | Resolves a simple type name to the corresponding qualified Element.+--   The simple type name will be qualified with "?" and wrapped in an+--   MetaModel.UnknownType Element  if the mapping is not known by the+--   provided NameResolutionMaps.+resolveType :: String            -- ^ The simple value name.+            -> NameResolutionMaps -- ^ The NameResolutionMaps.+            -> MetaModel.Element  -- ^ The corresponding Element.+resolveType s nrms = fromMaybe unknown lookupResult+  where+    lookupResult = Map.lookup s $ fst nrms                                      -- lookupResult = result from the lookup in the types NameResolutionMap+    unknown = MetaModel.UnknownType $ makeQualifiedId "?" s                     -- unknown = UnknownType object in case lookupResult == Nothing+++-- | Resolves a simple value name to the corresponding qualified Element.+--   The simple value name will be qualified with "?" if the mapping is not+--   known by the provided NameResolutionMaps.+resolveValue :: String            -- ^ The simple value name.+            -> NameResolutionMaps -- ^ The NameResolutionMaps.+            -> MetaModel.Element  -- ^ The corresponding Element.+resolveValue s nrms = fromMaybe unknown lookupResult+  where+    lookupResult = Map.lookup s $ snd nrms                                      -- lookupResult = result from the lookup in the value NameResolutionMap+    unknown = MetaModel.Function $ makeQualifiedId "?" s                        -- unknown = Function object in case lookupResult == Nothing++-- | Returns True if the Relation is of the form (Module "mn",Element)+--   where mn is the provided Module name.+isModuleNameContains :: String                                -- ^ Module name.+                     -> (MetaModel.Element,MetaModel.Element) -- ^ The (Element,Element) pair to check.+                     -> Bool                                  -- ^ Check result+isModuleNameContains mn (MetaModel.Module n,_) = n == mn+isModuleNameContains _ _ = False
+ src/MetaHS/EDSL.hs view
@@ -0,0 +1,16 @@+{-|+Module      : MetaHS.EDSL+Description : The MetaHS EDSL+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental++MetaHS EDSL+-}+module MetaHS.EDSL+    ( module X+    ) where++import MetaHS.EDSL.MetaModel as X+import MetaHS.EDSL.Graph as X+import MetaHS.EDSL.Utils as X
+ src/MetaHS/EDSL/Graph.hs view
@@ -0,0 +1,16 @@+{-|+Module      : MetaHS.EDSL.Graph+Description : The MetaHS EDSL Graph part+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS EDSL Graph part+-}+module MetaHS.EDSL.Graph+    ( module X+    ) where++import MetaHS.EDSL.Graph.Types as X+import MetaHS.EDSL.Graph.Utils as X+import MetaHS.EDSL.Graph.UsesGraph as X
+ src/MetaHS/EDSL/Graph/Types.hs view
@@ -0,0 +1,28 @@+{-|+Module      : MetaHS.EDSL.Graph.Types+Description : The MetaHS EDSL Graph types+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS EDSL Graph types+-}+module MetaHS.EDSL.Graph.Types+    ( GraphType+    , ParamsType+    , Directed (..)+    ) where++import Data.Text.Lazy (Text)+import Data.Graph.Inductive+import Data.GraphViz+import MetaHS.DataModel.MetaModel (Element)++-- | Type synonym for generated LCOM graph.+type GraphType  = Gr Element Text++-- | Type synonym for generated GraphvizParams.+type ParamsType = GraphvizParams Node Element Text () Element++-- | Determines whether the graph should be directed or undirected.+data Directed = Directed | Undirected
+ src/MetaHS/EDSL/Graph/UsesGraph.hs view
@@ -0,0 +1,129 @@+{-|+Module      : MetaHS.EDSL.Graph.UsesGraph+Description : Generates a Uses graph for a module+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Generates a Uses graph for a module+-}+module MetaHS.EDSL.Graph.UsesGraph+    ( internalUses+    , internalUsesGraph+    , internalUsesParams+    ) where++import Data.Maybe (fromMaybe)+import Data.List (nub, elemIndex)+import Data.Text.Lazy (Text, pack)+import Data.Graph.Inductive+import Data.GraphViz+import Data.GraphViz.Attributes.Complete+import MetaHS.DataModel.MetaModel+import MetaHS.EDSL.MetaModel+import MetaHS.EDSL.Graph.Types+import MetaHS.EDSL.Utils++-- | Generates the internal uses graph for the specified module and returns+--   the associated default GraphvizParams.+internalUses :: MetaModel               -- ^ The meta-model.+             -> Element                 -- ^ The module.+             -> Directed                -- ^ This option will determine whether the resulting graph is directed or undirected.+             -> String                  -- ^ The prefix for the links in the generated SVG images to the correct HTML editor for displaying the source code. Should probably become a hard link if a web server is used.+             -> (GraphType,ParamsType)  -- ^ The generated Graph.+internalUses metaModel moduleElement directed editorLink = (graph,params)+  where+    graph = internalUsesGraph metaModel moduleElement directed+    params = internalUsesParams metaModel moduleElement directed editorLink++-- | Generates the internal uses graph for the specified module.+internalUsesGraph :: MetaModel  -- ^ The meta-model.+                  -> Element    -- ^ The module.+                  -> Directed   -- ^ This option will determine whether the resulting graph is directed or undirected.+                  -> GraphType  -- ^ The generated Graph.+internalUsesGraph metaModel moduleElement directed = graph+  where+    graph = mkGraph ns es+    elements = [m | m  <- mc, isInteresting m]+    mc = moduleContains metaModel moduleElement++    ns :: [LNode Element]+    ns = zipWith f [0..] elements                                               -- ns = nodes+      where+        f :: Int -> Element -> LNode Element+        f i e = (i, e)++    es :: [LEdge Text]                                                          -- es = edges+    es = concat [f a b | a <- elements, b <- elementUses metaModel a]+      where+        f :: Element -> Element -> [LEdge Text]+        f a b = nub $ fromMaybe [] $ mkLEdge <$> ia <*> ib+          where+            mkLEdge :: Int -> Int -> [LEdge Text]+            mkLEdge x y = case directed of+                Directed   -> [(x, y, pack "")]                                 -- directed graphs+                Undirected -> [(x, y, pack ""), (y, x, pack "")]                -- undirected graphs require A -> B AND B -> A in order to come to A -- B+            ia = elemIndex a elements+            ib = elemIndex b elements++-- | Generates the default GraphvizParams for the internal uses graph for the+--   specified module.+internalUsesParams :: MetaModel    -- ^ The meta-model.+                   -> Element      -- ^ The module.+                   -> Directed     -- ^ This option will determine whether the resulting graph is directed or undirected.+                   -> String       -- ^ The prefix for the links in the generated SVG images to the correct HTML editor for display the source code. Should probably become a hard link if a web server is used.+                   -> ParamsType   -- ^ The generated Graph.+internalUsesParams metaModel moduleElement directed editorLink =+    nonClusteredParams+        { isDirected       = case directed of                                   -- undirected graphs require A -> B AND B -> A in order to come to A -- B+            Directed   -> True+            Undirected -> False+        , globalAttributes = globAttr+        , fmtNode          = formatNode+        , fmtEdge          = const []+        }+  where+    globAttr =+        [GraphAttrs+            [Label . StrLabel . pack $ name moduleElement+            ,Overlap ScaleXYOverlaps+            ]+        ]+    formatNode (_, fe@(Function qn)) =+        [qnToLabel qn+        ,shape BoxShape+        ,styles [bold, filled]+        ,FillColor [toWC (RGBA 0xFF 0xFF 0xFF 0x40)]                            -- White, alpha=0.25+        ,Color [toWC (RGBA 0x00 0x00 0x00 0xFF)]                                -- Black, alpha=1.00+        ,URL $ urlQuery metaModel fe+        ]+    formatNode (_, dte@(DataType qn)) =+        [qnToLabel qn+        ,shape BoxShape+        ,styles [bold, filled]+        ,FillColor [toWC (RGBA 0x41 0xA3 0x17 0x40)]                            -- LimeGreen, alpha=0.25+        ,Color [toWC (RGBA 0x41 0xA3 0x17 0xFF)]                                -- LimeGreen, alpha=1.00+        ,URL $ urlQuery metaModel dte+        ]+    formatNode (_, tse@(TypeSynonym qn)) =+        [qnToLabel qn+        ,shape BoxShape+        ,styles [bold, filled]+        ,FillColor [toWC (RGBA 0x2B 0x65 0xEC 0x40)]                            -- OceanBlue; alpha=0.25+        ,Color [toWC (RGBA 0x2B 0x65 0xEC 0xFF)]                                -- OceanBlue, alpha=1.00+        ,URL $ urlQuery metaModel tse+        ]+    formatNode (_, e) = [qnToLabel $ name e]++    qnToLabel qn = Label $ StrLabel . pack . snd $ split qn++    urlQuery mm e = pack $ case elementSource mm e of+        Just s -> editorLink ++ locationToQuery s+        _ -> ""++-- | The Elements for which the lcom is measured.+isInteresting :: Element -> Bool+isInteresting TypeSynonym{} = True+isInteresting DataType{} = True+isInteresting Function{} = True+isInteresting  _ = False
+ src/MetaHS/EDSL/Graph/Utils.hs view
@@ -0,0 +1,61 @@+{-|+Module      : MetaHS.EDSL.Graph.Utils+Description : Utilities for handling graphs+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Utilities for handling graphs+-}+module MetaHS.EDSL.Graph.Utils+    ( graphToImage+    ) where++import Data.Text.Lazy (Text)+import Control.Exception (try,SomeException)+import System.IO (hPutStrLn,stderr)+import Data.Graph.Inductive (Node)+import Data.GraphViz+import Data.GraphViz.Printing (renderDot)+import MetaHS.EDSL.Graph.Types++-- | Generates an image from a graph and writes this to a file in the specified+--   format using the specified Graphviz layouter.+graphToImage :: GraphvizCommand -- ^ The Graphviz layouter to use.+             -> GraphvizOutput  -- ^ The output format.+             -> FilePath        -- ^ The FilePath to use for the generated image.+             -> GraphType       -- ^ The graph to render.+             -> ParamsType      -- ^ The graph parameters to use.+             -> IO FilePath     -- ^ The FilePath used for the generated image.+graphToImage cmd outp path graph params =+    writeImage cmd outp path $ graphToDotGraph graph params++-- | Converts a graph and parameters to a DotGraph Node.+graphToDotGraph :: GraphType      -- ^ The graph to convert.+                -> ParamsType     -- ^ The graph parameters to use.+                -> DotGraph Node  -- ^ The resulting DotGraph Node.+graphToDotGraph graph params = adjustStrict $ graphToDot params graph++-- | Generates an image from a DotGraph Node and writes this to a file in the+--   specified format using the specified Graphviz layouter.+writeImage :: GraphvizCommand -- ^ The Graphviz layouter to use.+           -> GraphvizOutput  -- ^ The output format.+           -> FilePath        -- ^ The FilePath to use for the generated image.+           -> DotGraph Node   -- ^ The graph to generate.+           -> IO FilePath     -- ^ The FilePath used for the generated image.+writeImage cmd outp path dg = do+  result <- try (runGraphvizCommand cmd dg' outp path)+                 :: IO (Either SomeException FilePath)+  case result of+      Left _ -> do+          hPutStrLn stderr $ "Failed to write image " ++ path ++ "."+          return ""+      Right _ -> return path+    where+      dg' :: DotGraph Text+      dg' = parseDotGraph . renderDot . toDot $ adjustStrict dg++-- | Adjusts the DOT strict setting for a DotGraph Node. This option will be+--   enabled if the graph is undirected.+adjustStrict :: DotGraph Node -> DotGraph Node+adjustStrict a = setStrictness (not $ graphIsDirected a) a
+ src/MetaHS/EDSL/MetaModel.hs view
@@ -0,0 +1,246 @@+{-|+Module      : MetaHS.EDSL.MetaModel+Description : The MetaHS EDSL MetaModel part+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS EDSL MetaModel part+-}+module MetaHS.EDSL.MetaModel+    ( generateMetaModel+    , writeMetaModel+    , readMetaModel+    , writeMetaModelPretty+    , pretty+    , numberOfItems+    , getPrograms+    , getModules+    , programContains+    , moduleContains+    , moduleImports+    , elementContains+    , elementImports+    , elementSource+    , elementUses+    , getRelation+    , setRelation+    , domain+    , range+    , RelationKey+    ) where+import qualified Data.Map.Strict                             as Map+import           Data.Maybe                                  (listToMaybe)+import qualified Data.Set                                    as Set+import qualified MetaHS.DataModel.Extractor.Module.Contains  as ModuleContains+import qualified MetaHS.DataModel.Extractor.Module.Imports   as ModuleImports+import qualified MetaHS.DataModel.Extractor.Module.Source    as ModuleSource+import qualified MetaHS.DataModel.Extractor.Module.Uses      as ModuleUses+import qualified MetaHS.DataModel.Extractor.Program.Contains as ProgramContains+import qualified MetaHS.DataModel.MetaModel                  as MetaModel+import           MetaHS.DataModel.Utils.File.FileUtils+import           Text.PrettyPrint++-- | convenience type that represents the metamodel aggregation relation+type RelationKey = String++keyContains :: RelationKey+keyContains = "_contains"++keyUses :: RelationKey+keyUses = "_uses"++keySource :: RelationKey+keySource = "_source"++keyImports :: RelationKey+keyImports = "_imports"++-- | Generates a meta-model.+generateMetaModel :: String                 -- ^ The program name.+                  -> String                 -- ^ The program path.+                  -> String                 -- ^ The parse error output path.+                  -> IO MetaModel.MetaModel -- ^ The resulting meta-model.+generateMetaModel programName programPath parseErrorsPath = do+  (mods, failed) <- modulesInHierarchy programPath -- mods = modules, failed = ParseFailed+  writeFile parseErrorsPath $ show $ map show failed+  let pc = ProgramContains.contains programName mods -- pc = program contains+  let mc = Set.unions [ModuleContains.contains m | m <- mods] -- mc = module contains+  let mu = Set.unions [ModuleUses.uses m mc | m <- mods] -- mu = module uses+  let ms = Set.unions [ModuleSource.source m | m <- mods] -- ms = modules source+  let im = Set.unions [ModuleImports.imports m | m <- mods] -- im = module imports+  return . MetaModel.MetaModel $+    Map.insert keyContains (Set.union pc mc)+    $ Map.insert keyUses mu+    $ Map.insert keySource ms+    $ Map.insert keyImports im Map.empty++-- | Write a meta-model to a file.+writeMetaModel :: MetaModel.MetaModel -- ^ The meta-model to write.+               -> String              -- ^ The path of the file to write.+               -> IO ()               -- ^ No result.+writeMetaModel mm path = writeFile path $ show mm+++-- | Read a meta-model from a file.+readMetaModel :: String                 -- ^ The path of the file to read.+              -> IO MetaModel.MetaModel -- ^ The meta-model read.+readMetaModel path = do+    s <- readFile path+    return $ read s+++-- | Write a meta-model to a file.+writeMetaModelPretty :: MetaModel.MetaModel -- ^ The meta-model to write.+                     -> String              -- ^ The path of the file to write.+                     -> IO ()               -- ^ No result.+writeMetaModelPretty mm path = writeFile path $ renderStyle s $ pretty mm+  where+    s = style { mode = LeftMode }++-- | Returns a pretty printed representation of the meta-model.+pretty :: MetaModel.MetaModel -- ^ The meta-model to pretty print.+       -> Doc                 -- ^ The resulting Doc.+pretty = MetaModel.pPrint+++-- | Returns the number of relation items in the meta-model.+numberOfItems :: MetaModel.MetaModel -- ^ The meta-model.+              -> Int                 -- ^ The number of relation items in the meta-model.+numberOfItems mm = Map.foldr f 0 $ MetaModel.getMetaModelImpl mm+  where+    f :: MetaModel.Relation -> Int -> Int+    f r t = t + Set.size r++-- | Returns a list of Programs contained in the metamodel.+getPrograms :: MetaModel.MetaModel -- ^ The metamodel.+         -> [MetaModel.Element] -- ^ The Programs contained in the metamodel.+getPrograms mm = Set.elems $ Set.foldr f Set.empty pcs+  where+    f (p@MetaModel.Program{},_) es = Set.insert p es+    f _ es = es+    pcs = getRelation keyContains mm++-- | Returns a list of Modules contained in the metamodel.+getModules :: MetaModel.MetaModel  -- ^ The metamodel.+           -> [MetaModel.Element]  -- ^ The Modules contained by the specified Program.+getModules mm = Set.elems $ Set.foldr f Set.empty pcs+  where+    f (p,c) ms+        | isProgram p && isModule c = Set.insert c ms+        | otherwise = ms+    pcs = getRelation keyContains mm++-- | Returns a list of Elements contained by the specified Program.+programContains :: MetaModel.MetaModel  -- ^ The meta-model.+                -> MetaModel.Element    -- ^ The specified Program.+                -> [MetaModel.Element]  -- ^ The Elements contained by the specified Program.+programContains mm e+    | isProgram e = elementContains mm e+    | otherwise = error "Function MetaHS.EDSL.MetaModel.programContains only works for MetaHS.DataModel.MetaModel.Program Elements!"++-- | Returns a list of Elements contained by the specified Module.+moduleContains :: MetaModel.MetaModel  -- ^ The meta-model.+               -> MetaModel.Element    -- ^ The specified Module.+               -> [MetaModel.Element]  -- ^ The Elements contained by the specified Module.+moduleContains mm e+    | isModule e = elementContains mm e+    | otherwise = error "Function MetaHS.EDSL.MetaModel.moduleContains only works for MetaHS.DataModel.MetaModel.Module Elements!"++-- | Returns a list of Elements imported by the specified Module.+moduleImports :: MetaModel.MetaModel   -- ^ The meta-model.+               -> MetaModel.Element    -- ^ The specified Module.+               -> [MetaModel.Element]  -- ^ The Elements contained by the specified Module.+moduleImports mm e+    | isModule e = elementImports mm e+    | otherwise = error "Function MetaHS.EDSL.MetaModel.moduleContains only works for MetaHS.DataModel.MetaModel.Module Elements!"++-- | Returns a list of Elements contained by the specified Element.+elementContains :: MetaModel.MetaModel  -- ^ The meta-model.+                -> MetaModel.Element    -- ^ The specified Element.+                -> [MetaModel.Element]  -- ^ The Elements contained by the specified Element.+elementContains mm e = Set.foldr f [] pcs+  where+    f (p,c) es+        | p == e = c : es+        | otherwise = es+    pcs = getRelation keyContains mm++-- | Returns a list of Elements imported by the specified Element.+elementImports :: MetaModel.MetaModel  -- ^ The meta-model.+                -> MetaModel.Element    -- ^ The specified Element.+                -> [MetaModel.Element]  -- ^ The Elements contained by the specified Element.+elementImports mm e = Set.foldr f [] pcs+  where+    f (p,c) es+        | p == e = c : es+        | otherwise = es+    pcs = getRelation keyImports mm++-- | Returns a the source location for the specified Element.+elementSource :: MetaModel.MetaModel      -- ^ The meta-model.+              -> MetaModel.Element        -- ^ The specified Element.+              -> Maybe MetaModel.Element  -- ^ The source location for the specified Element.+elementSource mm e = listToMaybe $ Set.foldr f [] pcs+  where+    f (p,c) es+        | p == e = c : es+        | otherwise = es+    pcs = getRelation keySource mm++-- | Returns a list of Elements used by the specified Element.+elementUses :: MetaModel.MetaModel  -- ^ The meta-model.+            -> MetaModel.Element    -- ^ The specified Element.+            -> [MetaModel.Element]  -- ^ The Elements used by the specified Element.+elementUses mm e = Set.foldr f [] pcs+  where+    f (p,c) es+        | p == e = c : es+        | otherwise = es+    pcs = getRelation keyUses mm++-- | Returns the relation corresponding to the supplied key or an empty Set.+getRelation :: String               -- ^ The metamodel key string.+            -> MetaModel.MetaModel  -- ^ The metamodel.+            -> MetaModel.Relation   -- ^ The corresponding Relation or an empty set.+getRelation k mm =+    Map.findWithDefault Set.empty k $ MetaModel.getMetaModelImpl mm++-- | Returns a MetaModel that is appended with a new or replaced Relation set.+setRelation :: String               -- ^ The metamodel key string.+            -> MetaModel.Relation   -- ^ The Relation to add.+            -> MetaModel.MetaModel  -- ^ The metamodel.+            -> MetaModel.MetaModel  -- ^ The resulting metamodel.+setRelation k rs mm = MetaModel.MetaModel $ Map.insert k rs mmi+  where+    mmi = MetaModel.getMetaModelImpl mm++-- | Returns the domain for a specified relation in the metamodel.+domain :: String                    -- ^ The metamodel key string.+       -> MetaModel.MetaModel       -- ^ The metamodel.+       -> Set.Set MetaModel.Element -- ^ Set of Elements that form the domain of the binary relation.+domain k mm = foldr f Set.empty r+  where+    f a = Set.insert (fst a)+    r = getRelation k mm++-- | Returns the range for a specified relation in the metamodel.+range :: String                    -- ^ The metamodel key string.+      -> MetaModel.MetaModel       -- ^ The metamodel.+      -> Set.Set MetaModel.Element -- ^ Set of Elements that form the range of the binary relation.+range k mm = foldr f Set.empty r+  where+    f a = Set.insert (snd a)+    r = getRelation k mm++-- | Checks that the provided MetaModel.Element is a MetaModel.Program+isProgram :: MetaModel.Element+          -> Bool+isProgram MetaModel.Program{} = True+isProgram _ = False++-- | Checks that the provided MetaModel.Element is a MetaModel.Module+isModule :: MetaModel.Element+         -> Bool+isModule MetaModel.Module{} = True+isModule _ = False
+ src/MetaHS/EDSL/Utils.hs view
@@ -0,0 +1,31 @@+{-|+Module      : MetaHS.EDSL.Utils+Description : The MetaHS EDSL Utils part+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+MetaHS EDSL Utils part+-}+module MetaHS.EDSL.Utils+    ( split+    , isLocal+    , locationToQuery+    ) where++import System.FilePath.Posix (joinPath, splitPath)+import MetaHS.DataModel.Utils (split, isLocal)+import qualified MetaHS.DataModel.MetaModel as MetaModel++-- | Converts a Location Element to a query String suitable for URLs.+--   An empty String is returned if the Element is not a Location Element.+locationToQuery :: MetaModel.Element  -- ^ The Location Element.+                -> String             -- ^ The resulting URL query String or an empty String.+locationToQuery loc@MetaModel.Location{} = concat+    ["?path="           , joinPath . drop 1 . splitPath $ MetaModel.locationPath loc+    ,"&amp;startLine="  , show $ MetaModel.locationStartLine loc+    ,"&amp;startColumn=", show $ MetaModel.locationStartColumn loc+    ,"&amp;endLine="    , show $ MetaModel.locationEndLine loc+    ,"&amp;endColumn="  , show $ MetaModel.locationEndColumn loc+    ]+locationToQuery _ = ""
+ src/MetaHS/Extensions/CBO.hs view
@@ -0,0 +1,50 @@+{-|+Module      : MetaHS.Extensions+Description : The MetaHS LCOM aggregation+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Metamodel Element that is interesting (those that represents modules being imported) is :+Module. All other Elements that are part of the _contains relations are ignored.++CBO - Coupling between object classes+      The coupling between object classes (CBO) metric represents the number of classes coupled to a given class+      (efferent couplings, Ce).+      This coupling can occur through method calls, field accesses, inheritance, arguments, return types, and exceptions.+      ref. Chidamber and Kemerer (1994)+-}+module MetaHS.Extensions.CBO+  (keyCbo+  ,cboAggregator)+  where++import qualified Data.Set                   as Set+import           MetaHS.DataModel.MetaModel+import           MetaHS.EDSL.MetaModel++-- | MetaModel key used for the CBO relation.+keyCbo :: RelationKey+keyCbo = "CBO"++-- | CBO aggregator that adds the CBO metric relation to the supplied meta-model.+cboAggregator :: MetaModel -- ^ The supplied meta-model.+              -> MetaModel -- ^ The complemented meta-model.+cboAggregator mm = setRelation keyCbo r mm+  where+    r = foldr f Set.empty $ filter (\x -> x /= Module {name = "?"}) $ getModules mm+    f mod = Set.insert (mod, lv mod)+    lv m = IntValue $ calcCbo mm m++calcCbo ::+     MetaModel-- ^ The meta-model.+  -> Element  -- ^ Module+  -> Int      -- ^ The calculated LCOM metric value.+calcCbo mm mod = length xs+  where+    xs = filter isInteresting $ moduleImports mm mod++-- | The Elements for which the CBO is measured.+isInteresting :: Element -> Bool+isInteresting Module {} = True+isInteresting  _        = False
+ src/MetaHS/Extensions/LCOM.hs view
@@ -0,0 +1,62 @@+{-|+Module      : MetaHS.Extensions.LCOM+Description : The MetaHS EDSL LCOM part+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Metamodel Elements that are interesting (those that are used to determine nodes in+MetaHS.EDSL.Graph.UsesGraph module ) are : TypeSynonym, DataType, Function.+All other Elements that are  part of the _contains relations are ignored.++LCOM4 - Number of connected components in the graph that represents each method as a node and the sharing of at least+        one attribute/method as an edge.+        ref. Hitz and Montazeri (1995)+-}+module MetaHS.Extensions.LCOM+    ( lcom+    , lcomGraph+    , keyLcom+    , lcomAggregator+    ) where++import qualified Data.Set as Set+import Data.Graph.Inductive+import MetaHS.DataModel.MetaModel+import MetaHS.EDSL.MetaModel+import MetaHS.EDSL.Graph++-- | Calculates the LCOM metric value for a specified module name.+lcom :: MetaModel -- ^ The meta-model.+     -> Element   -- ^ The Module Element.+     -> Int       -- ^ The calculated LCOM metric value.+lcom metaModel moduleElement = do+    let (value, _, _) = lcomGraph metaModel moduleElement Directed ""+    value++-- | Generates the internalUsesGraph for the specified Module Element and+-- calculates the corresponding LCOM metric value.+lcomGraph :: MetaModel                    -- ^ The meta-model.+          -> Element                      -- ^ The Module Element.+          -> Directed                     -- ^ Create a directed or undirected graph.+          -> String                       -- ^ The prefix for the links in the generated SVG images to the correct HTML editor for display the source code. Should probably become a hard link if a web server is used.+          -> (Int, GraphType, ParamsType) -- ^ The calculated LCOM metric value and the generated Graph and default parameters.+lcomGraph metaModel moduleElement directed editorLink = do+    let (graph, params) = internalUses metaModel moduleElement directed editorLink+    (noComponents graph, graph, params)++-- | MetaModel key used for the LCOM relation.+keyLcom :: RelationKey+keyLcom = "LCOM"++-- | LCOM aggregator that adds the LCOM relation to the metamodel.+-- key = keyLcom+-- value = (p,c) where p is a Module Element and c is an IntValue Element that+-- contains the LCOM value for the module.+lcomAggregator :: MetaModel+               -> MetaModel+lcomAggregator mm = setRelation keyLcom r mm+  where+    r = foldr f Set.empty $ filter (\x -> x /= Module {name = "?"}) $ getModules mm -- r = relation+    f m = Set.insert (m, lv m) -- f = foldr function+    lv m = IntValue $ lcom mm m                                                        -- lv = LCOM value
+ src/MetaHS/Extensions/LOC.hs view
@@ -0,0 +1,61 @@+{-|+Module      : MetaHS.Extensions.LOC+Description : The MetaHS EDSL LOC aggregation+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Metamodel Elements that are interesting (those that occupy distinct line numbers) are :+ModuleHead, ModuleImport, TypeSynonym, DataType, Function, TypeSignature,+TypeClass and Instance. All other Elements that are part of the _contains relations are ignored.++LOC - Sum of all non-empty, non-comment lines in a module.+-}+module MetaHS.Extensions.LOC+  ( keyLoc+  , locAggregator+  ) where++import qualified Data.Set                   as Set+import           MetaHS.DataModel.MetaModel+import           MetaHS.EDSL.MetaModel++-- | MetaModel key used for the LOC relation.+keyLoc :: RelationKey+keyLoc = "LOC"++calcLoc ::+     MetaModel-- ^ The meta-model.+  -> Element  -- ^ Module+  -> Int      -- ^ The calculated LCOM metric value.+calcLoc mm mod = sum ls+  where+    ls = [extractLines x | x <- es]+    es = [elementSource mm mc | mc <- moduleContains mm mod, isInteresting mc]+    extractLines :: Maybe Element -> Int+    extractLines jl =+      case jl of+        Just Location {locationStartLine = ls, locationEndLine = le} -> (le - ls) + 1+        Nothing -> 0++-- | LOC aggregator that adds the LOC metric relation to the supplied meta-model.+locAggregator :: MetaModel-- ^ The supplied meta-model.+              -> MetaModel-- ^ The complemented meta-model.+locAggregator mm = setRelation keyLoc r mm+  where+    r = foldr f Set.empty $ filter (\x -> x /= Module {name = "?"}) $ getModules mm+    f mod = Set.insert (mod, lv mod)+    lv m = IntValue $ calcLoc mm m++-- | The Elements for which the loc is measured.+isInteresting :: Element -> Bool+isInteresting ModuleHead {} = True+isInteresting ModuleImport{} = True+isInteresting TypeSynonym{} = True+isInteresting DataType{} = True+isInteresting Function{} = True+isInteresting TypeSignature{} = True+isInteresting TypeClass{} = True+isInteresting Instance{} = True+isInteresting Pragma{} = True+isInteresting  _ = False
+ src/MetaHS/Extensions/MacroLevelAggregation/Average.hs view
@@ -0,0 +1,25 @@+{-|+Module      : MetaHS.MacroLevelAggregation+Description : The MetaHS Macro-level aggregation method: average+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Calculates the average of the metric values corresponding to supplied Relation Key.+-}+module MetaHS.Extensions.MacroLevelAggregation.Average+    where++import MetaHS.Extensions.MacroLevelAggregation.Utils+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.EDSL.MetaModel++-- | Calculate the average of the metric values associated with the supplied metric Relation key+average :: RelationKey          -- ^ The MetaModel Relation Key (E.g., LCOM).+        -> MetaModel.MetaModel  -- ^ The MetaModel Containing the associated key.+        -> Double               -- ^ The average+average key mm = fromIntegral addition / fromIntegral valuesCount+    where+    addition = sum values+    valuesCount = length values+    values = getMetricElements key mm
+ src/MetaHS/Extensions/MacroLevelAggregation/Distribution.hs view
@@ -0,0 +1,25 @@+{-|+Module      : MetaHS.MacroLevelAggregation+Description : The MetaHS Macro-level aggregation method: distribution+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Calculates the distribution of the metric values corresponding to supplied Relation Key.+-}+module MetaHS.Extensions.MacroLevelAggregation.Distribution+    where++import MetaHS.Extensions.MacroLevelAggregation.Utils+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.EDSL.MetaModel+import qualified Data.Set as Set++-- | Calculates the distribution of the metric values corresponding to supplied Relation Key.+distribution :: RelationKey          -- ^ The MetaModel Relation Key (E.g., LCOM).+             -> MetaModel.MetaModel  -- ^ The MetaModel Containing the associated key.+             -> Set.Set (Int, Int)   -- ^ The set containing tuple(s) (Frequency, MetricValue)+distribution key mm = Set.fromList [(countValues x xs, x) | x <- xs]+    where+    xs = getMetricElements key mm+    countValues x = length.filter(==x)
+ src/MetaHS/Extensions/MacroLevelAggregation/GiniCoefficient.hs view
@@ -0,0 +1,54 @@+{-|+Module      : MetaHS.MacroLevelAggregation+Description : The MetaHS Macro-level aggregation method: Gini-coefficient+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Calculates the Gini-coefficient of the metric population corresponding+to supplied Relation Key. Result is a value bounded by [0,1].+-}+module MetaHS.Extensions.MacroLevelAggregation.GiniCoefficient+  (giniCoefficient)+  where++import MetaHS.Extensions.MacroLevelAggregation.Utils+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.EDSL.MetaModel+import qualified Data.Set as Set+import qualified Data.List as List++-- | Calculate the Gini-coefficient of the metric values associated with the supplied metric Relation key+giniCoefficient :: RelationKey          -- ^ The MetaModel Relation Key (E.g., LCOM).+                -> MetaModel.MetaModel  -- ^ The MetaModel Containing the associated key.+                -> Double               -- ^ The Gini coefficient+giniCoefficient key mm = gini ordered_list+  where+  ordered_list = List.sort xs+  xs = getMetricElements key mm++-- | Calculates the Gini-coefficient of the elements contained in the supplied list+gini :: [Int]  -- ^ Ordered list+     -> Double -- ^ The Gini-coefficient+gini xs | null xs = 0.0+        | length xs == 1 = 0.0+        | otherwise = fromIntegral (deltaSum xs) / fromIntegral (last $ xsAccum xs) / fromIntegral (length xs)++-- | Sums up halve of all delta's of each consecutive element in a list. (x_i - x_i-1)+-- | This means that from a supplied list, the delta of each member with respect to+-- | each other member, will be added together.+-- | This function represents the numerator part of the Gini-coefficient algorithm.+-- | (although with one halve of the symmetric metric)+deltaSum :: [Int] -- ^ An ordered list+         -> Int   -- ^ All delta's added together+deltaSum xs = fromIntegral delta_cum+  where+  delta_cum = sum deltas+  deltas = zipWith3 (\idx x x_accum -> idx * x - x_accum) indices xs $ xsAccum xs+  xs_ord = List.sort xs+  indices = [0..length xs - 1]++-- | Every element in the resulting list is an accumulation of all it's predecessors.+xsAccum :: [Int] -- ^ An ordered list+         -> [Int] -- ^ Accumulated values+xsAccum = scanl (+) 0
+ src/MetaHS/Extensions/MacroLevelAggregation/IdealValueDeviation.hs view
@@ -0,0 +1,62 @@+{-|+Module      : MetaHS.MacroLevelAggregation+Description : The MetaHS Macro-level aggregation method: ideal value deviation (IVD)+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Calculates the deviation to a supplied 'ideal value' in a range between+a lower and upper bound for the median of metric values corresponding to+supplied Relation Key. Result is a value bounded by [0,1].+Empirically determined values are:+LOC; low = -15, ideal = 69, upper = 269+LCOM: low = 0, ideal = 1, upper = 11+CBO: low = 0, ideal = 6, upper = 16+-}+module MetaHS.Extensions.MacroLevelAggregation.IdealValueDeviation+  (idealValueDeviation)+  where++import MetaHS.Extensions.MacroLevelAggregation.Utils+import MetaHS.Extensions.MacroLevelAggregation.Median+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.EDSL.MetaModel++-- | Calculate the Ideal Value Deviation of the metric values associated with the supplied metric Relation key.+idealValueDeviation :: RelationKey          -- ^ The MetaModel Relation Key (E.g., LCOM).+                    -> MetaModel.MetaModel  -- ^ The MetaModel Containing the associated key.+                    -> Int                  -- ^ The lower bound.+                    -> Int                  -- ^ The ideal value.+                    -> Int                  -- ^ The upper bound.+                    -> Double               -- ^ The deviation from the ideal value.+idealValueDeviation key mm lowerBound idealValue upperBound = ivd ll ideal ul med+  where+  ll = fromIntegral lowerBound+  ideal = fromIntegral idealValue+  ul = fromIntegral upperBound+  med = median key mm++-- | Calculate the Ideal Value Deviation based on the supplied metric median.+ivd :: Double -- ^ The lower bound.+    -> Double -- ^ The ideal value.+    -> Double -- ^ The upper bound.+    -> Double -- ^ The metric median to be evaluated.+    -> Double -- ^ The deviation from the ideal value.+ivd ll ideal ul med+  | ll < med && med <= ideal = lowerThanIdeal ll ideal med+  | ideal < med && med < ul = higherThanIdeal ideal ul med+  | med <= ll || med >= ul = 0.0++-- | Calculate the Ideal Value Deviation when the metric median is between the lower bound and the ideal value.+lowerThanIdeal :: Double -- ^ The lower bound.+               -> Double -- ^ The ideal value.+               -> Double -- ^ The metric median to be evaluated.+               -> Double -- ^ The deviation from the ideal value.+lowerThanIdeal ll ideal m = (m - ll) / (ideal - ll)++-- | Calculate the Ideal Value Deviation when the metric median is between the ideal value and the lower bound.+higherThanIdeal :: Double -- ^ The ideal value.+                -> Double -- ^ The upper bound.+                -> Double -- ^ The metric median to be evaluated.+                -> Double -- ^ The deviation from the ideal value.+higherThanIdeal ideal ul m = 1 - ((m - ideal) / (ul - ideal))
+ src/MetaHS/Extensions/MacroLevelAggregation/Median.hs view
@@ -0,0 +1,41 @@+{-|+Module      : MetaHS.MacroLevelAggregation+Description : The MetaHS Macro-level aggregation method: median+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Calculates the median of the metric values corresponding to supplied Relation Key.+-}+module MetaHS.Extensions.MacroLevelAggregation.Median+  (median)+where++import Data.List (sort)++import MetaHS.Extensions.MacroLevelAggregation.Utils+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.EDSL.MetaModel++-- | Calculate the median of the metric values associated with the supplied metric Relation key+median :: RelationKey           -- ^ The MetaModel Relation Key (E.g., LCOM).+        -> MetaModel.MetaModel  -- ^ The MetaModel Containing the associated key.+        -> Double               -- ^ The median+median key mm = calcMedian values+  where+    values = getMetricElements key mm++calcMedian :: [Int] -> Double --todo wrap in Maybe+calcMedian xs | null xs = 0.0 --todo and return Nothing+              | odd $ length xs = calcOdd xs+              | even $ length xs = calcEven xs++calcOdd :: [Int] -> Double+calcOdd xs = fromIntegral $ sort xs !! idx+  where idx = length xs `div` 2++calcEven :: [Int] -> Double+calcEven xs =   (fromIntegral (sort xs !! (idx - 1)) + fromIntegral (sort xs !! idx)) / 2+  where+    len = length xs+    idx = len `div` 2
+ src/MetaHS/Extensions/MacroLevelAggregation/Population.hs view
@@ -0,0 +1,22 @@+{-|+Module      : MetaHS.MacroLevelAggregation+Description : The MetaHS Macro-level aggregation method: population+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+Calculates the metric population corresponding to supplied Relation Key.+-}+module MetaHS.Extensions.MacroLevelAggregation.Population+    where++import MetaHS.Extensions.MacroLevelAggregation.Utils+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.EDSL.MetaModel+import Data.List (sort)++-- | Calculates the metric population corresponding to supplied Relation Key.+population :: RelationKey          -- ^ The MetaModel Relation Key (E.g., LCOM).+           -> MetaModel.MetaModel  -- ^ The MetaModel Containing the associated key.+           -> [Int]                -- ^ The set containing the MetricValues+population key mm = sort $ getMetricElements key mm
+ src/MetaHS/Extensions/MacroLevelAggregation/Utils.hs view
@@ -0,0 +1,28 @@+{-|+Module      : MetaHS.Extensions.MacroLevelAggregation.Utils+Description : Utility functions for accessing the metric information in the MetaModel+Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}+module MetaHS.Extensions.MacroLevelAggregation.Utils+    (getMetricElements)+    where++import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.EDSL.MetaModel+import qualified Data.Set as Set++-- | Extracts the metric values from the Relation associated with supplied key+getMetricElements :: RelationKey        -- ^ The MetaModel Relation Key (E.g., LCOM).+                  -> MetaModel.MetaModel-- ^ The MetaModel Containing the associated key.+                  -> [Int]              -- ^ The list containing all (sane) values associated with the supplied key.+getMetricElements key mm = [x | Just x <- ms]+  where ms = map getValue $ Set.toList $getRelation key mm++-- | Extracts the value of the supplied metric Element Pair+getValue  :: MetaModel.Pair -- ^ The Module Element to analyze. Should be (Module,IntValue)+          -> Maybe Int      -- ^ The metric value for the supplied (Module,IntValue) Pair+getValue elementPair@(MetaModel.Module _, MetaModel.IntValue _) = Just (MetaModel.intValue $ snd elementPair)+getValue _ = Nothing
+ src/ModuleLevelAnalysis.hs view
@@ -0,0 +1,39 @@+{-|+Module      : ModuleLevelAnalysis+Description : Facade to the MetaModel module level analysis functions+Copyright   : Copyright (C) 2019 S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}+module ModuleLevelAnalysis+  (extractMetricData)+  where++import qualified Data.Set as Set++import MetaHS.EDSL+import qualified MetaHS.DataModel.MetaModel as MetaModel+import CsvData++-- | Extracts all metric values associated with supplied Relation key.+extractMetricData :: String              -- ^ The identifier associated with this analysis.+                  -> RelationKey         -- ^ The MetaModel Relation Key (E.g., LCOM).+                  -> MetaModel.MetaModel -- ^ The MetaModel Containing the associated key.+                  -> [MetricInfo]        -- ^ List of metric values of supplied key+extractMetricData id key mm = map (generateMetricInfo id key) $ Set.toList $getRelation key mm++-- | Generates a MetricInfoModule data-structure holding the metric value of supplied Element Pair.+generateMetricInfo  :: String         -- ^ The identifier associated with this analysis.+                    -> RelationKey    -- ^ The MetaModel metric key+                    -> MetaModel.Pair -- ^ The Module Element to analyze.+                    -> MetricInfo     -- ^ The metric information for the given (Element) Pair.+generateMetricInfo id metricKey elementPair =+    MetricInfo {+                 identifier = id ++ "," ++ mn -- hash + module name+                ,relationKey = metricKey+                ,value = v+               }+    where+    mn = MetaModel.name $ fst elementPair+    v = fromIntegral $ MetaModel.intValue $ snd elementPair
+ src/ProgramLevelAnalysis.hs view
@@ -0,0 +1,97 @@+{-|+Module      : ProgramLevelAnalysis+Description : Facade to the MetaModel aggregation functions+Copyright   : Copyright (C) 2019 S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}++module ProgramLevelAnalysis+  (calculateGiniCoefficient+  ,calculateCG+  ,calculateIvd+  ,calculateAverage+  ,calculateMedian+  ,calculateDistribution+  ,calculatePopulation+  )+  where++import qualified Data.Set as Set+import CsvData++import MetaHS.EDSL+import qualified MetaHS.DataModel.MetaModel as MetaModel+import MetaHS.Extensions.MacroLevelAggregation.GiniCoefficient+import MetaHS.Extensions.MacroLevelAggregation.Distribution+import MetaHS.Extensions.MacroLevelAggregation.Population+import MetaHS.Extensions.MacroLevelAggregation.Average+import MetaHS.Extensions.MacroLevelAggregation.Median+import MetaHS.Extensions.MacroLevelAggregation.IdealValueDeviation+import Settings (MetricType(LOC, LCOM, CBO))++-- | Calculate the Gini-coefficient of the metric values associated with the supplied metric Relation key+calculateGiniCoefficient :: String              -- ^ The identifier associated with this analysis.+                         -> RelationKey         -- ^ The MetaModel Relation Key (E.g., LCOM).+                         -> MetaModel.MetaModel -- ^ The MetaModel Containing the associated key.+                         -> MetricInfo          -- ^  The result of aggregating metric values of supplied key+calculateGiniCoefficient id key mm = generateMetricInfo id key $ giniCoefficient key mm++-- | Calculate the complement of the Gini-coefficient of the metric values associated with the supplied metric Relation key+calculateCG :: String              -- ^ The identifier associated with this analysis.+            -> RelationKey         -- ^ The MetaModel Relation Key (E.g., LCOM).+            -> MetaModel.MetaModel -- ^ The MetaModel Containing the associated key.+            -> MetricInfo          -- ^  The result of aggregating metric values of supplied key+calculateCG id key mm = generateMetricInfo id key $ 1 - (giniCoefficient key mm)++-- | Calculate the Ideal Value Deviation of the metric values associated with the supplied metric Relation key+-- | Note, the idealValueDeviation's arguments are determined empirically+calculateIvd :: String              -- ^ The identifier associated with this analysis.+             -> MetricType          -- ^ The MetaModel Relation Key (E.g., LCOM) expressed as MetricType+             -> MetaModel.MetaModel -- ^ The MetaModel Containing the associated key.+             -> MetricInfo          -- ^  The result of aggregating metric values of supplied key+calculateIvd id key@LOC mm = generateMetricInfo id (show key) $ idealValueDeviation (show key) mm (-15) 69 265+calculateIvd id key@CBO mm = generateMetricInfo id (show key) $ idealValueDeviation (show key) mm 0 6 16+calculateIvd id key@LCOM mm = generateMetricInfo id (show key) $ idealValueDeviation (show key) mm 0 1 11++-- | Calculate the average of the metric values associated with the supplied metric Relation key+calculateAverage :: String              -- ^ The identifier associated with this analysis.+                 -> RelationKey         -- ^ The MetaModel Relation Key (E.g., LCOM).+                 -> MetaModel.MetaModel -- ^ The MetaModel Containing the associated key.+                 -> MetricInfo          -- ^ The result of aggregating metric values of supplied key+calculateAverage id key mm =  generateMetricInfo id key $ average key mm++-- | Calculate the median of the metric values associated with the supplied metric Relation key+calculateMedian :: String              -- ^ The identifier associated with this analysis.+                 -> RelationKey         -- ^ The MetaModel Relation Key (E.g., LCOM).+                 -> MetaModel.MetaModel -- ^ The MetaModel Containing the associated key.+                 -> MetricInfo          -- ^ The result of aggregating metric values of supplied key+calculateMedian id key mm =  generateMetricInfo id key $ median key mm+++-- | Calculate the distribution of the metric values associated with the supplied metric Relation key+calculateDistribution :: String              -- ^ The identifier associated with this analysis.+                      -> RelationKey         -- ^ The MetaModel Relation Key (E.g., LCOM).+                      -> MetaModel.MetaModel -- ^ The MetaModel Containing the associated key.+                      -> Set.Set (Int, Int)  -- ^ The set containing tuple(s) (MetricValue,Frequency)+calculateDistribution id = distribution++-- | Calculate the population of the metric values associated with the supplied metric Relation key+calculatePopulation :: String              -- ^ The identifier associated with this analysis.+                      -> RelationKey         -- ^ The MetaModel Relation Key (E.g., LCOM).+                      -> MetaModel.MetaModel -- ^ The MetaModel Containing the associated key.+                      -> [Int]               -- ^ The list containing MetricValues+calculatePopulation id = population++-- | helper function+generateMetricInfo :: String+                   -> RelationKey+                   -> Double+                   -> MetricInfo+generateMetricInfo i k v =+    MetricInfo {+                 identifier = i+                ,relationKey = k+                ,value = v+               }
+ src/Settings.hs view
@@ -0,0 +1,84 @@+{-|+Module      : Settings+Description : For operations regarding file system io+Copyright   : Copyright (C) 2017-2019 S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}++module Settings where++import Data.Char+import System.Console.GetOpt+import System.Environment+import System.Exit++-- | Analyse the evolution of a Haskell repository: Information on program-level.+--   Analyse the distribution on module level+data AnalysisType = Evolution | Distribution+ deriving Show++-- | LCOM measures module cohesion, CBO measures module coupling, LOC measures module size in pure lines of code+data MetricType = LCOM | CBO | LOC+ deriving Show++-- | The settings required for the Implementation Under Test.+data Settings = Settings+    { programName :: String           -- ^ The Implementation Under Test name.+    , version     :: String           -- ^ The Implementation Under Test snapshot version.+    , commitHash  :: String           -- ^ The commit hash of the snapshot, currently analysed.+    , analysis    :: AnalysisType     -- ^ The type of analysis.+    , metricType  :: MetricType       -- ^ The metric to be used in the analysis.+    } + deriving Show++defaultSettings :: String -> Settings+defaultSettings name = Settings name "" "" Distribution LOC++settings :: [OptDescr (Settings -> Settings)]+settings = +   [ Option "v" ["version"] (ReqArg (\v set -> set { version = v }) "STRING") "version of snapshot"+   , Option "" ["hash"] (ReqArg (\h set -> set { commitHash = h }) "STRING") "commit hash of snapshot" +   , Option "" ["evolution"] (NoArg (\set -> set { analysis = Evolution } )) "evolution analysis type"+   , Option "" ["lcom"] (NoArg (\set -> set { metricType = LCOM } )) "LCOM metric (module cohesion)"+   , Option "" ["cbo"]  (NoArg (\set -> set { metricType = CBO } ))  "CBO metric (module coupling)"+   , Option "" ["loc"]  (NoArg (\set -> set { metricType = LOC } ))  "LOC metric (module lines of code)"+   ]++getSettings :: IO Settings+getSettings = do+   args <- getArgs+   case getOpt Permute settings args of+      -- legacy: 5 arguments+      ([], [name, vers, hash, ana, metric], []) -> +         return $ Settings+            { programName = name+            , version     = vers+            , commitHash  = hash+            , analysis    = readAnalysisType ana+            , metricType  = readMetricType metric+            }+      -- command-line options+      (fs, [name], []) ->+         return $ foldl (flip id) (defaultSettings name) fs+      -- errors/usage info+      (_, _, errs) -> do+         putStrLn $ concat errs ++ usageInfo header settings+         exitFailure + where header = "Usage: haskellanalysis [options] file"++readAnalysisType :: String -> AnalysisType+readAnalysisType s = +   case map toLower s of+      "evolution"    -> Evolution+      "distribution" -> Distribution+      _              -> error $ "Unknown analysis type " ++ s++readMetricType :: String -> MetricType+readMetricType s = +   case map toLower s of+      "lcom" -> LCOM+      "cbo"  -> CBO+      "loc"  -> LOC+      _      -> error $ "Unknown metric type " ++ s
+ test/Spec.hs view
@@ -0,0 +1,117 @@+{-|+Module      : Spec+Description : The MetaHS EDSL+Copyright   : Copyright (C) 2017-2019 S. Kamps+License     : -- This file is distributed under the  terms of the Apache License 2.0.+              For more information, see the file "LICENSE", which is included in the distribution.+Stability   : experimental+-}++module Spec where+  import Test.HUnit++  import MetaHS.DataModel.MetaModel+  import MetaHS.EDSL.MetaModel++  import MetaHS.Extensions.MacroLevelAggregation.Average+  import MetaHS.Extensions.MacroLevelAggregation.Median+  import MetaHS.Extensions.MacroLevelAggregation.GiniCoefficient+  import MetaHS.Extensions.MacroLevelAggregation.IdealValueDeviation+  import MetaHS.Extensions.MacroLevelAggregation.Distribution++  import qualified Data.Set as Set+  import qualified Data.Map.Strict as Map++  -- | Creates a dummy metamodel for one kind of key with Int values. E.g., LCOM+  createTestMm :: [Int]       -- ^ List with Int values which shall be used for the Element value.+               -> RelationKey -- ^ Relation key to be simulated.+               -> MetaModel   -- ^ Dummy metamodel to run function under test on.+  createTestMm xs key = MetaModel msr+    where msr = Map.insert key rel Map.empty+          rel = Set.fromList ls+          ls = zip [createMod k | k <- [1 .. length xs]] [createVal v | v <- xs]+          createMod k = Module {name = "mod" ++ show k}+          createVal v = IntValue {intValue = v}++  -- AVERAGE+  testAverage0 =        TestCase $ assertEqual "Average_0 [0] == 0" 0 (average "LCOM" $ createTestMm [0] "LCOM")+  testAverageRatio =    TestCase $ assertEqual "Average_Ratio [1,2] == 1,5" 1.5 (average "LCOM" $ createTestMm [1,2] "LCOM")+  testAverageNeg =      TestCase $ assertEqual "Average_Neg [-2,1] == -0.5" (-0.5) (average "LCOM" $ createTestMm [-2,1] "LCOM")+  testAverageOutlier =  TestCase $ assertEqual "Average_Outlier [10,10,10,10,60,60,60,60,60,60,260] == 60" 60 (average "LCOM"+                                      $ createTestMm [10,10,10,10,60,60,60,60,60,60,261] "LCOM")++  -- MEDIAN+  testMedianEven =      TestCase $ assertEqual "Median_Even [2,2] == 2" 2 (median "LCOM" $ createTestMm [2,2] "LCOM")+  testMedianOdd =       TestCase $ assertEqual "Median_Odd [2,2,2] == 2" 2 (median "LCOM" $ createTestMm [2,2,2] "LCOM")+  testMedian0 =         TestCase $ assertEqual "Median_0 [0] == 0" 0 (median "LCOM" $ createTestMm [0] "LCOM")+  testMedianRatio =     TestCase $ assertEqual "Median_Ratio [1,2] == 1,5" 1.5 (median "LCOM" $ createTestMm [1,2] "LCOM")+  testMedianNeg =       TestCase $ assertEqual "Median_Neg [-2,1] == -0.5" (-0.5) (median "LCOM" $ createTestMm [-2,1] "LCOM")+  testMedianOutlier =   TestCase $ assertEqual "Median_Outlier [10,10,10,10,60,60,60,60,60,60,260] == 60" 60 (median "LCOM"+                                      $ createTestMm [10,10,10,10,60,60,60,60,60,60,260] "LCOM")++  -- GINI+  testGini0 =           TestCase $ assertEqual "Gini_0 [0] == 0" 0 (giniCoefficient "LCOM" $ createTestMm [0] "LCOM")+  testGiniEq =          TestCase $ assertEqual "Gini_0 [1,1] == 0" 0 (giniCoefficient "LCOM" $ createTestMm [1,1] "LCOM")+  testGiniHalf =        TestCase $ assertEqual "Gini_0 [0,0,1,1] == 0.5" 0.5 (giniCoefficient "LCOM" $ createTestMm [0,0,1,1] "LCOM")+  testGiniThreeQuart =  TestCase $ assertEqual "Gini_0 [0,0,0,1] == 0.75" 0.75 (giniCoefficient "LCOM" $ createTestMm [0,0,0,1] "LCOM")+  testGiniOneQuart =    TestCase $ assertEqual "Gini_0 [0,1,1,1] == 0.25" 0.25 (giniCoefficient "LCOM" $ createTestMm [0,1,1,1] "LCOM")+  testGiniToNeq =       TestCase $ assertEqual "Gini_0 [0,0,0,0,1] == 0.8" 0.8 (giniCoefficient "LCOM" $ createTestMm [0,0,0,0,1] "LCOM")+  testGiniAproxNeq =    TestCase $ assertEqual "Gini_0 [0,0,0,0,0,0,0,0,0,1] == 0.9" 0.9 (giniCoefficient "LCOM" $+                                          createTestMm [0,0,0,0,0,0,0,0,0,1] "LCOM")++  -- IVD lower-bound on 4, ideal value on 10, upper-bound on 20+  testIvdIdeal =        TestCase $ assertEqual "Ivd_Ideal [5,10,15] == 1" 1 (idealValueDeviation "LCOM"+                                             (createTestMm [5,10,15] "LCOM") 4 10 20)+  testIvdLowerBound =   TestCase $ assertEqual "Ivd_LowerBound [2,6] == 0" 0 (idealValueDeviation "LCOM"+                                               (createTestMm [2,6] "LCOM") 4 10 20)+  testIvdUpperBound =   TestCase $ assertEqual "Ivd_UpperBound [10,30] == 0" 0 (idealValueDeviation "LCOM"+                                               (createTestMm [10,30] "LCOM") 4 10 20)+  testIvdTooLow =       TestCase $ assertEqual "Ivd_TooLow [1,2,3] == 0" 0 (idealValueDeviation "LCOM"+                                               (createTestMm [1,2,3] "LCOM") 4 10 20)+  testIvdTooHigh =      TestCase $ assertEqual "Ivd_TooHigh [21,22,23] == 0" 0 (idealValueDeviation "LCOM"+                                               (createTestMm [21,22,23] "LCOM") 4 10 20)+  testIvdLowIdeal =     TestCase $ assertEqual "Ivd_LowIdeal [5,4,10,9] == 0.5" 0.5 (idealValueDeviation "LCOM"+                                               (createTestMm [5,4,10,9] "LCOM") 4 10 20)+  testIvdIdealHigh =    TestCase $ assertEqual "Ivd_IdealHigh [6,11,19,25] == 0.5" 0.5 (idealValueDeviation "LCOM"+                                               (createTestMm [6,11,19,25] "LCOM") 4 10 20)++  -- DISTRIBUTION+  testDist =           TestCase $ assertEqual "Dist [1,2,2,3,3,3] == [(1,1),(2,2),(3,3)]"+                                              (Set.fromList([(1,1),(2,2),(3,3)])) (distribution "LCOM" $+                                              createTestMm [1,2,2,3,3,3] "LCOM")++  testlist = TestList [ TestLabel "testAverage_0" testAverage0,+                        TestLabel "testAverage_ratio" testAverageRatio,+                        TestLabel "testAverage_neg" testAverageNeg,+                        TestLabel "testAverage_outlier" testAverageOutlier,++                        TestLabel "testMedian_0" testMedianEven,+                        TestLabel "testMedian_1" testMedianOdd,+                        TestLabel "testMedian_0" testMedian0,+                        TestLabel "testMedian_ratio" testMedianRatio,+                        TestLabel "testMedian_neg" testMedianNeg,+                        TestLabel "testMedian_outlier" testMedianOutlier,++                        TestLabel "testGini0" testGini0,+                        TestLabel "testGiniEq" testGiniEq,+                        TestLabel "testGiniHalf" testGiniHalf,+                        TestLabel "testGiniThreeQuart" testGiniThreeQuart,+                        TestLabel "testGiniOneQuart" testGiniOneQuart,+                        TestLabel "testGiniP5divP4" testGiniToNeq,+                        TestLabel "testGiniP5divP4"testGiniAproxNeq,++                        TestLabel "testIvdIdeal" testIvdIdeal,+                        TestLabel "testIvdLowerBound" testIvdLowerBound,+                        TestLabel "testIvdUpperBound" testIvdUpperBound,+                        TestLabel "testIvdTooLow" testIvdTooLow,+                        TestLabel "testIvdTooHigh" testIvdTooHigh,+                        TestLabel "testIvdLowIdeal" testIvdLowIdeal,+                        TestLabel "testIvdIdealHigh"testIvdIdealHigh,++                        TestLabel "testDist"testDist+                      ]++  main :: IO ()+  main = do+    runTestTT testlist+    return ()