Commit 8d279ceb authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Merge remote-tracking branch 'origin/master' into records

Conflicts:
	src/Checks/InterfaceSyntaxCheck.hs
	src/Checks/TypeCheck.hs
	src/Env/Value.hs
	src/Transformations/Qual.hs
parents 0681cc80 b2e357a2
......@@ -4,6 +4,12 @@ Change log for curry-frontend
Under development
=================
* HTML generation now places HTML files for hierarchical modules into
files named `<Module>_curry.html`, i.e., no sub-folders reflecting
the the module name hierarchy are generated. In addition, if the option
`--html-dir` is not given, the current directory is used as the output
directory.
* Removed record type extensions
* Enabled declaration of (mutually) recursive record types
......
Completed
=========
- Anonymous free variables implemented
- hierarchically structured modules
- Records: There is no way to explicitly import a record with its fields:
import CompilerOpts -- okay, works
import CompilerOpts (Options) -- okay, but no field labels imported
import CompilerOpts (Options (..)) -- fails: Options is not a data type
- Checked correctness of created FlatCurry files by comparison with the old
frontend
Still to do
===========
- Module pragmas
- type classes
- option to disable nondeterminism by overlapping
- option/check for case mode
- FFI for C (Haskell?)
- Extend error messages of the type checker (and maybe others, too)
with the origin of the inferred types in case of a type conflict
......@@ -2,6 +2,7 @@
Module : $Header$
Description : Nested Environments
Copyright : (c) 1999 - 2003 Wolfgang Lux
2011 - 2015 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -18,18 +19,18 @@
module Base.NestEnv
( module Base.TopEnv
, NestEnv, bindNestEnv, qualBindNestEnv, lookupNestEnv, qualLookupNestEnv
, toplevelEnv, globalEnv, nestEnv
, toplevelEnv, globalEnv, nestEnv, elemNestEnv
) where
import qualified Data.Map as Map
import Curry.Base.Ident
import qualified Data.Map as Map
import Curry.Base.Ident
import Base.Messages (internalError)
import Base.TopEnv
data NestEnv a
= GlobalEnv (TopEnv a)
| LocalEnv (NestEnv a) (Map.Map Ident a)
= GlobalEnv (TopEnv a)
| LocalEnv (NestEnv a) (Map.Map Ident a)
deriving Show
instance Functor NestEnv where
......@@ -47,19 +48,17 @@ toplevelEnv (GlobalEnv env) = env
toplevelEnv (LocalEnv genv _) = toplevelEnv genv
bindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv x y (GlobalEnv env)
= GlobalEnv $ bindTopEnv "NestEnv.bindNestEnv" x y env
bindNestEnv x y (GlobalEnv env) = GlobalEnv $ bindTopEnv x y env
bindNestEnv x y (LocalEnv genv env) = case Map.lookup x env of
Just _ -> internalError $ "NestEnv.bindNestEnv " ++ show x ++ " failed"
Just _ -> internalError $ "NestEnv.bindNestEnv " ++ show x
Nothing -> LocalEnv genv $ Map.insert x y env
qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
qualBindNestEnv x y (GlobalEnv env)
= GlobalEnv $ qualBindTopEnv "NestEnv.qualBindNestEnv" x y env
qualBindNestEnv x y (GlobalEnv env) = GlobalEnv $ qualBindTopEnv x y env
qualBindNestEnv x y (LocalEnv genv env)
| isQualified x = internalError "NestEnv.qualBindNestEnv"
| isQualified x = internalError $ "NestEnv.qualBindNestEnv " ++ show x
| otherwise = case Map.lookup x' env of
Just _ -> internalError "NestEnv.qualBindNestEnv"
Just _ -> internalError $ "NestEnv.qualBindNestEnv " ++ show x
Nothing -> LocalEnv genv $ Map.insert x' y env
where x' = unqualify x
......@@ -73,3 +72,6 @@ qualLookupNestEnv :: QualIdent -> NestEnv a -> [a]
qualLookupNestEnv x env
| isQualified x = qualLookupTopEnv x $ toplevelEnv env
| otherwise = lookupNestEnv (unqualify x) env
elemNestEnv :: Ident -> NestEnv a -> Bool
elemNestEnv x env = not (null (lookupNestEnv x env))
......@@ -80,7 +80,7 @@ emptyTopEnv = TopEnv Map.empty
-- |Insert an 'Entity' into a 'TopEnv' as a predefined 'Entity'
predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a
predefTopEnv k v (TopEnv env) = case Map.lookup k env of
Just _ -> internalError "TopEnv.predefTopEnv"
Just _ -> internalError $ "TopEnv.predefTopEnv " ++ show k
Nothing -> TopEnv $ Map.insert k [(Import [], v)] env
-- |Insert an 'Entity' as unqualified into a 'TopEnv'
......@@ -106,17 +106,16 @@ addImport m k v (TopEnv env) = TopEnv $
Just y'' -> (Import (m : ms), y'') : xs
Nothing -> imp : mergeImport y xs
bindTopEnv :: String -> Ident -> a -> TopEnv a -> TopEnv a
bindTopEnv fun x y env = qualBindTopEnv fun (qualify x) y env
bindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a
bindTopEnv x y env = qualBindTopEnv (qualify x) y env
qualBindTopEnv :: String -> QualIdent -> a -> TopEnv a -> TopEnv a
qualBindTopEnv fun x y (TopEnv env) =
TopEnv $ Map.insert x (bindLocal y (entities x env)) env
qualBindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
qualBindTopEnv x y (TopEnv env)
= TopEnv $ Map.insert x (bindLocal y (entities x env)) env
where
bindLocal y' ys
| null [ y'' | (Local, y'') <- ys ] = (Local, y') : ys
| otherwise = internalError $ "\"qualBindTopEnv " ++ show x
++ "\" failed in function \"" ++ fun
| otherwise = internalError $ "qualBindTopEnv " ++ show x
rebindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a
rebindTopEnv = qualRebindTopEnv . qualify
......@@ -125,7 +124,8 @@ qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
qualRebindTopEnv x y (TopEnv env) =
TopEnv $ Map.insert x (rebindLocal (entities x env)) env
where
rebindLocal [] = internalError "TopEnv.qualRebindTopEnv"
rebindLocal [] = internalError
$ "TopEnv.qualRebindTopEnv " ++ show x
rebindLocal ((Local, _) : ys) = (Local, y) : ys
rebindLocal (imported : ys) = imported : rebindLocal ys
......@@ -133,7 +133,7 @@ unbindTopEnv :: Ident -> TopEnv a -> TopEnv a
unbindTopEnv x (TopEnv env) =
TopEnv $ Map.insert x' (unbindLocal (entities x' env)) env
where x' = qualify x
unbindLocal [] = internalError "TopEnv.unbindTopEnv"
unbindLocal [] = internalError $ "TopEnv.unbindTopEnv " ++ show x
unbindLocal ((Local, _) : ys) = ys
unbindLocal (imported : ys) = imported : unbindLocal ys
......@@ -164,4 +164,4 @@ allLocalBindings (TopEnv env) = [ (x, y) | (x, ys) <- Map.toList env
, (Local, y) <- ys ]
allEntities :: TopEnv a -> [(QualIdent, a)]
allEntities env = [ (x, y) | (x, ys) <- Map.toList env, (_, y) <- ys]
\ No newline at end of file
allEntities env = [ (x, y) | (x, ys) <- Map.toList env, (_, y) <- ys]
......@@ -28,10 +28,10 @@ import Base.Messages
import CompilerEnv
import CompilerOpts
type Check m a = Options -> CompilerEnv -> a -> CYT m (CompilerEnv, a)
type Check m a = Options -> CompEnv a -> CYT m (CompEnv a)
interfaceCheck :: Monad m => Check m Interface
interfaceCheck _ env intf
interfaceCheck _ (env, intf)
| null msgs = ok (env, intf)
| otherwise = failMessages msgs
where msgs = IC.interfaceCheck (opPrecEnv env) (tyConsEnv env)
......@@ -43,7 +43,7 @@ interfaceCheck _ env intf
-- disambiguated
-- * Environment: remains unchanged
kindCheck :: Monad m => Check m Module
kindCheck _ env mdl
kindCheck _ (env, mdl)
| null msgs = ok (env, mdl')
| otherwise = failMessages msgs
where (mdl', msgs) = KC.kindCheck (tyConsEnv env) mdl
......@@ -54,7 +54,7 @@ kindCheck _ env mdl
-- disambiguated, variables are renamed
-- * Environment: remains unchanged
syntaxCheck :: Monad m => Check m Module
syntaxCheck opts env mdl
syntaxCheck opts (env, mdl)
| null msgs = ok (env { extensions = exts }, mdl')
| otherwise = failMessages msgs
where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env)
......@@ -66,7 +66,7 @@ syntaxCheck opts env mdl
-- precedences
-- * Environment: The operator precedence environment is updated
precCheck :: Monad m => Check m Module
precCheck _ env (Module ps m es is ds)
precCheck _ (env, Module ps m es is ds)
| null msgs = ok (env { opPrecEnv = pEnv' }, Module ps m es is ds')
| otherwise = failMessages msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
......@@ -75,7 +75,7 @@ precCheck _ env (Module ps m es is ds)
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck :: Monad m => Check m Module
typeCheck _ env mdl@(Module _ _ _ _ ds)
typeCheck _ (env, mdl@(Module _ _ _ _ ds))
| null msgs = ok (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = failMessages msgs
where (tcEnv', tyEnv', msgs) = TC.typeCheck (moduleIdent env)
......@@ -83,7 +83,7 @@ typeCheck _ env mdl@(Module _ _ _ _ ds)
-- |Check the export specification
exportCheck :: Monad m => Check m Module
exportCheck _ env (Module ps m es is ds)
exportCheck _ (env, Module ps m es is ds)
| null msgs = ok (env, Module ps m es' is ds)
| otherwise = failMessages msgs
where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
......
......@@ -2,7 +2,7 @@
Module : $Header$
Description : Checks interface declarations
Copyright : (c) 2000 - 2007 Wolfgang Lux
Björn Peemöller
2011 - 2015 Björn Peemöller
2015 Jan Tikovsky
License : OtherLicense
......@@ -26,6 +26,7 @@ import Control.Monad (liftM, liftM2)
import qualified Control.Monad.State as S
import Data.List (nub, partition)
import Data.Maybe (catMaybes)
import qualified Data.Traversable as T (mapM)
import Base.Expr
import Base.Messages (Message, posMessage, internalError)
......@@ -37,13 +38,6 @@ import Curry.Base.Ident
import Curry.Base.Pretty
import Curry.Syntax
-- import Base
-- import Error
-- import List
-- import Maybe
-- import Monad
-- import TopEnv
data ISCState = ISCState
{ typeEnv :: TypeEnv
, errors :: [Message]
......@@ -70,14 +64,14 @@ intfSyntaxCheck (Interface n is ds) = (Interface n is ds', reverse $ errors s')
bindType :: IDecl -> TypeEnv -> TypeEnv
bindType (IInfixDecl _ _ _ _) = id
bindType (HidingDataDecl _ tc _) = qualBindTopEnv "" tc (Data tc [])
bindType (IDataDecl _ tc _ cs) = qualBindTopEnv "" tc
bindType (HidingDataDecl _ tc _) = qualBindTopEnv tc (Data tc [])
bindType (IDataDecl _ tc _ cs) = qualBindTopEnv tc
(Data tc (map constr (catMaybes cs)))
where constr (ConstrDecl _ _ c _) = c
constr (ConOpDecl _ _ _ op _) = op
bindType (INewtypeDecl _ tc _ nc) = qualBindTopEnv "" tc (Data tc [nconstr nc])
bindType (INewtypeDecl _ tc _ nc) = qualBindTopEnv tc (Data tc [nconstr nc])
where nconstr (NewConstrDecl _ _ c _) = c
bindType (ITypeDecl _ tc _ _) = qualBindTopEnv "" tc (Alias tc)
bindType (ITypeDecl _ tc _ _) = qualBindTopEnv tc (Alias tc)
bindType (IFunctionDecl _ _ _ _) = id
-- The checks applied to the interface are similar to those performed
......@@ -90,7 +84,7 @@ checkIDecl (HidingDataDecl p tc tvs) = do
return (HidingDataDecl p tc tvs)
checkIDecl (IDataDecl p tc tvs cs) = do
checkTypeLhs tvs
liftM (IDataDecl p tc tvs) (mapM (liftMaybe (checkConstrDecl tvs)) cs)
liftM (IDataDecl p tc tvs) (mapM (T.mapM (checkConstrDecl tvs)) cs)
checkIDecl (INewtypeDecl p tc tvs nc) = do
checkTypeLhs tvs
liftM (INewtypeDecl p tc tvs) (checkNewConstrDecl tvs nc)
......@@ -166,14 +160,6 @@ checkTypeConstructor tc tys = do
ConstructorType tc `liftM` mapM checkType tys
_ -> internalError "checkTypeConstructor"
-- ---------------------------------------------------------------------------
-- Auxiliary functions
-- ---------------------------------------------------------------------------
liftMaybe :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
liftMaybe f (Just x) = liftM Just (f x)
liftMaybe _ Nothing = return Nothing
-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------
......
......@@ -93,8 +93,7 @@ bindKind m (TypeDecl _ tc tvs _) = bindKind' m tc tvs
bindKind _ _ = id
bindKind' :: ModuleIdent -> Ident -> [Ident] -> KindEnv -> KindEnv
bindKind' m tc tvs = bindTopEnv "KindCheck.bindKind'" tc arity
. qualBindTopEnv "KindCheck.bindKind'" qtc arity
bindKind' m tc tvs = bindTopEnv tc arity . qualBindTopEnv qtc arity
where arity = length tvs
qtc = qualifyWith m tc
......
This diff is collapsed.
......@@ -27,6 +27,8 @@ import Env.OpPrec
import Env.TypeConstructor
import Env.Value
type CompEnv a = (CompilerEnv, a)
-- |A compiler environment contains information about the module currently
-- compiled. The information is updated during the different stages of
-- compilation.
......
......@@ -3,7 +3,7 @@
Description : Build tool for compiling multiple Curry modules
Copyright : (c) 2005 Martin Engelke
2007 Sebastian Fischer
2011 - 2014 Björn Peemöller
2011 - 2015 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -13,7 +13,7 @@
This module contains functions to generate Curry representations for a
Curry source file including all imported modules.
-}
module CurryBuilder (buildCurry) where
module CurryBuilder (buildCurry, findCurry) where
import Control.Monad (foldM, liftM)
import Data.Char (isSpace)
......
......@@ -44,9 +44,10 @@ type Precedence = Integer
-- if used anywhere.
instance Show OpPrec where
showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p
where assoc InfixL = "left "
assoc InfixR = "right "
assoc Infix = "non-assoc "
where
assoc InfixL = "left "
assoc InfixR = "right "
assoc Infix = "non-assoc "
-- |Default operator declaration (associativity and precedence).
defaultP :: OpPrec
......@@ -83,11 +84,10 @@ consPrec = PrecInfo qConsId (OpPrec InfixR 5)
-- |Bind an operator precedence.
bindP :: ModuleIdent -> Ident -> OpPrec -> OpPrecEnv -> OpPrecEnv
bindP m op p
| hasGlobalScope op = bindTopEnv fun op info . qualBindTopEnv fun qop info
| otherwise = bindTopEnv fun op info
| hasGlobalScope op = bindTopEnv op info . qualBindTopEnv qop info
| otherwise = bindTopEnv op info
where qop = qualifyWith m op
info = PrecInfo qop p
fun = "Env.OpPrec.bindP"
-- The lookup functions for the environment which maintains the operator
-- precedences are simpler than for the type and value environments
......
......@@ -96,10 +96,9 @@ type TCEnv = TopEnv TypeInfo
bindTypeInfo :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent
-> Ident -> [Ident] -> a -> TCEnv -> TCEnv
bindTypeInfo f m tc tvs x = bindTopEnv fun tc ty . qualBindTopEnv fun qtc ty
bindTypeInfo f m tc tvs x = bindTopEnv tc ty . qualBindTopEnv qtc ty
where qtc = qualifyWith m tc
ty = f qtc (length tvs) x
fun = "Base.bindTypeInfo"
lookupTC :: Ident -> TCEnv -> [TypeInfo]
lookupTC tc tcEnv = lookupTopEnv tc tcEnv ++! lookupTupleTC tc
......
......@@ -92,31 +92,28 @@ type ValueEnv = TopEnv ValueInfo
bindGlobalInfo :: (QualIdent -> a -> ValueInfo) -> ModuleIdent -> Ident -> a
-> ValueEnv -> ValueEnv
bindGlobalInfo f m c ty = bindTopEnv fun c v . qualBindTopEnv fun qc v
where qc = qualifyWith m c
v = f qc ty
fun = "Env.Value.bindGlobalInfo"
bindGlobalInfo f m c ty = bindTopEnv c v . qualBindTopEnv qc v
where qc = qualifyWith m c
v = f qc ty
bindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv
bindFun m f a ty
| idUnique f == 0 = bindTopEnv fun f v . qualBindTopEnv fun qf v
| otherwise = bindTopEnv fun f v
where qf = qualifyWith m f
v = Value qf a ty
fun = "Env.Value.bindFun"
| hasGlobalScope f = bindTopEnv f v . qualBindTopEnv qf v
| otherwise = bindTopEnv f v
where qf = qualifyWith m f
v = Value qf a ty
qualBindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv
qualBindFun m f a ty = qualBindTopEnv "Env.Value.qualBindFun" qf $
Value qf a ty
qualBindFun m f a ty = qualBindTopEnv qf $ Value qf a ty
where qf = qualifyWith m f
rebindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv
-> ValueEnv
rebindFun m f a ty
| idUnique f == 0 = rebindTopEnv f v . qualRebindTopEnv qf v
| otherwise = rebindTopEnv f v
| hasGlobalScope f = rebindTopEnv f v . qualRebindTopEnv qf v
| otherwise = rebindTopEnv f v
where qf = qualifyWith m f
v = Value qf a ty
v = Value qf a ty
unbindFun :: Ident -> ValueEnv -> ValueEnv
unbindFun = unbindTopEnv
......
......@@ -24,12 +24,8 @@ import IL (Module)
import ModuleSummary
-- |Generate AbstractCurry
genTypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genTypedAbstractCurry = GAC.genTypedAbstract
-- |Generate untyped AbstractCurry
genUntypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genUntypedAbstractCurry = GAC.genUntypedAbstract
genAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genAbstractCurry = GAC.genAbstractCurry
-- |Generate FlatCurry
genFlatCurry :: ModuleSummary -> CompilerEnv -> IL.Module -> EF.Prog
......
This diff is collapsed.
......@@ -171,18 +171,21 @@ visitModule (IL.Module mid imps decls) = do
ops <- genOpDecls
whenFlatCurry
( do
datas <- mapM visitDataDecl (filter isDataDecl decls)
datas <- mapM visitDataDecl (filter isDataDecl decls)
newtys <- mapM visitNewtypeDecl (filter isNewtypeDecl decls)
types <- genTypeSynonyms
recrds <- genRecordTypes
funcs <- mapM visitFuncDecl (filter isFuncDecl decls)
modid <- visitModuleIdent mid
imps' <- imports
is <- mapM visitModuleIdent $ nub $ imps ++ (map extractMid imps')
return $ Prog modid is (recrds ++ types ++ datas) funcs ops
return $ Prog modid is (recrds ++ types ++ datas ++ newtys) funcs ops
)
( do
ds <- filterM isPublicDataDecl decls
nts <- filterM isPublicNewtypeDecl decls
datas <- mapM visitDataDecl ds
newtys <- mapM visitNewtypeDecl nts
types <- genTypeSynonyms
recrds <- genRecordTypes
fs <- filterM isPublicFuncDecl decls
......@@ -194,25 +197,33 @@ visitModule (IL.Module mid imps decls) = do
modid <- visitModuleIdent mid
imps' <- imports
is <- mapM visitModuleIdent $ nub $ imps ++ (map extractMid imps')
return $ Prog modid is (itypes ++ recrds ++ types ++ datas) (ifuncs ++ funcs) (iops ++ ops)
return $ Prog modid is (itypes ++ recrds ++ types ++ datas ++ newtys) (ifuncs ++ funcs) (iops ++ ops)
)
where extractMid (CS.IImportDecl _ mid1) = mid1
--
visitDataDecl :: IL.Decl -> FlatState TypeDecl
visitDataDecl (IL.DataDecl qident arity constrs) = do
visitDataDecl (IL.DataDecl qid arity constrs) = do
cdecls <- mapM visitConstrDecl constrs
qname <- visitQualTypeIdent qident
vis <- getVisibility False qident
qname <- visitQualTypeIdent qid
vis <- getVisibility False qid
return $ Type qname vis [0 .. arity - 1] (concat cdecls)
visitDataDecl _ = internalError "GenFlatCurry: no data declaration"
visitNewtypeDecl :: IL.Decl -> FlatState TypeDecl
visitNewtypeDecl (IL.NewtypeDecl qid arity (IL.ConstrDecl _ ty)) = do
qname <- visitQualTypeIdent qid
vis <- getVisibility False qid
ty' <- visitType ty
return $ TypeSyn qname vis [0 .. arity - 1] ty'
visitNewtypeDecl _ = internalError "GenFlatCurry: no newtype declaration"
--
visitConstrDecl :: IL.ConstrDecl [IL.Type] -> FlatState [ConsDecl]
visitConstrDecl (IL.ConstrDecl qident types) = do
visitConstrDecl (IL.ConstrDecl qid types) = do
texprs <- mapM visitType types
qname <- visitQualIdent qident
vis <- getVisibility True qident
qname <- visitQualIdent qid
vis <- getVisibility True qid
genFint <- genInterface
return $ if genFint && vis == Private
then []
......@@ -232,16 +243,16 @@ visitType (IL.TypeArrow ty1 ty2) = liftM2 FuncType
--
visitFuncDecl :: IL.Decl -> FlatState FuncDecl
visitFuncDecl (IL.FunctionDecl qident params typeexpr expression) = do
visitFuncDecl (IL.FunctionDecl qid params typeexpr expression) = do
let argtypes = splitoffArgTypes typeexpr params
setFunctionId (qident, argtypes)
qname <- visitQualIdent qident
arity <- fromMaybe (length params) `liftM` lookupIdArity qident
setFunctionId (qid, argtypes)
qname <- visitQualIdent qid
arity <- fromMaybe (length params) `liftM` lookupIdArity qid
whenFlatCurry
(do is <- mapM newVarIndex params
texpr <- visitType typeexpr
expr <- visitExpression expression
vis <- getVisibility False qident
vis <- getVisibility False qid
clearVarIndices
return (Func qname arity vis texpr (Rule is expr))
)
......@@ -249,12 +260,12 @@ visitFuncDecl (IL.FunctionDecl qident params typeexpr expression) = do
clearVarIndices
return (Func qname arity Public texpr (Rule [] (Var $ mkIdx 0)))
)
visitFuncDecl (IL.ExternalDecl qident _ extname typeexpr) = do
setFunctionId (qident, [])
visitFuncDecl (IL.ExternalDecl qid _ extname typeexpr) = do
setFunctionId (qid, [])
texpr <- visitType typeexpr
qname <- visitQualIdent qident
arity <- fromMaybe (typeArity typeexpr) `liftM` lookupIdArity qident
vis <- getVisibility False qident
qname <- visitQualIdent qid
arity <- fromMaybe (typeArity typeexpr) `liftM` lookupIdArity qid
vis <- getVisibility False qid
xname <- visitExternalName extname
return $ Func qname arity vis texpr (External xname)
visitFuncDecl (IL.NewtypeDecl _ _ _) = do
......@@ -387,23 +398,23 @@ visitModuleIdent = return . Id.moduleName
--
visitQualIdent :: QualIdent -> FlatState QName
visitQualIdent qident = do
visitQualIdent qid = do
mid <- moduleId
let (mmod, ident) = (qidModule qident, qidIdent qident)
let (mmod, ident) = (qidModule qid, qidIdent qid)
modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
= Id.moduleName preludeMIdent
| otherwise
= maybe (Id.moduleName mid) Id.moduleName mmod
ftype <- lookupIdType qident
ftype <- lookupIdType qid
return (QName Nothing ftype modid $ idName ident)
-- This variant of visitQualIdent does not look up the type of the identifier,
-- which is wise when the identifier is bound to a type, because looking up
-- the type of a type via lookupIdType will get stuck in an endless loop. (hsi)
visitQualTypeIdent :: QualIdent -> FlatState QName
visitQualTypeIdent qident = do
visitQualTypeIdent qid = do
mid <- moduleId
let (mmod, ident) = (qidModule qident, qidIdent qident)
let (mmod, ident) = (qidModule qid, qidIdent qid)
modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
= Id.moduleName preludeMIdent
| otherwise
......@@ -415,13 +426,10 @@ visitExternalName :: String -> FlatState String
visitExternalName extname
= moduleId >>= \mid -> return (Id.moduleName mid ++ "." ++ extname)
-------------------------------------------------------------------------------
--
getVisibility :: Bool -> QualIdent -> FlatState Visibility
getVisibility isConstr qident = do
public <- isPublic isConstr qident
getVisibility isConstr qid = do
public <- isPublic isConstr qid
return $ if public then Public else Private
--
......@@ -433,31 +441,32 @@ getExportedImports = do
--
getExpImports :: ModuleIdent -> Map.Map ModuleIdent [CS.Export] -> [CS.Export]
-> Map.Map ModuleIdent [CS.Export]
-> Map.Map ModuleIdent [CS.Export]
getExpImports _ expenv [] = expenv
getExpImports mident expenv ((CS.Export qident):exps)
getExpImports mident expenv ((CS.Export qid):exps)
= getExpImports mident
(bindExpImport mident qident (CS.Export qident) expenv)
(bindExpImport mident qid (CS.Export qid) expenv)
exps
getExpImports mident expenv ((CS.ExportTypeWith qident idents):exps)
getExpImports mident expenv ((CS.ExportTypeWith qid idents):exps)
= getExpImports mident
(bindExpImport mident qident (CS.ExportTypeWith qident idents) expenv)
(bindExpImport mident qid (CS.ExportTypeWith qid idents) expenv)
exps
getExpImports mident expenv ((CS.ExportTypeAll qident):exps)
getExpImports mident expenv ((CS.ExportTypeAll qid):exps)
= getExpImports mident
(bindExpImport mident qident (CS.ExportTypeAll qident) expenv)
(bindExpImport mident qid (CS.ExportTypeAll qid) expenv)
exps
getExpImports mident expenv ((CS.ExportModule mident'):exps)
= getExpImports mident (Map.insert mident' [] expenv) exps