Commit 21f1698f authored by Unknown's avatar Unknown
Browse files

Started removing NoForeign

parent 4605366b
......@@ -66,7 +66,6 @@ instance QualExpr (Decl a) where
instance QuantExpr (Decl a) where
bv (TypeSig _ vs _) = vs
bv (FunctionDecl _ _ f _) = [f]
bv (ForeignDecl _ _ _ _ f _) = [f]
bv (ExternalDecl _ vs) = bv vs
bv (PatternDecl _ t _) = bv t
bv (FreeDecl _ vs) = bv vs
......
......@@ -166,7 +166,6 @@ declVars :: (Eq t, Typeable t, ValueType t) => Decl t -> [(Ident, Int, t)]
declVars (InfixDecl _ _ _ _) = []
declVars (TypeSig _ _ _) = []
declVars (FunctionDecl _ ty f eqs) = [(f, eqnArity $ head eqs, ty)]
declVars (ForeignDecl _ _ _ ty f _) = [(f, arrowArity $ typeOf ty, ty)]
declVars (PatternDecl _ t _) = patternVars t
declVars (FreeDecl _ vs) = [(v, 0, ty) | Var ty v <- vs]
declVars _ = internalError "Base.Typing.declVars"
......
......@@ -141,7 +141,6 @@ instance HasType (Decl a) where
fts m (TypeDecl _ _ _ ty) = fts m ty
fts m (TypeSig _ _ ty) = fts m ty
fts m (FunctionDecl _ _ _ eqs) = fts m eqs
fts m (ForeignDecl _ _ _ _ _ ty) = fts m ty
fts _ (ExternalDecl _ _) = id
fts m (PatternDecl _ _ rhs) = fts m rhs
fts _ (FreeDecl _ _) = id
......@@ -445,7 +444,6 @@ kcDecl tcEnv t@(TypeDecl p tc tvs ty) = do
kcType tcEnv' p "type declaration" (ppDecl t) k ty
kcDecl tcEnv (TypeSig p _ qty) = kcTypeSig tcEnv p qty
kcDecl tcEnv (FunctionDecl _ _ _ eqs) = mapM_ (kcEquation tcEnv) eqs
kcDecl tcEnv (ForeignDecl p _ _ _ _ ty) = kcTypeSig tcEnv p (QualTypeExpr [] ty)
kcDecl _ (ExternalDecl _ _) = ok
kcDecl tcEnv (PatternDecl _ _ rhs) = kcRhs tcEnv rhs
kcDecl _ (FreeDecl _ _) = ok
......
......@@ -112,7 +112,6 @@ boundValues (DataDecl _ _ _ cs _) = [ v | c <- cs
boundValues (NewtypeDecl _ _ _ nc _) = nconstrId nc : nrecordLabels nc
boundValues (TypeSig _ fs _) = fs
boundValues (FunctionDecl _ _ f _) = [f]
boundValues (ForeignDecl _ _ _ _ f _) = [f]
boundValues (ExternalDecl _ vs) = bv vs
boundValues (PatternDecl _ t _) = bv t
boundValues (FreeDecl _ vs) = bv vs
......
......@@ -366,9 +366,6 @@ bindFuncDecl _ _ (FunctionDecl _ _ _ []) _
bindFuncDecl tcc m (FunctionDecl _ _ f (eq:_)) env
= let arty = length $ snd $ getFlatLhs eq
in bindGlobal tcc m f (GlobalVar (qualifyWith m f) arty) env
bindFuncDecl tcc m (ForeignDecl _ _ _ _ f ty) env
= let arty = typeArity ty
in bindGlobal tcc m f (GlobalVar (qualifyWith m f) arty) env
bindFuncDecl tcc m (TypeSig _ fs (QualTypeExpr _ ty)) env
= foldr bindTS env $ map (qualifyWith m) fs
where
......@@ -537,8 +534,6 @@ checkDeclLhs (TypeSig p vs ty) =
(\vs' -> TypeSig p vs' ty) <$> mapM (checkVar "type signature") vs
checkDeclLhs (FunctionDecl p _ f eqs) =
inFunc f $ checkEquationsLhs p eqs
checkDeclLhs (ForeignDecl p cc ie a f ty) =
(\f' -> ForeignDecl p cc ie a f' ty) <$> checkVar "foreign declaration" f
checkDeclLhs (ExternalDecl p vs) =
ExternalDecl p <$> mapM (checkVar' "external declaration") vs
checkDeclLhs (PatternDecl p t rhs) =
......@@ -1107,7 +1102,6 @@ constrs _ = []
vars :: Decl a -> [Ident]
vars (TypeSig _ fs _) = fs
vars (FunctionDecl _ _ f _) = [f]
vars (ForeignDecl _ _ _ _ f _) = [f]
vars (ExternalDecl _ vs) = bv vs
vars (PatternDecl _ t _) = bv t
vars (FreeDecl _ vs) = bv vs
......
......@@ -442,9 +442,6 @@ tcPDeclGroup :: PredSet -> [PDecl a] -> TCM (PredSet, [PDecl PredType])
tcPDeclGroup ps [(i, ExternalDecl p fs)] = do
tys <- mapM (tcExternal . varIdent) fs
return (ps, [(i, ExternalDecl p (zipWith (fmap . const . predType) tys fs))])
tcPDeclGroup ps [(i, ForeignDecl p cc ie _ f ty)] = do
ty' <- tcForeign f ty
return (ps, [(i, ForeignDecl p cc ie (predType ty') f ty)])
tcPDeclGroup ps [(i, FreeDecl p fvs)] = do
vs <- mapM (tcDeclVar False) (bv fvs)
m <- getModuleIdent
......@@ -730,7 +727,6 @@ instance Binding (Decl a) where
isNonExpansive (InfixDecl _ _ _ _) = return True
isNonExpansive (TypeSig _ _ _) = return True
isNonExpansive (FunctionDecl _ _ _ _) = return True
isNonExpansive (ForeignDecl _ _ _ _ _ _) = return True
isNonExpansive (ExternalDecl _ _) = return True
isNonExpansive (PatternDecl _ _ _) = return False
-- TODO: Uncomment when polymorphic let declarations are fully supported
......@@ -805,9 +801,6 @@ bindDeclArity _ _ _ _ (InfixDecl _ _ _ _) = id
bindDeclArity _ _ _ _ (TypeSig _ _ _) = id
bindDeclArity _ _ _ _ (FunctionDecl _ _ f eqs) =
bindArity f (eqnArity $ head eqs)
bindDeclArity m tcEnv clsEnv _ (ForeignDecl _ _ _ _ f ty) =
bindArity f (arrowArity ty')
where ty' = unpredType $ expandPolyType m tcEnv clsEnv $ QualTypeExpr [] ty
bindDeclArity m tcEnv clsEnv sigs (ExternalDecl _ fs) =
flip (foldr $ \(Var _ f) -> bindArity f $ arrowArity $ ty f) fs
where ty = unpredType . expandPolyType m tcEnv clsEnv . fromJust .
......@@ -948,14 +941,19 @@ tcExternal f = do
sigs <- getSigEnv
case lookupTypeSig f sigs of
Nothing -> internalError "TypeCheck.tcExternal: type signature not found"
Just (QualTypeExpr _ ty) -> tcForeign f ty
tcForeign :: Ident -> TypeExpr -> TCM Type
tcForeign f ty = do
m <- getModuleIdent
PredType _ ty' <- expandPoly $ QualTypeExpr [] ty
modifyValueEnv $ bindFun m f False (arrowArity ty') (polyType ty')
return ty'
Just (QualTypeExpr _ ty) ->
-- tcForeign f ty
do m <- getModuleIdent
PredType _ ty' <- expandPoly $ QualTypeExpr [] ty
modifyValueEnv $ bindFun m f False (arrowArity ty') (polyType ty')
return ty'
--tcForeign :: Ident -> TypeExpr -> TCM Type
--tcForeign f ty = do
-- m <- getModuleIdent
-- PredType _ ty' <- expandPoly $ QualTypeExpr [] ty
-- modifyValueEnv $ bindFun m f False (arrowArity ty') (polyType ty')
-- return ty'
-- Patterns and Expressions:
-- Note that the type attribute associated with a constructor or infix
......
......@@ -190,8 +190,6 @@ instance Rename (Decl a) where
TypeDecl p tc <$> rename tvs <*> rename ty
rename (TypeSig p fs qty) = TypeSig p fs <$> renameTypeSig qty
rename (FunctionDecl p a f eqs) = FunctionDecl p a f <$> renameReset eqs
rename (ForeignDecl p cc ie a f ty) =
ForeignDecl p cc ie a f <$> renameTypeSig ty
rename (ExternalDecl p fs) = return $ ExternalDecl p fs
rename (PatternDecl p ts rhs) = PatternDecl p ts <$> renameReset rhs
rename (FreeDecl p fvs) = return $ FreeDecl p fvs
......@@ -339,8 +337,6 @@ checkDecl (FunctionDecl a p f eqs) =
FunctionDecl a p f <$> mapM checkEquation eqs
checkDecl (PatternDecl p t rhs) =
PatternDecl p t <$> checkRhs rhs
checkDecl (ForeignDecl p cc ie a f ty) =
ForeignDecl p cc ie a f <$> checkType ty
checkDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM checkType tys
checkDecl (ClassDecl p cx cls clsvar ds) = do
checkTypeVars "class declaration" [clsvar]
......
......@@ -986,7 +986,6 @@ insertDecl (TypeDecl _ t _ ty) = do
insertDecl (FunctionDecl _ _ f _) = do
cons <- isConsId f
unless cons $ insertVar f
insertDecl (ForeignDecl _ _ _ _ f _) = insertVar f
insertDecl (ExternalDecl _ vs) = mapM_ (insertVar . varIdent) vs
insertDecl (PatternDecl _ p _) = insertPattern False p
insertDecl (FreeDecl _ vs) = mapM_ (insertVar . varIdent) vs
......
......@@ -209,10 +209,6 @@ trFuncDecl global (FunctionDecl _ pty f eqs)
= (\f' a v ty rs -> [CFunc f' a v ty rs])
<$> trFuncName global f <*> pure (eqnArity $ head eqs) <*> getVisibility f
<*> getQualType f pty <*> mapM trEquation eqs
trFuncDecl global (ForeignDecl _ _ _ pty f _)
= (\f' a v ty rs -> [CFunc f' a v ty rs])
<$> trFuncName global f <*> pure (arrowArity $ unpredType pty)
<*> getVisibility f <*> getQualType f pty <*> return []
trFuncDecl global (ExternalDecl _ vs)
= T.forM vs $ \(Var pty f) -> CFunc
<$> trFuncName global f <*> pure (arrowArity $ unpredType pty)
......@@ -256,7 +252,6 @@ insertDeclLhs _ = return ()
trLocalDecl :: Decl PredType -> GAC [CLocalDecl]
trLocalDecl f@(FunctionDecl _ _ _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl f@(ForeignDecl _ _ _ _ _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl f@(ExternalDecl _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl (PatternDecl _ p rhs) = (\p' rhs' -> [CLocalPat p' rhs'])
<$> trPat p <*> trRhs rhs
......
......@@ -198,7 +198,7 @@ numCategories = [IntTok, FloatTok]
keywordCategories :: [Category]
keywordCategories =
[ KW_case, KW_class, KW_data, KW_default, KW_deriving, KW_do, KW_else
, KW_external, KW_fcase, KW_foreign, KW_free, KW_if, KW_import, KW_in
, KW_external, KW_fcase, KW_free, KW_if, KW_import, KW_in
, KW_infix, KW_infixl, KW_infixr, KW_instance, KW_let, KW_module, KW_newtype
, KW_of, KW_then, KW_type, KW_where
]
......@@ -252,7 +252,6 @@ declPos (NewtypeDecl p _ _ _ _ ) = p
declPos (TypeDecl p _ _ _ ) = p
declPos (TypeSig p _ _ ) = p
declPos (FunctionDecl p _ _ _ ) = p
declPos (ForeignDecl p _ _ _ _ _) = p
declPos (ExternalDecl p _ ) = p
declPos (PatternDecl p _ _ ) = p
declPos (FreeDecl p _ ) = p
......@@ -335,7 +334,6 @@ idsDecl (TypeDecl _ t vs ty) =
idsDecl (TypeSig _ fs qty) =
map (Function FuncTypeSig False . qualify) fs ++ idsQualTypeExpr qty
idsDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs
idsDecl (ForeignDecl _ _ _ _ _ _) = []
idsDecl (ExternalDecl _ fs) =
map (Function FuncDeclare False . qualify . varIdent) fs
idsDecl (PatternDecl _ p rhs) = idsPat p ++ idsRhs rhs
......@@ -534,7 +532,6 @@ showToken (Token KW_do _) = "do"
showToken (Token KW_else _) = "else"
showToken (Token KW_external _) = "external"
showToken (Token KW_fcase _) = "fcase"
showToken (Token KW_foreign _) = "foreign"
showToken (Token KW_free _) = "free"
showToken (Token KW_if _) = "if"
showToken (Token KW_import _) = "import"
......
......@@ -144,8 +144,9 @@ constrType c = do
trDecl :: Decl Type -> TransM [IL.Decl]
trDecl (DataDecl _ tc tvs cs _) = (:[]) <$> trData tc tvs cs
--trDecl (ForeignDecl _ cc ie ty f _) = (:[]) <$> trForeign f cc ie ty
trDecl (ExternalDecl _ vs) = mapM trExternalF vs
trDecl (ExternalDataDecl _ tc tvs) = (:[]) <$> trExternal tc tvs
trDecl (ForeignDecl _ cc ie ty f _) = (:[]) <$> trForeign f cc ie ty
trDecl (FunctionDecl _ ty f eqs) = (:[]) <$> trFunction f ty eqs
trDecl _ = return []
......@@ -167,15 +168,21 @@ trConstrDecl d = do
trExternal :: Ident -> [Ident] -> TransM IL.Decl
trExternal tc tvs = flip IL.ExternalDataDecl (length tvs) <$> trQualify tc
trForeign :: Ident -> CallConv -> Maybe String -> Type -> TransM IL.Decl
trForeign _ _ Nothing _ = internalError "CurryToIL.trForeign: no target"
trForeign f cc (Just ie) ty = do
f' <- trQualify f
let ty' = transType ty
return $ IL.ExternalDecl f' (callConv cc) ie ty'
where
callConv CallConvPrimitive = IL.Primitive
callConv CallConvCCall = IL.CCall
trExternalF :: Var Type -> TransM IL.Decl
trExternalF (Var pty f) = do
f' <- trQualify f
let ty' = transType pty
return $ IL.ExternalDecl f' IL.Primitive (idName f) ty'
--trForeign :: Ident -> CallConv -> Maybe String -> Type -> TransM IL.Decl
--trForeign _ _ Nothing _ = internalError "CurryToIL.trForeign: no target"
--trForeign f cc (Just ie) ty = do
-- f' <- trQualify f
-- let ty' = transType ty
-- return $ IL.ExternalDecl f' (callConv cc) ie ty'
-- where
-- callConv CallConvPrimitive = IL.Primitive
-- callConv CallConvCCall = IL.CCall
-- The type representation in the intermediate language does not support
-- types with higher order kinds. Therefore, the type transformations has
......
......@@ -246,13 +246,14 @@ dsDeclLhs (PatternDecl p t rhs) = do
(ds', t') <- dsPat p [] t
dss' <- mapM dsDeclLhs ds'
return $ PatternDecl p t' rhs : concat dss'
dsDeclLhs (ExternalDecl p vs) = return $ map (genForeignDecl p) vs
dsDeclLhs (ExternalDecl p vs) = return $ map (ExternalDecl p . (:[])) vs
--dsDeclLhs (ExternalDecl p vs) = return $ map (genForeignDecl p) vs
dsDeclLhs d = return [d]
genForeignDecl :: Position -> Var PredType -> Decl PredType
genForeignDecl p (Var pty v) =
ForeignDecl p CallConvPrimitive (Just $ idName v) pty v $
fromType identSupply $ typeOf pty
--genForeignDecl :: Position -> Var PredType -> Decl PredType
--genForeignDecl p (Var pty v) =
-- ForeignDecl p CallConvPrimitive (Just $ idName v) pty v $
-- fromType identSupply $ typeOf pty
-- TODO: Check if obsolete and remove
-- After desugaring its right hand side, each equation is eta-expanded
......@@ -269,10 +270,11 @@ dsDeclRhs :: Decl PredType -> DsM (Decl PredType)
dsDeclRhs (FunctionDecl p pty f eqs) =
FunctionDecl p pty f <$> mapM dsEquation eqs
dsDeclRhs (PatternDecl p t rhs) = PatternDecl p t <$> dsRhs p id rhs
dsDeclRhs (ForeignDecl p cc ie pty f ty) =
return $ ForeignDecl p cc ie' pty f ty
where ie' = ie `mplus` Just (idName f)
--dsDeclRhs (ForeignDecl p cc ie pty f ty) =
-- return $ ForeignDecl p cc ie' pty f ty
-- where ie' = ie `mplus` Just (idName f)
dsDeclRhs fs@(FreeDecl _ _) = return fs
dsDeclRhs fs@(ExternalDecl _ _) = return fs
dsDeclRhs _ =
error "Desugar.dsDeclRhs: no pattern match"
......
......@@ -779,14 +779,14 @@ instance DictTrans Decl where
dictTrans (TypeDecl p tc tvs ty) = return $ TypeDecl p tc tvs ty
dictTrans (FunctionDecl p pty f eqs) =
FunctionDecl p (transformPredType pty) f <$> mapM dictTrans eqs
dictTrans (ForeignDecl p cc ie pty f ty) =
return $ ForeignDecl p cc ie (unpredType pty) f ty
dictTrans (PatternDecl p t rhs) = case t of
VariablePattern pty@(PredType ps _) v | not (Set.null ps) ->
dictTrans $ FunctionDecl p pty v [Equation p (FunLhs v []) rhs]
_ -> withLocalDictEnv $ PatternDecl p <$> dictTrans t <*> dictTrans rhs
dictTrans (FreeDecl p vs) =
return $ FreeDecl p $ map (fmap unpredType) vs
dictTrans (ExternalDecl p vs) =
return $ ExternalDecl p $ map (fmap unpredType) vs
dictTrans d =
internalError $ "Dictionary.dictTrans: " ++ show d
......
......@@ -258,13 +258,24 @@ absFunDecl pre fvs lvs (FunctionDecl p _ f eqs) = do
addVars (Equation p' (FunLhs _ ts) rhs) =
Equation p' (FunLhs f' (map (uncurry VariablePattern) fvs ++ ts)) rhs
addVars _ = error "Lift.absFunDecl.addVars: no pattern match"
absFunDecl pre _ _ (ForeignDecl p cc ie ty f ty') = do
--absFunDecl pre _ _ (ForeignDecl p cc ie ty f ty') = do
-- m <- getModuleIdent
-- modifyValueEnv $ bindGlobalInfo
-- (\qf tySc -> Value qf False (arrowArity ty) tySc) m f' $ polyType ty
-- return $ ForeignDecl p cc ie ty f' ty'
-- where f' = liftIdent pre f
absFunDecl pre _ _ (ExternalDecl p vs) = do
vs' <- mapM (absVars pre) vs
return $ ExternalDecl p vs'
absFunDecl _ _ _ _ = error "Lift.absFunDecl: no pattern match"
absVars :: String -> Var Type -> LiftM (Var Type)
absVars pre (Var ty f) = do
m <- getModuleIdent
modifyValueEnv $ bindGlobalInfo
(\qf tySc -> Value qf False (arrowArity ty) tySc) m f' $ polyType ty
return $ ForeignDecl p cc ie ty f' ty'
return (Var ty f')
where f' = liftIdent pre f
absFunDecl _ _ _ _ = error "Lift.absFunDecl: no pattern match"
absExpr :: String -> [Ident] -> Expression Type -> LiftM (Expression Type)
absExpr _ _ l@(Literal _ _) = return l
......@@ -415,9 +426,9 @@ renameAlt rm (Alt p t rhs) = Alt p t (renameRhs rm rhs)
-- ---------------------------------------------------------------------------
isFunDecl :: Decl a -> Bool
isFunDecl (FunctionDecl _ _ _ _) = True
isFunDecl (ForeignDecl _ _ _ _ _ _) = True
isFunDecl _ = False
isFunDecl (FunctionDecl _ _ _ _) = True
isFunDecl (ExternalDecl _ _ ) = True
isFunDecl _ = False
mkFun :: ModuleIdent -> String -> a -> Ident -> Expression a
mkFun m pre a = Variable a . qualifyWith m . liftIdent pre
......
......@@ -76,7 +76,6 @@ qDecl (NewtypeDecl p n vs nc clss) = NewtypeDecl p n vs <$>
qDecl (TypeDecl p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty
qDecl (TypeSig p fs qty) = TypeSig p fs <$> qQualTypeExpr qty
qDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs
qDecl (ForeignDecl p c x a n ty) = ForeignDecl p c x a n <$> qTypeExpr ty
qDecl e@(ExternalDecl _ _) = return e
qDecl (PatternDecl p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs
qDecl vs@(FreeDecl _ _) = return vs
......
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