Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: marcotmarcot/mptc
base: 68af71d3c7
...
head fork: marcotmarcot/mptc
compare: 4aa418064e
Checking mergeability… Don't worry, you can still create the pull request.
  • 3 commits
  • 7 files changed
  • 0 commit comments
  • 1 contributor
View
102 mptc.cabal
@@ -2,7 +2,7 @@ name: mptc
version: 0.1
cabal-version: >= 1.2
tested-with: GHC==7.0.4
-build-type: Configure
+build-type: Simple
license: GPL-3
executable mptc
@@ -11,103 +11,5 @@ executable mptc
build-depends: base, haskell-src-exts, syb, containers, mtl, array, HUnit, test-framework, test-framework-hunit, pretty,
parsec,
unix,
- filepath
- other-modules:
- Utils.Id,
- Utils.Env,
- Utils.Debug,
- Utils.Nameable,
- Utils.ErrMsg,
- Utils.DependencyAnalysis,
- Tests.RunAllTests,
- Tests.Data.TestCase2KindDependence,
- Tests.Cases.DeclDependencyTest,
- Tests.Data.TestCase1DeclDependence,
- Tc.Kc.KcMonad,
- Tc.Kc.KcEnv,
- Tc.Kc.KcSubst,
- Tc.Kc.KcDriver,
- Utils.Stack,
- Utils.EnvMonad,
- Tests.Data.TestCase1KindInference,
- Utils.ExpandTySyn,
- Tests.Cases.TypeSynExpandTest,
- Tests.Data.TestCase1TypeSynExpand,
- Tc.Assumption,
- Tc.Class,
- Tc.TcEnv,
- Tc.TcSubst,
- Tc.TcMonad,
- Tc.TcOrdering,
- Tests.Cases.TypeOrderingTest,
- Tests.Cases.KindInferenceTest,
- Tests.Data.TestCase1TypeOrdering,
- Tc.TcSat,
- Tc.TcInst,
- Tests.Cases.SatTest,
- Tests.Data.TestCase1Sat,
- BuiltIn.BuiltInTypes,
- Tc.TcLiteral,
- Tests.Cases.TcLiteralTest,
- Tests.Data.TestCase1TcLiteral,
- Tc.TcPat,
- Tests.Data.TestCase1TcPat,
- Tests.Cases.TcPatTest,
- Tc.TcExp,
- Tests.Cases.TcExpTest,
- Tests.Data.TestCase1TcExp,
- Tc.TcWellformed,
- Tc.TcAlphaEq,
- Tests.Cases.TestWellFormedInstances,
- Tests.Data.TestCase1WellFormedInstances,
- Tests.Data.TestCase1WellFormedTypes,
- Tests.Cases.TestWellFormedTypes,
- Tc.TcLcg,
- Tests.Data.TestCase1Lcg,
- Tests.Cases.TcLcgTest,
- Tc.TcDecl,
- Iface.ClassInstCollector,
- Iface.DataConsCollector,
- Iface.InstDeriving,
- Tests.Data.Full.Teste1,
- Tests.Cases.InstDerivingTest,
- Tests.Cases.DataConsInfoTest,
- Tests.Cases.ClassInstCollectorTest,
- Iface.IfaceWriter,
- Iface.IfaceReader,
- Tests.Cases.IfaceWriterTest,
- Tests.Cases.IfaceReaderTest,
- Iface.IfaceDriver,
- Iface.Iface,
- Tc.TySyn,
- Tc.TcDriver,
- Tc.TcLabel,
- Tests.Data.Full.Teste2,
- BuiltIn.InitialKindEnv,
- BuiltIn.InitialDataConEnv,
- Tests.Data.Full.Teste3,
- Tests.Cases.FullTypeInferenceTest,
- Libs.BuiltIn,
- Libs.Base,
- Libs.Eq,
- Libs.Enum,
- Libs.Bounded,
- Utils.CmdArgParser,
- Utils.RecompilationChecker,
- Utils.FileNameUtils,
- Libs.TesteGhcPT
-
- type: exitcode-stdio-1.0
- x-uses-tf: true
- build-depends:
- base >= 4,
- HUnit >= 1.2 && < 2,
- QuickCheck >= 2.4,
- test-framework >= 0.4.1,
- test-framework-quickcheck2,
- test-framework-hunit,
+ filepath,
directory
- hs-source-dirs: src
- ghc-options: -Wall -rtsopts
-
-
View
26 src/Iface/IfaceDriver.hs
@@ -12,6 +12,7 @@ module Iface.IfaceDriver where
-- in a module to write / read and to
-- report error messages
+import Control.Applicative
import Data.List
import qualified Data.Map as Map
@@ -40,7 +41,30 @@ readIface :: FilePath -> ImportDecl -> IO Iface
readIface dir i
= do
let v = gen dir (importModule i)
- parseInterface v
+ filterIl (importSpecs i) <$> parseInterface v
+
+filterIl :: Maybe (Bool, [ImportSpec]) -> Iface -> Iface
+filterIl Nothing i = i
+filterIl
+ (Just (hid, is))
+ i@(Iface {synonyms = s, classes = c, assumps = a})
+ = i
+ {synonyms = doFilterIl hid is s,
+ classes = doFilterIl hid is c,
+ assumps = doFilterIl hid is a}
+
+doFilterIl :: ToId a => Bool -> [ImportSpec] -> [a] -> [a]
+doFilterIl hid is
+ = filter ((\x -> any (f x) $ map isToName is) . idToName . toId)
+ where
+ f :: Eq a => a -> a -> Bool
+ f
+ | hid = (/=)
+ | otherwise = (==)
+
+isToName :: ImportSpec -> Name
+isToName (IVar n) = n
+isToName (IAbs n) = n
-- write Iface file using the export list
View
20 src/Main.hs
@@ -22,6 +22,7 @@ import Utils.Env
import Utils.ExpandTySyn
import Utils.RecompilationChecker
import Utils.FileNameUtils
+import Utils.Id
main :: IO()
main = do
@@ -79,7 +80,7 @@ continueCompilation dir' m args ifaces
opts = filter (flip notElem [Make, Help]) args
miface <- tcDriver syns' lbls kenv cls ins assums m'
-- writing module interface and printing final inference results
- writeIface dir' m' ifaces miface
+ writeIface dir' m' ifaces $ filterEl m miface
let result = foldr f miface ([KindInfo .. AssumpInfo] \\ opts)
f KindInfo ac = ac{kinds = K.emptyEnv}
f ClassInfo ac = ac{classes = []}
@@ -87,6 +88,23 @@ continueCompilation dir' m args ifaces
f AssumpInfo ac = ac{assumps = []}
print result
+filterEl :: Module -> Iface -> Iface
+filterEl (Module _ _ _ _ Nothing _ _) i = i
+filterEl
+ (Module _ _ _ _ (Just exps) _ _)
+ i@(Iface {synonyms = s, classes = c, assumps = a})
+ = i
+ {synonyms = doFilterEl exps s,
+ classes = doFilterEl exps c,
+ assumps = doFilterEl exps a}
+
+doFilterEl :: ToId a => [ExportSpec] -> [a] -> [a]
+doFilterEl exps = filter ((`elem` map esToName exps) . idToName . toId)
+
+esToName :: ExportSpec -> Name
+esToName (EVar q) = qNameToName q
+esToName (EAbs q) = qNameToName q
+
-- Loading interfaces using import declarations.
-- if multi-module compilation is turned on,
-- this function does the job.
View
5 src/Tc/Assumption.hs
@@ -14,4 +14,7 @@ data Assumption = Id :>: Type
instance Show Assumption where
show (i :>: ty) = show i ++ " :: " ++ prettyPrint ty
-toScheme n ctx t = toId n :>: (TyForall Nothing ctx t)
+toScheme n ctx t = toId n :>: (TyForall Nothing ctx t)
+
+instance ToId Assumption where
+ toId (i :>: _) = i
View
3  src/Tc/Class.hs
@@ -17,6 +17,9 @@ data Class = Class {
members :: [Assumption],
instances :: [Inst]
} deriving (Eq, Ord)
+
+instance ToId Class where
+ toId = name
data Inst = Inst {
instname :: Id,
View
8 src/Tc/TySyn.hs
@@ -9,14 +9,10 @@ module Tc.TySyn where
-- and to write / read interface files
import Language.Haskell.Exts
-
+import Utils.Id
type TySyn = (Type, Type) -- first component: left hand side of type synonym
-- second component: right hand side.
tySynName :: TySyn -> QName
-tySynName (t,_)
- = goLeft t
- where
- goLeft (TyApp l _) = goLeft l
- goLeft (TyCon qn) = qn
+tySynName (t,_) = goLeft t
View
21 src/Utils/Id.hs
@@ -1,10 +1,13 @@
{-#LANGUAGE DeriveDataTypeable#-}
module Utils.Id ( Id,
+ qNameToName,
+ idToName,
ToId(..),
Unqualify(..),
isqual,
isunqual,
+ goLeft,
unid
) where
@@ -23,6 +26,14 @@ data Id = IdName Name
| IdSpecial SpecialCon
deriving (Data, Typeable)
+qNameToName :: QName -> Name
+qNameToName (Qual _ n) = n
+qNameToName (UnQual n) = n
+
+idToName :: Id -> Name
+idToName (IdName n) = n
+idToName (IdQName q) = qNameToName q
+
-- a type class to convert such thing to Id's
class ToId n where
@@ -53,6 +64,16 @@ instance ToId TyVarBind where
toId (UnkindedVar n) = toId n
toId x = unsupportedDeclMsg x
+goLeft :: Type -> QName
+goLeft (TyApp l _) = goLeft l
+goLeft (TyCon qn) = qn
+
+instance ToId Type where
+ toId = toId . goLeft
+
+instance ToId a => ToId (a, b) where
+ toId = toId . fst
+
unid (IdName n) = UnQual n
unid (IdQName n) = n
unid (IdSpecial n) = Special n

No commit comments for this range

Something went wrong with that request. Please try again.