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

Different improvements

parent cc84f0ac
......@@ -39,22 +39,7 @@ Executable cymake
, mtl, old-time, containers, pretty
ghc-options: -Wall
Other-Modules:
Checks
, CompilerEnv
, CompilerOpts
, CurryBuilder
, CurryDeps
, Exports
, Frontend
, Generators
, IL
, Imports
, Interfaces
, Modules
, ModuleSummary
, Records
, Transformations
, Base.CurryTypes
Base.CurryTypes
, Base.Expr
, Base.Messages
, Base.NestEnv
......@@ -67,11 +52,16 @@ Executable cymake
, Base.TypeSubst
, Base.Typing
, Base.Utils
, Checks
, Checks.KindCheck
, Checks.PrecCheck
, Checks.SyntaxCheck
, Checks.TypeCheck
, Checks.WarnCheck
, CompilerEnv
, CompilerOpts
, CurryBuilder
, CurryDeps
, Env.Arity
, Env.Eval
, Env.Interface
......@@ -80,13 +70,23 @@ Executable cymake
, Env.OpPrec
, Env.TypeConstructors
, Env.Value
, Exports
, Frontend
, Generators
, Generators.GenAbstractCurry
, Generators.GenFlatCurry
, Html.CurryHtml
, Html.SyntaxColoring
, IL
, IL.Pretty
, IL.Type
, IL.XML
, Imports
, Interfaces
, Modules
, ModuleSummary
, Records
, Transformations
, Transformations.CaseCompletion
, Transformations.CurryToIL
, Transformations.Desugar
......
......@@ -41,8 +41,8 @@ imported.
> ) where
> import Control.Arrow (second)
> import qualified Data.Map as Map (Map, empty, insert, lookup, toList)
> import Data.Maybe (fromMaybe)
> import qualified Data.Map as Map
> (Map, empty, insert, findWithDefault, lookup, toList)
> import Curry.Base.Ident
> import Base.Messages (internalError)
......@@ -63,7 +63,7 @@ imported.
> fmap f (TopEnv env) = TopEnv (fmap (map (second f)) env)
> entities :: QualIdent -> Map.Map QualIdent [(Source, a)] -> [(Source, a)]
> entities x env = fromMaybe [] $ Map.lookup x env
> entities = Map.findWithDefault []
> emptyTopEnv :: TopEnv a
> emptyTopEnv = TopEnv Map.empty
......
......@@ -28,8 +28,8 @@ is defined more than once.
> import Control.Monad (forM, liftM, liftM2, liftM3, when)
> import qualified Control.Monad.State as S (State, runState, gets, modify)
> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Syntax
> import Base.Messages (Message, posErr, qposErr, internalError)
......
......@@ -22,8 +22,8 @@ of the operators involved.
> import qualified Control.Monad.State as S (State, runState, gets, modify)
> import Data.List (partition)
> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Syntax
> import Base.Expr
......
......@@ -28,12 +28,12 @@ merged into a single definition.
> import Data.Maybe (fromJust, isJust, isNothing, maybeToList)
> import qualified Data.Set as Set (empty, insert, member)
> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Syntax
> import Base.Expr
> import Base.Messages (Message, toMessage, errorMessages, internalError)
> import Base.Messages (Message, toMessage, internalError, posErr, qposErr)
> import Base.NestEnv
> import Base.Types
> import Base.Utils ((++!), findDouble, findMultiples)
......@@ -65,10 +65,7 @@ addition, this process will also rename the local variables.
> css -> (decls, map errMultipleDataConstructor css)
> where
> tds = filter isTypeDecl decls
> (rds, dds) = partition isRecordDecl tds
> rEnv = foldr (bindTypeDecl m)
> (globalEnv $ fmap (renameInfo tcEnv iEnv aEnv) tyEnv)
> (dds ++ rds)
> rEnv = globalEnv $ fmap (renameInfo tcEnv iEnv aEnv) tyEnv
> initState = SCState (optExtensions opts) m rEnv globalKey []
\end{verbatim}
......@@ -189,28 +186,36 @@ than once.
------------------------------------------------------------------------------
> -- Binding type constructor information
> bindTypeDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
> bindTypeDecl m (DataDecl _ _ _ cs) env = foldr (bindConstr m) env cs
> bindTypeDecl m (NewtypeDecl _ _ _ nc) env = bindNewConstr m nc env
> bindTypeDecl m (TypeDecl _ t _ (RecordType fs _)) env
> | any isConstr other = errorMessages [errIllegalRecordId t]
> | otherwise = foldr (bindRecordLabel m t allLabels) env allLabels
> where other = qualLookupVar (qualifyWith m t) env
> allLabels = concatMap fst fs
> bindTypeDecl _ _ env = env
> bindConstr :: ModuleIdent -> ConstrDecl -> RenameEnv -> RenameEnv
> bindConstr m (ConstrDecl _ _ c tys) = bindGlobal m c (Constr $ length tys)
> bindConstr m (ConOpDecl _ _ _ op _) = bindGlobal m op (Constr 2)
> bindNewConstr :: ModuleIdent -> NewConstrDecl -> RenameEnv -> RenameEnv
> bindNewConstr m (NewConstrDecl _ _ c _) = bindGlobal m c (Constr 1)
> bindRecordLabel :: ModuleIdent -> Ident -> [Ident] -> Ident -> RenameEnv
> -> RenameEnv
> bindRecordLabel m t allLabels l env = case lookupVar l env of
> [] -> bindGlobal m l (RecordLabel (qualifyWith m t) allLabels) env
> _ -> errorMessages [errDuplicateDefinition l]
> bindTypeDecl :: Decl -> SCM ()
> bindTypeDecl (DataDecl _ _ _ cs) = mapM_ bindConstr cs
> bindTypeDecl (NewtypeDecl _ _ _ nc) = bindNewConstr nc
> bindTypeDecl (TypeDecl _ t _ (RecordType fs _)) = do
> m <- getModuleIdent
> others <- qualLookupVar (qualifyWith m t) `liftM` getRenameEnv
> when (any isConstr others) $ report $ errIllegalRecordId t
> mapM_ (bindRecordLabel t allLabels) allLabels
> where allLabels = concatMap fst fs
> bindTypeDecl _ = return ()
> bindConstr :: ConstrDecl -> SCM ()
> bindConstr (ConstrDecl _ _ c tys) = do
> m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m c (Constr $ length tys)
> bindConstr (ConOpDecl _ _ _ op _) = do
> m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m op (Constr 2)
> bindNewConstr :: NewConstrDecl -> SCM ()
> bindNewConstr (NewConstrDecl _ _ c _) = do
> m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m c (Constr 1)
> bindRecordLabel :: Ident -> [Ident] -> Ident -> SCM ()
> bindRecordLabel t allLabels l = do
> m <- getModuleIdent
> new <- (null . lookupVar l) `liftM` getRenameEnv
> unless new $ report $ errDuplicateDefinition l
> modifyRenameEnv $ bindGlobal m l (RecordLabel (qualifyWith m t) allLabels)
------------------------------------------------------------------------------
......@@ -281,8 +286,11 @@ local declarations.
\begin{verbatim}
> checkModule :: [Decl] -> SCM [Decl]
> checkModule decls = liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
> checkModule decls = do
> mapM_ bindTypeDecl (rds ++ dds)
> liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
> where (tds, vds) = partition isTypeDecl decls
> (rds, dds) = partition isRecordDecl tds
> checkTypeDecl :: Decl -> SCM Decl
> checkTypeDecl rec@(TypeDecl _ r _ (RecordType fs rty)) = do
......@@ -1079,10 +1087,4 @@ Error messages.
> show q1 ++ " " ++ showLine (positionOfQualIdent q1)
> ++ "calls " ++ show q2 ++ " " ++ showLine (positionOfQualIdent q2)
> qposErr :: QualIdent -> String -> Message
> qposErr i = toMessage (positionOfQualIdent i)
> posErr :: Ident -> String -> Message
> posErr i = toMessage (positionOfIdent i)
\end{verbatim}
......@@ -31,8 +31,8 @@ type annotation is present.
> import qualified Data.Set as Set (Set, fromList, member, notMember, unions)
> import Text.PrettyPrint
> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Syntax
> import Curry.Syntax.Pretty
......
......@@ -18,7 +18,7 @@ module CompilerOpts
, DumpLevel (..), defaultOptions, compilerOpts, usage
) where
import Data.List (nub)
import Data.List (intercalate, nub)
import Data.Maybe (isJust)
import System.Console.GetOpt
import System.Environment (getArgs, getProgName)
......@@ -109,6 +109,9 @@ data Extension
| UnknownExtension String
deriving (Eq, Read, Show)
allExtensions :: [Extension]
allExtensions = [Records, FunctionalPatterns, AnonFreeVars, NoImplicitPrelude]
-- |'Extension's available by @-e@ flag
curryExtensions :: [Extension]
curryExtensions = [Records, FunctionalPatterns, AnonFreeVars]
......@@ -195,7 +198,7 @@ options =
, Option "X" []
(ReqArg (\ arg opts -> opts { optExtensions =
nub $ classifyExtension arg : optExtensions opts }) "EXT")
"enable language extension EXT"
("enable language extension EXT, one of " ++ show allExtensions)
-- dump
, Option "" ["dump-all"]
(NoArg (\ opts -> opts { optDumps = dumpAll }))
......@@ -235,9 +238,12 @@ parseOpts args = (foldl (flip ($)) defaultOptions opts, files, errs) where
checkOpts :: Options -> [String] -> [String]
checkOpts opts files
| isJust (optOutput opts) && length files > 1
= ["cannot specify -o with multiple targets"]
= ["cannot specify -o with multiple targets"]
| not $ null unknownExtensions
= ["Unknown language extension(s): " ++ intercalate ", " unknownExtensions]
| otherwise
= []
= []
where unknownExtensions = [ e | UnknownExtension e <- optExtensions opts ]
-- |Print the usage information of the command line tool.
usage :: String -> String
......
{- |In order to generate correct FlatCurry applications it is necessary
{- |
Module : $Header$
Description : Environment of function and constructor arities
Copyright : (c) 2005, Martin Engelke (men@informatik.uni-kiel.de)
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
In order to generate correct FlatCurry applications it is necessary
to define the number of arguments as the arity value (instead of
using the arity computed from the type). For this reason the compiler
needs a table containing the information for all known functions
and constructors.
September 2005, Martin Engelke (men@informatik.uni-kiel.de)
-}
module Env.Arity
......@@ -19,13 +28,13 @@ import Base.TopEnv
import Base.Types (DataConstr (..), predefTypes)
import Base.Utils ((++!))
type ArityEnv = TopEnv ArityInfo
data ArityInfo = ArityInfo QualIdent Int deriving Show
instance Entity ArityInfo where
origName (ArityInfo orgName _) = orgName
type ArityEnv = TopEnv ArityInfo
initAEnv :: ArityEnv
initAEnv = foldr bindPredefArity emptyTopEnv $ concatMap snd predefTypes
where bindPredefArity (DataConstr ident _ ts) =
......@@ -67,8 +76,7 @@ lookupTupleArity ident
constructor arities.
-}
bindArities :: ArityEnv -> Module -> ArityEnv
bindArities aEnv (Module mid _ _ decls)
= foldl (visitDecl mid) aEnv decls
bindArities aEnv (Module mid _ _ decls) = foldl (visitDecl mid) aEnv decls
visitDecl :: ModuleIdent -> ArityEnv -> Decl -> ArityEnv
visitDecl mid aEnv (DataDecl _ _ _ cdecls)
......
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