ModuleSummary.hs 4.98 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1 2 3 4
{- |
    Module      :  $Header$
    Description :  Summarized information of a module
    Copyright   :  (c) 2005, Martin Engelke (men@informatik.uni-kiel.de)
5
                       2015, Jan Tikovsky
Björn Peemöller 's avatar
Björn Peemöller committed
6
    License     :  OtherLicense
Björn Peemöller 's avatar
Björn Peemöller committed
7

Björn Peemöller 's avatar
Björn Peemöller committed
8 9 10 11 12 13
    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    Generates a record containing extracted and prepared data from a
    'Curry.Syntax.Module'.
Björn Peemöller 's avatar
Björn Peemöller committed
14 15 16
-}
module ModuleSummary (ModuleSummary (..), summarizeModule) where

17
import Data.Maybe (fromMaybe)
Björn Peemöller 's avatar
Björn Peemöller committed
18 19 20 21 22 23 24

import Curry.Base.Ident
import Curry.Syntax

import Base.Messages (internalError)
import Base.Types

25
import Env.OpPrec          (mkPrec)
26
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
Björn Peemöller 's avatar
Björn Peemöller committed
27 28 29

-- |A record containing data for a module 'm'
data ModuleSummary = ModuleSummary
30 31 32 33 34 35 36
  { moduleId     :: ModuleIdent   -- ^The name of 'm'
  , interface    :: [IDecl]       -- ^all exported declarations in 'm'
                                  --  (including exported imports)
  , exports      :: [Export]      -- ^The export list extracted from 'm'
  , imports      :: [IImportDecl] -- ^imports
  , infixDecls   :: [IDecl]       -- ^Interfaces of all infix declarations in 'm'
  , typeSynonyms :: [IDecl]       -- ^Interfaces of all type synonyms in 'm'
Björn Peemöller 's avatar
Björn Peemöller committed
37 38 39
  } deriving Show


Björn Peemöller 's avatar
Björn Peemöller committed
40 41
-- |Return a 'ModuleSummary' for a module, its corresponding
-- table of type constructors and its interface
Björn Peemöller 's avatar
Björn Peemöller committed
42
summarizeModule :: TCEnv -> Interface -> Module -> ModuleSummary
43
summarizeModule tcEnv (Interface iid _ idecls) (Module _ mid mExp imps decls)
Björn Peemöller 's avatar
Björn Peemöller committed
44 45 46 47
  | iid == mid = ModuleSummary
      { moduleId     = mid
      , interface    = idecls
      , exports      = maybe [] (\ (Exporting _ exps) -> exps) mExp
48
      , imports      = genImports imps
49 50
      , infixDecls   = genInfixDecls mid decls
      , typeSynonyms = genTypeSyns tcEnv mid decls
Björn Peemöller 's avatar
Björn Peemöller committed
51
      }
Björn Peemöller 's avatar
Björn Peemöller committed
52 53
  | otherwise = internalError $
      "Interface " ++ show iid ++ " does not match module " ++ show mid
Björn Peemöller 's avatar
Björn Peemöller committed
54 55

-- |Generate interface import declarations
56
genImports :: [ImportDecl] -> [IImportDecl]
Björn Peemöller 's avatar
Björn Peemöller committed
57
genImports = map snd . foldr addImport []
Björn Peemöller 's avatar
Björn Peemöller committed
58 59 60 61
  where
  addImport (ImportDecl pos mid _ _ _) imps = case lookup mid imps of
    Nothing -> (mid, IImportDecl pos mid) : imps
    Just _  -> imps
Björn Peemöller 's avatar
Björn Peemöller committed
62 63

-- |Generate interface infix declarations in the module
64 65
genInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]
genInfixDecls mident decls = concatMap genInfixDecl decls
Björn Peemöller 's avatar
Björn Peemöller committed
66
  where
Björn Peemöller 's avatar
Björn Peemöller committed
67
  genInfixDecl :: Decl -> [IDecl]
68 69
  genInfixDecl (InfixDecl pos spec mPrec idents)
    = map (IInfixDecl pos spec (mkPrec mPrec) . qualifyWith mident) idents
Björn Peemöller 's avatar
Björn Peemöller committed
70
  genInfixDecl _ = []
Björn Peemöller 's avatar
Björn Peemöller committed
71 72 73 74

-- ---------------------------------------------------------------------------

-- |Generate interface declarations for all type synonyms in the module.
75 76
genTypeSyns :: TCEnv -> ModuleIdent -> [Decl] -> [IDecl]
genTypeSyns tcEnv mident decls
Björn Peemöller 's avatar
Björn Peemöller committed
77 78 79
  = concatMap (genTypeSynDecl mident tcEnv) $ filter isTypeSyn decls

isTypeSyn :: Decl -> Bool
80 81
isTypeSyn (TypeDecl _ _ _ _) = True
isTypeSyn _                  = False
Björn Peemöller 's avatar
Björn Peemöller committed
82 83 84

--
genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl]
Björn Peemöller 's avatar
Björn Peemöller committed
85 86
genTypeSynDecl mid tcEnv (TypeDecl p i vs ty)
  = [ITypeDecl p (qualifyWith mid i) vs (modifyTypeExpr tcEnv ty)]
Björn Peemöller 's avatar
Björn Peemöller committed
87
genTypeSynDecl _   _     _                    = []
Björn Peemöller 's avatar
Björn Peemöller committed
88 89 90

--
modifyTypeExpr :: TCEnv -> TypeExpr -> TypeExpr
Björn Peemöller 's avatar
Björn Peemöller committed
91 92 93 94 95
modifyTypeExpr tcEnv (ConstructorType q tys) = case qualLookupTC q tcEnv of
  [AliasType _ ar ty] -> modifyTypeExpr tcEnv
                        (genTypeSynDeref (zip [0 .. ar - 1] tys) ty)
  _                   -> ConstructorType (fromMaybe q (lookupTCId q tcEnv))
                                         (map (modifyTypeExpr tcEnv) tys)
96 97
modifyTypeExpr _     v@(VariableType      _) = v
modifyTypeExpr tcEnv (ArrowType     ty1 ty2)
Björn Peemöller 's avatar
Björn Peemöller committed
98
  = ArrowType (modifyTypeExpr tcEnv ty1) (modifyTypeExpr tcEnv ty2)
99
modifyTypeExpr tcEnv (TupleType         tys)
Björn Peemöller 's avatar
Björn Peemöller committed
100 101 102
  | null tys  = ConstructorType qUnitId []
  | otherwise = ConstructorType (qTupleId $ length tys)
                                (map (modifyTypeExpr tcEnv) tys)
103
modifyTypeExpr tcEnv (ListType           ty)
Björn Peemöller 's avatar
Björn Peemöller committed
104
  = ConstructorType (qualify listId) [modifyTypeExpr tcEnv ty]
105
modifyTypeExpr tcEnv (ParenType          ty) = modifyTypeExpr tcEnv ty
Björn Peemöller 's avatar
Björn Peemöller committed
106 107 108 109

--
genTypeSynDeref :: [(Int, TypeExpr)] -> Type -> TypeExpr
genTypeSynDeref its (TypeVariable i) = case lookup i its of
Björn Peemöller 's avatar
Björn Peemöller committed
110
  Nothing -> internalError "ModuleSummary.genTypeSynDeref: unkown type var index"
Björn Peemöller 's avatar
Björn Peemöller committed
111
  Just te -> te
Björn Peemöller 's avatar
Björn Peemöller committed
112 113 114 115
genTypeSynDeref its (TypeConstructor qid tys)
  = ConstructorType qid $ map (genTypeSynDeref its) tys
genTypeSynDeref its (TypeArrow ty1 ty2)
  = ArrowType (genTypeSynDeref its ty1) (genTypeSynDeref its ty2)
Björn Peemöller 's avatar
Björn Peemöller committed
116
genTypeSynDeref _ (TypeConstrained _ _) = internalError
Björn Peemöller 's avatar
Björn Peemöller committed
117
  "ModuleSummary.genTypeSynDeref: illegal constrained type occured"
Björn Peemöller 's avatar
Björn Peemöller committed
118
genTypeSynDeref _ (TypeSkolem _) = internalError
Björn Peemöller 's avatar
Björn Peemöller committed
119
  "ModuleSummary.genTypeSynDeref: illegal skolem type occured"
Björn Peemöller 's avatar
Björn Peemöller committed
120 121 122 123 124 125 126 127

--
lookupTCId :: QualIdent -> TCEnv -> Maybe QualIdent
lookupTCId qident tcEnv = case qualLookupTC qident tcEnv of
  [DataType     qid _ _] -> Just qid
  [RenamingType qid _ _] -> Just qid
  [AliasType    qid _ _] -> Just qid
  _                      -> Nothing