Commit ba24b14c authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Hopefully fixed last bugs

parent 40c64c60
......@@ -34,7 +34,7 @@ import qualified Base.ScopeEnv as SE
, lookupWithLevel, toLevelList, currentLevel)
import Base.Types
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.TypeConstructor (TCEnv, TypeInfo (..), lookupTC, qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import CompilerOpts
......@@ -529,11 +529,14 @@ getConTy q = do
getTyCons :: Type -> WCM [DataConstr]
getTyCons (TypeConstructor tc _) = do
tcEnv <- gets tyConsEnv
return $ case qualLookupTC tc tcEnv of
return $ case lookupTC (unqualify tc) tcEnv of
[DataType _ _ cs] -> catMaybes cs
[RenamingType _ _ nc] -> [nc]
_ -> internalError $
"Checks.WarnCheck.getTyCons: " ++ show tc
_ -> case qualLookupTC tc tcEnv of
[DataType _ _ cs] -> catMaybes cs
[RenamingType _ _ nc] -> [nc]
err -> internalError $
"Checks.WarnCheck.getTyCons: " ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv
getTyCons _ = internalError "Checks.WarnCheck.getTyCons"
firstPat :: [Pattern] -> Pattern
......
......@@ -117,8 +117,9 @@ lookupTupleTC tc | isTupleId tc = [tupleTCs !! (tupleArity tc - 2)]
tupleTCs :: [TypeInfo]
tupleTCs = map typeInfo tupleData
where typeInfo c@(DataConstr _ _ tys) = let arity = length tys
in DataType (qTupleId arity) arity [Just c]
where typeInfo (DataConstr c _ tys) =
DataType (qualifyWith preludeMIdent c) (length tys)
[Just (DataConstr c 0 tys)]
tupleData :: [DataConstr]
tupleData = [DataConstr (tupleId n) 0 (take n tvs) | n <- [2 ..]]
......
......@@ -80,11 +80,11 @@ compileModule opts fn = do
Left errs -> abortWithMessages errs
Right (env, mdl) -> do
warn opts $ warnCheck opts env mdl
writeParsed opts fn mdl
writeOutput opts fn (env, mdl)
writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
writeParsed opts fn modul
let (env1, qlfd) = qual opts env modul
doDump opts (DumpQualified, env1, show $ CS.ppModule qlfd)
writeAbstractCurry opts fn env1 qlfd
......@@ -96,8 +96,8 @@ writeOutput opts fn (env, modul) = do
-- dump intermediate results
mapM_ (doDump opts) dumps
-- generate target code
let intf = exportInterface env2 modul
let modSum = summarizeModule (tyConsEnv env2) intf modul
let intf = exportInterface env2 qlfd
let modSum = summarizeModule (tyConsEnv env2) intf qlfd
writeFlat opts fn env2 modSum il
where
withFlat = any (`elem` optTargetTypes opts)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment