curry-frontend 0.2.2 → 0.2.3
raw patch · 43 files changed
+482/−2535 lines, 43 filesdep +curry-basedep +prettydep −directorydep −filepath
Dependencies added: curry-base, pretty
Dependencies removed: directory, filepath
Files
- curry-frontend.cabal +8/−15
- src/Base.lhs +40/−112
- src/Curry/AbstractCurry.hs +1/−1
- src/Curry/Base/Ident.lhs +0/−352
- src/Curry/Base/MessageMonad.hs +0/−83
- src/Curry/Base/Position.lhs +0/−96
- src/Curry/ExtendedFlat.hs +0/−475
- src/Curry/Syntax/LLParseComb.lhs +6/−8
- src/Curry/Syntax/Lexer.lhs +1/−1
- src/Curry/Syntax/Pretty.lhs +2/−1
- src/Curry/Syntax/Utils.hs +56/−1
- src/CurryBuilder.hs +11/−5
- src/CurryCompilerOpts.hs +1/−7
- src/CurryDeps.lhs +4/−2
- src/CurryEnv.hs +10/−1
- src/CurryHtml.hs +2/−1
- src/Desugar.lhs +2/−2
- src/Exports.lhs +7/−7
- src/Filenames.hs +0/−72
- src/Frontend.hs +12/−7
- src/GenAbstractCurry.hs +1/−0
- src/GenFlatCurry.hs +209/−157
- src/IL/CurryToIL.lhs +5/−5
- src/IL/Pretty.lhs +2/−2
- src/IL/Type.lhs +4/−1
- src/IL/XML.lhs +1/−1
- src/InterfaceCheck.hs +1/−1
- src/KindCheck.lhs +4/−3
- src/Modules.lhs +44/−40
- src/PatchPrelude.hs +1/−1
- src/PathUtils.hs +0/−122
- src/PrecCheck.lhs +3/−3
- src/PrettyCombinators.lhs +0/−905
- src/ScopeEnv.hs +7/−8
- src/Simplify.lhs +1/−1
- src/Subst.lhs +0/−3
- src/SyntaxCheck.lhs +19/−19
- src/SyntaxColoring.hs +1/−1
- src/TopEnv.lhs +5/−3
- src/TypeCheck.lhs +5/−5
- src/Typing.lhs +2/−1
- src/Utils.lhs +0/−3
- src/cymake.hs +4/−1
curry-frontend.cabal view
@@ -1,5 +1,5 @@ Name: curry-frontend-Version: 0.2.2+Version: 0.2.3 Cabal-Version: >= 1.6 Synopsis: Compile the functional logic language Curry to several intermediate formats Description: The Curry Frontend consists of the executable program "cymake".@@ -25,36 +25,29 @@ Executable cymake hs-source-dirs: src Main-is: cymake.hs- Build-Depends: base >= 3 && < 4, mtl, old-time, directory, filepath, containers- ghc-options: -fwarn-unused-binds -fwarn-unused-imports--- -fwarn-incomplete-patterns- Other-Modules: Curry.Base.Position, Curry.Base.Ident, Curry.Base.MessageMonad- Curry.Syntax.Lexer, Curry.Syntax.LexComb+ Build-Depends: base >= 3 && < 4, curry-base == 0.2.2, mtl, old-time, containers, pretty+ ghc-options: -fwarn-unused-binds -fwarn-unused-imports -auto-all + Other-Modules: Curry.Syntax.Lexer, Curry.Syntax.LexComb Curry.Syntax.Parser, Curry.Syntax.LLParseComb Curry.Syntax.ShowModule, Curry.Syntax.Pretty Curry.Syntax, Curry.Syntax.Type Curry.Syntax.Unlit, Curry.Syntax.Utils- Curry.AbstractCurry, Curry.ExtendedFlat+ Curry.AbstractCurry, CurryBuilder, IL.Type CurryCompilerOpts, Modules, Subst, Arity CurryDeps, Eval, IL.Pretty, NestEnv, SyntaxCheck, Base Exports, IL.Scope, SyntaxColoring, CurryEnv IL.CurryToIL, OldScopeEnv, CurryHtml IL.XML, PatchPrelude, TopEnv, CaseCompletion- Imports, PathUtils, Filenames,+ Imports, TypeCheck, InterfaceCheck, Types, Frontend, PrecCheck TypeSubst, GenAbstractCurry- PrettyCombinators, Typing+ Typing GenFlatCurry, KindCheck, Qual SCC, Utils, GetOpt Lift, ScopeEnv, WarnCheck- Desugar, Curry.Base.Ident, + Desugar, Simplify---- Executable pretty-ecy--- hs-source-dirs: src--- Main-is: pretty-ecy.hs--- Build-Depends: base >= 3 && < 4
src/Base.lhs view
@@ -25,7 +25,7 @@ > import Curry.Base.Ident > import Curry.Base.Position > import Types-> import Curry.Syntax+> import qualified Curry.Syntax as CS > import Curry.Syntax.Utils > import TopEnv > import Utils@@ -47,33 +47,33 @@ order of type variables in the left hand side of a type declaration. \begin{verbatim} -> toQualType :: ModuleIdent -> [Ident] -> TypeExpr -> Type+> toQualType :: ModuleIdent -> [Ident] -> CS.TypeExpr -> Type > toQualType m tvs = qualifyType m . toType tvs -> toQualTypes :: ModuleIdent -> [Ident] -> [TypeExpr] -> [Type]+> toQualTypes :: ModuleIdent -> [Ident] -> [CS.TypeExpr] -> [Type] > toQualTypes m tvs = map (qualifyType m) . toTypes tvs -> toType :: [Ident] -> TypeExpr -> Type+> toType :: [Ident] -> CS.TypeExpr -> Type > toType tvs ty = toType' (Map.fromList (zip (tvs ++ tvs') [0..])) ty > where tvs' = [tv | tv <- nub (fv ty), tv `notElem` tvs] -> toTypes :: [Ident] -> [TypeExpr] -> [Type]+> toTypes :: [Ident] -> [CS.TypeExpr] -> [Type] > toTypes tvs tys = map (toType' (Map.fromList (zip (tvs ++ tvs') [0..]))) tys > where tvs' = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs] -> toType' :: Map.Map Ident Int -> TypeExpr -> Type-> toType' tvs (ConstructorType tc tys) =+> toType' :: Map.Map Ident Int -> CS.TypeExpr -> Type+> toType' tvs (CS.ConstructorType tc tys) = > TypeConstructor tc (map (toType' tvs) tys)-> toType' tvs (VariableType tv) =+> toType' tvs (CS.VariableType tv) = > maybe (internalError ("toType " ++ show tv)) TypeVariable (Map.lookup tv tvs)-> toType' tvs (TupleType tys)+> toType' tvs (CS.TupleType tys) > | null tys = TypeConstructor (qualify unitId) [] > | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys' > where tys' = map (toType' tvs) tys-> toType' tvs (ListType ty) = TypeConstructor (qualify listId) [toType' tvs ty]-> toType' tvs (ArrowType ty1 ty2) =+> toType' tvs (CS.ListType ty) = TypeConstructor (qualify listId) [toType' tvs ty]+> toType' tvs (CS.ArrowType ty1 ty2) = > TypeArrow (toType' tvs ty1) (toType' tvs ty2)-> toType' tvs (RecordType fs rty) =+> toType' tvs (CS.RecordType fs rty) = > TypeRecord (concatMap (\ (ls,ty) -> map (\l -> (l, toType' tvs ty)) ls) fs) > (maybe Nothing > (\ty -> case toType' tvs ty of@@ -81,25 +81,25 @@ > _ -> internalError ("toType " ++ show ty)) > rty) -> fromQualType :: ModuleIdent -> Type -> TypeExpr+> fromQualType :: ModuleIdent -> Type -> CS.TypeExpr > fromQualType m = fromType . unqualifyType m -> fromType :: Type -> TypeExpr+> fromType :: Type -> CS.TypeExpr > fromType (TypeConstructor tc tys)-> | isTupleId c = TupleType tys'-> | c == listId && length tys == 1 = ListType (head tys')-> | c == unitId && null tys = TupleType []-> | otherwise = ConstructorType tc tys'+> | isTupleId c = CS.TupleType tys'+> | c == listId && length tys == 1 = CS.ListType (head tys')+> | c == unitId && null tys = CS.TupleType []+> | otherwise = CS.ConstructorType tc tys' > where c = unqualify tc > tys' = map fromType tys > fromType (TypeVariable tv) =-> VariableType (if tv >= 0 then nameSupply !! tv+> CS.VariableType (if tv >= 0 then nameSupply !! tv > else mkIdent ('_' : show (-tv))) > fromType (TypeConstrained tys _) = fromType (head tys)-> fromType (TypeArrow ty1 ty2) = ArrowType (fromType ty1) (fromType ty2)-> fromType (TypeSkolem k) = VariableType (mkIdent ("_?" ++ show k))+> fromType (TypeArrow ty1 ty2) = CS.ArrowType (fromType ty1) (fromType ty2)+> fromType (TypeSkolem k) = CS.VariableType (mkIdent ("_?" ++ show k)) > fromType (TypeRecord fs rty) = -> RecordType (map (\ (l,ty) -> ([l], fromType ty)) fs)+> CS.RecordType (map (\ (l,ty) -> ([l], fromType ty)) fs) > (maybe Nothing (Just . fromType . TypeVariable) rty) @@ -109,44 +109,19 @@ The compiler maintains a global environment holding all (directly or indirectly) imported interfaces. -The function \texttt{bindFlatInterfac} transforms FlatInterface+The function \texttt{bindFlatInterface} transforms FlatInterface information (type \texttt{FlatCurry.Prog} to MCC interface declarations (type \texttt{CurrySyntax.IDecl}. This is necessary to process FlatInterfaces instead of ".icurry" files when using MCC as frontend for PAKCS. \begin{verbatim} -> type ModuleEnv = Map.Map ModuleIdent [IDecl]+> type ModuleEnv = Map.Map ModuleIdent [CS.IDecl] -> lookupModule :: ModuleIdent -> ModuleEnv -> Maybe [IDecl]+> lookupModule :: ModuleIdent -> ModuleEnv -> Maybe [CS.IDecl] > lookupModule = Map.lookup -\end{verbatim}-The label environment is used to store information of labels.-Unlike unsual identifiers like in functions, types etc. identifiers-of labels are always represented unqualified. Since the common type -environment (type \texttt{ValueEnv}) has some problems with handling -imported unqualified identifiers, it is necessary to process the type -information for labels seperately.-\begin{verbatim} -> data LabelInfo = LabelType Ident QualIdent Type deriving Show--> type LabelEnv = Map.Map Ident [LabelInfo]--> bindLabelType :: Ident -> QualIdent -> Type -> LabelEnv -> LabelEnv-> bindLabelType l r ty lEnv =-> maybe (Map.insert l [LabelType l r ty] lEnv)-> (\ls -> Map.insert l (LabelType l r ty:ls) lEnv)-> (Map.lookup l lEnv)--> lookupLabelType :: Ident -> LabelEnv -> [LabelInfo]-> lookupLabelType = Map.findWithDefault []--> initLabelEnv :: LabelEnv-> initLabelEnv = Map.empty-- \end{verbatim} \paragraph{Type constructors} For all defined types the compiler must maintain kind information. At@@ -404,8 +379,8 @@ > type ImportEnv = Map.Map ModuleIdent ModuleIdent -> bindAlias :: Decl -> ImportEnv -> ImportEnv-> bindAlias (ImportDecl _ mid _ mmid _)+> bindAlias :: CS.Decl -> ImportEnv -> ImportEnv+> bindAlias (CS.ImportDecl _ mid _ mmid _) > = Map.insert mid (fromMaybe mid mmid) > lookupAlias :: ModuleIdent -> ImportEnv -> Maybe ModuleIdent@@ -432,16 +407,16 @@ introduction of unlimited integer constants in the parser / lexer. \begin{verbatim} -> data OpPrec = OpPrec Infix Integer deriving Eq+> data OpPrec = OpPrec CS.Infix Integer deriving Eq > 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 CS.InfixL = "left "+> assoc CS.InfixR = "right "+> assoc CS.Infix = "non-assoc " > defaultP :: OpPrec-> defaultP = OpPrec InfixL 9+> defaultP = OpPrec CS.InfixL 9 \end{verbatim} The lookup functions for the environment which maintains the operator@@ -478,7 +453,7 @@ sufficient. \begin{verbatim} -> type EvalEnv = Map.Map Ident EvalAnnotation+> type EvalEnv = Map.Map Ident CS.EvalAnnotation \end{verbatim}@@ -501,7 +476,7 @@ > initPEnv :: PEnv > initPEnv =-> predefTopEnv qConsId (PrecInfo qConsId (OpPrec InfixR 5)) emptyTopEnv+> predefTopEnv qConsId (PrecInfo qConsId (OpPrec CS.InfixR 5)) emptyTopEnv > initTCEnv :: TCEnv > initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes@@ -564,66 +539,19 @@ \ToDo{The \texttt{nameSupply} should respect the current case mode, i.e., use upper case for variables in Prolog mode.} -Here is a list of predicates identifying various kinds of-declarations.-\begin{verbatim}--> isImportDecl, isInfixDecl, isTypeDecl :: Decl -> Bool-> isTypeSig, isEvalAnnot, isExtraVariables, isValueDecl :: Decl -> Bool-> isImportDecl (ImportDecl _ _ _ _ _) = True-> isImportDecl _ = False-> isInfixDecl (InfixDecl _ _ _ _) = True-> isInfixDecl _ = False-> isTypeDecl (DataDecl _ _ _ _) = True-> isTypeDecl (NewtypeDecl _ _ _ _) = True-> isTypeDecl (TypeDecl _ _ _ _) = True-> isTypeDecl _ = False-> isTypeSig (TypeSig _ _ _) = True-> isTypeSig (ExternalDecl _ _ _ _ _) = True-> isTypeSig _ = False-> isEvalAnnot (EvalAnnot _ _ _) = True-> isEvalAnnot _ = False-> isExtraVariables (ExtraVariables _ _) = True-> isExtraVariables _ = False-> isValueDecl (FunctionDecl _ _ _) = True-> isValueDecl (ExternalDecl _ _ _ _ _) = True-> isValueDecl (FlatExternalDecl _ _) = True-> isValueDecl (PatternDecl _ _ _) = True-> isValueDecl (ExtraVariables _ _) = True-> isValueDecl _ = False-> isRecordDecl (TypeDecl _ _ _ (RecordType _ _)) = True-> isRecordDecl _ = False--> isIImportDecl :: IDecl -> Bool-> isIImportDecl (IImportDecl _ _) = True-> isIImportDecl _ = False- \end{verbatim}-The function \texttt{infixOp} converts an infix operator into an-expression.-\begin{verbatim}--> infixOp :: InfixOp -> Expression-> infixOp (InfixOp op) = Variable op-> infixOp (InfixConstr op) = Constructor op--\end{verbatim}-The function \texttt{linear} checks whether a list of entities is+The function \texttt{findDouble} checks whether a list of entities is linear, i.e., if every entity in the list occurs only once. If it is non-linear, the first offending object is returned. \begin{verbatim} -> data Linear a = Linear | NonLinear a--> linear :: Eq a => [a] -> Linear a-> linear (x:xs)-> | x `elem` xs = NonLinear x-> | otherwise = linear xs-> linear [] = Linear+> findDouble :: Eq a => [a] -> Maybe a+> findDouble (x:xs)+> | x `elem` xs = Just x+> | otherwise = findDouble xs+> findDouble [] = Nothing \end{verbatim}--
src/Curry/AbstractCurry.hs view
@@ -30,7 +30,7 @@ import Data.List(intersperse) -import PathUtils (writeModule,readModule)+import Curry.Files.PathUtils (writeModule,readModule) ------------------------------------------------------------------------------
− src/Curry/Base/Ident.lhs
@@ -1,352 +0,0 @@-> {-# LANGUAGE DeriveDataTypeable #-}--% $Id: Ident.lhs,v 1.21 2004/10/29 13:08:09 wlux Exp $-%-% Copyright (c) 1999-2004, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Ident.lhs}-\section{Identifiers}-This module provides the implementation of identifiers and some-utility functions for identifiers, which are used at various places in-the compiler.--Identifiers comprise the name of the denoted entity and an \emph{id},-which can be used for renaming identifiers, e.g., in order to resolve-name conflicts between identifiers from different scopes. An-identifier with an \emph{id} $0$ is considered as not being renamed-and, hence, its \emph{id} will not be shown.--\ToDo{Probably we should use \texttt{Integer} for the \emph{id}s.}--Qualified identifiers may optionally be prefixed by a module-name. \textbf{The order of the cases \texttt{UnqualIdent} and-\texttt{QualIdent} is important. Some parts of the compiler rely on-the fact that all qualified identifiers are greater than any-unqualified identifier.}-\begin{verbatim}--> module Curry.Base.Ident(Ident(..), showIdent,-> QualIdent(..),ModuleIdent(..),SrcRefOf(..),-> mkIdent, qualName,-> renameIdent, unRenameIdent,-> mkMIdent, moduleName,-> isInfixOp, isQInfixOp,-> qualify, qualifyWith, qualQualify,-> isQualified, unqualify, qualUnqualify,-> localIdent, -- splitQualIdent,-> emptyMIdent, mainMIdent,preludeMIdent,-> anonId,unitId,boolId,charId,intId,floatId,listId,ioId,-> successId,trueId,falseId,nilId,consId,mainId,-> tupleId,isTupleId,tupleArity,-> minusId,fminusId,updIdentName,-> qUnitId,qBoolId,qCharId,qIntId,qFloatId,qListId,qIOId,-> qSuccessId,qTrueId,qFalseId,qNilId,qConsId,-> qTupleId,isQTupleId,qTupleArity,-> fpSelectorId,isFpSelectorId,isQualFpSelectorId,-> recSelectorId,qualRecSelectorId,-> recUpdateId, qualRecUpdateId, recordExtId, labelExtId,-> isRecordExtId, isLabelExtId, fromRecordExtId, fromLabelExtId,-> renameLabel,-> recordExt, labelExt, mkLabelIdent,-- hasPositionIdent,-> addPositionIdent, -> addPositionModuleIdent,addRef,addRefId,-> positionOfQualIdent,updQualIdent ) where--> import Control.Monad(liftM)-> import Data.Char-> import Data.List-> import Data.Maybe-> import Data.Generics-> import Data.Function(on)--> import Curry.Base.Position---Simple identifiers--> data Ident = Ident { positionOfIdent :: Position,-> name :: String,-> uniqueId :: Int }-> deriving (Read, Data, Typeable)->-> instance Eq Ident where-> Ident _ m i == Ident _ n j = (m,i) == (n, j)->-> instance Ord Ident where-> Ident _ m i `compare` Ident _ n j = (m,i) `compare` (n, j)->-> instance Show Ident where-> show = showIdent->-> showIdent :: Ident -> String-> showIdent (Ident _ x 0) = x-> showIdent (Ident _ x n) = x ++ '.' : show n---Qualified identifiers--> data QualIdent = QualIdent { qualidMod :: Maybe ModuleIdent,-> qualidId:: Ident }-> deriving (Eq, Ord, Read, Data,Typeable)--> qualName :: QualIdent -> String-> qualName (QualIdent Nothing x) = name x-> qualName (QualIdent (Just m) x) = moduleName m ++ "." ++ name x--> instance Show QualIdent where-> show = qualName--Module names--> data ModuleIdent = ModuleIdent { positionOfModuleIdent :: Position,-> moduleQualifiers :: [String] }-> deriving (Read, Data,Typeable)--> instance Eq ModuleIdent where-> (==) = (==) `on` moduleQualifiers--> instance Ord ModuleIdent where-> compare = compare `on` moduleQualifiers--> moduleName :: ModuleIdent -> String-> moduleName = concat . intersperse "." . moduleQualifiers--> instance Show ModuleIdent where-> show = moduleName---- -------------------------------------------> addPositionIdent :: Position -> Ident -> Ident-> addPositionIdent pos (Ident NoPos x n) = Ident pos x n-> addPositionIdent AST{ast=sr} (Ident pos x n)-> = Ident pos{ast=sr} x n-> addPositionIdent pos (Ident _ x n) = Ident pos x n--> addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent-> addPositionModuleIdent pos (ModuleIdent _ x) = ModuleIdent pos x --> positionOfQualIdent :: QualIdent -> Position-> positionOfQualIdent = positionOfIdent . qualidId--> mkIdent :: String -> Ident-> mkIdent x = Ident NoPos x 0--> renameIdent :: Ident -> Int -> Ident-> renameIdent (Ident p x _) n = Ident p x n---> unRenameIdent :: Ident -> Ident-> unRenameIdent (Ident p x _) = Ident p x 0--> mkMIdent :: [String] -> ModuleIdent-> mkMIdent = ModuleIdent NoPos--> isInfixOp :: Ident -> Bool-> isInfixOp (Ident _ ('<':c:cs) _)=-> last (c:cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["-> isInfixOp (Ident _ (c:_) _) = not (isAlphaNum c) && c `notElem` "_(["-> isInfixOp (Ident _ _ _) = False -- error "Zero-length identifier"--> isQInfixOp :: QualIdent -> Bool-> isQInfixOp (QualIdent _ x) = isInfixOp x--\end{verbatim}-The functions \texttt{qualify} and \texttt{qualifyWith} convert an-unqualified identifier into a qualified identifier (without and with a-given module prefix, respectively).-\begin{verbatim}--> qualify :: Ident -> QualIdent-> qualify = QualIdent Nothing--> qualifyWith :: ModuleIdent -> Ident -> QualIdent-> qualifyWith = QualIdent . Just--> qualQualify :: ModuleIdent -> QualIdent -> QualIdent-> qualQualify m (QualIdent Nothing x) = QualIdent (Just m) x-> qualQualify _ x = x--> isQualified :: QualIdent -> Bool-> isQualified (QualIdent m _) = isJust m--> unqualify :: QualIdent -> Ident-> unqualify (QualIdent _ x) = x--> qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent-> qualUnqualify m qid@(QualIdent Nothing x) = qid-> qualUnqualify m (QualIdent (Just m') x) = QualIdent m'' x-> where m'' | m == m' = Nothing-> | otherwise = Just m'--> localIdent :: ModuleIdent -> QualIdent -> Maybe Ident-> localIdent _ (QualIdent Nothing x) = Just x-> localIdent m (QualIdent (Just m') x)-> | m == m' = Just x-> | otherwise = Nothing--> splitQualIdent :: QualIdent -> (Maybe ModuleIdent,Ident)-> splitQualIdent (QualIdent m x) = (m,x)--> updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident) -> QualIdent -> QualIdent-> updQualIdent f g (QualIdent m x) = QualIdent (liftM f m) (g x)--> addRef :: SrcRef -> QualIdent -> QualIdent-> addRef r = updQualIdent id (addRefId r)--> addRefId :: SrcRef -> Ident -> Ident-> addRefId = addPositionIdent . AST--\end{verbatim}-A few identifiers a predefined here.-\begin{verbatim}--> emptyMIdent, mainMIdent, preludeMIdent :: ModuleIdent-> emptyMIdent = ModuleIdent NoPos []-> mainMIdent = ModuleIdent NoPos ["main"]-> preludeMIdent = ModuleIdent NoPos ["Prelude"]--> anonId :: Ident-> anonId = Ident NoPos "_" 0--> unitId, boolId, charId, intId, floatId, listId, ioId, successId :: Ident-> unitId = Ident NoPos "()" 0-> boolId = Ident NoPos "Bool" 0-> charId = Ident NoPos "Char" 0-> intId = Ident NoPos "Int" 0-> floatId = Ident NoPos "Float" 0-> listId = Ident NoPos "[]" 0-> ioId = Ident NoPos "IO" 0-> successId = Ident NoPos "Success" 0--> trueId, falseId, nilId, consId :: Ident-> trueId = Ident NoPos "True" 0-> falseId = Ident NoPos "False" 0-> nilId = Ident NoPos "[]" 0-> consId = Ident NoPos ":" 0--> tupleId :: Int -> Ident-> tupleId n-> | n >= 2 = Ident NoPos ("(" ++ replicate (n - 1) ',' ++ ")") 0-> | otherwise = error "internal error: tupleId"--> isTupleId :: Ident -> Bool-> isTupleId x = n > 1 && x == tupleId n-> where n = length (name x) - 1--> tupleArity :: Ident -> Int-> tupleArity x-> | n > 1 && x == tupleId n = n-> | otherwise = error "internal error: tupleArity"-> where n = length (name x) - 1--> mainId, minusId, fminusId :: Ident-> mainId = Ident NoPos "main" 0-> minusId = Ident NoPos "-" 0-> fminusId = Ident NoPos "-." 0--> qUnitId, qNilId, qConsId, qListId :: QualIdent-> qUnitId = QualIdent Nothing unitId-> qListId = QualIdent Nothing listId-> qNilId = QualIdent Nothing nilId-> qConsId = QualIdent Nothing consId--> qBoolId, qCharId, qIntId, qFloatId, qSuccessId, qIOId :: QualIdent-> qBoolId = QualIdent (Just preludeMIdent) boolId-> qCharId = QualIdent (Just preludeMIdent) charId-> qIntId = QualIdent (Just preludeMIdent) intId-> qFloatId = QualIdent (Just preludeMIdent) floatId-> qSuccessId = QualIdent (Just preludeMIdent) successId-> qIOId = QualIdent (Just preludeMIdent) ioId--> qTrueId, qFalseId :: QualIdent-> qTrueId = QualIdent (Just preludeMIdent) trueId-> qFalseId = QualIdent (Just preludeMIdent) falseId--> qTupleId :: Int -> QualIdent-> qTupleId = QualIdent Nothing . tupleId--> isQTupleId :: QualIdent -> Bool-> isQTupleId = isTupleId . unqualify--> qTupleArity :: QualIdent -> Int-> qTupleArity = tupleArity . unqualify--\end{verbatim}-Micellaneous function for generating and testing extended identifiers.-\begin{verbatim}--> fpSelectorId :: Int -> Ident-> fpSelectorId n = Ident NoPos (fpSelExt ++ show n) 0--> isFpSelectorId :: Ident -> Bool-> isFpSelectorId f = any (fpSelExt `isPrefixOf`) (tails (name f))--> isQualFpSelectorId :: QualIdent -> Bool-> isQualFpSelectorId = isFpSelectorId . unqualify--> recSelectorId :: QualIdent -> Ident -> Ident-> recSelectorId r l =-> mkIdent (recSelExt ++ name (unqualify r) ++ "." ++ name l)--> qualRecSelectorId :: ModuleIdent -> QualIdent -> Ident -> QualIdent-> qualRecSelectorId m r l = qualifyWith m' (recSelectorId r l)-> where m' = (fromMaybe m (fst (splitQualIdent r)))--> recUpdateId :: QualIdent -> Ident -> Ident-> recUpdateId r l = -> mkIdent (recUpdExt ++ name (unqualify r) ++ "." ++ name l)--> qualRecUpdateId :: ModuleIdent -> QualIdent -> Ident -> QualIdent-> qualRecUpdateId m r l = qualifyWith m' (recUpdateId r l)-> where m' = (fromMaybe m (fst (splitQualIdent r)))--> recordExtId :: Ident -> Ident-> recordExtId r = mkIdent (recordExt ++ name r)--> labelExtId :: Ident -> Ident-> labelExtId l = mkIdent (labelExt ++ name l)--> fromRecordExtId :: Ident -> Ident-> fromRecordExtId r -> | p == recordExt = mkIdent r'-> | otherwise = r-> where (p,r') = splitAt (length recordExt) (name r)--> fromLabelExtId :: Ident -> Ident-> fromLabelExtId l -> | p == labelExt = mkIdent l'-> | otherwise = l-> where (p,l') = splitAt (length labelExt) (name l)--> isRecordExtId :: Ident -> Bool-> isRecordExtId r = recordExt `isPrefixOf` name r--> isLabelExtId :: Ident -> Bool-> isLabelExtId l = labelExt `isPrefixOf` name l--> mkLabelIdent :: String -> Ident-> mkLabelIdent c = renameIdent (mkIdent c) (-1)--> renameLabel :: Ident -> Ident-> renameLabel l = renameIdent l (-1)---> fpSelExt = "_#selFP"-> recSelExt = "_#selR@"-> recUpdExt = "_#updR@"-> recordExt = "_#Rec:"-> labelExt = "_#Lab:"---> instance SrcRefOf Ident where-> srcRefOf = srcRefOf . positionOfIdent--> instance SrcRefOf QualIdent where-> srcRefOf = srcRefOf . unqualify--> updIdentName :: (String -> String) -> Ident -> Ident-> updIdentName f ident = let p=positionOfIdent ident-> i=uniqueId ident-> n=name ident in-> addPositionIdent p $ flip renameIdent i $ mkIdent (f n)
− src/Curry/Base/MessageMonad.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-- The \texttt{MsgMonad} type is used for describing the result of a- computation that can fail. In contrast to the standard \texttt{Maybe}- type, its \texttt{Error} case provides for an error message that- describes the failure.--}--module Curry.Base.MessageMonad where--import Control.Monad.Error-import Control.Monad.Writer-import Control.Monad.Identity--import Curry.Base.Position---type MsgMonadT m = ErrorT WarnMsg (WriterT [WarnMsg] m)--type MsgMonad = MsgMonadT Identity--type MsgMonadIO = MsgMonadT IO--data WarnMsg = WarnMsg { warnPos :: Maybe Position,- warnTxt :: String- }-instance Error WarnMsg where- noMsg = WarnMsg Nothing "Failure!"- strMsg = WarnMsg Nothing--instance Show WarnMsg where- show = showWarning---- tell w = Control.Monad.Writer.tell w--showWarning w = "Warning: " ++ pos ++ warnTxt w- where pos = case warnPos w of- Nothing -> ""- Just p -> show p ++": "--showError w = "Error: " ++ pos ++ warnTxt w- where pos = case warnPos w of- Nothing -> ""- Just p -> show p ++": "--ok :: MsgMonad a -> a-ok = either (error . showError) id . fst . runMsg---failWith :: (MonadError a m, Error a) => String -> m a1-failWith = throwError . strMsg---failWithAt :: (MonadError WarnMsg m) => Position -> String -> m a-failWithAt p s = throwError (WarnMsg (Just p) s)---warnMessage :: (MonadWriter [WarnMsg] m) => String -> m ()-warnMessage s = tell [WarnMsg Nothing s]---warnMessageAt :: (MonadWriter [WarnMsg] m) => Position -> String -> m ()-warnMessageAt p s = tell [WarnMsg (Just p) s]--runMsg :: MsgMonad a -> (Either WarnMsg a, [WarnMsg])-runMsg = runIdentity . runWriterT . runErrorT---- returnIO :: MsgMonad a -> MsgMonadIO a--- returnIO x = return$ (runIdentity . runWriterT . runErrorT) x--runMsgIO :: MsgMonad a -> (a -> IO (MsgMonad b)) -> IO (MsgMonad b)-runMsgIO m f- = case runMsg m of- (Left e, msgs) -> return (tell msgs >> throwError e)- (Right x, msgs) -> do m' <- f x- case runMsg m' of- (Left _,_) -> return m'- (Right x', msgs') -> return (tell (msgs ++ msgs') >> return x')--dropIO :: MsgMonad a -> MsgMonadIO a-dropIO x = case runMsg x of- (Left e, m) -> tell m >> throwError e- (Right x, m) -> tell m >> return x
− src/Curry/Base/Position.lhs
@@ -1,96 +0,0 @@-> {-# LANGUAGE DeriveDataTypeable #-}--% -*- LaTeX -*--% $Id: Position.lhs,v 1.2 2000/10/08 09:55:43 lux Exp $-%-% $Log: Position.lhs,v $-% Revision 1.2 2000/10/08 09:55:43 lux-% Column numbers now start at 1. If the column number is less than 1 it-% will not be shown.-%-% Revision 1.1 2000/07/23 11:03:37 lux-% Positions now implemented in a separate module.-%-%-\nwfilename{Position.lhs}-\section{Positions}-A source file position consists of a filename, a line number, and a-column number. A tab stop is assumed at every eighth column.-\begin{verbatim}--> module Curry.Base.Position where-> import Data.Generics--> newtype SrcRef = SrcRef [Int] deriving (Typeable,Data) -- a pointer to the origin---- the instances for standard classes or such that SrcRefs are invisible--> instance Show SrcRef where show _ = ""-> instance Read SrcRef where readsPrec _ s = [(noRef,s)]-> instance Eq SrcRef where _ == _ = True-> instance Ord SrcRef where compare _ _ = EQ--> noRef :: SrcRef-> noRef = SrcRef []->-> incSrcRef :: SrcRef -> Int -> SrcRef-> incSrcRef (SrcRef [i]) j = SrcRef [i+j]-> incSrcRef is _ = error $ "internal error; increment source ref: " ++ show is--> data Position -> = Position{ file :: FilePath, line :: Int, column :: Int, ast :: SrcRef }-> | AST { ast :: SrcRef }-> | NoPos-> deriving (Eq, Ord,Data,Typeable)--> incPosition :: Position -> Int -> Position-> incPosition p j = p{ast=incSrcRef (ast p) j}--> instance Read Position where-> readsPrec p s = -> [ (Position{file="",line=i,column=j,ast=noRef},s') | ((i,j),s') <- readsPrec p s]--> instance Show Position where-> showsPrec _ Position{file=fn,line=l,column=c} =-> (if null fn then id else shows fn . showString ", ") .-> showString "line " . shows l .-> (if c > 0 then showChar '.' . shows c else id)-> showsPrec _ AST{} = id-> showsPrec _ NoPos = id--> tabWidth :: Int-> tabWidth = 8--> first :: FilePath -> Position-> first fn = Position fn 1 1 noRef--> incr :: Position -> Int -> Position-> incr p@Position{column=c} n = p{column=c + n}-> incr p _ = p--> next :: Position -> Position-> next = flip incr 1--> tab :: Position -> Position-> tab p@Position{column=c} = p{column=c + tabWidth - (c - 1) `mod` tabWidth}-> tab p = p--> nl :: Position -> Position-> nl p@Position{line=l} = p{line=l + 1, column=1}-> nl p = p--> showLine :: Position -> String-> showLine NoPos = ""-> showLine AST{} = ""-> showLine Position{line=l,column=c} -> = "(line " ++ show l ++ "." ++ show c ++ ") "--\end{verbatim}--> class SrcRefOf a where-> srcRefsOf :: a -> [SrcRef]-> srcRefsOf = (:[]) . srcRefOf-> srcRefOf :: a -> SrcRef-> srcRefOf = head . srcRefsOf--> instance SrcRefOf Position where srcRefOf = ast
− src/Curry/ExtendedFlat.hs
@@ -1,475 +0,0 @@----------------------------------------------------------------------------------- Library to support meta-programming in Curry.-------- This library contains a definition for representing FlatCurry programs---- in Haskell (type "Prog").-------- @author Michael Hanus---- @version September 2003-------- Version for Haskell (slightly modified):---- December 2004, Martin Engelke (men@informatik.uni-kiel.de)-------- Added part calls for constructors, Bernd Brassel, August 2005---- Added source references, Bernd Brassel, May 2009---------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}--module Curry.ExtendedFlat (SrcRef,Prog(..),- QName(..), qnOf,mkQName,- Visibility(..),- TVarIndex, TypeDecl(..), ConsDecl(..), TypeExpr(..),- OpDecl(..), Fixity(..),- VarIndex(..), mkIdx,- FuncDecl(..), Rule(..), - CaseType(..), CombType(..), Expr(..), BranchExpr(..),- Pattern(..), Literal(..), - readFlatCurry, readFlatInterface, readFlat, - writeFlatCurry,writeExtendedFlat,gshowsPrec- ) where--import Data.List(intersperse)-import Control.Monad (liftM)-import Data.Generics hiding (Fixity)-import Data.Function(on)-import System.FilePath--import PathUtils (writeModule, maybeReadModule)-import Filenames(flatName)-import Curry.Base.Position (SrcRef)----------------------------------------------------------------------------------- Definition of data types for representing FlatCurry programs:--- =============================================================----- Data type for representing a Curry module in the intermediate form.---- A value of this data type has the form---- <CODE>---- (Prog modname imports typedecls functions opdecls translation_table)---- </CODE>---- where modname: name of this module,---- imports: list of modules names that are imported,---- typedecls, opdecls, functions, translation of type names---- and constructor/function names: see below--data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] - deriving (Read, Show, Eq,Data,Typeable)-------------------------------------------------------------------------------- The data type for representing qualified names.---- In FlatCurry all names are qualified to avoid name clashes.---- The first component is the module name and the second component the---- unqualified name as it occurs in the source program.---- The additional information about source references and types should---- be invisible for the normal usage of QName.----------------------------------------------------------------------------data QName = QName {srcRef :: Maybe SrcRef,- typeofQName :: Maybe TypeExpr,- modName :: String,- localName :: String} deriving (Data,Typeable)---instance Read QName where- readsPrec d r = - [ (mkQName nm,s) | (nm,s) <- readsPrec d r ]- ++ [ (QName r t m n, s) | ((r, t, m, n),s) <- readsPrec d r ]--instance Show QName where- showsPrec d (QName r t m n)- = showsPrec d (r,t,m,n)--instance Eq QName where (==) = (==) `on` qnOf--instance Ord QName where compare = compare `on` qnOf--mkQName :: (String,String) -> QName-mkQName = uncurry (QName Nothing Nothing)--qnOf :: QName -> (String,String) -qnOf QName{modName=m,localName=n} = (m,n)-------------------------------------------------------------------------------- The data type for representing variable names.---- The additional information should---- be invisible for the normal usage of VarIndex.----------------------------------------------------------------------------data VarIndex = VarIndex {- typeofVar :: Maybe TypeExpr,- idxOf :: Int- } deriving (Data,Typeable)--onIndex :: (Int -> Int) -> VarIndex -> VarIndex-onIndex f (VarIndex{ typeofVar = t, idxOf = x})- = VarIndex t (f x)--onIndexes :: (Int ->Int -> Int) -> VarIndex -> VarIndex -> VarIndex-onIndexes g x = VarIndex (typeofVar x) . (g `on` idxOf) x--mkIdx :: Int -> VarIndex-mkIdx = VarIndex Nothing---instance Read VarIndex where- readsPrec d r = - [ (mkIdx i,s) | (i,s) <- readsPrec d r ]- ++ [ (VarIndex t i,s) | ((t,i),s) <- readsPrec d r ]--instance Show VarIndex where- showsPrec d (VarIndex t i)= showsPrec d (t,i)--instance Eq VarIndex where- (==) = (==) `on` idxOf--instance Ord VarIndex where- compare = compare `on` idxOf--instance Num VarIndex where- (+) = onIndexes (+)- (*) = onIndexes (*)- (-) = onIndexes (-)- abs = onIndex abs- signum = onIndex signum- fromInteger = mkIdx . fromInteger------------------------------------------------------------------ Data type to specify the visibility of various entities.---------------------------------------------------------------data Visibility = Public -- public (exported) entity- | Private -- private entity- deriving (Read, Show, Eq,Data,Typeable)----- The data type for representing type variables.---- They are represented by (TVar i) where i is a type variable index.--type TVarIndex = Int----- Data type for representing definitions of algebraic data types.---- <PRE>---- A data type definition of the form-------- data t x1...xn = ...| c t1....tkc |...-------- is represented by the FlatCurry term-------- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])-------- where each ij is the index of the type variable xj-------- Note: the type variable indices are unique inside each type declaration---- and are usually numbered from 0-------- Thus, a data type declaration consists of the name of the data type,---- a list of type parameters and a list of constructor declarations.---- </PRE>--data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]- | TypeSyn QName Visibility [TVarIndex] TypeExpr- deriving (Read, Show, Eq,Data,Typeable)----- A constructor declaration consists of the name and arity of the---- constructor and a list of the argument types of the constructor.--data ConsDecl = Cons QName Int Visibility [TypeExpr]- deriving (Read, Show, Eq,Data,Typeable)------ Data type for type expressions.---- A type expression is either a type variable, a function type,---- or a type constructor application.-------- Note: the names of the predefined type constructors are---- "Int", "Float", "Bool", "Char", "IO", "Success",---- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)--data TypeExpr =- TVar TVarIndex -- type variable- | FuncType TypeExpr TypeExpr -- function type t1->t2- | TCons QName [TypeExpr] -- type constructor application- deriving (Read, Show, Eq,Data,Typeable) -- TCons module name typeargs------ Data type for operator declarations.---- An operator declaration "fix p n" in Curry corresponds to the---- FlatCurry term (Op n fix p).---- Note: the constructor definition of 'Op' differs from the original---- PAKCS definition using Haskell type 'Integer' instead of 'Int'---- for representing the precedence. --data OpDecl = Op QName Fixity Integer deriving (Read, Show, Eq,Data,Typeable)----- Data types for the different choices for the fixity of an operator.--data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq,Data,Typeable)------ Data type for representing object variables.---- Object variables occurring in expressions are represented by (Var i)---- where i is a variable index.----- Data type for representing function declarations.---- <PRE>---- A function declaration in FlatCurry is a term of the form-------- (Func name arity type (Rule [i_1,...,i_arity] e))-------- and represents the function "name" with definition-------- name :: type---- name x_1...x_arity = e-------- where each i_j is the index of the variable x_j-------- Note: the variable indices are unique inside each function declaration---- and are usually numbered from 0-------- External functions are represented as (Func name arity type (External s))---- where s is the external name associated to this function.-------- Thus, a function declaration consists of the name, arity, type, and rule.---- </PRE>--data FuncDecl = Func QName Int Visibility TypeExpr Rule- deriving (Read, Show, Eq,Data,Typeable)------ A rule is either a list of formal parameters together with an expression---- or an "External" tag.--data Rule = Rule [VarIndex] Expr- | External String- deriving (Read, Show, Eq,Data,Typeable)----- Data type for classifying case expressions.---- Case expressions can be either flexible or rigid in Curry.--data CaseType = Rigid | Flex deriving (Read, Show, Eq,Data,Typeable)----- Data type for classifying combinations---- (i.e., a function/constructor applied to some arguments).---- @cons FuncCall - a call to a function all arguments are provided---- @cons ConsCall - a call with a constructor at the top,---- all arguments are provided---- @cons FuncPartCall - a partial call to a function---- (i.e., not all arguments are provided) ---- where the parameter is the number of---- missing arguments---- @cons ConsPartCall - a partial call to a constructor along with ---- number of missing arguments--data CombType = FuncCall - | ConsCall - | FuncPartCall Int - | ConsPartCall Int deriving (Read, Show, Eq,Data,Typeable)----- Data type for representing expressions.-------- Remarks:---- <PRE>---- 1. if-then-else expressions are represented as function calls:---- (if e1 then e2 else e3)---- is represented as---- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])---- ---- 2. Higher order applications are represented as calls to the (external)---- function "apply". For instance, the rule---- app f x = f x---- is represented as---- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))---- ---- 3. A conditional rule is represented as a call to an external function---- "cond" where the first argument is the condition (a constraint).---- For instance, the rule---- equal2 x | x=:=2 = success---- is represented as---- (Rule [0]---- (Comb FuncCall ("Prelude","cond")---- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],---- Comb FuncCall ("Prelude","success") []]))---- ---- 4. Functions with evaluation annotation "choice" are represented---- by a rule whose right-hand side is enclosed in a call to the---- external function "Prelude.commit".---- Furthermore, all rules of the original definition must be---- represented by conditional expressions (i.e., (cond [c,e]))---- after pattern matching.---- Example:---- ---- m eval choice---- m [] y = y---- m x [] = x---- ---- is translated into (note that the conditional branches can be also---- wrapped with Free declarations in general):---- ---- Rule [0,1]---- (Comb FuncCall ("Prelude","commit")---- [Or (Case Rigid (Var 0)---- [(Pattern ("Prelude","[]") []---- (Comb FuncCall ("Prelude","cond")---- [Comb FuncCall ("Prelude","success") [],---- Var 1]))] )---- (Case Rigid (Var 1)---- [(Pattern ("Prelude","[]") []---- (Comb FuncCall ("Prelude","cond")---- [Comb FuncCall ("Prelude","success") [],---- Var 0]))] )])---- ---- Operational meaning of (Prelude.commit e):---- evaluate e with local search spaces and commit to the first---- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c---- is satisfied---- </PRE>---- @cons Var - variable (represented by unique index)---- @cons Lit - literal (Integer/Float/Char constant)---- @cons Comb - application (f e1 ... en) of function/constructor f---- with n<=arity(f)---- @cons Free - introduction of free local variables---- @cons Or - disjunction of two expressions (used to translate rules---- with overlapping left-hand sides)---- @cons Case - case distinction (rigid or flex)--data Expr = Var VarIndex - | Lit Literal- | Comb CombType QName [Expr]- | Free [VarIndex] Expr- | Let [(VarIndex,Expr)] Expr- | Or Expr Expr- | Case SrcRef CaseType Expr [BranchExpr]- deriving (Read, Show, Eq,Data,Typeable)------ Data type for representing branches in a case expression.---- <PRE>---- Branches "(m.c x1...xn) -> e" in case expressions are represented as-------- (Branch (Pattern (m,c) [i1,...,in]) e)-------- where each ij is the index of the pattern variable xj, or as-------- (Branch (LPattern (Intc i)) e)-------- for integers as branch patterns (similarly for other literals---- like float or character constants).---- </PRE>--data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq,Data,Typeable)----- Data type for representing patterns in case expressions.--data Pattern = Pattern QName [VarIndex]- | LPattern Literal- deriving (Read, Show, Eq,Data,Typeable)----- Data type for representing literals occurring in an expression---- or case branch. It is either an integer, a float, or a character constant.---- Note: the constructor definition of 'Intc' differs from the original---- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'---- to provide an unlimited range of integer numbers. Furthermore---- float values are represented with Haskell type 'Double' instead of---- 'Float'.--data Literal = Intc SrcRef Integer- | Floatc SrcRef Double- | Charc SrcRef Char- deriving (Read, Show, Eq,Data,Typeable)-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Reads a FlatCurry file (extension ".fcy") and returns the corresponding--- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.-readFlatCurry :: FilePath -> IO (Maybe Prog)-readFlatCurry fn - = do let filename = flatName fn- readFlat filename---- Reads a FlatInterface file (extension ".fint") and returns the--- corresponding term (type 'Prog') as a value of type 'Maybe'.-readFlatInterface :: String -> IO (Maybe Prog)-readFlatInterface fn- = do let filename = replaceExtension fn ".fint"- readFlat filename---- Reads a Flat file and returns the corresponding term (type 'Prog') as--- a value of type 'Maybe'.-readFlat :: FilePath -> IO (Maybe Prog)-readFlat = liftM (fmap read) . maybeReadModule- --- Writes a FlatCurry program term into a file.-writeFlatCurry :: String -> Prog -> IO ()-writeFlatCurry filename prog- = writeModule filename (showFlatCurry' False prog)---- Writes a FlatCurry program term with source references into a file.-writeExtendedFlat :: String -> Prog -> IO ()-writeExtendedFlat filename prog =- writeModule (replaceExtension filename ".efc") (showFlatCurry' True prog)---showFlatCurry' :: Bool -> Prog -> String-showFlatCurry' b x = gshowsPrec b False x ""--gshowsPrec :: Data a => Bool -> Bool -> a -> ShowS-gshowsPrec showType d = - genericShowsPrec d `ext1Q` showsList- `ext2Q` showsTuple- `extQ` (const id :: SrcRef -> ShowS)- `extQ` (const id :: [SrcRef] -> ShowS)- `extQ` (shows :: String -> ShowS)- `extQ` (shows :: Char -> ShowS)- `extQ` showsQName d- `extQ` showsVarIndex d- - where- showsQName :: Bool -> QName -> ShowS- showsQName d qn@QName{modName=m,localName=n,typeofQName=t} = - if showType then showParen d (shows qn{srcRef=Nothing})- else shows (m,n)-- showsVarIndex :: Bool -> VarIndex -> ShowS- showsVarIndex d- | showType = showParen d . shows- | otherwise = shows . idxOf-- genericShowsPrec :: Data a => Bool -> a -> ShowS- genericShowsPrec d t = let args = intersperse (showChar ' ') $- gmapQ (gshowsPrec showType True) t in- showParen (d && not (null args)) $- showString (showConstr (toConstr t)) .- (if null args then id else showChar ' ') .- foldr (.) id args-- showsList :: Data a => [a] -> ShowS- showsList xs = showChar '[' . - foldr (.) (showChar ']') - (intersperse (showChar ',') $ - map (gshowsPrec showType False) xs)- -- showsTuple :: (Data a,Data b) => (a,b) -> ShowS- showsTuple (x,y) = showChar '(' . - gshowsPrec showType False x . - showChar ',' .- gshowsPrec showType False y .- showChar ')' ---newtype Q r a = Q (a -> r)- -ext2Q :: (Data d, Typeable2 t) => (d -> q) -> - (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q-ext2Q def ext arg =- case dataCast2 (Q ext) of- Just (Q ext') -> ext' arg- Nothing -> def arg----------------------------------------------------------------------------------------------------------------------------------------------------------------
src/Curry/Syntax/LLParseComb.lhs view
@@ -1,4 +1,3 @@-% -*- LaTeX -*- % $Id: LLParseComb.lhs,v 1.26 2004/02/15 23:11:30 wlux Exp $ % % Copyright (c) 1999-2004, Wolfgang Lux@@ -49,7 +48,6 @@ > class (Ord s,Show s) => Symbol s where > isEOF :: s -> Bool -> type Empty = Bool > type SuccessCont s a = Position -> s -> P a > type FailureCont a = Position -> String -> P a > type Lexer s a = SuccessCont s a -> FailureCont a -> P a@@ -60,7 +58,7 @@ > (Map.Map s (Lexer s b -> ParseFun s a b)) > instance Symbol s => Show (Parser s a b) where-> showsPrec p (Parser e ps) = showParen (p >= 10) $ -- $+> showsPrec p (Parser e ps) = showParen (p >= 10) $ > showString "Parser " . shows (isJust e) . > showChar ' ' . shows (Map.keysSet ps) @@ -200,13 +198,13 @@ > f <$> p = succeed f <*> p > (<$->) :: Symbol s => a -> Parser s b c -> Parser s a c-> f <$-> p = const f <$> p {-$-}+> f <$-> p = const f <$> p > (<*->) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c-> p <*-> q = const <$> p <*> q {-$-}+> p <*-> q = const <$> p <*> q > (<-*>) :: Symbol s => Parser s a c -> Parser s b c -> Parser s b c-> p <-*> q = const id <$> p <*> q {-$-}+> p <-*> q = const id <$> p <*> q > (<**>) :: Symbol s => Parser s a c -> Parser s (a -> b) c -> Parser s b c > p <**> q = flip ($) <$> p <*> q@@ -238,7 +236,7 @@ > p `sepBy` q = p `sepBy1` q `opt` [] > sepBy1 :: Symbol s => Parser s a c -> Parser s b c -> Parser s [a] c-> p `sepBy1` q = (:) <$> p <*> many (q <-*> p) {-$-}+> p `sepBy1` q = (:) <$> p <*> many (q <-*> p) > chainr :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b -> a > -> Parser s a b@@ -247,7 +245,7 @@ > chainr1 :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b > -> Parser s a b > chainr1 p op = r-> where r = p <**> (flip <$> op <*> r `opt` id) {-$-}+> where r = p <**> (flip <$> op <*> r `opt` id) > chainl :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b -> a > -> Parser s a b
src/Curry/Syntax/Lexer.lhs view
@@ -273,7 +273,7 @@ > isIdent, isSym, isOctit, isHexit :: Char -> Bool > isIdent c = isAlphaNum c || c `elem` "'_"-> isSym c = c `elem` "~!@#$%^&*+-=<>:?./|\\" {-$-}+> isSym c = c `elem` "~!@#$%^&*+-=<>:?./|\\" > isOctit c = c >= '0' && c <= '7' > isHexit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
src/Curry/Syntax/Pretty.lhs view
@@ -15,10 +15,11 @@ > module Curry.Syntax.Pretty where +> import Text.PrettyPrint.HughesPJ+ > import Curry.Base.Ident > import Curry.Syntax.Type -> import PrettyCombinators \end{verbatim} Pretty print a module
src/Curry/Syntax/Utils.hs view
@@ -1,8 +1,15 @@ module Curry.Syntax.Utils(Expr, fv, qfv,- QuantExpr, bv) where+ QuantExpr, bv, + isEvalAnnot, isTypeSig,+ infixOp,+ isTypeDecl, isValueDecl,+ isInfixDecl,+ isRecordDecl, isImportDecl) where+ import qualified Data.Set as Set + import Curry.Base.Ident import Curry.Syntax.Type @@ -200,3 +207,51 @@ bvfp bvs (InfixFuncPattern t1 op t2) = foldl bvfp bvs [t1, t2] bvfp bvs (RecordPattern fs r) = foldl bvfp (maybe bvs (bvfp bvs) r) (map fieldTerm fs)++++{-+ Here is a list of predicates identifying various kinds of+ declarations.+-}++isImportDecl, isInfixDecl, isTypeDecl :: Decl -> Bool+isTypeSig, isEvalAnnot, isValueDecl :: Decl -> Bool++isImportDecl (ImportDecl _ _ _ _ _) = True+isImportDecl _ = False++isInfixDecl (InfixDecl _ _ _ _) = True+isInfixDecl _ = False++isTypeDecl (DataDecl _ _ _ _) = True+isTypeDecl (NewtypeDecl _ _ _ _) = True+isTypeDecl (TypeDecl _ _ _ _) = True+isTypeDecl _ = False++isTypeSig (TypeSig _ _ _) = True+isTypeSig (ExternalDecl _ _ _ _ _) = True+isTypeSig _ = False++isEvalAnnot (EvalAnnot _ _ _) = True+isEvalAnnot _ = False++isValueDecl (FunctionDecl _ _ _) = True+isValueDecl (ExternalDecl _ _ _ _ _) = True+isValueDecl (FlatExternalDecl _ _) = True+isValueDecl (PatternDecl _ _ _) = True+isValueDecl (ExtraVariables _ _) = True+isValueDecl _ = False++isRecordDecl (TypeDecl _ _ _ (RecordType _ _)) = True+isRecordDecl _ = False+++{-+ The function \texttt{infixOp} converts an infix operator into an+ expression.+-}++infixOp :: InfixOp -> Expression+infixOp (InfixOp op) = Variable op+infixOp (InfixConstr op) = Constructor op
src/CurryBuilder.hs view
@@ -23,9 +23,15 @@ import Modules (compileModule) import CurryCompilerOpts import CurryDeps-import Filenames-import PathUtils+import Curry.Files.Filenames+import Curry.Files.PathUtils ++flatName' :: Options -> FilePath -> FilePath+flatName' o+ | extendedFlat o = extFlatName+ | otherwise = flatName+ ------------------------------------------------------------------------------- -- Compiles the Curry program 'file' including all imported modules, depending@@ -64,7 +70,7 @@ = do flatIntfExists <- doesModuleExist (flatIntName file') if flatIntfExists- then smake [flatName file'] --[flatName file', flatIntName file']+ then smake [flatName' options file'] --[flatName file', flatIntName file'] (file':(catMaybes (map flatInterface mods))) (compileFile file') (skipFile file')@@ -89,12 +95,12 @@ return () targetNames fn - | flat options = [flatName fn] -- , flatIntName fn]+ | flat options = [flatName' options fn] -- , flatIntName fn] | flatXml options = [xmlName fn] | abstract options = [acyName fn] | untypedAbstract options = [uacyName fn] | parseOnly options = [maybe (sourceRepName fn) id (output options)]- | otherwise = [flatName fn] -- , flatIntName fn]+ | otherwise = [flatName' options fn] -- , flatIntName fn] flatInterface mod = case (lookup mod deps) of
src/CurryCompilerOpts.hs view
@@ -34,7 +34,7 @@ parseOnly :: Bool, -- generate source representation withExtensions :: Bool, -- enable extended functionalities dump :: [Dump] -- dumps- }+ } deriving Show -- Default compiler options@@ -116,10 +116,6 @@ "dump intermediate language before lifting", Option "" ["dump-case"] (NoArg (Dump [DumpCase])) "dump intermediate language after case simplification",- Option "" ["dump-transformed"] (NoArg (Dump [DumpTransformed]))- "dump IL code after debugging transformation",- Option "" ["dump-normalized"] (NoArg (Dump [DumpNormalized]))- "dump IL code after normalization", Option "?h" ["help"] (NoArg Help) "display this help and exit" ]@@ -158,8 +154,6 @@ | DumpLifted -- dump source after lambda-lifting | DumpIL -- dump IL code after translation | DumpCase -- dump IL code after case elimination- | DumpTransformed -- dump transformed code- | DumpNormalized -- dump IL code after normalization deriving (Eq,Bounded,Enum,Show)
src/CurryDeps.lhs view
@@ -25,11 +25,13 @@ > import Curry.Base.Ident > import Curry.Base.MessageMonad +> import Curry.Files.Filenames+> import Curry.Files.PathUtils+ > import Curry.Syntax hiding(Interface(..)) > import SCC-> import Filenames-> import PathUtils+ > data Source = Source FilePath [ModuleIdent] > | Interface FilePath
src/CurryEnv.hs view
@@ -95,7 +95,7 @@ -- Generate interface declarations for all type synonyms in the module. genTypeSyns :: TCEnv -> Module -> [IDecl] genTypeSyns tcEnv (Module mident _ decls)- = concatMap (genTypeSynDecl mident tcEnv) decls+ = concatMap (genTypeSynDecl mident tcEnv) (filter isTypeSyn decls) -- genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl]@@ -170,3 +170,12 @@ [RenamingType qident' _ _] -> Just qident' [AliasType qident' _ _] -> Just qident' _ -> Nothing++++isTypeSyn :: Decl -> Bool+isTypeSyn (TypeDecl _ _ _ texpr)+ = case texpr of+ RecordType _ _ -> False+ _ -> True+isTypeSyn _ = False
src/CurryHtml.hs view
@@ -6,8 +6,9 @@ import Curry.Base.Ident import Curry.Base.MessageMonad +import Curry.Files.PathUtils (readModule, writeModule, getCurryPath)+ import SyntaxColoring-import PathUtils (readModule, writeModule, getCurryPath) import Frontend
src/Desugar.lhs view
@@ -209,7 +209,7 @@ > where > fixType tyEnv > | typeOf tyEnv v == floatType -> = Float (ast $ positionOfIdent v) (fromIntegral i)+> = Float (srcRefOf $ positionOfIdent v) (fromIntegral i) > | otherwise = Int v i > desugarLiteral (Float p f) = return (Left (Float p f)) > desugarLiteral (String (SrcRef [i]) cs) @@ -292,7 +292,7 @@ > do > v0 <- S.get >>= freshIdent m "_#lazy" . monoType . flip typeOf t > let v' = addPositionIdent (AST pos) v0-> return (patDecl p{ast=pos} t (mkVar v') : ds,VariablePattern v')+> return (patDecl p{astRef=pos} t (mkVar v') : ds,VariablePattern v') \end{verbatim}
src/Exports.lhs view
@@ -40,15 +40,15 @@ > expandInterface :: Module -> TCEnv -> ValueEnv -> Module > expandInterface (Module m es ds) tcEnv tyEnv = > --error (show es')-> case linear [unqualify tc | ExportTypeWith tc _ <- es'] of-> Linear ->-> case linear ([c | ExportTypeWith _ cs <- es', c <- cs] +++> case findDouble [unqualify tc | ExportTypeWith tc _ <- es'] of+> Nothing ->+> case findDouble ([c | ExportTypeWith _ cs <- es', c <- cs] ++ > [unqualify f | Export f <- es']) of-> Linear -> Module m (Just (Exporting NoPos es')) ds-> NonLinear v -> errorAt' (ambiguousExportValue v)-> NonLinear tc -> errorAt' (ambiguousExportType tc) +> Nothing -> Module m (Just (Exporting NoPos es')) ds+> Just v -> errorAt' (ambiguousExportValue v)+> Just tc -> errorAt' (ambiguousExportType tc) > where ms = Set.fromList [fromMaybe m asM | ImportDecl _ m _ asM _ <- ds]-> es' = joinExports $ -- $+> es' = joinExports $ > maybe (expandLocalModule tcEnv tyEnv) > (expandSpecs ms m tcEnv tyEnv) > es
− src/Filenames.hs
@@ -1,72 +0,0 @@-module Filenames(module Filenames,- - ) where--import System.FilePath---- Various filename extensions----curryExt, lcurryExt, icurryExt, oExt :: String-curryExt = ".curry"--lcurryExt = ".lcurry"--icurryExt = ".icurry"--flatExt = ".fcy"--flatIntExt = ".fint"--- fintExt = ".fint"--xmlExt = "_flat.xml"--acyExt = ".acy"--uacyExt = ".uacy"--sourceRepExt = ".cy"--oExt = ".o"--debugExt = ".d.o"--sourceExts, moduleExts, objectExts :: [String]-sourceExts = [curryExt,lcurryExt]-moduleExts = sourceExts ++ [icurryExt]-objectExts = [oExt]--{-- The following functions compute the name of the target file (e.g.- interface file, flat curry file etc.)- for a source module. Note that- output files are always created in the same directory as the source- file.--}--interfName :: FilePath -> FilePath-interfName sfn = replaceExtension sfn icurryExt---flatName :: FilePath -> FilePath-flatName fn = replaceExtension fn flatExt--flatIntName :: FilePath -> FilePath-flatIntName fn = replaceExtension fn flatIntExt--xmlName :: FilePath -> FilePath-xmlName fn = replaceExtension fn xmlExt--acyName :: FilePath -> FilePath-acyName fn = replaceExtension fn acyExt--uacyName :: FilePath -> FilePath-uacyName fn = replaceExtension fn uacyExt--sourceRepName :: FilePath -> FilePath-sourceRepName fn = replaceExtension fn sourceRepExt--objectName :: Bool -> FilePath -> FilePath-objectName debug = name (if debug then debugExt else oExt)- where name ext fn = replaceExtension fn ext
src/Frontend.hs view
@@ -15,18 +15,23 @@ import Control.Monad.Error import Prelude hiding (lex) -import Modules-import CurryBuilder-import CurryCompilerOpts+ import Curry.Base.MessageMonad+import Curry.Base.Ident+import Curry.Base.Position++import Curry.Files.Filenames+import Curry.Files.PathUtils+ import qualified Curry.Syntax as CS import Curry.Syntax.Lexer +import Modules+import CurryBuilder+import CurryCompilerOpts+ import CurryDeps-import Curry.Base.Ident-import Curry.Base.Position-import Filenames-import PathUtils+ import Base(ModuleEnv) -------------------------------------------------------------------------------
src/GenAbstractCurry.hs view
@@ -17,6 +17,7 @@ import Data.Char import Curry.Syntax+import Curry.Syntax.Utils import Curry.AbstractCurry import Base
src/GenFlatCurry.hs view
@@ -10,24 +10,32 @@ module GenFlatCurry (genFlatCurry, genFlatInterface) where + import Control.Monad.State import Control.Monad import Data.Maybe import Data.List import qualified Data.Map as Map + import Curry.Base.MessageMonad import Curry.Base.Ident as Id +import qualified Curry.Syntax as CS++import Curry.ExtendedFlat.Type+import Curry.ExtendedFlat.TypeInference+ import Base {-(ArityEnv, ArityInfo(..), ModuleEnv, TCEnv, TypeInfo(..), ValueEnv, ValueInfo(..), lookupValue, qualLookupTC, qualLookupArity, lookupArity, internalError, qualLookupValue)-}-import Curry.ExtendedFlat+ import qualified IL.Type as IL import qualified IL.CurryToIL as IL-import qualified Curry.Syntax as CS++import TopEnv(topEnvMap) import CurryEnv (CurryEnv) import qualified CurryEnv import ScopeEnv (ScopeEnv)@@ -37,7 +45,8 @@ import PatchPrelude -trace _ x = x+import Debug.Trace+trace' _ x = x ------------------------------------------------------------------------------- @@ -45,9 +54,10 @@ genFlatCurry :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> (Prog, [WarnMsg]) genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv mod- = (patchPreludeFCY prog, messages)+ = (prog', messages) where (prog, messages) - = run opts cEnv mEnv tyEnv tcEnv aEnv False (visitModule mod)+ = run opts cEnv mEnv tyEnv tcEnv aEnv False (visitModule mod)+ prog' = adjustTypeInfo $ patchPreludeFCY prog -- transforms intermediate language code (IL) to FlatCurry interfaces@@ -62,10 +72,93 @@ ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- ++-- The environment 'FlatEnv' is embedded in the monadic representation+-- 'FlatState' which allows the usage of 'do' expressions.++type FlatState a = State FlatEnv a++-- Data type for representing an environment which contains information needed+-- for generating FlatCurry code.+data FlatEnv = FlatEnv{ moduleIdE :: ModuleIdent,+ functionIdE :: (QualIdent, [(Ident, IL.Type)]),+ compilerOptsE :: Options,+ moduleEnvE :: ModuleEnv,+ arityEnvE :: ArityEnv,+ typeEnvE :: ValueEnv, -- types of defined values+ tConsEnvE :: TCEnv,+ publicEnvE :: Map.Map Ident IdentExport,+ fixitiesE :: [CS.IDecl],+ typeSynonymsE :: [CS.IDecl],+ importsE :: [CS.IDecl],+ exportsE :: [CS.Export],+ interfaceE :: [CS.IDecl],+ varIndexE :: Int,+ varIdsE :: ScopeEnv Ident VarIndex,+ tvarIndexE :: Int,+ messagesE :: [WarnMsg],+ genInterfaceE :: Bool,+ localTypes :: Map.Map QualIdent IL.Type,+ constrTypes :: Map.Map QualIdent IL.Type+ }++data IdentExport = NotConstr -- function, type-constructor+ | OnlyConstr -- constructor+ | NotOnlyConstr -- constructor, function, type-constructor+++++-- Runs a 'FlatState' action and returns the result+run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv + -> Bool -> FlatState a -> (a, [WarnMsg])+run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f+ = (result, messagesE env)+ where+ (result, env) = runState f env0+ env0 = FlatEnv{ moduleIdE = CurryEnv.moduleId cEnv,+ functionIdE = (qualify (mkIdent ""), []),+ compilerOptsE = opts,+ moduleEnvE = mEnv,+ arityEnvE = aEnv,+ typeEnvE = tyEnv,+ tConsEnvE = tcEnv,+ publicEnvE = genPubEnv (CurryEnv.moduleId cEnv)+ (CurryEnv.interface cEnv),+ fixitiesE = CurryEnv.infixDecls cEnv,+ typeSynonymsE = CurryEnv.typeSynonyms cEnv,+ importsE = CurryEnv.imports cEnv,+ exportsE = CurryEnv.exports cEnv,+ interfaceE = CurryEnv.interface cEnv,+ varIndexE = 0,+ varIdsE = ScopeEnv.new,+ tvarIndexE =0,+ messagesE = [],+ genInterfaceE = genIntf,+ localTypes = Map.empty,+ constrTypes = Map.fromList (getConstrTypes tcEnv)+ }++getConstrTypes :: TCEnv -> [(QualIdent, IL.Type)]+getConstrTypes tcEnv = trace' (show tinfos) tinfos+ where tcList = Map.toList $ topEnvMap tcEnv+ tinfos = [ foo tqid conid argtypes targnum+ | (_, (_, DataType tqid targnum dts):_) <- tcList+ , Just (Data conid _ argtypes) <- dts]+ foo tqid conid argtypes targnum+ = let conname = QualIdent (qualidMod tqid) conid+ resulttype = IL.TypeConstructor tqid (map IL.TypeVariable [0..targnum-1])+ contype = foldr IL.TypeArrow resulttype (map ttrans argtypes)+ in (conname, contype)+ + -- visitModule :: IL.Module -> FlatState Prog-visitModule (IL.Module mid imps decls)- = whenFlatCurry+visitModule (IL.Module mid imps decls) = do+ -- insert local decls into localDecls+ let ts = [ (qn, t) | IL.FunctionDecl qn _ t _ <- decls ]+ modify (\ s -> s {localTypes = Map.fromList ts})+ whenFlatCurry (do ops <- genOpDecls datas <- mapM visitDataDecl (filter isDataDecl decls) types <- genTypeSynonyms@@ -123,12 +216,12 @@ visitType :: IL.Type -> FlatState TypeExpr visitType (IL.TypeConstructor qident types) = do texprs <- mapM visitType types- qname <- visitQualIdent qident+ qname <- visitQualTypeIdent qident if (qualName qident) == "Identity" then return (head texprs) else return (TCons qname texprs) visitType (IL.TypeVariable index)- = return (TVar (int2num index))+ = return (TVar (abs index)) visitType (IL.TypeArrow type1 type2) = do texpr1 <- visitType type1 texpr2 <- visitType type2@@ -137,22 +230,20 @@ -- visitFuncDecl :: IL.Decl -> FlatState FuncDecl visitFuncDecl (IL.FunctionDecl qident params typeexpr expression)- = whenFlatCurry- (do setFunctionId qident- is <- mapM newVarIndex params- texpr <- visitType typeexpr- expr <- visitExpression expression- qname <- visitQualIdent qident- vis <- getVisibility False qident- clearVarIndices- return (Func qname (length params) vis texpr (Rule is expr)))- (do setFunctionId qident- texpr <- visitType typeexpr- qname <- visitQualIdent qident- clearVarIndices- return (Func qname (length params) Public texpr (Rule [] (Var $ mkIdx 0))))+ = let argtypes = splitoffArgTypes typeexpr params + in do setFunctionId (qident, argtypes)+ qname <- visitQualIdent qident+ whenFlatCurry (do is <- mapM newVarIndex params+ texpr <- visitType typeexpr+ expr <- visitExpression expression+ vis <- getVisibility False qident+ clearVarIndices+ return (Func qname (length params) vis texpr (Rule is expr)))+ (do texpr <- visitType typeexpr+ clearVarIndices+ return (Func qname (length params) Public texpr (Rule [] (Var $ mkIdx 0)))) visitFuncDecl (IL.ExternalDecl qident _ name typeexpr)- = do setFunctionId qident+ = do setFunctionId (qident, []) texpr <- visitType typeexpr qname <- visitQualIdent qident vis <- getVisibility False qident@@ -173,15 +264,14 @@ visitExpression (IL.Function qident _) = do arity_ <- lookupIdArity qident qname <- visitQualIdent qident- -- ftype <- lookupIdType qident- -- let qident' = qname{ typeofQName = ftype }- maybe (internalError (funcArity qident))+ maybe (internalError (funcArity qname)) (\arity -> genFuncCall qname arity []) arity_ visitExpression (IL.Constructor qident arity) = do arity_ <- lookupIdArity qident+ qname <- visitQualIdent qident maybe (internalError (consArity qident))- (\arity -> genConsCall qident arity [])+ (\arity -> genConsCall qname arity []) arity_ visitExpression (IL.Apply e1 e2) = genFlatApplication e1 e2@@ -206,6 +296,7 @@ newVarIndex (bindingIdent binding) bind <- visitBinding binding expr <- visitExpression expression+ -- is it correct that there is no endScope? (hsi) return (Let [bind] expr) visitExpression (IL.Letrec bindings expression) = do beginScope@@ -216,32 +307,6 @@ return (Let binds expr) -getTypeOf :: Ident -> FlatState (Maybe TypeExpr)-getTypeOf ident = do- (valEnv, _) <- environments- case lookupValue ident valEnv of - Value _ (ForAll _ t) : _ - -> do t <- visitType (ttrans t)- trace ("getTypeOf(" ++ show ident ++ ") = " ++ show t)$- return (Just t)- v -> trace ("lookupValue did not return a value for index " ++ show ident ++ ", instead " ++ show v)- (return Nothing)- where ttrans :: Type -> IL.Type - ttrans (TypeConstructor i ts)- = IL.TypeConstructor i (map ttrans ts)- ttrans (TypeVariable v)- = IL.TypeVariable v- ttrans (TypeConstrained [] v)- = trace (msg1 v) $ IL.TypeVariable v- ttrans (TypeConstrained (v:_) i)- = trace (msg2 i ilt) ilt- where ilt = ttrans v- ttrans (TypeArrow f x) = IL.TypeArrow (ttrans f) (ttrans x)- ttrans s@(TypeSkolem _) = error $ "in ttrans: " ++ show s- ttrans s@(TypeRecord _ _) = error $ "in ttrans: " ++ show s- msg1 i = "in ttrans: empty TypeConstrained, coerced to type var #" ++ show i- msg2 i t = "in ttrans: TypeConstrained with index " ++ show i ++ ", coerced to " ++ show t- -- visitLiteral :: IL.Literal -> FlatState Literal visitLiteral (IL.Char rs c) = return (Charc rs c)@@ -345,8 +410,22 @@ = Id.moduleName preludeMIdent | otherwise = maybe (Id.moduleName mid) Id.moduleName mmod- return (curry mkQName mod $ name ident)+ ftype <- lookupIdType qident+ return (QName Nothing ftype mod $ name 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 mid <- moduleId+ let (mmod, ident) = (qualidMod qident, qualidId qident)+ mod | elem ident [listId, consId, nilId, unitId] || isTupleId ident+ = Id.moduleName preludeMIdent+ | otherwise+ = maybe (Id.moduleName mid) Id.moduleName mmod+ return (QName Nothing Nothing mod $ name ident)+ -- visitExternalName :: String -> FlatState String visitExternalName name @@ -488,8 +567,9 @@ arity_ (IL.Constructor qident _) -> do arity_ <- lookupIdArity qident+ qname <- visitQualIdent qident maybe (internalError (consArity qident))- (\arity -> genConsCall qident arity args)+ (\arity -> genConsCall qname arity args) arity_ _ -> do expr <- visitExpression expression genApplicComb expr args@@ -508,26 +588,22 @@ where cnt = length args ---genConsCall :: QualIdent -> Int -> [IL.Expression] -> FlatState Expr-genConsCall qident arity args+genConsCall :: QName -> Int -> [IL.Expression] -> FlatState Expr+genConsCall qname arity args | arity > cnt - = do qname <- visitQualIdent qident- genComb qname args (ConsPartCall (arity - cnt))+ = genComb qname args (ConsPartCall (arity - cnt)) | arity < cnt = do let (funcargs, applicargs) = splitAt arity args- qname <- visitQualIdent qident conscall <- genComb qname funcargs ConsCall genApplicComb conscall applicargs | otherwise - = do qname <- visitQualIdent qident- genComb qname args ConsCall + = genComb qname args ConsCall where cnt = length args -- genComb :: QName -> [IL.Expression] -> CombType -> FlatState Expr genComb qname args combtype = do exprs <- mapM visitExpression args--- qname <- visitQualIdent qident return (Comb combtype qname exprs) --@@ -569,7 +645,8 @@ genTypeSynonym :: CS.IDecl -> FlatState TypeDecl genTypeSynonym (CS.ITypeDecl _ qident params typeexpr) = do let is = [0 .. (length params) - 1]- (tyEnv,tcEnv) <- environments+ tyEnv <- gets typeEnvE+ tcEnv <- gets tConsEnvE let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr texpr <- visitType (fst (cs2ilType (zip params is) typeexpr')) qname <- visitQualIdent qident@@ -613,7 +690,8 @@ genRecordLabel :: Maybe ModuleIdent -> [(Ident,Int)] -> ([Ident],CS.TypeExpr) -> FlatState ConsDecl genRecordLabel mod vis ([ident],typeexpr)- = do (tyEnv,tcEnv) <- environments+ = do tyEnv <- gets typeEnvE+ tcEnv <- gets tConsEnvE let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr texpr <- visitType (fst (cs2ilType vis typeexpr')) qname <- visitQualIdent ((maybe qualify qualifyWith mod) @@ -812,10 +890,6 @@ ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -int2num :: Int -> Int-int2num = abs-- emap :: (e -> a -> (b,e)) -> e -> [a] -> ([b], e) emap _ env [] = ([], env) emap f env (x:xs) = let (x',env') = f env x@@ -825,80 +899,16 @@ ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- --- Data type for representing an environment which contains information needed--- for generating FlatCurry code.-data FlatEnv = FlatEnv{ moduleIdE :: ModuleIdent,- functionIdE :: QualIdent, -- function name for error messages- compilerOptsE :: Options,- moduleEnvE :: ModuleEnv,- arityEnvE :: ArityEnv,- typeEnvE :: ValueEnv,- tConsEnvE :: TCEnv,- publicEnvE :: Map.Map Ident IdentExport,- fixitiesE :: [CS.IDecl],- typeSynonymsE :: [CS.IDecl],- importsE :: [CS.IDecl],- exportsE :: [CS.Export],- interfaceE :: [CS.IDecl],- varIndexE :: Int,- varIdsE :: ScopeEnv Ident VarIndex,- tvarIndexE :: Int,- tvarIdsE :: ScopeEnv Ident TVarIndex,- messagesE :: [WarnMsg],- genInterfaceE :: Bool- }--data IdentExport = NotConstr -- function, type-constructor- | OnlyConstr -- constructor- | NotOnlyConstr -- constructor, function, type-constructor------ The environment 'FlatEnv' is embedded in the monadic representation--- 'FlatState' which allows the usage of 'do' expressions.-type FlatState a = State FlatEnv a----- Runs a 'FlatState' action and returns the result-run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv - -> Bool -> FlatState a -> (a, [WarnMsg])-run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f- = (result, messagesE env)- where- (result, env) = runState f env0- env0 = FlatEnv{ moduleIdE = CurryEnv.moduleId cEnv,- functionIdE = qualify (mkIdent ""),- compilerOptsE = opts,- moduleEnvE = mEnv,- arityEnvE = aEnv,- typeEnvE = tyEnv,- tConsEnvE = tcEnv,- publicEnvE = genPubEnv (CurryEnv.moduleId cEnv)- (CurryEnv.interface cEnv),- fixitiesE = CurryEnv.infixDecls cEnv,- typeSynonymsE = CurryEnv.typeSynonyms cEnv,- importsE = CurryEnv.imports cEnv,- exportsE = CurryEnv.exports cEnv,- interfaceE = CurryEnv.interface cEnv,- varIndexE = 0,- varIdsE = ScopeEnv.new,- tvarIndexE = 0,- tvarIdsE = ScopeEnv.new,- messagesE = [],- genInterfaceE = genIntf- }-- -- moduleId :: FlatState ModuleIdent moduleId = gets moduleIdE -- functionId :: FlatState QualIdent-functionId = gets functionIdE+functionId = gets (fst . functionIdE) ---setFunctionId :: QualIdent -> FlatState ()+setFunctionId :: (QualIdent, [(Ident, IL.Type)]) -> FlatState () setFunctionId qid = modify (\env -> env{ functionIdE = qid }) --@@ -926,10 +936,6 @@ typeSynonyms = gets typeSynonymsE ---environments :: FlatState (ValueEnv,TCEnv)-environments = gets (\env -> (typeEnvE env, tConsEnvE env))---- isPublic :: Bool -> QualIdent -> FlatState Bool isPublic isConstr qid = gets (\env -> maybe False isP (Map.lookup (unqualify qid) @@ -957,30 +963,70 @@ _ -> Nothing _ -> Nothing ---+++getTypeOf :: Ident -> FlatState (Maybe TypeExpr)+getTypeOf ident = do+ valEnv <- gets typeEnvE + case lookupValue ident valEnv of + Value _ (ForAll _ t) : _ + -> do t <- visitType (ttrans t)+ trace' ("getTypeOf(" ++ show ident ++ ") = " ++ show t)$+ return (Just t)+ DataConstructor _ (ForAllExist _ _ t):_ + -> do t <- visitType (ttrans t)+ trace' ("getTypeOfDataCon(" ++ show ident ++ ") = " ++ show t)$+ return (Just t)+ _ -> do (_,ats) <- gets functionIdE+ case lookup ident ats of+ Just t -> liftM Just (visitType t)+ Nothing -> trace' ("lookupValue did not return a value for index " ++ show ident)+ (return Nothing)+ttrans :: Type -> IL.Type +ttrans (TypeConstructor i ts)+ = IL.TypeConstructor i (map ttrans ts)+ttrans (TypeVariable v)+ = IL.TypeVariable v+ttrans (TypeConstrained [] v)+ = IL.TypeVariable v+ttrans (TypeConstrained (v:_) i)+ = ttrans v+ttrans (TypeArrow f x) = IL.TypeArrow (ttrans f) (ttrans x)+ttrans s@(TypeSkolem _) = error $ "in ttrans: " ++ show s+ttrans s@(TypeRecord _ _) = error $ "in ttrans: " ++ show s++++-- Constructor (:) receives special treatment throughout the+-- whole implementation. We won't depart from that for mere+-- aesthetic reasons. (hsi) lookupIdType :: QualIdent -> FlatState (Maybe TypeExpr)+lookupIdType (QualIdent Nothing (Ident _ ":" _))+ = return (Just (FuncType (TVar 0) (FuncType (l0) (l0))))+ where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0] lookupIdType qid = do aEnv <- gets typeEnvE- lookupT qid aEnv- where- lookupT qid aEnv = let vals = qualLookupValue qid aEnv - ts = [ t | Value _ (ForAll _ t) <- vals]- in case ts of - t : _ -> do t' <- visitType (IL.translType t)- return (Just t')- [] -> error ("no type for " ++ show qid ++ show vals ++ show aEnv) -- return Nothing-+ lt <- gets localTypes+ ct <- gets constrTypes+ case Map.lookup qid lt `mplus` Map.lookup qid ct of+ Just t -> trace' ("lookupIdType local " ++ show (qid, t)) $ liftM Just (visitType t) -- local name or constructor+ Nothing -> case [ t | Value _ (ForAll _ t) <- qualLookupValue qid aEnv ] of + t : _ -> liftM Just (visitType (IL.translType t)) -- imported name+ [] -> case qualidMod qid of+ Nothing -> trace' ("no type for " ++ show qid) $ return Nothing -- no known type+ Just _ -> lookupIdType qid {qualidMod = Nothing}+-- -- Generates a new index for a variable newVarIndex :: Ident -> FlatState VarIndex-newVarIndex id+newVarIndex ident = do idx0 <- gets varIndexE- ty <- getTypeOf id+ ty <- getTypeOf ident let idx = idx0 + 1 vid = VarIndex ty idx vids <- gets varIdsE modify (\env -> env{ varIndexE = idx,- varIdsE = ScopeEnv.insert id vid vids+ varIdsE = ScopeEnv.insert ident vid vids }) return vid @@ -1009,15 +1055,13 @@ -- beginScope :: FlatState () beginScope = modify- (\env -> env { varIdsE = ScopeEnv.beginScope (varIdsE env),- tvarIdsE = ScopeEnv.beginScope (tvarIdsE env)+ (\env -> env { varIdsE = ScopeEnv.beginScope (varIdsE env) }) -- endScope :: FlatState () endScope = modify- (\env -> env { varIdsE = ScopeEnv.endScope (varIdsE env),- tvarIdsE = ScopeEnv.endScope (tvarIdsE env)+ (\env -> env { varIdsE = ScopeEnv.endScope (varIdsE env) }) --@@ -1088,3 +1132,11 @@ bindEnvRecordLabel r env ([lab], _) = bindIdentExport (recSelectorId (qualify r) lab) False expo where expo = (bindIdentExport (recUpdateId (qualify r) lab) False env)+++splitoffArgTypes :: IL.Type -> [Ident] -> [(Ident, IL.Type)]+splitoffArgTypes (IL.TypeArrow l r) (i:is) = (i, l):splitoffArgTypes r is+splitoffArgTypes _ [] = []+splitoffArgTypes _ _ = error "internal error in splitoffArgTypes"++
src/IL/CurryToIL.lhs view
@@ -254,8 +254,8 @@ > translFunction :: Position -> Bool -> ModuleIdent -> ValueEnv -> TCEnv > -> EvalEnv -> Ident -> [Equation] -> IL.Decl > translFunction pos flat m tyEnv tcEnv evEnv f eqs =-> -- | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))-> -- | otherwise = +> -- - | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))+> -- - | otherwise = > IL.FunctionDecl f' vs (translType' m tyEnv tcEnv ty) expr > -- = IL.FunctionDecl f' vs (translType ty) > -- (match ev vs (map (translEquation tyEnv vs vs'') eqs))@@ -272,10 +272,10 @@ > (IL.Function > (qualifyWith preludeMIdent (mkIdent "commit")) > 1)-> (match (ast pos) IL.Rigid vs +> (match (srcRefOf pos) IL.Rigid vs > (map (translEquation tyEnv vs vs'') eqs)) > | otherwise-> = match (ast pos) ev vs (map (translEquation tyEnv vs vs'') eqs)+> = match (srcRefOf pos) ev vs (map (translEquation tyEnv vs vs'') eqs) > --- > -- (vs',vs'') = splitAt (arrowArity ty) (argNames (mkIdent "")) @@ -351,7 +351,7 @@ > translLiteral :: Literal -> IL.Literal > translLiteral (Char p c) = IL.Char p c-> translLiteral (Int id i) = IL.Int (ast (positionOfIdent id)) i+> translLiteral (Int id i) = IL.Int (srcRefOf (positionOfIdent id)) i > translLiteral (Float p f) = IL.Float p f > translLiteral _ = internalError "translLiteral"
src/IL/Pretty.lhs view
@@ -15,10 +15,10 @@ > module IL.Pretty(ppModule) where > +> import Text.PrettyPrint.HughesPJ+ > import Curry.Base.Ident-> > import IL.Type-> import PrettyCombinators > default(Int,Double)
src/IL/Type.lhs view
@@ -1,3 +1,5 @@+> {-# LANGUAGE DeriveDataTypeable #-}+ % $Id: IL.lhs,v 1.18 2003/10/28 05:43:38 wlux Exp $ % % Copyright (c) 1999-2003 Wolfgang Lux@@ -40,6 +42,7 @@ > module IL.Type where +> import Data.Generics > import Curry.Base.Ident > import Curry.Base.Position (SrcRef(..)) @@ -59,7 +62,7 @@ > TypeConstructor QualIdent [Type] > | TypeVariable Int > | TypeArrow Type Type-> deriving (Eq,Show)+> deriving (Eq,Show, Typeable, Data) > data Literal = Char SrcRef Char | Int SrcRef Integer | Float SrcRef Double deriving (Eq,Show)
src/IL/XML.lhs view
@@ -20,6 +20,7 @@ > module IL.XML(module IL.XML) where +> import Text.PrettyPrint.HughesPJ > import Data.Maybe > import Curry.Base.Ident@@ -27,7 +28,6 @@ > import IL.Type > import CurryEnv-> import PrettyCombinators
src/InterfaceCheck.hs view
@@ -11,7 +11,7 @@ import Data.List -import Curry.ExtendedFlat+import Curry.ExtendedFlat.Type
src/KindCheck.lhs view
@@ -28,6 +28,7 @@ > import Data.Maybe > import Curry.Syntax+> import Curry.Syntax.Utils(isTypeDecl) > import Curry.Base.Position > import Curry.Base.Ident > import Base hiding (bindArity)@@ -45,9 +46,9 @@ > kindCheck :: ModuleIdent -> TCEnv -> [Decl] -> [Decl] > kindCheck m tcEnv ds =-> case linear (map tconstr ds') of-> Linear -> map (checkDecl m kEnv) ds-> NonLinear tc -> errorAt' (duplicateType tc)+> case findDouble (map tconstr ds') of+> Nothing -> map (checkDecl m kEnv) ds+> Just tc -> errorAt' (duplicateType tc) > where ds' = filter isTypeDecl ds > kEnv = foldr (bindArity m) (fmap tcArity tcEnv) ds'
src/Modules.lhs view
@@ -21,7 +21,7 @@ > simpleCheckModule, checkModule > ) where -+> import Text.PrettyPrint.HughesPJ > import Data.List > import qualified Data.Map as Map > import System.IO@@ -31,10 +31,23 @@ > import Curry.Base.MessageMonad > import Curry.Base.Position > import Curry.Base.Ident++> import Curry.Files.Filenames+> import Curry.Files.PathUtils+ > import Curry.Syntax+> import Curry.Syntax.Utils(isImportDecl) > import Curry.Syntax.Pretty(ppModule,ppIDecl) > import Curry.Syntax.ShowModule(showModule) +> import Curry.ExtendedFlat.Type+> import qualified Curry.ExtendedFlat.Type as EF ++> import qualified IL.Type as IL+> import IL.CurryToIL(ilTrans)+> import qualified IL.Pretty(ppModule)+> import IL.XML(xmlModule)+ > import Base > import Types > import KindCheck(kindCheck)@@ -50,25 +63,21 @@ > import Desugar(desugar) > import Simplify(simplify) > import Lift(lift)-> import qualified IL.Type as IL-> import IL.CurryToIL(ilTrans)-> import IL.XML(xmlModule)-> import Curry.ExtendedFlat+ > import GenFlatCurry (genFlatCurry,genFlatInterface) > import qualified Curry.AbstractCurry as AC > import GenAbstractCurry > import InterfaceCheck > import CurryEnv-> import qualified IL.Pretty(ppModule)+ > import CurryCompilerOpts(Options(..),Dump(..)) > import CaseCompletion-> import PathUtils-> import Filenames++ > import TypeSubst-> import PrettyCombinators > import TopEnv-> import qualified Curry.ExtendedFlat as EF + \end{verbatim} The function \texttt{compileModule} is the main entry-point of this module for compiling a Curry source module. Depending on the command@@ -112,7 +121,10 @@ > writeModule outputFile outputMod > return Nothing > else-> do (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m+> do -- checkModule checks types, and then transModule introduces new+> -- functions (by lambda lifting in 'desugar'). Consequence: The+> -- type of the newly introduced functions are not inferred (hsi)+> (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m > let (il,aEnv',dumps) = transModule fcy False False > mEnv tyEnv tcEnv aEnv m' > mapM_ (doDump opts) dumps@@ -299,7 +311,7 @@ \begin{verbatim} > importLabels :: ModuleEnv -> [Decl] -> LabelEnv-> importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds+> importLabels mEnv ds = foldl importLabelTypes Map.empty ds > where > importLabelTypes lEnv (ImportDecl p m _ asM is) = > case (Map.lookup m mEnv) of@@ -456,32 +468,7 @@ Interface files are updated by the Curry builder when necessary. (see module \texttt{CurryBuilder}). -Description of the following obsolete functions:-After checking the module successfully, the compiler may need to-update the module's interface file. The file will be updated only if-the interface has been changed or the file did not exist before.--The code is a little bit tricky because we must make sure that the-interface file is closed before rewriting the interface, even if it-has not been read completely. On the other hand, we must not apply-\texttt{hClose} too early. Note that there is no need to close the-interface explicitly if the interface check succeeds because the whole-file must have been read in this case. In addition, we do not update-the interface file in this case and therefore it doesn't matter when-the file is closed.-\begin{verbatim}- \end{verbatim}-The compiler searches for interface files in the import search path-using the extension \texttt{".fint"}. Note that the current-directory is always searched first.-\begin{verbatim}--> lookupInterface :: [FilePath] -> ModuleIdent -> IO (Maybe FilePath)-> lookupInterface paths m = lookupFile ("":paths) [flatIntExt] ifn-> where ifn = foldr1 catPath (moduleQualifiers m)--\end{verbatim} The \texttt{doDump} function writes the selected information to the standard output. \begin{verbatim}@@ -500,9 +487,6 @@ > dumpHeader DumpLifted = "Source code after lifting" > dumpHeader DumpIL = "Intermediate code" > dumpHeader DumpCase = "Intermediate code after case simplification"-> --dumpHeader DumpTransformed = "Transformed code" -> --dumpHeader DumpNormalized = "Intermediate code after normalization"-> --dumpHeader DumpCam = "Abstract machine code" \end{verbatim}@@ -687,3 +671,23 @@ > > pos = first m > ts' = filter (not . isSpecialPreludeType) ts+++++\end{verbatim}+The label environment is used to store information of labels.+Unlike unsual identifiers like in functions, types etc. identifiers+of labels are always represented unqualified. Since the common type +environment (type \texttt{ValueEnv}) has some problems with handling +imported unqualified identifiers, it is necessary to process the type +information for labels seperately.+\begin{verbatim}++> data LabelInfo = LabelType Ident QualIdent Type deriving Show++> type LabelEnv = Map.Map Ident [LabelInfo]++> bindLabelType :: Ident -> QualIdent -> Type -> LabelEnv -> LabelEnv+> bindLabelType l r ty = Map.insertWith (++) l [LabelType l r ty]+
src/PatchPrelude.hs view
@@ -1,7 +1,7 @@ module PatchPrelude where -import Curry.ExtendedFlat+import Curry.ExtendedFlat.Type -- the prelude has to be extended by data declarations for list and tuples
− src/PathUtils.hs
@@ -1,122 +0,0 @@-{-- $Id: PathUtils.lhs,v 1.5 2003/05/04 16:12:35 wlux Exp $-- Copyright (c) 1999-2003, Wolfgang Lux- See LICENSE for the full license.--}--module PathUtils(-- re-exports from System.FilePath:- takeBaseName, -- replaceExtension,- dropExtension,- takeDirectory, takeExtension, - pathSeparator,- catPath,-- lookupModule, lookupFile, getCurryPath,- writeModule,readModule,- doesModuleExist,maybeReadModule,getModuleModTime) where--import System.FilePath-import System.Directory-import System.Time (ClockTime)--import Control.Monad (unless)--import Curry.Base.Ident-import Filenames---lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent- -> IO (Maybe FilePath)-lookupModule paths libraryPaths m- = lookupFile ("" : paths ++ libraryPaths) moduleExts fn- where fn = foldr1 catPath (moduleQualifiers m)--catPath :: FilePath -> FilePath -> FilePath-catPath = combine--lookupFile :: [FilePath] -> [String] -> String -> IO (Maybe FilePath)-lookupFile paths exts file = lookupFile' paths'- where- paths' = do p <- paths- e <- exts- let fn = p `combine` replaceExtension file e- [fn, inCurrySubdir fn]- lookupFile' [] = return Nothing- lookupFile' (fn:paths)- = do so <- doesFileExist fn- if so then return (Just fn) else lookupFile' paths------ add a subdirectory to a given filename --- if it is not already present------ inSubdir ""--inSubdir :: FilePath -> FilePath -> FilePath-inSubdir sub fn = joinPath $ add (splitDirectories fn) - where- add ps@[n] = sub:ps- add ps@[p,n] | p==sub = ps- add (p:ps) = p:add ps----The sub directory to hide files in:--currySubdir :: String -currySubdir = ".curry"--inCurrySubdir :: FilePath -> FilePath-inCurrySubdir = inSubdir currySubdir----write a file to curry subdirectory--writeModule :: FilePath -> String -> IO ()-writeModule filename contents = do- let filename' = inCurrySubdir filename- subdir = takeDirectory filename'- ensureDirectoryExists subdir- writeFile filename' contents--ensureDirectoryExists :: FilePath -> IO ()-ensureDirectoryExists dir- = do ex <- doesDirectoryExist dir- unless ex (createDirectory dir)---- do things with file in subdir--onExistingFileDo :: (FilePath -> IO a) -> FilePath -> IO a-onExistingFileDo act filename = do- ex <- doesFileExist filename- if ex then act filename - else act $ inCurrySubdir filename--readModule :: FilePath -> IO String-readModule = onExistingFileDo readFile--maybeReadModule :: FilePath -> IO (Maybe String)-maybeReadModule filename = - catch (readModule filename >>= return . Just) (\_ -> return Nothing)--doesModuleExist :: FilePath -> IO Bool-doesModuleExist = onExistingFileDo doesFileExist--getModuleModTime :: FilePath -> IO ClockTime-getModuleModTime = onExistingFileDo getModificationTime---{-- The function \verb|getCurryPath| searches in predefined paths- for the corresponding \texttt{.curry} or \texttt{.lcurry} file, - if the given file name has no extension.--}-getCurryPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)-getCurryPath paths fn = lookupFile filepaths exts fn- where- filepaths = "":paths'- fnext = takeExtension fn- exts | null fnext = sourceExts- | otherwise = [fnext]- paths' | pathSeparator `elem` fn = []- | otherwise = paths-
src/PrecCheck.lhs view
@@ -37,12 +37,12 @@ > bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv > bindPrecs m ds pEnv =-> case linear ops of-> Linear ->+> case findDouble ops of+> Nothing -> > case [ op | op <- ops, op `notElem` bvs] of > [] -> foldr bindPrec pEnv fixDs > op : _ -> errorAt' (undefinedOperator op)-> NonLinear op -> errorAt' (duplicatePrecedence op)+> Just op -> errorAt' (duplicatePrecedence op) > where (fixDs,nonFixDs) = partition isInfixDecl ds > bvs = concatMap boundValues nonFixDs > ops = [ op | InfixDecl p _ _ ops <- fixDs, op <- ops]
− src/PrettyCombinators.lhs
@@ -1,905 +0,0 @@-Hand converted to standard Haskell -- jcp--*********************************************************************************-* *-* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators *-* *-* based on "The Design of a Pretty-printing Library" *-* in Advanced Functional Programming, *-* Johan Jeuring and Erik Meijer (eds), LNCS 925 *-* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps *-* *-* Heavily modified by Simon Peyton Jones, Dec 96 *-* *-*********************************************************************************--Version 3.0 28 May 1997- * Cured massive performance bug. If you write-- foldl <> empty (map (text.show) [1..10000])-- you get quadratic behaviour with V2.0. Why? For just the same reason as you get- quadratic behaviour with left-associated (++) chains.-- This is really bad news. One thing a pretty-printer abstraction should- certainly guarantee is insensivity to associativity. It matters: suddenly- GHC's compilation times went up by a factor of 100 when I switched to the- new pretty printer.- - I fixed it with a bit of a hack (because I wanted to get GHC back on the- road). I added two new constructors to the Doc type, Above and Beside:- - <> = Beside- $$ = Above- - Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"- the Doc to squeeze out these suspended calls to Beside and Above; but in so- doing I re-associate. It's quite simple, but I'm not satisfied that I've done- the best possible job. I'll send you the code if you are interested.-- * Added new exports:- punctuate, hang- int, integer, float, double, rational,- lparen, rparen, lbrack, rbrack, lbrace, rbrace,-- * fullRender's type signature has changed. Rather than producing a string it- now takes an extra couple of arguments that tells it how to glue fragments- of output together:-- fullRender :: Mode- -> Int -- Line length- -> Float -- Ribbons per line- -> (TextDetails -> a -> a) -- What to do with text- -> a -- What to do at the end- -> Doc- -> a -- Result-- The "fragments" are encapsulated in the TextDetails data type:- data TextDetails = Chr Char- | Str String- | PStr FAST_STRING-- The Chr and Str constructors are obvious enough. The PStr constructor has a packed- string (FAST_STRING) inside it. It's generated by using the new "ptext" export.-- An advantage of this new setup is that you can get the renderer to do output- directly (by passing in a function of type (TextDetails -> IO () -> IO ()),- rather than producing a string that you then print.---Version 2.0 24 April 1997- * Made empty into a left unit for <> as well as a right unit;- it is also now true that- nest k empty = empty- which wasn't true before.-- * Fixed an obscure bug in sep that occassionally gave very wierd behaviour-- * Added $+$-- * Corrected and tidied up the laws and invariants--======================================================================-Relative to John's original paper, there are the following new features:--1. There's an empty document, "empty". It's a left and right unit for - both <> and $$, and anywhere in the argument list for- sep, hcat, hsep, vcat, fcat etc.-- It is Really Useful in practice.--2. There is a paragraph-fill combinator, fsep, that's much like sep,- only it keeps fitting things on one line until itc can't fit any more.--3. Some random useful extra combinators are provided. - <+> puts its arguments beside each other with a space between them,- unless either argument is empty in which case it returns the other--- hcat is a list version of <>- hsep is a list version of <+>- vcat is a list version of $$-- sep (separate) is either like hsep or like vcat, depending on what fits-- cat is behaves like sep, but it uses <> for horizontal conposition- fcat is behaves like fsep, but it uses <> for horizontal conposition-- These new ones do the obvious things:- char, semi, comma, colon, space,- parens, brackets, braces, - quotes, doubleQuotes- -4. The "above" combinator, $$, now overlaps its two arguments if the- last line of the top argument stops before the first line of the second begins.- For example: text "hi" $$ nest 5 "there"- lays out as- hi there- rather than- hi- there-- There are two places this is really useful-- a) When making labelled blocks, like this:- Left -> code for left- Right -> code for right- LongLongLongLabel ->- code for longlonglonglabel- The block is on the same line as the label if the label is- short, but on the next line otherwise.-- b) When laying out lists like this:- [ first- , second- , third- ]- which some people like. But if the list fits on one line- you want [first, second, third]. You can't do this with- John's original combinators, but it's quite easy with the- new $$.-- The combinator $+$ gives the original "never-overlap" behaviour.--5. Several different renderers are provided:- * a standard one- * one that uses cut-marks to avoid deeply-nested documents - simply piling up in the right-hand margin- * one that ignores indentation (fewer chars output; good for machines)- * one that ignores indentation and newlines (ditto, only more so)--6. Numerous implementation tidy-ups- Use of unboxed data types to speed up the implementation----\begin{code}-module PrettyCombinators (- Doc, -- Abstract- Mode(..), TextDetails(..),- Style,-- empty, nest,-- text, char, ptext,- int, integer, float, double, rational,- parens, brackets, braces, quotes, doubleQuotes,- semi, comma, colon, space, equals,- lparen, rparen, lbrack, rbrack, lbrace, rbrace,-- (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, -- hang, punctuate,- - renderStyle, - render, fullRender- ) where---- Don't import Util( assertPanic ) because it makes a loop in the module structure--import Data.Ratio-infixl 6 <> -infixl 6 <+>-infixl 5 $$, $+$-\end{code}----*********************************************************-* *-\subsection{CPP magic so that we can compile with both GHC and Hugs}-* *-*********************************************************--The library uses unboxed types to get a bit more speed, but these CPP macros-allow you to use either GHC or Hugs. To get GHC, just set the CPP variable- __GLASGOW_HASKELL__---*********************************************************-* *-\subsection{The interface}-* *-*********************************************************--The primitive @Doc@ values--\begin{code}-empty :: Doc-text :: String -> Doc -char :: Char -> Doc--semi, comma, colon, space, equals :: Doc-lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc--parens, brackets, braces :: Doc -> Doc -quotes, doubleQuotes :: Doc -> Doc--int :: Int -> Doc-integer :: Integer -> Doc-float :: Float -> Doc-double :: Double -> Doc-rational :: Rational -> Doc-\end{code}---Combining @Doc@ values--\begin{code}-(<>) :: Doc -> Doc -> Doc -- Beside-hcat :: [Doc] -> Doc -- List version of <>-(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space-hsep :: [Doc] -> Doc -- List version of <+>--($$) :: Doc -> Doc -> Doc -- Above; if there is no- -- overlap it "dovetails" the two-vcat :: [Doc] -> Doc -- List version of $$--cat :: [Doc] -> Doc -- Either hcat or vcat-sep :: [Doc] -> Doc -- Either hsep or vcat-fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat-fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep--nest :: Int -> Doc -> Doc -- Nested-\end{code}--GHC-specific ones.--\begin{code}-hang :: Doc -> Int -> Doc -> Doc-punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]-\end{code}--Displaying @Doc@ values. --\begin{code}-instance Show Doc where- showsPrec prec doc cont = showDoc doc cont--render :: Doc -> String -- Uses default style-fullRender :: Mode- -> Int -- Line length- -> Float -- Ribbons per line- -> (TextDetails -> a -> a) -- What to do with text- -> a -- What to do at the end- -> Doc- -> a -- Result--renderStyle :: Style -> Doc -> String-data Style = Style { lineLength :: Int, -- In chars- ribbonsPerLine :: Float, -- Ratio of ribbon length to line length- mode :: Mode- }-style :: Style -- The default style-style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }--data Mode = PageMode -- Normal - | ZigZagMode -- With zig-zag cuts- | LeftMode -- No indentation, infinitely long lines- | OneLineMode -- All on one line--\end{code}---*********************************************************-* *-\subsection{The @Doc@ calculus}-* *-*********************************************************--The @Doc@ combinators satisfy the following laws:-\begin{verbatim}-Laws for $$-~~~~~~~~~~~-<a1> (x $$ y) $$ z = x $$ (y $$ z)-<a2> empty $$ x = x-<a3> x $$ empty = x-- ...ditto $+$...--Laws for <>-~~~~~~~~~~~-<b1> (x <> y) <> z = x <> (y <> z)-<b2> empty <> x = empty-<b3> x <> empty = x-- ...ditto <+>...--Laws for text-~~~~~~~~~~~~~-<t1> text s <> text t = text (s++t)-<t2> text "" <> x = x, if x non-empty--Laws for nest-~~~~~~~~~~~~~-<n1> nest 0 x = x-<n2> nest k (nest k' x) = nest (k+k') x-<n3> nest k (x <> y) = nest k z <> nest k y-<n4> nest k (x $$ y) = nest k x $$ nest k y-<n5> nest k empty = empty-<n6> x <> nest k y = x <> y, if x non-empty--** Note the side condition on <n6>! It is this that-** makes it OK for empty to be a left unit for <>.--Miscellaneous-~~~~~~~~~~~~~-<m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$ - nest (-length s) y)--<m2> (x $$ y) <> z = x $$ (y <> z)- if y non-empty---Laws for list versions-~~~~~~~~~~~~~~~~~~~~~~-<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)- ...ditto hsep, hcat, vcat, fill...--<l2> nest k (sep ps) = sep (map (nest k) ps)- ...ditto hsep, hcat, vcat, fill...--Laws for oneLiner-~~~~~~~~~~~~~~~~~-<o1> oneLiner (nest k p) = nest k (oneLiner p)-<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y -\end{verbatim}---You might think that the following verion of <m1> would-be neater:-\begin{verbatim}-<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ - nest (-length s) y)-\end{verbatim}-But it doesn't work, for if x=empty, we would have-\begin{verbatim}- text s $$ y = text s <> (empty $$ nest (-length s) y)- = text s <> nest (-length s) y-\end{verbatim}----*********************************************************-* *-\subsection{Simple derived definitions}-* *-*********************************************************--\begin{code}-semi = char ';'-colon = char ':'-comma = char ','-space = char ' '-equals = char '='-lparen = char '('-rparen = char ')'-lbrack = char '['-rbrack = char ']'-lbrace = char '{'-rbrace = char '}'--int n = text (show n)-integer n = text (show n)-float n = text (show n)-double n = text (show n)-rational n = text (show n)--- SIGBJORN wrote instead:--- rational n = text (show (fromRationalX n))--quotes p = char '`' <> p <> char '\''-doubleQuotes p = char '"' <> p <> char '"'-parens p = char '(' <> p <> char ')'-brackets p = char '[' <> p <> char ']'-braces p = char '{' <> p <> char '}'---hcat = foldr (<>) empty-hsep = foldr (<+>) empty-vcat = foldr ($$) empty--hang d1 n d2 = d1 $$ (nest n d2)--punctuate p [] = []-punctuate p (d:ds) = go d ds- where- go d [] = [d]- go d (e:es) = (d <> p) : go e es-\end{code}---*********************************************************-* *-\subsection{The @Doc@ data type}-* *-*********************************************************--A @Doc@ represents a {\em set} of layouts. A @Doc@ with-no occurrences of @Union@ or @NoDoc@ represents just one layout.-\begin{code}-data Doc- = Empty -- empty- | NilAbove Doc -- text "" $$ x- | TextBeside TextDetails Int Doc -- text s <> x - | Nest Int Doc -- nest k x- | Union Doc Doc -- ul `union` ur- | NoDoc -- The empty set of documents- | Beside Doc Bool Doc -- True <=> space between- | Above Doc Bool Doc -- True <=> never overlap--type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside---reduceDoc :: Doc -> RDoc-reduceDoc (Beside p g q) = beside p g (reduceDoc q)-reduceDoc (Above p g q) = above p g (reduceDoc q)-reduceDoc p = p---data TextDetails = Chr Char- | Str String- | PStr String-space_text = Chr ' '-nl_text = Chr '\n'-\end{code}--Here are the invariants:-\begin{itemize}-\item-The argument of @NilAbove@ is never @Empty@. Therefore-a @NilAbove@ occupies at least two lines.--\item-The arugment of @TextBeside@ is never @Nest@.--\item -The layouts of the two arguments of @Union@ both flatten to the same string.--\item -The arguments of @Union@ are either @TextBeside@, or @NilAbove@.--\item-The right argument of a union cannot be equivalent to the empty set (@NoDoc@).-If the left argument of a union is equivalent to the empty set (@NoDoc@),-then the @NoDoc@ appears in the first line.--\item -An empty document is always represented by @Empty@.-It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.--\item -The first line of every layout in the left argument of @Union@-is longer than the first line of any layout in the right argument.-(1) ensures that the left argument has a first line. In view of (3),-this invariant means that the right argument must have at least two-lines.-\end{itemize}--\begin{code}- -- Arg of a NilAbove is always an RDoc-nilAbove_ p = NilAbove p-- -- Arg of a TextBeside is always an RDoc-textBeside_ s sl p = TextBeside s sl p-- -- Arg of Nest is always an RDoc-nest_ k p = Nest k p-- -- Args of union are always RDocs-union_ p q = Union p q--\end{code}---Notice the difference between- * NoDoc (no documents)- * Empty (one empty document; no height and no width)- * text "" (a document containing the empty string;- one line high, but has no width)----*********************************************************-* *-\subsection{@empty@, @text@, @nest@, @union@}-* *-*********************************************************--\begin{code}-empty = Empty--char c = textBeside_ (Chr c) 1 Empty-text s = case length s of {sl -> textBeside_ (Str s) sl Empty}-ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}--nest k p = mkNest k (reduceDoc p) -- Externally callable version---- mkNest checks for Nest's invariant that it doesn't have an Empty inside it-mkNest k (Nest k1 p) = mkNest (k + k1) p-mkNest k NoDoc = NoDoc-mkNest k Empty = Empty-mkNest 0 p = p -- Worth a try!-mkNest k p = nest_ k p---- mkUnion checks for an empty document-mkUnion Empty q = Empty-mkUnion p q = p `union_` q-\end{code}--*********************************************************-* *-\subsection{Vertical composition @$$@}-* *-*********************************************************---\begin{code}-p $$ q = Above p False q-p $+$ q = Above p True q--above :: Doc -> Bool -> RDoc -> RDoc-above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)-above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)-above p g q = aboveNest p g 0 (reduceDoc q)--aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc--- Specfication: aboveNest p g k q = p $g$ (nest k q)--aboveNest NoDoc g k q = NoDoc-aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` - aboveNest p2 g k q- -aboveNest Empty g k q = mkNest k q-aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)- -- p can't be Empty, so no need for mkNest- -aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)-aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest- where- k1 = k - sl- rest = case p of- Empty -> nilAboveNest g k1 q- other -> aboveNest p g k1 q-\end{code}--\begin{code}-nilAboveNest :: Bool -> Int -> RDoc -> RDoc--- Specification: text s <> nilaboveNest g k q --- = text s <> (text "" $g$ nest k q)--nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!-nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q--nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap- = textBeside_ (Str (spaces k)) k q- | otherwise -- Put them really above- = nilAbove_ (mkNest k q)-\end{code}---*********************************************************-* *-\subsection{Horizontal composition @<>@}-* *-*********************************************************--\begin{code}-p <> q = Beside p False q-p <+> q = Beside p True q--beside :: Doc -> Bool -> RDoc -> RDoc--- Specification: beside g p q = p <g> q- -beside NoDoc g q = NoDoc-beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)-beside Empty g q = q-beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty-beside p@(Beside p1 g1 q1) g2 q2 - {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 - [ && (op1 == <> || op1 == <+>) ] -}- | g1 == g2 = beside p1 g1 (beside q1 g2 q2)- | otherwise = beside (reduceDoc p) g2 q2-beside p@(Above _ _ _) g q = beside (reduceDoc p) g q-beside (NilAbove p) g q = nilAbove_ (beside p g q)-beside (TextBeside s sl p) g q = textBeside_ s sl rest- where- rest = case p of- Empty -> nilBeside g q- other -> beside p g q-\end{code}--\begin{code}-nilBeside :: Bool -> RDoc -> RDoc--- Specification: text "" <> nilBeside g p --- = text "" <g> p--nilBeside g Empty = Empty -- Hence the text "" in the spec-nilBeside g (Nest _ p) = nilBeside g p-nilBeside g p | g = textBeside_ space_text 1 p- | otherwise = p-\end{code}--*********************************************************-* *-\subsection{Separate, @sep@, Hughes version}-* *-*********************************************************--\begin{code}--- Specification: sep ps = oneLiner (hsep ps)--- `union`--- vcat ps--sep = sepX True -- Separate with spaces-cat = sepX False -- Don't--sepX x [] = empty-sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps----- Specification: sep1 g k ys = sep (x : map (nest k) ys)--- = oneLiner (x <g> nest k (hsep ys))--- `union` x $$ nest k (vcat ys)--sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc-sep1 g NoDoc k ys = NoDoc-sep1 g (p `Union` q) k ys = sep1 g p k ys- `union_`- (aboveNest q False k (reduceDoc (vcat ys)))--sep1 g Empty k ys = mkNest k (sepX g ys)-sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)--sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))-sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)---- Specification: sepNB p k ys = sep1 (text "" <> p) k ys--- Called when we have already found some text in the first item--- We have to eat up nests--sepNB g (Nest _ p) k ys = sepNB g p k ys--sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))- `mkUnion` - nilAboveNest False k (reduceDoc (vcat ys))- where- rest | g = hsep ys- | otherwise = hcat ys--sepNB g p k ys = sep1 g p k ys-\end{code}--*********************************************************-* *-\subsection{@fill@}-* *-*********************************************************--\begin{code}-fsep = fill True-fcat = fill False---- Specification: --- fill [] = empty--- fill [p] = p--- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) --- (fill (oneLiner p2 : ps))--- `union`--- p1 $$ fill ps--fill g [] = empty-fill g (p:ps) = fill1 g (reduceDoc p) 0 ps---fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc-fill1 g NoDoc k ys = NoDoc-fill1 g (p `Union` q) k ys = fill1 g p k ys- `union_`- (aboveNest q False k (fill g ys))--fill1 g Empty k ys = mkNest k (fill g ys)-fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)--fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))-fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)--fillNB g (Nest _ p) k ys = fillNB g p k ys-fillNB g Empty k [] = Empty-fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)- `mkUnion` - nilAboveNest False k (fill g (y:ys))- where- k1 | g = k - 1- | otherwise = k--fillNB g p k ys = fill1 g p k ys-\end{code}---*********************************************************-* *-\subsection{Selecting the best layout}-* *-*********************************************************--\begin{code}-best :: Mode- -> Int -- Line length- -> Int -- Ribbon length- -> RDoc- -> RDoc -- No unions in here!--best OneLineMode w r p- = get p- where- get Empty = Empty- get NoDoc = NoDoc- get (NilAbove p) = nilAbove_ (get p)- get (TextBeside s sl p) = textBeside_ s sl (get p)- get (Nest k p) = get p -- Elide nest- get (p `Union` q) = first (get p) (get q)--best mode w r p- = get w p- where- get :: Int -- (Remaining) width of line- -> Doc -> Doc- get w Empty = Empty- get w NoDoc = NoDoc- get w (NilAbove p) = nilAbove_ (get w p)- get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)- get w (Nest k p) = nest_ k (get (w - k) p)- get w (p `Union` q) = nicest w r (get w p) (get w q)-- get1 :: Int -- (Remaining) width of line- -> Int -- Amount of first line already eaten up- -> Doc -- This is an argument to TextBeside => eat Nests- -> Doc -- No unions in here!-- get1 w sl Empty = Empty- get1 w sl NoDoc = NoDoc- get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)- get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)- get1 w sl (Nest k p) = get1 w sl p- get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) - (get1 w sl q)--nicest w r p q = nicest1 w r 0 p q-nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p- | otherwise = q--fits :: Int -- Space available- -> Doc- -> Bool -- True if *first line* of Doc fits in space available- -fits n p | n < 0 = False-fits n NoDoc = False-fits n Empty = True-fits n (NilAbove _) = True-fits n (TextBeside _ sl p) = fits (n - sl) p--minn x y | x < y = x- | otherwise = y-\end{code}--@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.-@first@ returns its first argument if it is non-empty, otherwise its second.--\begin{code}-first p q | nonEmptySet p = p - | otherwise = q--nonEmptySet NoDoc = False-nonEmptySet (p `Union` q) = True-nonEmptySet Empty = True-nonEmptySet (NilAbove p) = True -- NoDoc always in first line-nonEmptySet (TextBeside _ _ p) = nonEmptySet p-nonEmptySet (Nest _ p) = nonEmptySet p-\end{code}--@oneLiner@ returns the one-line members of the given set of @Doc@s.--\begin{code}-oneLiner :: Doc -> Doc-oneLiner NoDoc = NoDoc-oneLiner Empty = Empty-oneLiner (NilAbove p) = NoDoc-oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)-oneLiner (Nest k p) = nest_ k (oneLiner p)-oneLiner (p `Union` q) = oneLiner p-\end{code}----*********************************************************-* *-\subsection{Displaying the best layout}-* *-*********************************************************---\begin{code}-renderStyle Style{mode=mode, lineLength=lineLength, ribbonsPerLine=ribbonsPerLine} doc - = fullRender mode lineLength ribbonsPerLine string_txt "" doc--render doc = showDoc doc ""-showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc--string_txt (Chr c) s = c:s-string_txt (Str s1) s2 = s1 ++ s2-string_txt (PStr s1) s2 = s1 ++ s2-\end{code}--\begin{code}--fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)-fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)--fullRender mode line_length ribbons_per_line txt end doc- = display mode line_length ribbon_length txt end best_doc- where - best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)-- hacked_line_length, ribbon_length :: Int- ribbon_length = round (fromIntegral line_length / ribbons_per_line)- hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }--display mode page_width ribbon_width txt end doc- = case page_width - ribbon_width of { gap_width ->- case gap_width `quot` 2 of { shift ->- let- lay k (Nest k1 p) = lay (k + k1) p- lay k Empty = end- - lay k (NilAbove p) = nl_text `txt` lay k p- - lay k (TextBeside s sl p)- = case mode of- ZigZagMode | k >= gap_width- -> nl_text `txt` (- Str (multi_ch shift '/') `txt` (- nl_text `txt` (- lay1 (k - shift) s sl p)))-- | k < 0- -> nl_text `txt` (- Str (multi_ch shift '\\') `txt` (- nl_text `txt` (- lay1 (k + shift) s sl p )))-- other -> lay1 k s sl p- - lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)- - lay2 k (NilAbove p) = nl_text `txt` lay k p- lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)- lay2 k (Nest _ p) = lay2 k p- lay2 k Empty = end- in- lay 0 doc- }}--cant_fail = error "easy_display: NoDoc"-easy_display nl_text txt end doc - = lay doc cant_fail- where- lay NoDoc no_doc = no_doc- lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc- lay (Nest k p) no_doc = lay p no_doc- lay Empty no_doc = end- lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line- lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc--indent n | n >= 8 = '\t' : indent (n - 8)- | otherwise = spaces n--multi_ch 0 ch = ""-multi_ch n ch = ch : multi_ch (n - 1) ch--spaces 0 = ""-spaces n = ' ' : spaces (n - 1)-\end{code}-
src/ScopeEnv.hs view
@@ -21,6 +21,13 @@ ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- +-- Data type for representing information in nested scopes.+data ScopeEnv a b = ScopeEnv Int (Map.Map a (b,Int)) [Map.Map a (b,Int)]+ deriving Show+++-------------------------------------------------------------------------------+------------------------------------------------------------------------------- -- Returns an empty scope environment new :: Ord a => ScopeEnv a b new = ScopeEnv 0 Map.empty []@@ -162,14 +169,6 @@ else local') (Map.lookup key local) ---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Data type for representing information in nested scopes.-data ScopeEnv a b = ScopeEnv Int (Map.Map a (b,Int)) [Map.Map a (b,Int)]- deriving Show -------------------------------------------------------------------------------
src/Simplify.lhs view
@@ -374,7 +374,7 @@ > _ -> > do > v0 <- freshIdent m patternId (monoType (typeOf tyEnv t))-> let v = addRefId (ast p) v0+> let v = addRefId (srcRefOf p) v0 > return [PatternDecl p t (SimpleRhs p (mkVar v) []), > PatternDecl p (VariablePattern v) rhs] > where patternId n = mkIdent ("_#pat" ++ show n)
src/Subst.lhs view
@@ -1,6 +1,3 @@-% -*- LaTeX -*--% $Id: Subst.lhs,v 1.7 2002/12/20 13:12:51 lux Exp $-% % Copyright (c) 2002, Wolfgang Lux % See LICENSE for the full license. %
src/SyntaxCheck.lhs view
@@ -50,11 +50,11 @@ > syntaxCheck :: Bool -> ModuleIdent -> ImportEnv -> ArityEnv -> ValueEnv -> TCEnv -> [Decl] -> [Decl] > syntaxCheck withExt m iEnv aEnv tyEnv tcEnv ds =-> case linear (concatMap constrs tds) of-> --Linear -> tds ++ run (checkModule withExt m env vds)-> Linear -> map (checkTypeDecl withExt m) tds+> case findDouble (concatMap constrs tds) of+> --Nothing -> tds ++ run (checkModule withExt m env vds)+> Nothing -> map (checkTypeDecl withExt m) tds > ++ run (checkModule withExt m env2 vds)-> NonLinear c -> errorAt' (duplicateData c)+> Just c -> errorAt' (duplicateData c) > where (tds,vds) = partition isTypeDecl ds > (rs, tds') = partition isRecordDecl tds > env1 = foldr (bindTypes m) -- (bindConstrs m) @@ -143,9 +143,9 @@ > bindTypes m (DataDecl _ tc _ cs) env = foldr (bindConstr m) env cs > bindTypes m (NewtypeDecl _ tc _ nc) env = bindNewConstr m nc env > bindTypes m (TypeDecl _ t _ (RecordType fs r)) env =-> -- | isJust r = internalError "bindTypes: illegal record declaration"-> -- | null fs = errorAt (positionOfIdent t) emptyRecord-> -- | otherwise =+> -- - | isJust r = internalError "bindTypes: illegal record declaration"+> -- - | null fs = errorAt (positionOfIdent t) emptyRecord+> -- - | otherwise = > case (qualLookupVar (qualifyWith m t) env) of > [] -> foldr (bindRecordLabel m t (concatMap fst fs)) env fs > rs | any isConstr rs -> errorAt' (illegalRecordId t)@@ -375,19 +375,19 @@ > checkDecls :: (Decl -> RenameEnv -> RenameEnv) -> Bool -> ModuleIdent > -> RenameEnv -> [Decl] -> RenameState (RenameEnv,[Decl]) > checkDecls bindDecl withExt m env ds = -> case linear bvs of-> Linear ->-> case linear tys of-> Linear ->-> case linear evs of-> Linear ->+> case findDouble bvs of+> Nothing ->+> case findDouble tys of+> Nothing ->+> case findDouble evs of+> Nothing -> > case filter (`notElem` tys) fs' of > [] -> liftM ((,) env') > (mapM (checkDeclRhs withExt bvs m env'') ds) > f : _ -> errorAt' (noTypeSig f)-> NonLinear v -> errorAt' (duplicateEvalAnnot v)-> NonLinear v -> errorAt' (duplicateTypeSig v)-> NonLinear v -> errorAt' (duplicateDefinition v)+> Just v -> errorAt' (duplicateEvalAnnot v)+> Just v -> errorAt' (duplicateTypeSig v)+> Just v -> errorAt' (duplicateDefinition v) > where vds = filter isValueDecl ds > tds = filter isTypeSig ds > bvs = concat (map vars vds)@@ -472,9 +472,9 @@ > checkConstrTerms :: QuantExpr t => Bool -> RenameEnv -> t > -> (RenameEnv,t) > checkConstrTerms withExt env ts =-> case linear bvs of-> Linear -> (foldr bindVar env bvs,ts)-> NonLinear v -> errorAt' (duplicateVariable v)+> case findDouble bvs of+> Nothing -> (foldr bindVar env bvs,ts)+> Just v -> errorAt' (duplicateVariable v) > where bvs = bv ts > checkConstrTerm :: Bool -> Int -> Position -> ModuleIdent -> RenameEnv
src/SyntaxColoring.hs view
@@ -129,7 +129,7 @@ getPositionFromString :: String -> Maybe Position getPositionFromString message = if line > 0 && col > 0 - then Just Position{file=file,line=line,column=col,ast=noRef}+ then Just Position{file=file,line=line,column=col,astRef=noRef} else Nothing where file = takeWhile (/= '"') (tail (dropWhile (/= '"') message))
src/TopEnv.lhs view
@@ -34,11 +34,12 @@ imported. \begin{verbatim} -> module TopEnv(TopEnv, Entity(..), emptyTopEnv,+> module TopEnv(TopEnv(..), Entity(..), emptyTopEnv, > predefTopEnv,qualImportTopEnv,importTopEnv, > bindTopEnv,qualBindTopEnv,rebindTopEnv,qualRebindTopEnv, > unbindTopEnv,lookupTopEnv,qualLookupTopEnv,-> allImports,moduleImports,localBindings) where+> allImports,moduleImports,localBindings+> ) where > import Data.Maybe > import qualified Data.Map as Map@@ -55,7 +56,8 @@ > | origName x == origName y = Just x > | otherwise = Nothing -> newtype TopEnv a = TopEnv (Map.Map QualIdent [(Source,a)]) deriving Show+> newtype TopEnv a = TopEnv { topEnvMap :: Map.Map QualIdent [(Source,a)] +> } deriving Show > instance Functor TopEnv where > fmap f (TopEnv env) = TopEnv (fmap (map (second f)) env)
src/TypeCheck.lhs view
@@ -23,6 +23,7 @@ > module TypeCheck(typeCheck) where +> import Text.PrettyPrint.HughesPJ > import Control.Monad.State as S > import Data.List > import Data.Maybe@@ -38,7 +39,6 @@ > import Base > import Types-> import PrettyCombinators > import TopEnv > import SCC > import TypeSubst@@ -478,7 +478,7 @@ > tcConstrTerm m tcEnv sigs p (ParenPattern t) = tcConstrTerm m tcEnv sigs p t > tcConstrTerm m tcEnv sigs p (TuplePattern _ ts) > | null ts = return unitType-> | otherwise = liftM tupleType $ mapM (tcConstrTerm m tcEnv sigs p) ts -- $+> | otherwise = liftM tupleType $ mapM (tcConstrTerm m tcEnv sigs p) ts > tcConstrTerm m tcEnv sigs p t@(ListPattern _ ts) = > freshTypeVar >>= flip (tcElems (ppConstrTerm 0 t)) ts > where tcElems _ ty [] = return (listType ty)@@ -577,7 +577,7 @@ > tcConstrTermFP m tcEnv sigs p (ParenPattern t) = tcConstrTermFP m tcEnv sigs p t > tcConstrTermFP m tcEnv sigs p (TuplePattern _ ts) > | null ts = return unitType-> | otherwise = liftM tupleType $ mapM (tcConstrTermFP m tcEnv sigs p) ts -- $+> | otherwise = liftM tupleType $ mapM (tcConstrTermFP m tcEnv sigs p) ts > tcConstrTermFP m tcEnv sigs p t@(ListPattern _ ts) = > freshTypeVar >>= flip (tcElems (ppConstrTerm 0 t)) ts > where tcElems _ ty [] = return (listType ty)@@ -700,7 +700,7 @@ > tcExpr m tcEnv sigs p (Paren e) = tcExpr m tcEnv sigs p e > tcExpr m tcEnv sigs p (Tuple _ es) > | null es = return unitType-> | otherwise = liftM tupleType $ mapM (tcExpr m tcEnv sigs p) es -- $+> | otherwise = liftM tupleType $ mapM (tcExpr m tcEnv sigs p) es > tcExpr m tcEnv sigs p e@(List _ es) = freshTypeVar >>= tcElems (ppExpr 0 e) es > where tcElems _ [] ty = return (listType ty) > tcElems doc (e:es) ty =@@ -975,7 +975,7 @@ > unify :: Position -> String -> Doc -> ModuleIdent -> Type -> Type > -> TcState () > unify p what doc m ty1 ty2 =-> S.lift $ {-$-}+> S.lift $ > do > theta <- S.get > let ty1' = subst theta ty1
src/Typing.lhs view
@@ -16,6 +16,7 @@ > import Curry.Base.Ident > import Curry.Syntax+> import Curry.Syntax.Utils > import Types > import Base@@ -148,7 +149,7 @@ > argType tyEnv (ParenPattern t) = argType tyEnv t > argType tyEnv (TuplePattern _ ts) > | null ts = return unitType-> | otherwise = liftM tupleType $ mapM (argType tyEnv) ts -- $+> | otherwise = liftM tupleType $ mapM (argType tyEnv) ts > argType tyEnv (ListPattern _ ts) = freshTypeVar >>= flip elemType ts > where elemType ty [] = return (listType ty) > elemType ty (t:ts) =
src/Utils.lhs view
@@ -1,4 +1,3 @@-% -*- LaTeX -*- % $Id: Utils.lhs,v 1.4 2003/10/04 17:04:38 wlux Exp $ % % Copyright (c) 2001-2003, Wolfgang Lux@@ -12,8 +11,6 @@ \begin{verbatim} > module Utils where--> import Data.List(foldl') > infixr 5 ++!
src/cymake.hs view
@@ -13,6 +13,8 @@ module Main(main) where ++ import Data.List import Data.Maybe import System.IO@@ -21,6 +23,7 @@ import Control.Monad (unless) import Data.Char (isDigit) + import GetOpt import CurryBuilder(buildCurry) import CurryCompilerOpts@@ -45,7 +48,7 @@ | null errs' && not (elem Html opts) = do unless (noVerb options') (putStrLn $ "This is cymake, version 0.1." - ++ filter isDigit "$Revision: 3630 $")+ ++ filter isDigit "$Revision: 3680 $") mapM_ (buildCurry options') files | null errs' = do let importFiles = nub $ importPaths opts'