Commit e9a3bfbd authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Clean ups

parent a4a66440
......@@ -17,7 +17,7 @@ import Base.TopEnv
import Base.Types
import Base.Utils (findMultiples)
import Env.ModuleAlias
import Env.ModuleAlias (AliasEnv)
import Env.TypeConstructor
import Env.Value
......
......@@ -31,10 +31,10 @@ of the operators involved.
> import Base.Messages (Message, posMessage)
> import Base.Utils (findDouble)
> import Env.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
> import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
> , qualLookupP)
> precCheck :: ModuleIdent -> PEnv -> [Decl] -> ([Decl], PEnv, [Message])
> precCheck :: ModuleIdent -> OpPrecEnv -> [Decl] -> ([Decl], OpPrecEnv, [Message])
> precCheck m pEnv decls = runPCM (checkDecls decls) initState
> where initState = PCState m pEnv []
......@@ -44,23 +44,23 @@ The Prec check monad.
> data PCState = PCState
> { moduleIdent :: ModuleIdent
> , precEnv :: PEnv
> , precEnv :: OpPrecEnv
> , errors :: [Message]
> }
> type PCM = S.State PCState -- the Prec Check Monad
> runPCM :: PCM a -> PCState -> (a, PEnv, [Message])
> runPCM :: PCM a -> PCState -> (a, OpPrecEnv, [Message])
> runPCM kcm s = let (a, s') = S.runState kcm s
> in (a, precEnv s', reverse $ errors s')
> getModuleIdent :: PCM ModuleIdent
> getModuleIdent = S.gets moduleIdent
> getPrecEnv :: PCM PEnv
> getPrecEnv :: PCM OpPrecEnv
> getPrecEnv = S.gets precEnv
> modifyPrecEnv :: (PEnv -> PEnv) -> PCM ()
> modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> PCM ()
> modifyPrecEnv f = S.modify $ \ s -> s { precEnv = f $ precEnv s }
> withLocalPrecEnv :: PCM a -> PCM a
......@@ -94,7 +94,7 @@ imported precedence environment.
> opFixDecls = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops]
> bvs = concatMap boundValues nonFixDs
> bindPrec :: ModuleIdent -> Decl -> PEnv -> PEnv
> bindPrec :: ModuleIdent -> Decl -> OpPrecEnv -> OpPrecEnv
> bindPrec m (InfixDecl _ fix prc ops) pEnv
> | p == defaultP = pEnv
> | otherwise = foldr (flip (bindP m) p) pEnv ops
......@@ -409,7 +409,7 @@ the pattern to be accepted.
> return $ infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)
> fixRPrecT infixpatt t1 op t2 = return $ infixpatt t1 op t2
> {-fixPrecT :: Position -> PEnv -> ConstrTerm -> QualIdent -> ConstrTerm
> {-fixPrecT :: Position -> OpPrecEnv -> ConstrTerm -> QualIdent -> ConstrTerm
> -> ConstrTerm
> fixPrecT p pEnv t1@(NegativePattern uop l) op t2
> | pr < 6 || pr == 6 && fix == InfixL = fixRPrecT p pEnv t1 op t2
......@@ -417,7 +417,7 @@ the pattern to be accepted.
> where OpPrec fix pr = prec op pEnv
> fixPrecT p pEnv t1 op t2 = fixRPrecT p pEnv t1 op t2-}
> {-fixRPrecT :: Position -> PEnv -> ConstrTerm -> QualIdent -> ConstrTerm
> {-fixRPrecT :: Position -> OpPrecEnv -> ConstrTerm -> QualIdent -> ConstrTerm
> -> ConstrTerm
> fixRPrecT p pEnv t1 op t2@(NegativePattern uop l)
> | pr < 6 = InfixPattern t1 op t2
......@@ -478,10 +478,10 @@ an operator definition that shadows an imported definition.
> getOpPrec :: InfixOp -> PCM OpPrec
> getOpPrec op = opPrec op `liftM` getPrecEnv
> opPrec :: InfixOp -> PEnv -> OpPrec
> opPrec :: InfixOp -> OpPrecEnv -> OpPrec
> opPrec op = prec (opName op)
> prec :: QualIdent -> PEnv -> OpPrec
> prec :: QualIdent -> OpPrecEnv -> OpPrec
> prec op env = case qualLookupP op env of
> [] -> defaultP
> PrecInfo _ p : _ -> p
......
{- |
Module : $Header$
Description : Environment containing the module's information
Copyright : (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Copyright : (c) 2011, Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -21,7 +21,7 @@ import Curry.Base.Ident (ModuleIdent)
import Base.TopEnv (allLocalBindings)
import Env.Interface
import Env.ModuleAlias
import Env.ModuleAlias (AliasEnv, initAliasEnv)
import Env.OpPrec
import Env.TypeConstructor
import Env.Value
......@@ -35,7 +35,7 @@ data CompilerEnv = CompilerEnv
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: PEnv -- ^ operator precedences
, opPrecEnv :: OpPrecEnv -- ^ operator precedences
}
initCompilerEnv :: ModuleIdent -> CompilerEnv
......@@ -45,7 +45,7 @@ initCompilerEnv mid = CompilerEnv
, aliasEnv = initAliasEnv
, tyConsEnv = initTCEnv
, valueEnv = initDCEnv
, opPrecEnv = initPEnv
, opPrecEnv = initOpPrecEnv
}
showCompilerEnv :: CompilerEnv -> String
......
{- |
Module : $Header$
Description : Environment of imported interfaces
Copyright : (c) 2002-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Copyright : (c) 2002 - 2004, Wolfgang Lux
2011 , Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -16,7 +16,7 @@ module Env.Interface where
import qualified Data.Map as Map (Map, empty, lookup)
import Curry.Base.Ident (ModuleIdent)
import Curry.Syntax (Interface)
import Curry.Syntax (Interface)
type InterfaceEnv = Map.Map ModuleIdent Interface
......
{- |
Module : $Header$
Description : Environment of module aliases
Copyright : (c) 2002-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Copyright : (c) 2002 - 2004, Wolfgang Lux
2011 , Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -11,23 +11,23 @@
This module provides an environment for resolving module aliases.
For example, if a module @M@ is imported via
For example, if module @FiniteMap@ is imported via
@import M as N@
@import FiniteMap as FM@
then @N@ is an alias for @M@, and @M@ is aliased by @N@.
then @FM@ is an alias for @FiniteMap@, and @FiniteMap@ is aliased by @FM@.
-}
module Env.ModuleAlias
( AliasEnv, initAliasEnv, importAliases
, bindAlias, lookupAlias, sureLookupAlias
) where
import qualified Data.Map as Map (Map, empty, findWithDefault, insert, lookup)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map (Map, empty, insert)
import Data.Maybe (fromMaybe)
import Curry.Base.Ident (ModuleIdent)
import Curry.Syntax (ImportDecl (..))
import Curry.Syntax (ImportDecl (..))
-- |Mapping from original name to alias.
type AliasEnv = Map.Map ModuleIdent ModuleIdent
-- |Initial alias environment
......@@ -41,11 +41,3 @@ importAliases = foldr bindAlias initAliasEnv
-- |Bind an alias for a module from a single import declaration
bindAlias :: ImportDecl -> AliasEnv -> AliasEnv
bindAlias (ImportDecl _ mid _ alias _) = Map.insert mid $ fromMaybe mid alias
-- |Lookup the alias for a module, if existent
lookupAlias :: ModuleIdent -> AliasEnv -> Maybe ModuleIdent
lookupAlias = Map.lookup
-- |Try to lookup the alias for a module and default to the module if missing
sureLookupAlias :: ModuleIdent -> AliasEnv -> ModuleIdent
sureLookupAlias m = Map.findWithDefault m m
{- |
Module : $Header$
Description : Environment of Operator precedences
Copyright : (c) 2002-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Description : Environment of operator precedences
Copyright : (c) 2002 - 2004, Wolfgang Lux
2011 , Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -19,14 +19,15 @@
If no fixity is assigned to an operator, it will be given the default
precedence 9 and assumed to be a left-associative operator.
\em{Note:} this modified version uses Haskell type \texttt{Integer}
/Note:/ this modified version uses Haskell type 'Integer'
for representing the precedence. This change had to be done due to the
introduction of unlimited integer constants in the parser / lexer.
-}
module Env.OpPrec
( PEnv, PrecInfo (..), OpPrec (..), defaultP, bindP, lookupP, qualLookupP
, initPEnv ) where
( OpPrecEnv, PrecInfo (..), OpPrec (..)
, defaultP, bindP, lookupP, qualLookupP, initOpPrecEnv
) where
import Curry.Base.Ident
import Curry.Syntax (Infix (..))
......@@ -49,12 +50,12 @@ data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq, Show)
instance Entity PrecInfo where
origName (PrecInfo op _) = op
type PEnv = TopEnv PrecInfo
type OpPrecEnv = TopEnv PrecInfo
bindP :: ModuleIdent -> Ident -> OpPrec -> PEnv -> PEnv
bindP :: ModuleIdent -> Ident -> OpPrec -> OpPrecEnv -> OpPrecEnv
bindP m op p
| idUnique op == 0 = bindTopEnv fun op info . qualBindTopEnv fun qop info
| otherwise = bindTopEnv fun op info
| hasGlobalScope op = bindTopEnv fun op info . qualBindTopEnv fun qop info
| otherwise = bindTopEnv fun op info
where qop = qualifyWith m op
info = PrecInfo qop p
fun = "Env.OpPrec.bindP"
......@@ -63,14 +64,14 @@ bindP m op p
-- precedences are simpler than for the type and value environments
-- because they do not need to handle tuple constructors.
lookupP :: Ident -> PEnv -> [PrecInfo]
lookupP :: Ident -> OpPrecEnv -> [PrecInfo]
lookupP = lookupTopEnv
qualLookupP :: QualIdent -> PEnv -> [PrecInfo]
qualLookupP :: QualIdent -> OpPrecEnv -> [PrecInfo]
qualLookupP = qualLookupTopEnv
initPEnv :: PEnv
initPEnv = predefTopEnv qConsId consPrec emptyTopEnv
initOpPrecEnv :: OpPrecEnv
initOpPrecEnv = predefTopEnv qConsId consPrec emptyTopEnv
consPrec :: PrecInfo
consPrec = PrecInfo qConsId (OpPrec InfixR 5)
{- |
Module : $Header$
Description : Environment of type constructors
Copyright : (c) 2002-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Copyright : (c) 2002 - 2004, Wolfgang Lux
2011 , Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -119,7 +119,7 @@ tupleData = [DataConstr (tupleId n) 0 (take n tvs) | n <- [2 ..]]
initTCEnv :: TCEnv
initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes
where predefTC (TypeConstructor tc tys) =
predefTopEnv (qualify (unqualify tc)) .
DataType tc (length tys) . map Just
predefTC _ = internalError "Base.initTCEnv.predefTC: no type constructor"
where
predefTC (TypeConstructor tc tys) = predefTopEnv (qualify (unqualify tc))
. DataType tc (length tys) . map Just
predefTC _ = internalError "Base.initTCEnv.predefTC: no type constructor"
......@@ -28,7 +28,7 @@ import Base.CurryTypes (fromQualType)
import Base.Messages
import Base.Types
import Env.OpPrec (PEnv, PrecInfo (..), OpPrec (..), qualLookupP)
import Env.OpPrec (OpPrecEnv, PrecInfo (..), OpPrec (..), qualLookupP)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
......@@ -54,7 +54,7 @@ exportInterface :: CompilerEnv -> Module -> Interface
exportInterface env mdl = exportInterface' mdl
(opPrecEnv env) (tyConsEnv env) (valueEnv env)
exportInterface' :: Module -> PEnv -> TCEnv -> ValueEnv -> Interface
exportInterface' :: Module -> OpPrecEnv -> TCEnv -> ValueEnv -> Interface
exportInterface' (Module m (Just (Exporting _ es)) _ _) pEnv tcEnv tyEnv
= Interface m imports $ precs ++ hidden ++ decls
where
......@@ -65,14 +65,14 @@ exportInterface' (Module m (Just (Exporting _ es)) _ _) pEnv tcEnv tyEnv
exportInterface' (Module _ Nothing _ _) _ _ _
= internalError "Exports.exportInterface: no export specification"
infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl]
infixDecl :: ModuleIdent -> OpPrecEnv -> Export -> [IDecl] -> [IDecl]
infixDecl m pEnv (Export f) ds = iInfixDecl m pEnv f ds
infixDecl m pEnv (ExportTypeWith tc cs) ds =
foldr (iInfixDecl m pEnv . qualifyLike (qidModule tc)) ds cs
where qualifyLike = maybe qualify qualifyWith
infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match"
iInfixDecl :: ModuleIdent -> PEnv -> QualIdent -> [IDecl] -> [IDecl]
iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl]
iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
[] -> ds
[PrecInfo _ (OpPrec fix pr)] ->
......
{- |
Module : $Header$
Description : Intermediate language
Copyright : (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Copyright : (c) 2011, Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -19,4 +19,4 @@ module IL
import IL.Pretty (ppModule)
import IL.Type
import IL.XML (xmlModule)
import IL.XML (xmlModule)
{- |
Module : $Header$
Description : Loading interfaces
Copyright : (c) 2000-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Copyright : (c) 2000 - 2004, Wolfgang Lux
2011 , Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -24,25 +24,23 @@
-}
module Interfaces (loadInterfaces) where
import Control.Monad (foldM, liftM, unless)
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.State as S (StateT (..), modify)
import Data.List (intercalate, isPrefixOf)
import qualified Data.Map as Map
import Text.PrettyPrint
import Control.Monad (foldM, liftM, unless)
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.State as S (StateT (..), modify)
import Data.List (intercalate, isPrefixOf)
import qualified Data.Map as Map
import Text.PrettyPrint
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Ident
import Curry.Base.Position
import qualified Curry.ExtendedFlat.Type as EF
import Curry.Files.PathUtils as PU
import Curry.Syntax
import Curry.Files.PathUtils as PU
import Curry.Syntax
import Base.Messages (Message, posMessage, internalError)
import Env.Interface
-- TODO: Propagate errors
type IntfLoader a = S.StateT [Message] IO a
report :: Message -> IntfLoader ()
......@@ -116,18 +114,15 @@ flatToCurryInterface (EF.Prog m imps ts fs os)
genITypeDecl :: EF.TypeDecl -> IDecl
genITypeDecl (EF.Type qn _ is cs)
| recordExt `isPrefixOf` EF.localName qn
= ITypeDecl pos
(genQualIdent qn)
= ITypeDecl pos (genQualIdent qn)
(map genVarIndexIdent is)
(RecordType (map genLabeledType cs) Nothing)
| otherwise
= IDataDecl pos
(genQualIdent qn)
= IDataDecl pos (genQualIdent qn)
(map genVarIndexIdent is)
(map (Just . genConstrDecl) cs)
genITypeDecl (EF.TypeSyn qn _ is t)
= ITypeDecl pos
(genQualIdent qn)
= ITypeDecl pos (genQualIdent qn)
(map genVarIndexIdent is)
(genTypeExpr t)
......
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