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

Simplify external declarations

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