Commit 140c696e authored by Finn Teegen's avatar Finn Teegen
Browse files

Simplify external declarations

parent 0ced31dd
......@@ -927,34 +927,19 @@ instMethodType qual (PredType ps ty) f = do
let PredType ps'' ty'' = instanceType ty (PredType (Set.deleteMin ps') ty')
return $ PredType (ps `Set.union` ps'') ty''
-- Foreign and external functions:
-- Argument and result types of foreign functions using the ccall calling
-- convention are restricted to the basic types Bool, Char, Int, and Float.
-- In addition, IO t is a legitimate result type when t is either one of the
-- basic types or ().
-- TODO: Extend the set of legitimate types to match the types admitted
-- by the Haskell Foreign Function Interface Addendum.
-- External functions:
tcExternal :: Ident -> TCM Type
tcExternal f = do
sigs <- getSigEnv
case lookupTypeSig f sigs of
Nothing -> internalError "TypeCheck.tcExternal: type signature not found"
Just (QualTypeExpr _ ty) ->
-- tcForeign f ty
do m <- getModuleIdent
Just (QualTypeExpr _ 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
-- pattern is the type of the whole pattern and not the type of the
......
......@@ -297,12 +297,12 @@ trAFuncDecl (IL.FunctionDecl f vs _ e) = do
r' <- trARule ty vs e
return [AFunc f' a vis ty' r']
where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs
trAFuncDecl (IL.ExternalDecl f _ e ty) = do
trAFuncDecl (IL.ExternalDecl f ty) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
ty' <- trType ty
r' <- trAExternal ty e
r' <- trAExternal ty f
return [AFunc f' a vis ty' r']
trAFuncDecl _ = return []
......@@ -314,10 +314,8 @@ trARule ty vs e = withFreshEnv $ ARule <$> trType ty
<*> mapM (uncurry newVar) vs
<*> trAExpr e
trAExternal :: IL.Type -> String -> FlatState (ARule TypeExpr)
trAExternal ty e = do mid <- getModuleIdent
ty' <- trType ty
return (AExternal ty' $ moduleName mid ++ "." ++ e)
trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)
trAExternal ty f = flip AExternal (qualName f) <$> trType ty
-- Translate an expression
trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)
......
......@@ -61,11 +61,7 @@ ppDecl (ExternalDataDecl tc n) =
ppDecl (FunctionDecl f vs ty e) = ppTypeSig f ty $$ sep
[ ppQIdent f <+> hsep (map (ppIdent . snd) vs) <+> equals
, nest bodyIndent (ppExpr 0 e)]
ppDecl (ExternalDecl f cc ie ty) = sep
[ text "external" <+> ppCallConv cc <+> text (show ie)
, nest bodyIndent (ppTypeSig f ty)]
where ppCallConv Primitive = text "primitive"
ppCallConv CCall = text "ccall"
ppDecl (ExternalDecl f ty) = text "external" <+> ppTypeSig f ty
ppTypeLhs :: QualIdent -> Int -> Doc
ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))
......
......@@ -51,11 +51,9 @@ showsDecl (FunctionDecl qident idents typ expr)
. showsType typ . space
. showsExpression expr
. showsString ")"
showsDecl (ExternalDecl qident cconv str typ)
showsDecl (ExternalDecl qident typ)
= showsString "(ExternalDecl "
. showsQualIdent qident . space
. shows cconv . space
. shows str . space
. showsType typ
. showsString ")"
......
......@@ -43,9 +43,8 @@
module IL.Type
( -- * Data types
Module (..), Decl (..), ConstrDecl (..), CallConv (..), Type (..)
, Literal (..), ConstrTerm (..), Expression (..), Eval (..), Alt (..)
, Binding (..)
Module (..), Decl (..), ConstrDecl (..), Type (..), Literal (..)
, ConstrTerm (..), Expression (..), Eval (..), Alt (..), Binding (..)
) where
import Curry.Base.Ident
......@@ -59,17 +58,12 @@ data Decl
= DataDecl QualIdent Int [ConstrDecl]
| ExternalDataDecl QualIdent Int
| FunctionDecl QualIdent [(Type, Ident)] Type Expression
| ExternalDecl QualIdent CallConv String Type
| ExternalDecl QualIdent Type
deriving (Eq, Show)
data ConstrDecl = ConstrDecl QualIdent [Type]
deriving (Eq, Show)
data CallConv
= Primitive
| CCall
deriving (Eq, Show)
data Type
= TypeConstructor QualIdent [Type]
| TypeVariable Int
......
......@@ -96,7 +96,7 @@ ccDecl :: Decl -> CCM Decl
ccDecl dd@(DataDecl _ _ _) = return dd
ccDecl edd@(ExternalDataDecl _ _) = return edd
ccDecl (FunctionDecl qid vs ty e) = FunctionDecl qid vs ty <$> ccExpr e
ccDecl ed@(ExternalDecl _ _ _ _) = return ed
ccDecl ed@(ExternalDecl _ _) = return ed
ccExpr :: Expression -> CCM Expression
ccExpr l@(Literal _ _) = return l
......
......@@ -67,7 +67,7 @@ mdlsDecl (IL.DataDecl _ _ cs) ms = foldr mdlsConstrsDecl ms cs
where mdlsConstrsDecl (IL.ConstrDecl _ tys) ms' = foldr mdlsType ms' tys
mdlsDecl (IL.ExternalDataDecl _ _) ms = ms
mdlsDecl (IL.FunctionDecl _ _ ty e) ms = mdlsType ty (mdlsExpr e ms)
mdlsDecl (IL.ExternalDecl _ _ _ ty) ms = mdlsType ty ms
mdlsDecl (IL.ExternalDecl _ ty) ms = mdlsType ty ms
mdlsType :: IL.Type -> Set.Set ModuleIdent -> Set.Set ModuleIdent
mdlsType (IL.TypeConstructor tc tys) ms = modules tc (foldr mdlsType ms tys)
......@@ -144,10 +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 (ExternalDataDecl _ tc tvs) = (:[]) <$> trExternalData tc tvs
trDecl (FunctionDecl _ ty f eqs) = (:[]) <$> trFunction f ty eqs
trDecl (ExternalDecl _ vs) = mapM trExternal vs
trDecl _ = return []
trData :: Ident -> [Ident] -> [ConstrDecl] -> TransM IL.Decl
......@@ -165,24 +164,11 @@ trConstrDecl d = do
constr (ConOpDecl _ _ _ _ op _) = op
constr (RecordDecl _ _ _ c _) = c
trExternal :: Ident -> [Ident] -> TransM IL.Decl
trExternal tc tvs = flip IL.ExternalDataDecl (length tvs) <$> trQualify tc
trExternalData :: Ident -> [Ident] -> TransM IL.Decl
trExternalData tc tvs = flip IL.ExternalDataDecl (length tvs) <$> trQualify tc
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
trExternal :: Var Type -> TransM IL.Decl
trExternal (Var ty f) = flip IL.ExternalDecl (transType ty) <$> trQualify f
-- The type representation in the intermediate language does not support
-- types with higher order kinds. Therefore, the type transformations has
......
......@@ -59,7 +59,7 @@ module Transformations.Desugar (desugar) where
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Arrow (first, second)
import Control.Monad (liftM2, mplus)
import Control.Monad (liftM2)
import Control.Monad.Extra (concatMapM)
import Control.Monad.ListM (mapAccumM)
import qualified Control.Monad.State as S (State, runState, gets, modify)
......@@ -246,15 +246,8 @@ 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 (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
-- TODO: Check if obsolete and remove
-- After desugaring its right hand side, each equation is eta-expanded
-- by adding as many variables as necessary to the argument list and
......@@ -270,11 +263,8 @@ 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 fs@(FreeDecl _ _) = return fs
dsDeclRhs fs@(ExternalDecl _ _) = return fs
dsDeclRhs d@(FreeDecl _ _) = return d
dsDeclRhs d@(ExternalDecl _ _) = return d
dsDeclRhs _ =
error "Desugar.dsDeclRhs: no pattern match"
......
......@@ -258,23 +258,15 @@ 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
-- 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 pre _ _ (ExternalDecl p vs) = ExternalDecl p <$> mapM (absVar pre) vs
absFunDecl _ _ _ _ = error "Lift.absFunDecl: no pattern match"
absVars :: String -> Var Type -> LiftM (Var Type)
absVars pre (Var ty f) = do
absVar :: String -> Var Type -> LiftM (Var Type)
absVar pre (Var ty f) = do
m <- getModuleIdent
modifyValueEnv $ bindGlobalInfo
(\qf tySc -> Value qf False (arrowArity ty) tySc) m f' $ polyType ty
return (Var ty f')
return $ Var ty f'
where f' = liftIdent pre f
absExpr :: String -> [Ident] -> Expression Type -> LiftM (Expression Type)
......
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