Make frontend runnable

src/Checks/InstanceCheck.hs

@@ -51,7 +51,7 @@ instanceCheck exts m tcEnv clsEnv inEnv ds =
     iss -> (inEnv, map (errMultipleInstances tcEnv) iss)
   where
     local = map (flip InstSource m) $ concatMap (genInstIdents m tcEnv) ds
-    imported = map (uncurry InstSource . fmap fst3) $ Map.toList inEnv
+    imported = map (uncurry InstSource . fmap fst3) $ instEnvToList inEnv
     state = INCState
       { moduleIdent = m
       , instEnv = inEnv
@@ -384,22 +384,23 @@ genInstIdents m tcEnv (InstanceDecl _ _ _ qcls ty _) =
   --[genInstIdent m tcEnv qcls ty]
 genInstIdents _ _     _                            = []
 
-genInstIdent :: ModuleIdent -> TCEnv -> QualIdent -> TypeExpr -> InstIdent
-genInstIdent m tcEnv qcls = qualInstIdent m tcEnv . (,) qcls . typeConstr
+genInstIdent :: ModuleIdent -> TCEnv -> QualIdent -> TypeExpr -> InstIdent -- todo : adapt to new inst env
+genInstIdent m tcEnv qcls = internalError "InstanceCheck.genInstIdent: not yet adapted" -- qualInstIdent m tcEnv . (,) qcls . typeConstr
 
 -- When qualifiying an instance identifier, we replace both the class and
 -- type constructor with their original names as found in the type constructor
 -- environment.
 
 qualInstIdent :: ModuleIdent -> TCEnv -> InstIdent -> InstIdent
-qualInstIdent m tcEnv (cls, tc) = (qual cls, qual tc)
-  where
-    qual = flip (getOrigName m) tcEnv
+qualInstIdent m tcEnv (cls, tc) = internalError "InstanceCheck.qualInstIdent: not yet adapted" -- (qual cls, qual tc)
+--  where
+--    qual = flip (getOrigName m) tcEnv
 
 unqualInstIdent :: TCEnv -> InstIdent -> InstIdent
-unqualInstIdent tcEnv (qcls, tc) = (unqual qcls, unqual tc)
-  where
-    unqual = head . flip reverseLookupByOrigName tcEnv
+unqualInstIdent tcEnv (qcls, tc) = internalError "InstanceCheck.unqualInstIdent: not yet adapted" 
+  --(unqual qcls, unqual tc)
+  --where
+  --  unqual = head . flip reverseLookupByOrigName tcEnv
 
 isFunType :: Type -> Bool
 isFunType (TypeArrow         _ _) = True

src/Checks/TypeCheck.hs

@@ -1542,8 +1542,8 @@ instPredSet inEnv qcls ty = case Map.lookup qcls $ snd inEnv of
   Just tys | ty `elem` tys -> Just emptyPredSet
   _ -> case unapplyType False ty of
     (TypeConstructor tc, tys) ->
-      fmap (expandAliasType tys . snd3) (lookupInstInfo (qcls, tc) $ fst inEnv)
-    _ -> Nothing
+      fmap (expandAliasType tys . snd3) (lookupInstInfo (qcls, [TypeConstructor tc]) $ fst inEnv)
+    _ -> Nothing -- todo : adapt to new instance env
 
 reportMissingInstance :: HasSpanInfo p => ModuleIdent -> p -> String -> Doc
                       -> InstEnv' -> TypeSubst -> Pred -> TCM TypeSubst

src/CompilerEnv.hs

@@ -13,7 +13,7 @@
 -}
 module CompilerEnv where
 
-import qualified Data.Map as Map (Map, keys, toList)
+import qualified Data.Map as Map (Map, keys, toList, fromList)
 
 import Curry.Base.Ident    (ModuleIdent, moduleName)
 import Curry.Base.Pretty
@@ -78,7 +78,9 @@ showCompilerEnv env allBinds simpleEnv = show $ vcat
   , header "Precedences        " $ ppAL simpleEnv $ bindings $ opPrecEnv env
   , header "Type Constructors  " $ ppAL simpleEnv $ bindings $ tyConsEnv env
   , header "Classes            " $ ppMap simpleEnv $ classEnv env
-  , header "Instances          " $ ppMap simpleEnv $ instEnv env
+  , header "Instances          " $ ppMap simpleEnv $ Map.fromList  -- taken from Leif-Erik Krueger
+                                                   $ instEnvToList 
+                                                   $ instEnv env
   , header "Values             " $ ppAL simpleEnv $ bindings $ valueEnv  env
   ]
   where

src/Env/Instance.hs

@@ -22,10 +22,11 @@
 module Env.Instance
   ( InstIdent, ppInstIdent, InstInfo
   , InstEnv, initInstEnv, bindInstInfo, removeInstInfo, lookupInstInfo
+  , instEnvToList
   ) where
 
 import qualified Data.Map as Map ( Map, empty, insert, delete, lookup, union
-                                 , singleton, insertWith, adjust
+                                 , singleton, insertWith, adjust, toList
                                  )
 
 import Curry.Base.Ident
@@ -70,6 +71,11 @@ lookupInstInfo (qcls, tys) iEnv = do
   res    <- Map.lookup tys clsMap
   return res
 
+-- from Leif-Erik Krueger
+instEnvToList :: InstEnv -> [(InstIdent, InstInfo)]
+instEnvToList iEnv = [ ((qcls,tys), iInfo) | 
+                        (qcls,qclsMap) <- Map.toList iEnv,
+                        (tys,iInfo) <- Map.toList qclsMap ]
 
 -------------------------------------------------------------------------------
 --- Type Matching and Unification

src/Exports.hs

@@ -79,7 +79,7 @@ exportInterface' m es pEnv tcEnv vEnv clsEnv inEnv = Interface m imports decls'
   precs   = foldr (infixDecl m pEnv) [] es
   types   = foldr (typeDecl m tcEnv clsEnv tvs) [] es
   values  = foldr (valueDecl m vEnv tvs) [] es
-  insts   = Map.foldrWithKey (instDecl m tcEnv tvs) [] inEnv
+  insts   = foldr (instDecl m tcEnv tvs) [] $ instEnvToList inEnv
   decls   = precs ++ types ++ values ++ insts
   decls'  = closeInterface m tcEnv clsEnv inEnv tvs Set.empty decls
 
@@ -185,21 +185,21 @@ valueDecl m vEnv tvs (Export     _ f) ds = case qualLookupValue f vEnv of
 valueDecl _ _ _ (ExportTypeWith _ _ _) ds = ds
 valueDecl _ _ _ _ _ = internalError "Exports.valueDecl: no pattern match"
 
-instDecl :: ModuleIdent -> TCEnv -> [Ident] -> InstIdent -> InstInfo -> [IDecl]
+instDecl :: ModuleIdent -> TCEnv -> [Ident] -> (InstIdent, InstInfo) -> [IDecl]
          -> [IDecl]
-instDecl m tcEnv tvs ident@(cls, tc) info@(m', _, _) ds
-  | qidModule cls /= Just m' && qidModule tc /= Just m' =
-    iInstDecl m tcEnv tvs ident info : ds
-  | otherwise = ds
+instDecl m tcEnv tvs (ident@(cls, tc), info@(m', _, _)) ds = internalError "Exports.instDecl: not yet adapted"
+ -- | qidModule cls /= Just m' && qidModule tc /= Just m' =
+ --   iInstDecl m tcEnv tvs ident info : ds
+ -- | otherwise = ds
 
 iInstDecl :: ModuleIdent -> TCEnv -> [Ident] -> InstIdent -> InstInfo -> IDecl
-iInstDecl m tcEnv tvs (cls, tc) (m', ps, is) =
-  IInstanceDecl NoPos cx (qualUnqualify m cls) [ty] is mm
-  where pty = PredType ps $ applyType (TypeConstructor tc) $
-                map TypeVariable [0 .. n-1]
-        QualTypeExpr _ cx ty = fromQualPredType m tvs pty
-        n = kindArity (tcKind m tc tcEnv) - kindArity (clsKind m cls tcEnv)
-        mm = if m == m' then Nothing else Just m'
+iInstDecl m tcEnv tvs (cls, tc) (m', ps, is) = internalError "Exports.iInstDecl: not yet adapted"
+--  IInstanceDecl NoPos cx (qualUnqualify m cls) [ty] is mm
+--  where pty = PredType ps $ applyType (TypeConstructor tc) $
+--                map TypeVariable [0 .. n-1]
+--        QualTypeExpr _ cx ty = fromQualPredType m tvs pty
+--        n = kindArity (tcKind m tc tcEnv) - kindArity (clsKind m cls tcEnv)
+--        mm = if m == m' then Nothing else Just m'
 
 -- The compiler determines the list of imported modules from the set of
 -- module qualifiers that are used in the interface. Careful readers
@@ -343,22 +343,22 @@ hiddenTypes m tcEnv clsEnv tvs d =
                   --in  HidingClassDecl NoPos cx tc k' [tv] []
 
 instances :: ModuleIdent -> TCEnv -> InstEnv -> [Ident] -> Set.Set IInfo
-          -> IInfo -> [IDecl]
+          -> IInfo -> [IDecl] -- todo : adapt to new inst env
 instances _ _ _ _ _ IOther = []
-instances m tcEnv inEnv tvs is (IType tc) =
-  [ iInstDecl m tcEnv tvs ident info
-  | (ident@(cls, tc'), info@(m', _, _)) <- Map.toList inEnv,
-    qualQualify m tc == tc',
-    if qidModule cls == Just m' then Set.member (IClass (qualUnqualify m cls)) is
-                                else qidModule tc' == Just m' ]
-instances m tcEnv inEnv tvs is (IClass cls) =
-  [ iInstDecl m tcEnv tvs ident info
-  | (ident@(cls', tc), info@(m', _, _)) <- Map.toList inEnv,
-    qualQualify m cls == cls',
-    qidModule cls' == Just m',
-    m /= m' || isPrimTypeId tc
-            || qidModule tc /= Just m
-            || Set.member (IType (qualUnqualify m tc)) is ]
+instances m tcEnv inEnv tvs is (IType tc) = internalError "Exports.instances: not yet adapted"
+--  [ iInstDecl m tcEnv tvs ident info
+--  | (ident@(cls, tc'), info@(m', _, _)) <- Map.toList inEnv,
+--    qualQualify m tc == tc',
+--    if qidModule cls == Just m' then Set.member (IClass (qualUnqualify m cls)) is
+--                                else qidModule tc' == Just m' ]
+instances m tcEnv inEnv tvs is (IClass cls) = internalError "Exports.instances: not yet adapted"
+--  [ iInstDecl m tcEnv tvs ident info
+--  | (ident@(cls', tc), info@(m', _, _)) <- Map.toList inEnv,
+--    qualQualify m cls == cls',
+--    qidModule cls' == Just m',
+--    m /= m' || isPrimTypeId tc
+--            || qidModule tc /= Just m
+--            || Set.member (IType (qualUnqualify m tc)) is ]
 instances _ _ _ _ _ (IInst _) = []
 
 definedTypes :: [IDecl] -> [QualIdent]

src/Transformations/Derive.hs

@@ -95,10 +95,10 @@ deriveAllInstances ds = do
 hasDataInstance :: InstEnv -> ModuleIdent -> Decl PredType -> Bool
 hasDataInstance inst mid (DataDecl    _ tc _ _ _) =
   maybe False (\(mid', _, _) -> mid == mid') $
-    lookupInstInfo (qDataId, qualifyWith mid tc) inst
+    lookupInstInfo (qDataId, [TypeConstructor (qualifyWith mid tc)]) inst -- todo : adapt to new instance env
 hasDataInstance inst mid (NewtypeDecl _ tc _ _ _) =
   maybe False (\(mid', _, _) -> mid == mid') $
-    lookupInstInfo (qDataId, qualifyWith mid tc) inst
+    lookupInstInfo (qDataId, [TypeConstructor (qualifyWith mid tc)]) inst -- todo : adapt to new instance env
 hasDataInstance _       _   _                     =
   False
 
@@ -128,7 +128,7 @@ deriveInstance :: QualIdent -> [Ident] -> [ConstrInfo] -> QualIdent
                -> DVM (Decl PredType)
 deriveInstance tc tvs cis cls = do
   inEnv <- getInstEnv
-  let ps = snd3 $ fromJust $ lookupInstInfo (cls, tc) inEnv
+  let ps = snd3 $ fromJust $ lookupInstInfo (cls, [TypeConstructor tc]) inEnv  -- todo : adapt to new instance env
       ty = applyType (TypeConstructor tc) $
              take (length tvs) $ map TypeVariable [0 ..]
       QualTypeExpr _ cx inst = fromPredType tvs $ PredType ps ty

src/Transformations/Dictionary.hs

@@ -426,15 +426,16 @@ bindSuperStub m cls scls = bindEntity m f $ Value f Nothing 1 $ polyType ty
 
 bindInstDecls :: ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> ValueEnv
                   -> ValueEnv
-bindInstDecls m tcEnv clsEnv =
-  flip (foldr $ bindInstFuns m tcEnv clsEnv) . Map.toList
+bindInstDecls m tcEnv clsEnv = internalError "Dictionary.bindInstDecls: not yet adapted"
+--  flip (foldr $ bindInstFuns m tcEnv clsEnv) . Map.toList     todo : adapt to new inst Env
 
 bindInstFuns :: ModuleIdent -> TCEnv -> ClassEnv -> (InstIdent, InstInfo)
              -> ValueEnv -> ValueEnv
 bindInstFuns m tcEnv clsEnv ((cls, tc), (m', ps, is)) =
   bindInstDict m cls ty m' ps . bindInstMethods m clsEnv cls ty m' ps is
-  where ty = applyType (TypeConstructor tc) (take n (map TypeVariable [0..]))
-        n = kindArity (tcKind m tc tcEnv) - kindArity (clsKind m cls tcEnv)
+  where ty = internalError "Dictionary.bindInstFuns: not yet adapted"    -- todo : adapt to new inst env
+           -- applyType (TypeConstructor tc) (take n (map TypeVariable [0..]))
+        n = internalError "Dictionary.bindInstFun: not yet adapted" --kindArity (tcKind m tc tcEnv) - kindArity (clsKind m cls tcEnv)
 
 bindInstDict :: ModuleIdent -> QualIdent -> Type -> ModuleIdent -> PredSet
              -> ValueEnv -> ValueEnv
@@ -792,14 +793,15 @@ emptySpEnv :: SpecEnv
 emptySpEnv = Map.empty
 
 initSpEnv :: ClassEnv -> InstEnv -> SpecEnv
-initSpEnv clsEnv = foldr (uncurry bindInstance) emptySpEnv . Map.toList
-  where bindInstance (cls, tc) (m, _, _) =
-          flip (foldr $ bindInstanceMethod m cls tc) $ classMethods cls clsEnv
-        bindInstanceMethod m cls tc f = Map.insert (f', d) f''
-          where f'  = qualifyLike cls f
-                d   = qInstFunId m cls ty
-                f'' = qImplMethodId m cls ty f
-                ty  = TypeConstructor tc
+initSpEnv clsEnv = internalError "Dictionary.initSpecEnv: not yet adapted"
+--                   foldr (uncurry bindInstance) emptySpEnv . Map.toList
+--  where bindInstance (cls, tc) (m, _, _) =
+--          flip (foldr $ bindInstanceMethod m cls tc) $ classMethods cls clsEnv
+--        bindInstanceMethod m cls tc f = Map.insert (f', d) f''
+--          where f'  = qualifyLike cls f
+--                d   = qInstFunId m cls ty
+--                f'' = qImplMethodId m cls ty f
+--                ty  = TypeConstructor tc
 
 class Specialize a where
   specialize :: a Type -> DTM (a Type)