Contains.hs

{-|
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 -> []