Source.hs

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