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

Workaround to solve ticket #9 (internal error in record translation)

parent addfb8e4
......@@ -13,7 +13,8 @@
-}
module CompilerEnv where
import qualified Data.Map as Map (keys)
import qualified Data.Map as Map (Map, keys, toList)
import Text.PrettyPrint
import Curry.Base.Ident (ModuleIdent)
......@@ -51,13 +52,24 @@ initCompilerEnv mid = CompilerEnv
}
showCompilerEnv :: CompilerEnv -> String
showCompilerEnv env = unlines $ concat
[ header "ModuleIdent" $ show $ moduleIdent env
, header "Interfaces" $ show $ Map.keys $ interfaceEnv env
, header "ModuleAliases" $ show $ aliasEnv env
, header "TypeConstructors" $ show $ allLocalBindings $ tyConsEnv env
, header "Values" $ show $ allLocalBindings $ valueEnv env
, header "Precedences" $ show $ allLocalBindings $ opPrecEnv env
, header "Eval Annotations" $ show $ evalAnnotEnv env
showCompilerEnv env = show $ vcat
[ header "ModuleIdent " $ textS $ moduleIdent env
, header "Interfaces " $ hcat $ punctuate comma $ map textS $ Map.keys $ interfaceEnv env
, header "ModuleAliases " $ ppMap $ aliasEnv env
, header "TypeConstructors" $ ppAL $ allLocalBindings $ tyConsEnv env
, header "Values " $ ppAL $ allLocalBindings $ valueEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
, header "Eval Annotations" $ ppMap $ evalAnnotEnv env
]
where header hdr content = [hdr, replicate (length hdr) '=', content]
\ No newline at end of file
where
header hdr content = hang (text hdr <+> colon) 4 content
textS = text . show
ppMap :: (Show a, Show b) => Map.Map a b -> Doc
ppMap = ppAL . Map.toList
ppAL :: (Show a, Show b) => [(a, b)] -> Doc
ppAL xs = vcat $ map (\(a,b) -> text (pad a keyWidth) <+> equals <+> text b) showXs
where showXs = map (\(a,b) -> (show a, show b)) xs
keyWidth = maximum (0 : map (length .fst) showXs)
pad s n = take n (s ++ repeat ' ')
......@@ -155,11 +155,11 @@ run opts modSum mEnv tyEnv tcEnv genIntf f = (result, messagesE env)
, messagesE = []
, genInterfaceE = genIntf
, localTypes = Map.empty
, constrTypes = Map.fromList $ getConstrTypes tcEnv
, constrTypes = Map.fromList $ getConstrTypes tcEnv tyEnv
}
getConstrTypes :: TCEnv -> [(QualIdent, IL.Type)]
getConstrTypes tcEnv =
getConstrTypes :: TCEnv -> ValueEnv -> [(QualIdent, IL.Type)]
getConstrTypes tcEnv tyEnv =
[ mkConstrType tqid conid argtys argc
| (_, (_, DataType tqid argc dts):_) <- Map.toList $ topEnvMap tcEnv
, Just (DataConstr conid _ argtys) <- dts
......@@ -169,7 +169,7 @@ getConstrTypes tcEnv =
where
conname = QualIdent (qualidMod tqid) conid
resulttype = IL.TypeConstructor tqid (map IL.TypeVariable [0 .. targnum - 1])
contype = foldr IL.TypeArrow resulttype $ map ttrans argtypes
contype = foldr IL.TypeArrow resulttype $ map (ttrans tcEnv tyEnv) argtypes
--
visitModule :: IL.Module -> FlatState Prog
......@@ -919,33 +919,22 @@ lookupIdArity qid = gets (lookupA . typeEnvE)
_ -> Nothing
_ -> Nothing
getTypeOf :: Ident -> FlatState (Maybe TypeExpr)
getTypeOf ident = do
valEnv <- gets typeEnvE
case lookupValue ident valEnv of
Value _ _ (ForAll _ t) : _ -> do
t1 <- visitType (ttrans t)
trace' ("getTypeOf(" ++ show ident ++ ") = " ++ show t1) $
return (Just t1)
DataConstructor _ _ (ForAllExist _ _ t) : _ -> do
t1 <- visitType (ttrans t)
trace' ("getTypeOfDataCon(" ++ show ident ++ ") = " ++ show t1) $
return (Just t1)
_ -> do
(_, ats) <- gets functionIdE
case lookup ident ats of
Just t -> liftM Just (visitType t)
Nothing -> trace' ("lookupValue did not return a value for index " ++ show ident)
(return Nothing)
ttrans :: Type -> IL.Type
ttrans (TypeConstructor i ts) = IL.TypeConstructor i (map ttrans ts)
ttrans (TypeVariable v) = IL.TypeVariable v
ttrans (TypeConstrained [] v) = IL.TypeVariable v
ttrans (TypeConstrained (v:_) _) = ttrans v
ttrans (TypeArrow f x) = IL.TypeArrow (ttrans f) (ttrans x)
ttrans s = internalError $ "in ttrans: " ++ show s
ttrans :: TCEnv -> ValueEnv -> Type -> IL.Type
ttrans _ _ (TypeVariable v) = IL.TypeVariable v
ttrans tcEnv tyEnv (TypeConstructor i ts) = IL.TypeConstructor i (map (ttrans tcEnv tyEnv) ts)
ttrans tcEnv tyEnv (TypeArrow f x) = IL.TypeArrow (ttrans tcEnv tyEnv f) (ttrans tcEnv tyEnv x)
ttrans _ _ (TypeConstrained [] v) = IL.TypeVariable v
ttrans tcEnv tyEnv (TypeConstrained (v:_) _) = ttrans tcEnv tyEnv v
ttrans _ _ (TypeSkolem k) = internalError $
"Generators.GenFlatCurry.ttrans: skolem type " ++ show k
ttrans _ _ (TypeRecord [] _) = internalError $
"Generators.GenFlatCurry.ttrans: empty type record"
ttrans tcEnv tyEnv (TypeRecord ((l, _):_) _) = case lookupValue l tyEnv of
[Label _ rec _ ] -> case qualLookupTC rec tcEnv of
[AliasType _ n (TypeRecord _ _)] ->
IL.TypeConstructor rec (map IL.TypeVariable [0 .. n - 1])
_ -> internalError $ "Generators.GenFlatCurry.ttrans: unknown record type " ++ show rec
_ -> internalError $ "Generators.GenFlatCurry.ttrans: ambigous record label " ++ show l
-- Constructor (:) receives special treatment throughout the
-- whole implementation. We won't depart from that for mere
......@@ -988,6 +977,26 @@ newVarIndex ident = do
modify $ \ s -> s { varIndexE = idx, varIdsE = ScopeEnv.insert ident vid (varIdsE s) }
return vid
getTypeOf :: Ident -> FlatState (Maybe TypeExpr)
getTypeOf ident = do
valEnv <- gets typeEnvE
tcEnv <- gets tConsEnvE
case lookupValue ident valEnv of
Value _ _ (ForAll _ t) : _ -> do
t1 <- visitType (ttrans tcEnv valEnv t)
trace' ("getTypeOf(" ++ show ident ++ ") = " ++ show t1) $
return (Just t1)
DataConstructor _ _ (ForAllExist _ _ t) : _ -> do
t1 <- visitType (ttrans tcEnv valEnv t)
trace' ("getTypeOfDataCon(" ++ show ident ++ ") = " ++ show t1) $
return (Just t1)
_ -> do
(_, ats) <- gets functionIdE
case lookup ident ats of
Just t -> liftM Just (visitType t)
Nothing -> trace' ("lookupValue did not return a value for index " ++ show ident)
(return Nothing)
--
lookupVarIndex :: Ident -> FlatState VarIndex
lookupVarIndex ident = do
......
------------------------------------------------------------------------------
--- Compiler options for the ID-based curry compiler
---
--- @author Fabian Reck, Bjoern Peemoeller
--- @version June 2011
------------------------------------------------------------------------------
module CompilerOpts ( Options (..), defaultOptions) where
type Options = { optHelp :: Bool }
defaultOptions :: Options
defaultOptions = { optHelp = False }
options :: [Options -> Options]
options = []
parseOpts :: Options
parseOpts = foldl (flip ($)) defaultOptions opts
where opts = options
module ImportError where
import Prelude (foo, bar)
\ No newline at end of file
module Ticket9 where
type Options = { optHelp :: Bool }
options :: [Options -> Options]
options = []
parseOpts :: Options
parseOpts = foldl (flip ($)) { optHelp = False } opts
where opts = options
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