Commit 280187d5 authored by Robert Köhler's avatar Robert Köhler
Browse files

Make frontend runnable

parent c9db275c
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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)
......
Supports Markdown
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