Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Simple implementation of export lists.

  • Loading branch information...
commit 3bb0a0dd1e87315b2a5eac4e4f4be3e74714dc63 1 parent e635fca
Marco Túlio Gontijo authored October 09, 2012
20  src/Main.hs
@@ -22,6 +22,7 @@ import Utils.Env
22 22
 import Utils.ExpandTySyn
23 23
 import Utils.RecompilationChecker
24 24
 import Utils.FileNameUtils
  25
+import Utils.Id
25 26
 
26 27
 main :: IO()
27 28
 main = do
@@ -79,7 +80,7 @@ continueCompilation dir' m args ifaces
79 80
             opts = filter (flip notElem [Make, Help]) args
80 81
         miface <- tcDriver syns' lbls kenv cls ins assums m'
81 82
         -- writing module interface and printing final inference results
82  
-        writeIface dir' m' ifaces miface
  83
+        writeIface dir' m' ifaces $ filterEl m miface
83 84
         let result = foldr f miface ([KindInfo .. AssumpInfo] \\ opts)
84 85
             f KindInfo ac = ac{kinds = K.emptyEnv}
85 86
             f ClassInfo ac = ac{classes = []}
@@ -87,6 +88,23 @@ continueCompilation dir' m args ifaces
87 88
             f AssumpInfo ac = ac{assumps = []} 
88 89
         print result
89 90
 
  91
+filterEl :: Module -> Iface -> Iface
  92
+filterEl (Module _ _ _ _ Nothing _ _) i = i
  93
+filterEl
  94
+    (Module _ _ _ _ (Just exps) _ _)
  95
+    i@(Iface {synonyms = s, classes = c, assumps = a})
  96
+  = i
  97
+    {synonyms = doFilterEl exps s,
  98
+      classes = doFilterEl exps c,
  99
+      assumps = doFilterEl exps a}
  100
+
  101
+doFilterEl :: ToId a => [ExportSpec] -> [a] -> [a]
  102
+doFilterEl exps = filter ((`elem` map esToName exps) . idToName . toId)
  103
+
  104
+esToName :: ExportSpec -> Name
  105
+esToName (EVar q) = qNameToName q
  106
+esToName (EAbs q) = qNameToName q
  107
+
90 108
 -- Loading interfaces using import declarations.
91 109
 -- if multi-module compilation is turned on,
92 110
 -- this function does the job.
5  src/Tc/Assumption.hs
@@ -14,4 +14,7 @@ data Assumption = Id :>: Type
14 14
 instance Show Assumption where
15 15
    show (i :>: ty) = show i ++ " :: " ++ prettyPrint ty        
16 16
     
17  
-toScheme n ctx t = toId n :>: (TyForall Nothing ctx t)              
  17
+toScheme n ctx t = toId n :>: (TyForall Nothing ctx t)              
  18
+
  19
+instance ToId Assumption where
  20
+  toId (i :>: _) = i
3  src/Tc/Class.hs
@@ -17,6 +17,9 @@ data Class = Class {
17 17
                 members :: [Assumption],
18 18
                 instances :: [Inst]
19 19
              } deriving (Eq, Ord)
  20
+
  21
+instance ToId Class where
  22
+  toId = name
20 23
              
21 24
 data Inst = Inst {
22 25
                 instname :: Id,
8  src/Tc/TySyn.hs
@@ -9,14 +9,10 @@ module Tc.TySyn where
9 9
 -- and to write / read interface files
10 10
 
11 11
 import Language.Haskell.Exts
12  
-
  12
+import Utils.Id
13 13
 
14 14
 type TySyn = (Type, Type) -- first component: left hand side of type synonym
15 15
                           -- second component: right hand side.
16 16
 
17 17
 tySynName :: TySyn -> QName
18  
-tySynName (t,_) 
19  
-    = goLeft t
20  
-      where
21  
-         goLeft (TyApp l _) = goLeft l
22  
-         goLeft (TyCon qn) = qn                           
  18
+tySynName (t,_) = goLeft t
21  src/Utils/Id.hs
... ...
@@ -1,10 +1,13 @@
1 1
 {-#LANGUAGE DeriveDataTypeable#-}
2 2
 
3 3
 module Utils.Id ( Id,
  4
+                  qNameToName,
  5
+                  idToName,
4 6
                   ToId(..),
5 7
                   Unqualify(..),
6 8
                   isqual,
7 9
                   isunqual,
  10
+                  goLeft,
8 11
                   unid 
9 12
                  ) where
10 13
 
@@ -23,6 +26,14 @@ data Id = IdName Name
23 26
         | IdSpecial SpecialCon
24 27
         deriving (Data, Typeable)
25 28
 
  29
+qNameToName :: QName -> Name
  30
+qNameToName (Qual _ n) = n
  31
+qNameToName (UnQual n) = n
  32
+
  33
+idToName :: Id -> Name
  34
+idToName (IdName n) = n
  35
+idToName (IdQName q) = qNameToName q
  36
+
26 37
 -- a type class to convert such thing to Id's
27 38
 
28 39
 class ToId n where
@@ -53,6 +64,16 @@ instance ToId TyVarBind where
53 64
    toId (UnkindedVar n) = toId n
54 65
    toId x = unsupportedDeclMsg x   
55 66
 
  67
+goLeft :: Type -> QName
  68
+goLeft (TyApp l _) = goLeft l
  69
+goLeft (TyCon qn) = qn
  70
+
  71
+instance ToId Type where
  72
+  toId = toId . goLeft
  73
+
  74
+instance ToId a => ToId (a, b) where
  75
+  toId = toId . fst
  76
+
56 77
 unid (IdName n) = UnQual n
57 78
 unid (IdQName n) = n
58 79
 unid (IdSpecial n) = Special n

0 notes on commit 3bb0a0d

Please sign in to comment.
Something went wrong with that request. Please try again.