pax_global_header00006660000000000000000000000064130265131170014511gustar00rootroot0000000000000052 comment=8d20a558ca2967d0f5b4acfd160daa686d26e55b curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/000077500000000000000000000000001302651311700224565ustar00rootroot00000000000000curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/.gitignore000066400000000000000000000000761302651311700244510ustar00rootroot00000000000000cabal-dev/ dist/ .curry/ .cabal-sandbox/ cabal.sandbox.config curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/CHANGELOG.md000066400000000000000000000215141302651311700242720ustar00rootroot00000000000000Change log for curry-frontend ============================= Under development (0.4.1) ================= * Added a simple cabal test suite * Split import of interfaces/modules and expansion and checking of import specifications into two modules. * Improved error messages generated by export check (fixes #1253) * Split checking and expansion of export specification into two subsequent steps (by Yannik Potdevin, fixes #1335) * Consider parenthesized type expressions in the Curry AST (by Katharina Rahf) Version 0.4.0 ============= * Refactored AbstractCurry generation * Complete refactoring of FlatCurry generation * Removed support for Curry's record syntax and introduced Haskell's record syntax instead * During desugaring record updates are translated to fcase-expressions instead of introducing explicit update functions * HTML generation now places HTML files for hierarchical modules into files named `_curry.html`, i.e., no sub-folders reflecting the the module name hierarchy are generated. In addition, if the option `--html-dir` is not given, the current directory is used as the output directory. * Removed record type extensions * Enabled declaration of (mutually) recursive record types * Removed expansion of record types in type error messages * Replaced `MessageM` monad with `CYT` monads and moved `CYT` monads to package `curry-base` * Implemented warnings for overlapping module aliases - fixes #14 * The check for overlapping rules has been completely refactored and improved to now also handle rigid case expressions. * The check for missing pattern matching alternatives now correctly handles String literals - fixes #1048. * Added warnings for top-level functions without type signatures - fixes #769 * Moved pretty-printing of types from Checks.TypeCheck to Base.CurryTypes * Type synonyms in typed expressions are now desugared - fixes #921 * Declaration of operator precedence is now optional in infix operator declarations * Moved module `InterfaceEquivalence` to curry-base (`Curry.Syntax.InterfaceEquivalence`) * Converted literate Haskell files into simple Haskell files * Removed support for FlatCurry XML files. * Added syntax extension `NegativeLiterals` to translate negated literals into negative literals instead of a call to `Prelude.negate` and `Prelude.negateFloat`, respectively. * The frontend now considers options pragmas of the following form: ~~~ {.curry} {-# OPTIONS_CYMAKE opt1 ... optn #-} ~~~ The string following `OPTIONS_CYMAKE` will be split at white spaces and treated like an ordinary command line argument string. If one wishes to provide options containing spaces, e.g., directory paths or alike, this can be achieved by quoting the respective argument using either `'single quotes'` or `'double quotes'` (may bot be mixed). Note that *following options are excluded*: * A change of the current mode (e.g., change from compilation to HTML generation) * A change of the import paths * A change of the library paths * A change of the compilation targets (e.g., change from FlatCurry to AbstractCurry) These options can only be set via the command line. * Refactored the source code HTML generation. The generation now supports full Curry with all supported extensions, i.e., it supports pragmas, record types and functional patterns. Furthermore, the created HTML has been simplified, and updated towards HTML 5. * The HTML generation now accepts an option `--htmldir=dir` to specify the output directory of the generated HTML files. Version 0.3.10 ============== * Various improvements of the internal structure. * Improved status messages. The compilation status message are now of the form [m of n] Compiling/Skipping (, ) * Implemented support for custom preprocessors. It is now possible to run a custom preprocessor command via the following options: * `-F` enables support for a preprocessor * `-pgmF ` set the preprocessor command to `` * `-optF ` adds an additional argument to the preprocessor command (can be repeated to add multiple arguments) The preprocessor is applied to all source files which are (re)compiled after unliterating *and after determining the import list*. Consequently, adding modules via the preprocessor will results in compilation errors due to missing imports. On the other hand, the frontend will automatically determine changed files which are then handed to the preprocessor. The command is called with at least three arguments: #. The (normalised) file name of the source file currently processed. **This name is intended only for reference.** #. The name of the file containing the (potentially unliterated) contents of the original file. **This is the file the preprocessor should read from.** #. The name of the file where the preprocessed source code should go to. **This is the file the preprocessor should write to.** #. Optionally, any additional arguments specified using `-optF`. Version 0.3.9 ============= * Simplified verbosity options by merging options "-v1" and "-v2". Now only "-v0" and "-v1" are supported. * Fixed bug in non-exhaustive pattern matching check which occured when retrieving the siblings of a constructor imported using an alias. * Fixed bug when using functional patterns in `case`-expressions. Functional patterns are only allowed in the patterns of a function definition and forbidden elsewhere, i.e., in `case`-expressions, `do`-sequences, list comprehensions or lambda expressions. * Implementation of module pragmas added. Module pragmas of the following types are now parsed and represented in the abstract syntax tree: ~~~ {.curry} {-# LANGUAGE LANG_EXT+ #-} {-# OPTIONS "string" #-} {-# OPTIONS_TOOL "string" #-} module Main where ~~~ where - `LANGEXT+` is a non-empty, comma-separated list of the following language extensions: `AnonFreeVars`, `FunctionalPatterns`, `NoImplicitPrelude`, `Records` - `TOOL` is either `KICS2`, `PAKCS`, or some other tool, represented as `Unknown String`. While the distinct language pragmas enable the respective language extensions, the OPTIONS pragma is ignored. All other texts given in the pragma braces is ignored and treated as a nested comment. * Error message for different arities of function equations now also report the corresponding source code positions. Version 0.3.8 ============= * Implemented warnings for non-exhaustive pattern matchings both in function declarations and `case`-expressions - fixes #349. * Extended options to enable/disable certain types of warnings. * Fixed problem when defining an operator directly after an import statement without import restrictions - fixes #494. * Fixed bug w.r.t. polymorphically typed local variables - fixes #480. * Fixed missing polymorphism in record labels - fixes #445. * Dumping of intermediate structures improved. * Fixed bug in type checking w.r.t. recursive type synonyms - fixes 489. * Reactivation of Curry interface files. During adaption of the MCC frontend to FlatCurry the Curry interface files have been deactivated and replaced by FlatCurry's interface files. To allow the later addition of type classes to Curry, they have now been reactivated. * Implemented missing semantics of functional patterns in combination with non-linear left-hand-sides and as-patterns. * Various improvements. Version 0.3.7 ============= * Support for typed FlatCurry expressions added. Now additional type information given by the programmer as in ~~~ {.curry} null (unknown :: [()]) ~~~ is represented in FlatCurry and cann therefore be processed by other programs like PAKCS or KICS2. Version 0.3.6 ============= * Error messages are now sorted according to their source code position. Version 0.3.5 ============= * Improved reporting of mutiple type signatures. Version 0.3.4 ============= * Bug in renaming phase fixed. Version 0.3.3 ============= * Corrected translation of `fcase`-expressions. Version 0.3.2 ============= * Non-linear left-hand-sides now work with guarded expressions - fixes #328. * Implemented precedence check - fixes #327. * Case completion refactored and corrected - fixes #323. * Various improvements and refactorings. Version 0.3.1 ============= * Corrected renaming of anonymous free variables - fixes #288. Version 0.3.0 ============= * Massive refactoring of the previous version. * All compiler warnings removed. * Fixed various implementation bugs (#9, #16, #19, #29, #289). curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/LICENSE000066400000000000000000000027461302651311700234740ustar00rootroot00000000000000Copyright (c) 1998-2004, Wolfgang Lux Copyright (c) 2005-2016, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. None of the names of the copyright holders and contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/LIESMICH000066400000000000000000000125661302651311700236100ustar00rootroot00000000000000=============================================================================== == == Münster-Curry-Compiler == Distribution zur Anwendung als Frontend in PAKCS == == Letztes Update: 27.10.05 Diese Distribution enthält die modifizierte Version des Münster-Curry-Compilers (MCC) für die Verwendung als Frontend in PAKCS. Dieses System ist u.a. in der Lage aus Curry-Programmen (entwickelt nach PAKCS-Standard) Flat-Darstellungen (FlatCurry ".fcy", FlatInterface ".fint" und FlatXML "_flat.xml"), sowie Abstract-Darstellungen (AbstractCurry ".acy" und untyped AbstractCurry ".uacy") zu generieren. 1. Installation --------------- 1.1 Installation der Binary-Distribution Die Binary-Distribution befindet sich in einem tar-Archiv und wird durch folgendes Kommando entpackt: tar zxvf .tar.gz Danach steht der Compiler im Verzeichnis 'mcc' zur Verfügung. 1.2 Installation der Source-Distribution Nach dem Entpacken des tar-Archivs mittels tar zxvf .tar.gz kann der Compiler durch Aufruf von 'make' im Verzeichnis 'mcc' installiert werden. Bei Recompilierung (z.B. nach Änderungen in der Quelldateien) wird empfohlen vor einer erneuten Installation 'make clean' auszuführen. Nach erfolgreicher Installation befindet sich in beiden Fällen im Verzeichnis 'mcc/bin/' folgende ausführbare Datei: cymake - der Curry-Programm-Builder Dieses Tool übersetzt Curry-Programme unter Berücksichtigung der Import- abhängigkeiten. 2. Kommandoübersicht -------------------- In der folgenden Tabelle sind die Optionen zur Generierung der jeweiligen Darstellungen für das Kommando 'cymake' aufgelistet: --flat : Erzeugt FlatCurry- und FlatInterface-Datei --xml : Erzeugt FlatXML-Datei --acy : Erzeugt (typinferierte) AbstractCurry-Datei --uacy : Erzeugt ungetypte AbstractCurry-Datei 3. Erzeugung von FlatCurry- und FlatXML-Programmen -------------------------------------------------- Die Übersetzung eines Curry-Programms 'file.curry', sowie sämtlicher importierter Module nach FlatCurry bzw. FlatInterface, bewirkt folgendes Kommando: cymake --flat Hierdurch werden die Dateien mit den entsprechenden Endungen ".fcy" und ".fint" generiert. Der Dateiname kann hierbei mit oder ohne Endung ".curry" bzw. ".lcurry" angegeben werden. Die analogen Übersetzungen in die FlatXML-Darstellung bewirkt folgendes Kommando: cymake --xml Die hierdurch generierte Flat-XML-Datei hat die Endung '_flat.xml'. 4. Erzeugung von AbstractCurry-Programmen ----------------------------------------- Die Übersetzung eines Curry-Programms 'file.curry' nach (typgeprüftem) AbstractCurry bewirkt folgendes Kommando: cymake --acy Hierdurch wird die entsprechende Datei (mit der Endung ".acy") generiert. Der Dateiname kann hierbei mit oder ohne Endung ".curry" bzw. ".lcurry" angegeben werden. Ungetypte, bzw. typsignierte AbstractCurry-Programme werden mit folgendem Kommando generiert: cymake --uacy Die hierdurch generierte Datei besitzt die Endung ".uacy". Die Generierung des ungetypten AbstractCurry-Programms findet ohne Typüberprüfung statt (d.h. auch Programme mit Typfehlern werden übersetzt). Alle Funktionen besitzen entweder die im Quellprogramm angegebenen Typsignatur, oder, sofern diese nicht vorhanden ist, den Dummy-Typ "prelude.untyped". In beiden Fällen werden für die Übersetzung FlatCurry-Dateien für alle importierten Module erzeugt. Dies ist notwendig, da die entsprechenden Interfaces für die Typinferenz (nur im Fall der getypten AbstractCurry-Generierung) und die statisch-semantische Analyse benötigt werden. 5. Anmerkungen -------------- - Um die PAKCS-Bibliotheken (insbesondere die Prelude) für Übersetzungen nutzen zu können muß die Umgebungsvariable 'PAKCS_LIB' auf die entsprechenden Pfade verweisen, z.B. mittels export PAKCS_LIB=/pacs/lib:/pacs/lib/meta:... wobei das Verzeichnis ist, das die PAKCS-Distribution enthält. - Im Gegensatz zu PAKCS erlaubt das Frontend die Verwendung anonymer Variablen (dargestellt durch dem Unterstrich '_') in Typdeklarationen, z.B. data T _ = C Bekannte Probleme ------------------ - Lambda-, do-, if-, case-, oder let-Ausdrücke, die in Argumenten von Funktionsaufrufen verwendet werden, müssen immer geklammert werden. - 'let'-Anweisungen dürfen nicht folgendes Layout besitzen: let x = in ... - Die Regeln einer Funktionsdeklaration müssen immer zusammenstehen, d.h. nicht durch andere Deklarationen unterbrochen werden. - Es ist bislang nicht möglich, den Konstruktor für leere Listen [], sowie den Unit-Konstruktor () zu qualifizieren (z.B. führt 'prelude.[]' zu einem Fehler). Der Listenkonstruktor (:), sowie Tupel-Konstruktoren dagegen sind qualifizierbar. - FlatXML-Übersetzungen können derzeit mittels der Funktionen aus dem PAKCS-Modul "FlatXML" noch nicht eingelesen werden, da es Unstimmigkeiten zwischen dem generierten und den erforderlichen Formaten gibt. - Bei der Erzeugung von typgeprüftem AbstractCurry können die im Quelltext verwendeten Bezeichner für Typvariablen nicht ins AbstractCurry-Programm übernommen werden. Stattdessen generiert der Übersetzer neue Bezeichner. - Bei der Erzeugung von ungetyptem AbstractCurry werden Typsynonyme in Typsignaturen von Funktionen nicht dereferenziert. - Das Frontend gibt derzeit noch keinerlei Warnungen aus. curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/Setup.hs000066400000000000000000000000561302651311700241130ustar00rootroot00000000000000import Distribution.Simple main = defaultMain curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/curry-frontend.cabal000066400000000000000000000066411302651311700264320ustar00rootroot00000000000000Name: curry-frontend Version: 0.4.1 Cabal-Version: >= 1.10 Synopsis: Compile the functional logic language Curry to several intermediate formats Description: The Curry Frontend consists of the executable program "cymake". It is used by various backends to compile Curry programs to an intermediate representation. The code is a stripped-down version of an early version of the Muenster Curry Compiler () which has been extended to produce different intermediate representations. Category: Language License: BSD-3-clause License-File: LICENSE Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel, Bjoern Peemoeller Maintainer: Bjoern Peemoeller Bug-Reports: mailto:bjp@informatik.uni-kiel.de Homepage: http://curry-language.org Build-Type: Simple Stability: experimental Extra-Source-Files: LIESMICH Data-Dir: data Data-Files: currysource.css source-repository head type: git location: https://git.ps.informatik.uni-kiel.de/curry/curry-frontend.git Flag network-uri description: Get Network.URI from the network-uri package default: True Library hs-source-dirs: src default-language: Haskell2010 Build-Depends: base == 4.* , containers , curry-base == 0.4.2 , directory , filepath , mtl , process , syb , transformers if flag(network-uri) build-depends: network-uri >= 2.6 else build-depends: network < 2.6 Exposed-Modules: Base.CurryTypes , Base.Expr , Base.Messages , Base.NestEnv , Base.SCC , Base.Subst , Base.TopEnv , Base.Types , Base.TypeSubst , Base.Typing , Base.Utils , Checks , Checks.ExportCheck , Checks.InterfaceCheck , Checks.InterfaceSyntaxCheck , Checks.ImportSyntaxCheck , Checks.KindCheck , Checks.PrecCheck , Checks.SyntaxCheck , Checks.TypeCheck , Checks.WarnCheck , CompilerEnv , CompilerOpts , CurryBuilder , CurryDeps , Env.Interface , Env.ModuleAlias , Env.OpPrec , Env.TypeConstructor , Env.Value , Exports , Files.CymakePath , Generators , Generators.GenAbstractCurry , Generators.GenFlatCurry , Html.CurryHtml , Html.SyntaxColoring , IL , IL.Pretty , IL.ShowModule , IL.Type , Imports , Interfaces , Modules , TokenStream , Transformations , Transformations.CaseCompletion , Transformations.CurryToIL , Transformations.Desugar , Transformations.Lift , Transformations.Qual , Transformations.Simplify Other-Modules: Paths_curry_frontend ghc-options: -Wall Executable cymake hs-source-dirs: src Main-is: cymake.hs default-language: Haskell2010 Build-Depends: base == 4.* , containers , curry-base == 0.4.1 , curry-frontend , directory , filepath , mtl , process , syb , transformers if flag(network-uri) build-depends: network-uri >= 2.6 else build-depends: network < 2.6 ghc-options: -Wall Test-Suite test-frontend type: detailed-0.9 hs-source-dirs: test default-language: Haskell2010 test-module: TestFrontend build-depends: base == 4.*, Cabal >= 1.20, curry-base == 0.4.1 , curry-frontend == 0.4.1, filepath curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/data/000077500000000000000000000000001302651311700233675ustar00rootroot00000000000000curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/data/currysource.css000066400000000000000000000016271302651311700264740ustar00rootroot00000000000000/* Use always white background */ body { background : white; color : black; font-family: monospace; } /* Show hyperlinks without text decoration, but in light yellow */ a:visited, a:link, a:active { text-decoration: none; background : lightyellow; } /* Line numbers */ .linenumbers { width : 40px; text-align : right; color : grey; padding-right: 10px; border-right : 1px solid grey; } /* Source code */ .sourcecode { padding-left: 10px; } /* Code highlighting */ .pragma { color : green } .comment { color : green } .keyword { color : blue } .symbol { color : red } .type { color : orange } .cons { color : magenta } .label { color : darkgreen } .func { color : purple } .ident { color : black } .module { color : brown } .number { color : teal } .string { color : maroon } .char { color : maroon } curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/overview.md000066400000000000000000000065641302651311700246610ustar00rootroot00000000000000Module overview of package `curry-frontend` =========================================== * `Base`: Basic types and functions * `.CurryTypes` : Conversion of the type representation of `Curry.Syntax.Type` into the representation of `Base.Types` * `.Expr` : Type class for computation of free and bound variables * `.Messages` : Error messages * `.NestEnv` : Nested environment * `.SCC` : Computation of strongly connected components * `.ScopeEnv` : TODO: old stuff * `.Subst` : general substitution implementation * `.TopEnv` : Top level environment * `.Types` : internal representation of types * `.TypeSubst` : type substitution * `.Typing` : Type computation * `.Utils` : auxiliary functions * `Checks`: Ãœberprüfungen eines Curry-Moduls * `.ExportCheck`: Ãœberprüfung der Exports (unbekannte Symbole etc.) * `.KindCheck` : Ãœberprüfung der Typkonstruktoren, Unterscheidung von Typkonstruktoren und Variablen * `.PrecCheck` : Umordnung des Syntaxbaumes entsprechend der Operatorpräzedenzen * `.SyntaxCheck`: Ãœberprüfung der Syntax, Umbenennung von Variablen * `.TypeCheck` : Typüberprüfung * `.WarnCheck` : Erzeugung von Warnungen * `Env`: Umgebungen für die Kompilierung * `.Eval` : Auswertungsannotationen * `.Interface` : Importierte Interfaces * `.ModuleAlias` : Aliase für Module * `.OpPrec` : Operatorpräzedenzen * `.TypeConstructor`: Typkonstruktoren * `.Value` : Werte (Funktionen, Konstruktoren, Labels) * `Files.CymakePath`: Pfad zur binary * `Generators`: Generatoren zur Code-Erzeugung * `GenAbstractCurry`: Erzeugung von AbstractCurry * `GenFlatCurry` : Erzeugung von FlatCurry * `Html`: Dokumentation * `.CurrryHtml` : Erzeugung einer HTML-Dokumentation * `.SyntaxColoring`: Hilfsfunktionen * `IL`: interne Zwischensprache (Intermediate Language) * `.Pretty`: Pretty-Printer für die Intermediate Language * `.Type` : Intermediate Language * `.XML` : XML-Darstellung der Intermediate Language * `Transformations`: Codetransformationen * `.CaseCompletion`: Vervollständigung von case-Ausdrücken * `.CurryToIL` : Ãœbersetzung von Curry in die Intermediate Language * `.Desugar` : Ãœbersetzung von syntaktischem Zucker * `.Lift` : Lifting von lambda-Ausdrücken und lokalen Funktionen * `.Qual` : Qualifizierung von Konstruktoren und Funktionen * `.Simplify` : Code-Vereinfachung * `CompilerEnv` : Sammlung von Informationen für die Kompilierung eines Moduls * `CompilerOpts` : Optionen für den Compiler * `CurryBuilder` : Kompilierung eines Moduls inklusive Modulabhängigkeiten * `CurryDeps` : Berechnung von Modulabhängigkeiten * `cymake` : Command-line tool * `Exports` : Erzeugung des Interfaces * `Frontend` : API-Modul (to be removed) * `Imports` : Import von Funktionen etc. aus Schnittstellen * `Interfaces` : Laden der benötigten Schnittstellen * `Modules` : Kompilierung eines einzelnen Moduls * `ModuleSummary` : Zusammenfassung eines Moduls (to be removed) curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/000077500000000000000000000000001302651311700232455ustar00rootroot00000000000000curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/000077500000000000000000000000001302651311700241175ustar00rootroot00000000000000curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/CurryTypes.hs000066400000000000000000000073401302651311700266100ustar00rootroot00000000000000{- | Module : $Header$ Description : Conversion of type representation Copyright : (c) Wolfgang Lux 2011 - 2012 Björn Peemöller 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable The functions 'toType', 'toTypes', and 'fromType' convert Curry type expressions into types and vice versa. The functions 'qualifyType' and 'unqualifyType' add and remove module qualifiers in a type, respectively. When Curry type expression are converted with 'toType' or 'toTypes', type variables are assigned ascending indices in the order of their occurrence. It is possible to pass a list of additional type variables to both functions which are assigned indices before those variables occurring in the type. This allows preserving the order of type variables in the left hand side of a type declaration. -} module Base.CurryTypes ( toQualType, toQualTypes, toType, toTypes, fromQualType, fromType, ppType, ppTypeScheme ) where import Data.List (nub) import qualified Data.Map as Map (Map, fromList, lookup) import Curry.Base.Ident import Curry.Base.Pretty (Doc) import qualified Curry.Syntax as CS import Curry.Syntax.Pretty (ppTypeExpr) import Base.Expr import Base.Messages (internalError) import Base.Types toQualType :: ModuleIdent -> [Ident] -> CS.TypeExpr -> Type toQualType m tvs = qualifyType m . toType tvs toQualTypes :: ModuleIdent -> [Ident] -> [CS.TypeExpr] -> [Type] toQualTypes m tvs = map (qualifyType m) . toTypes tvs toType :: [Ident] -> CS.TypeExpr -> Type toType tvs ty = toType' (Map.fromList $ zip (tvs ++ newInTy) [0 ..]) ty where newInTy = [tv | tv <- nub (fv ty), tv `notElem` tvs] toTypes :: [Ident] -> [CS.TypeExpr] -> [Type] toTypes tvs tys = map (toType' (Map.fromList $ zip (tvs ++ newInTys) [0 ..])) tys where newInTys = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs] toType' :: Map.Map Ident Int -> CS.TypeExpr -> Type toType' tvs (CS.ConstructorType tc tys) = TypeConstructor tc (map (toType' tvs) tys) toType' tvs (CS.VariableType tv) = case Map.lookup tv tvs of Just tv' -> TypeVariable tv' Nothing -> internalError $ "Base.CurryTypes.toType': " ++ show tv 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 (CS.ListType ty) = TypeConstructor (qualify listId) [toType' tvs ty] toType' tvs (CS.ArrowType ty1 ty2) = TypeArrow (toType' tvs ty1) (toType' tvs ty2) toType' tvs (CS.ParenType ty) = toType' tvs ty fromQualType :: ModuleIdent -> Type -> CS.TypeExpr fromQualType m = fromType . unqualifyType m fromType :: Type -> CS.TypeExpr fromType (TypeConstructor tc tys) | isTupleId c = CS.TupleType tys' | c == unitId && null tys = CS.TupleType [] | c == listId && length tys == 1 = CS.ListType (head tys') | otherwise = CS.ConstructorType tc tys' where c = unqualify tc tys' = map fromType tys fromType (TypeVariable tv) = CS.VariableType (if tv >= 0 then identSupply !! tv else mkIdent ('_' : show (-tv))) fromType (TypeConstrained tys _) = fromType (head tys) fromType (TypeArrow ty1 ty2) = CS.ArrowType (fromType ty1) (fromType ty2) fromType (TypeSkolem k) = CS.VariableType $ mkIdent $ "_?" ++ show k -- The following functions implement pretty-printing for types. ppType :: ModuleIdent -> Type -> Doc ppType m = ppTypeExpr 0 . fromQualType m ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc ppTypeScheme m (ForAll _ ty) = ppType m ty curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/Expr.hs000066400000000000000000000152431302651311700253760ustar00rootroot00000000000000{- | Module : $Header$ Description : Extraction of free and bound variables Copyright : (c) Wolfgang Lux 2011 - 2015 Björn Peemöller 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable The compiler needs to compute the lists of free and bound variables for various different entities. We will devote three type classes to that purpose. The 'QualExpr' class is expected to take into account that it is possible to use a qualified name to refer to a function defined in the current module and therefore @M.x@ and @x@, where @M@ is the current module name, should be considered the same name. However, note that this is correct only after renaming all local definitions as @M.x@ always denotes an entity defined at the top-level. -} module Base.Expr (Expr (..), QualExpr (..), QuantExpr (..)) where import Data.List (nub) import qualified Data.Set as Set (fromList, notMember) import Curry.Base.Ident import Curry.Syntax class Expr e where -- |Free variables in an 'Expr' fv :: e -> [Ident] class QualExpr e where -- |Free qualified variables in an 'Expr' qfv :: ModuleIdent -> e -> [Ident] class QuantExpr e where -- |Bounded variables in an 'Expr' bv :: e -> [Ident] instance Expr e => Expr [e] where fv = concatMap fv instance QualExpr e => QualExpr [e] where qfv m = concatMap (qfv m) instance QuantExpr e => QuantExpr [e] where bv = concatMap bv -- The 'Decl' instance of 'QualExpr' returns all free -- variables on the right hand side, regardless of whether they are bound -- on the left hand side. This is more convenient as declarations are -- usually processed in a declaration group where the set of free -- variables cannot be computed independently for each declaration. Also -- note that the operator in a unary minus expression is not a free -- variable. This operator always refers to a global function from the -- prelude. instance QualExpr Decl where qfv m (FunctionDecl _ _ eqs) = qfv m eqs qfv m (PatternDecl _ _ rhs) = qfv m rhs qfv _ _ = [] instance QuantExpr Decl where bv (TypeSig _ vs _) = vs bv (FunctionDecl _ f _) = [f] bv (ForeignDecl _ _ _ f _) = [f] bv (ExternalDecl _ fs) = fs bv (PatternDecl _ t _) = bv t bv (FreeDecl _ vs) = vs bv _ = [] instance QualExpr Equation where qfv m (Equation _ lhs rhs) = filterBv lhs $ qfv m lhs ++ qfv m rhs instance QuantExpr Lhs where bv = bv . snd . flatLhs instance QualExpr Lhs where qfv m lhs = qfv m $ snd $ flatLhs lhs instance QualExpr Rhs where qfv m (SimpleRhs _ e ds) = filterBv ds $ qfv m e ++ qfv m ds qfv m (GuardedRhs es ds) = filterBv ds $ qfv m es ++ qfv m ds instance QualExpr CondExpr where qfv m (CondExpr _ g e) = qfv m g ++ qfv m e instance QualExpr Expression where qfv _ (Literal _) = [] qfv m (Variable v) = maybe [] return $ localIdent m v qfv _ (Constructor _) = [] qfv m (Paren e) = qfv m e qfv m (Typed e _) = qfv m e qfv m (Record _ fs) = qfv m fs qfv m (RecordUpdate e fs) = qfv m e ++ qfv m fs qfv m (Tuple _ es) = qfv m es qfv m (List _ es) = qfv m es qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs qfv m (EnumFrom e) = qfv m e qfv m (EnumFromThen e1 e2) = qfv m e1 ++ qfv m e2 qfv m (EnumFromTo e1 e2) = qfv m e1 ++ qfv m e2 qfv m (EnumFromThenTo e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3 qfv m (UnaryMinus _ e) = qfv m e qfv m (Apply e1 e2) = qfv m e1 ++ qfv m e2 qfv m (InfixApply e1 op e2) = qfv m op ++ qfv m e1 ++ qfv m e2 qfv m (LeftSection e op) = qfv m op ++ qfv m e qfv m (RightSection op e) = qfv m op ++ qfv m e qfv m (Lambda _ ts e) = filterBv ts $ qfv m e qfv m (Let ds e) = filterBv ds $ qfv m ds ++ qfv m e qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3 qfv m (Case _ _ e alts) = qfv m e ++ qfv m alts qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident] qfvStmt m st fvs = qfv m st ++ filterBv st fvs instance QualExpr Statement where qfv m (StmtExpr _ e) = qfv m e qfv m (StmtDecl ds) = filterBv ds $ qfv m ds qfv m (StmtBind _ _ e) = qfv m e instance QualExpr Alt where qfv m (Alt _ t rhs) = filterBv t $ qfv m rhs instance QuantExpr a => QuantExpr (Field a) where bv (Field _ _ t) = bv t instance QualExpr a => QualExpr (Field a) where qfv m (Field _ _ t) = qfv m t instance QuantExpr Statement where bv (StmtExpr _ _) = [] bv (StmtBind _ t _) = bv t bv (StmtDecl ds) = bv ds instance QualExpr InfixOp where qfv m (InfixOp op) = qfv m $ Variable op qfv _ (InfixConstr _) = [] instance QuantExpr Pattern where bv (LiteralPattern _) = [] bv (NegativePattern _ _) = [] bv (VariablePattern v) = [v] bv (ConstructorPattern _ ts) = bv ts bv (InfixPattern t1 _ t2) = bv t1 ++ bv t2 bv (ParenPattern t) = bv t bv (RecordPattern _ fs) = bv fs bv (TuplePattern _ ts) = bv ts bv (ListPattern _ ts) = bv ts bv (AsPattern v t) = v : bv t bv (LazyPattern _ t) = bv t bv (FunctionPattern _ ts) = nub $ bv ts bv (InfixFuncPattern t1 _ t2) = nub $ bv t1 ++ bv t2 instance QualExpr Pattern where qfv _ (LiteralPattern _) = [] qfv _ (NegativePattern _ _) = [] qfv _ (VariablePattern _) = [] qfv m (ConstructorPattern _ ts) = qfv m ts qfv m (InfixPattern t1 _ t2) = qfv m [t1, t2] qfv m (ParenPattern t) = qfv m t qfv m (RecordPattern _ fs) = qfv m fs qfv m (TuplePattern _ ts) = qfv m ts qfv m (ListPattern _ ts) = qfv m ts qfv m (AsPattern _ ts) = qfv m ts qfv m (LazyPattern _ t) = qfv m t qfv m (FunctionPattern f ts) = maybe [] return (localIdent m f) ++ qfv m ts qfv m (InfixFuncPattern t1 op t2) = maybe [] return (localIdent m op) ++ qfv m [t1, t2] instance Expr TypeExpr where fv (ConstructorType _ tys) = fv tys fv (VariableType tv) | isAnonId tv = [] | otherwise = [tv] fv (TupleType tys) = fv tys fv (ListType ty) = fv ty fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2 fv (ParenType ty) = fv ty filterBv :: QuantExpr e => e -> [Ident] -> [Ident] filterBv e = filter (`Set.notMember` Set.fromList (bv e)) curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/Messages.hs000066400000000000000000000055521302651311700262310ustar00rootroot00000000000000{- | Module : $Header$ Description : Construction and output of compiler messages Copyright : (c) 2011 - 2016 Björn Peemöller License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module defines several operations to construct and emit compiler messages to the user. -} module Base.Messages ( -- * Output of user information MonadIO (..), status, putMsg, putErrLn, putErrsLn -- * program abortion , abortWith, abortWithMessage, abortWithMessages, warnOrAbort, internalError -- * creating messages , Message, message, posMessage ) where import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO(..)) import Data.List (sort) import System.IO (hFlush, hPutStrLn, stderr, stdout) import System.Exit (exitFailure) import Curry.Base.Message ( Message, message, posMessage, ppWarning , ppMessages, ppError) import Curry.Base.Pretty (Doc, text) import CompilerOpts (Options (..), WarnOpts (..), Verbosity (..)) -- |Print a status message, depending on the current verbosity status :: MonadIO m => Options -> String -> m () status opts msg = unless (optVerbosity opts < VerbStatus) (putMsg msg) -- |Print a message on 'stdout' putMsg :: MonadIO m => String -> m () putMsg msg = liftIO (putStrLn msg >> hFlush stdout) -- |Print an error message on 'stderr' putErrLn :: MonadIO m => String -> m () putErrLn msg = liftIO (hPutStrLn stderr msg >> hFlush stderr) -- |Print a list of error messages on 'stderr' putErrsLn :: MonadIO m => [String] -> m () putErrsLn = mapM_ putErrLn -- |Print a list of 'String's as error messages on 'stderr' -- and abort the program abortWith :: [String] -> IO a abortWith errs = putErrsLn errs >> exitFailure -- |Print a single error message on 'stderr' and abort the program abortWithMessage :: Message -> IO a abortWithMessage msg = abortWithMessages [msg] -- |Print a list of error messages on 'stderr' and abort the program abortWithMessages :: [Message] -> IO a abortWithMessages msgs = printMessages ppError msgs >> exitFailure -- |Print a list of warning messages on 'stderr' and abort the program -- |if the -Werror option is set warnOrAbort :: WarnOpts -> [Message] -> IO () warnOrAbort opts msgs = when (wnWarn opts && not (null msgs)) $ do if wnWarnAsError opts then abortWithMessages (msgs ++ [message $ text "Failed due to -Werror"]) else printMessages ppWarning msgs -- |Print a list of messages on 'stderr' printMessages :: (Message -> Doc) -> [Message] -> IO () printMessages msgType msgs = unless (null msgs) $ putErrLn (show $ ppMessages msgType $ sort msgs) -- |Raise an internal error internalError :: String -> a internalError msg = error $ "Internal error: " ++ msg curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/NestEnv.hs000066400000000000000000000106671302651311700260470ustar00rootroot00000000000000{- | Module : $Header$ Description : Nested Environments Copyright : (c) 1999 - 2003 Wolfgang Lux 2011 - 2015 Björn Peemöller License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable The 'NestEnv' environment type extends top-level environments to manage nested scopes. Local scopes allow only for a single, unambiguous definition. As a matter of convenience, the module 'TopEnv' is exported by the module 'NestEnv'. Thus, only the latter needs to be imported. -} module Base.NestEnv ( module Base.TopEnv , NestEnv, emptyEnv, bindNestEnv, qualBindNestEnv , lookupNestEnv, qualLookupNestEnv , rebindNestEnv, qualRebindNestEnv , unnestEnv, toplevelEnv, globalEnv, nestEnv, elemNestEnv , qualModifyNestEnv, modifyNestEnv, localNestEnv, qualInLocalNestEnv ) where import qualified Data.Map as Map import Curry.Base.Ident import Base.Messages (internalError) import Base.TopEnv data NestEnv a = GlobalEnv (TopEnv a) | LocalEnv (NestEnv a) (Map.Map Ident a) deriving Show instance Functor NestEnv where fmap f (GlobalEnv env) = GlobalEnv (fmap f env) fmap f (LocalEnv genv env) = LocalEnv (fmap f genv) (fmap f env) globalEnv :: TopEnv a -> NestEnv a globalEnv = GlobalEnv emptyEnv :: NestEnv a emptyEnv = globalEnv emptyTopEnv nestEnv :: NestEnv a -> NestEnv a nestEnv env = LocalEnv env Map.empty unnestEnv :: NestEnv a -> NestEnv a unnestEnv g@(GlobalEnv _) = g unnestEnv (LocalEnv genv _) = genv toplevelEnv :: NestEnv a -> TopEnv a toplevelEnv (GlobalEnv env) = env toplevelEnv (LocalEnv genv _) = toplevelEnv genv bindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a bindNestEnv x y (GlobalEnv env) = GlobalEnv $ bindTopEnv x y env bindNestEnv x y (LocalEnv genv env) = case Map.lookup x env of Just _ -> internalError $ "NestEnv.bindNestEnv: " ++ show x ++ " is already bound" Nothing -> LocalEnv genv $ Map.insert x y env qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a qualBindNestEnv x y (GlobalEnv env) = GlobalEnv $ qualBindTopEnv x y env qualBindNestEnv x y (LocalEnv genv env) | isQualified x = internalError $ "NestEnv.qualBindNestEnv " ++ show x | otherwise = case Map.lookup x' env of Just _ -> internalError $ "NestEnv.qualBindNestEnv " ++ show x Nothing -> LocalEnv genv $ Map.insert x' y env where x' = unqualify x -- Rebinds a value to a variable, failes if the variable was unbound before rebindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a rebindNestEnv = qualRebindNestEnv . qualify qualRebindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a qualRebindNestEnv x y (GlobalEnv env) = GlobalEnv $ qualRebindTopEnv x y env qualRebindNestEnv x y (LocalEnv genv env) | isQualified x = internalError $ "NestEnv.qualRebindNestEnv " ++ show x | otherwise = case Map.lookup x' env of Just _ -> LocalEnv genv $ Map.insert x' y env Nothing -> LocalEnv (qualRebindNestEnv x y genv) env where x' = unqualify x lookupNestEnv :: Ident -> NestEnv a -> [a] lookupNestEnv x (GlobalEnv env) = lookupTopEnv x env lookupNestEnv x (LocalEnv genv env) = case Map.lookup x env of Just y -> [y] Nothing -> lookupNestEnv x genv qualLookupNestEnv :: QualIdent -> NestEnv a -> [a] qualLookupNestEnv x env | isQualified x = qualLookupTopEnv x $ toplevelEnv env | otherwise = lookupNestEnv (unqualify x) env elemNestEnv :: Ident -> NestEnv a -> Bool elemNestEnv x env = not (null (lookupNestEnv x env)) -- Applies a function to a value binding, does nothing if the variable is unbound modifyNestEnv :: (a -> a) -> Ident -> NestEnv a -> NestEnv a modifyNestEnv f = qualModifyNestEnv f . qualify qualModifyNestEnv :: (a -> a) -> QualIdent -> NestEnv a -> NestEnv a qualModifyNestEnv f x env = case qualLookupNestEnv x env of [] -> env y : _ -> qualRebindNestEnv x (f y) env -- Returns the variables and values bound on the bottom (meaning non-top) scope localNestEnv :: NestEnv a -> [(Ident, a)] localNestEnv (GlobalEnv env) = localBindings env localNestEnv (LocalEnv _ env) = Map.toList env -- Returns wether the variable is bound on the bottom (meaning non-top) scope qualInLocalNestEnv :: QualIdent -> NestEnv a -> Bool qualInLocalNestEnv x (GlobalEnv env) = qualElemTopEnv x env qualInLocalNestEnv x (LocalEnv _ env) = (not (isQualified x)) && Map.member (unqualify x) env curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/SCC.hs000066400000000000000000000046671302651311700251000ustar00rootroot00000000000000{- | Module : $Header$ Description : Computation of strongly connected components Copyright : (c) 2000, 2002 - 2003 Wolfgang Lux License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable At various places in the compiler we had to partition a list of declarations into strongly connected components. The function 'scc' computes this relation in two steps. First, the list is topologically sorted downwards using the 'defs' relation. Then the resulting list is sorted upwards using the 'uses' relation and partitioned into the connected components. Both relations are computed within this module using the bound and free names of each declaration. In order to avoid useless recomputations, the code in the module first decorates the declarations with their bound and free names and a unique number. The latter is only used to provide a trivial ordering so that the declarations can be used as set elements. -} module Base.SCC (scc) where import qualified Data.Set as Set (empty, member, insert) data Node a b = Node { key :: Int, bvs :: [b], fvs :: [b], node :: a } instance Eq (Node a b) where n1 == n2 = key n1 == key n2 instance Ord (Node b a) where n1 `compare` n2 = key n1 `compare` key n2 -- |Computation of strongly connected components scc :: Eq b => (a -> [b]) -- ^entities defined by node -> (a -> [b]) -- ^entities used by node -> [a] -- ^list of nodes -> [[a]] -- ^strongly connected components scc bvs' fvs' = map (map node) . tsort' . tsort . zipWith wrap [0 ..] where wrap i n = Node i (bvs' n) (fvs' n) n tsort :: Eq b => [Node a b] -> [Node a b] tsort xs = snd (dfs xs Set.empty []) where dfs [] marks stack = (marks,stack) dfs (x : xs') marks stack | x `Set.member` marks = dfs xs' marks stack | otherwise = dfs xs' marks' (x : stack') where (marks',stack') = dfs (defs x) (x `Set.insert` marks) stack defs x1 = filter (any (`elem` fvs x1) . bvs) xs tsort' :: Eq b => [Node a b] -> [[Node a b]] tsort' xs = snd (dfs xs Set.empty []) where dfs [] marks stack = (marks,stack) dfs (x : xs') marks stack | x `Set.member` marks = dfs xs' marks stack | otherwise = dfs xs' marks' ((x : concat stack') : stack) where (marks',stack') = dfs (uses x) (x `Set.insert` marks) [] uses x1 = filter (any (`elem` bvs x1) . fvs) xs curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/Subst.hs000066400000000000000000000116111302651311700255530ustar00rootroot00000000000000{- | Module : $Header$ Description : General substitution implementation Copyright : (c) 2002 Wolfgang Lux License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable The module Subst implements substitutions. A substitution sigma = {x_1 |-> t_1, ... ,x_n |-> t_n} is a finite mapping from (finitely many) variables x_1, ... ,x_n to some kind of expression or term. In order to implement substitutions efficiently, composed substitutions are marked with a boolean flag (see below). -} module Base.Subst ( Subst (..), IntSubst (..), idSubst, singleSubst, bindSubst, unbindSubst , substToList, compose, substVar', isubstVar, restrictSubstTo ) where import qualified Data.Map as Map -- |Data type for substitution data Subst a b = Subst Bool (Map.Map a b) deriving Show -- |Identity substitution idSubst :: Subst a b idSubst = Subst False Map.empty -- |Convert a substitution to a list of replacements substToList :: Subst v e -> [(v, e)] substToList (Subst _ sigma) = Map.toList sigma -- |Create a substitution for a single replacement singleSubst :: Ord v => v -> e -> Subst v e singleSubst v e = bindSubst v e idSubst -- |Extend a substitution with a single replacement bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e bindSubst v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma -- |Remove a single replacement from a substitution unbindSubst :: Ord v => v -> Subst v e -> Subst v e unbindSubst v (Subst comp sigma) = Subst comp $ Map.delete v sigma -- For any substitution we have the following definitions: -- sigma(x) = t_i if x = x_i -- x otherwise -- Dom(sigma) = {x_1, ... , x_n} -- Codom(sigma) = {t_1, ... , t_n} -- Note that obviously the set of variables must be a subset of the set -- of expressions. Also it is usually possible to extend the substitution -- to a homomorphism on the codomain of the substitution. This is -- captured by the following class declaration: -- class Ord v => Subst v e where -- var :: v -> e -- subst :: Subst v e -> e -> e -- With the help of the injection 'var', we can then compute the -- substitution for a variable sigma(v) and also the composition of -- two substitutions sigma1 o sigma2(e) := sigma1(sigma2(e)). -- A naive implementation of the composition were -- -- compose sigma sigma' = -- foldr (uncurry bindSubst) sigma (substToList (fmap (subst sigma) sigma')) -- -- However, such an implementation is very inefficient because the -- number of substiutions applied to a variable increases in -- O(n) of the number of compositions. -- A more efficient implementation is to apply 'subst' again to -- the value substituted for a variable in Dom(sigma). -- However, this is correct only as long as the result of the substitution -- does not include any variables which are in Dom(sigma). For instance, -- it is impossible to implement simple variable renamings in this way. -- Therefore we use the simple strategy to apply 'subst' again -- only in case of a substitution which was returned from 'compose'. -- substVar :: Subst v e => Subst v e -> v -> e -- substVar (Subst comp sigma) v = maybe (var v) subst' (Map.lookup v sigma) -- where subst' = if comp then subst (Subst comp sigma) else id -- |Compose two substitutions compose :: Ord v => Subst v e -> Subst v e -> Subst v e compose sigma sigma' = composed (foldr (uncurry bindSubst) sigma' (substToList sigma)) where composed (Subst _ sigma'') = Subst True sigma'' -- Unfortunately Haskell does not (yet) support multi-parameter type -- classes. For that reason we have to define a separate class for each -- kind of variable type for these functions. We implement -- 'substVar' as a function that takes the class functions as an -- additional parameters. As an example for the use of this function the -- module includes a class 'IntSubst' for substitution whose -- domain are integer numbers. -- |Apply a substitution to a variable substVar' :: Ord v => (v -> e) -> (Subst v e -> e -> e) -> Subst v e -> v -> e substVar' var subst (Subst comp sigma) v = maybe (var v) subst' (Map.lookup v sigma) where subst' = if comp then subst (Subst comp sigma) else id -- |Type class for terms where variables are represented as 'Int's class IntSubst e where -- |Construct a variable from an 'Int' ivar :: Int -> e -- |Apply a substitution to a term isubst :: Subst Int e -> e -> e -- |Apply a substitution to a term with variables represented as 'Int's isubstVar :: IntSubst e => Subst Int e -> Int -> e isubstVar = substVar' ivar isubst -- |The function 'restrictSubstTo' implements the restriction of a -- substitution to a given subset of its domain. restrictSubstTo :: Ord v => [v] -> Subst v e -> Subst v e restrictSubstTo vs (Subst comp sigma) = foldr (uncurry bindSubst) (Subst comp Map.empty) (filter ((`elem` vs) . fst) (Map.toList sigma)) curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/TopEnv.hs000066400000000000000000000150431302651311700256710ustar00rootroot00000000000000{- | Module : $Header$ Description : Top-Level Environments Copyright : 1999 - 2003 Wolfgang Lux 2005 Martin Engelke 2011 - 2012 Björn Peemöller License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable The module 'TopEnv' implements environments for qualified and possibly ambiguous identifiers. An identifier is ambiguous if two different entities are imported under the same name or if a local definition uses the same name as an imported entity. Following an idea presented in a paper by Diatchki, Jones and Hallgren (2002), an identifier is associated with a list of entities in order to handle ambiguous names properly. In general, two entities are considered equal if the names of their original definitions match. However, in the case of algebraic data types it is possible to hide some or all of their data constructors on import and export, respectively. In this case we have to merge both imports such that all data constructors which are visible through any import path are visible in the current module. The class Entity is used to handle this merge. The code in this module ensures that the list of entities returned by the functions 'lookupTopEnv' and 'qualLookupTopEnv' contains exactly one element for each imported entity regardless of how many times and from which module(s) it was imported. Thus, the result of these function is a list with exactly one element if and only if the identifier is unambiguous. The module names associated with an imported entity identify the modules from which the entity was imported. -} module Base.TopEnv ( -- * Data types TopEnv (..), Entity (..) -- * creation and insertion , emptyTopEnv, predefTopEnv, importTopEnv, qualImportTopEnv , bindTopEnv, qualBindTopEnv, rebindTopEnv , qualRebindTopEnv, unbindTopEnv, lookupTopEnv, qualLookupTopEnv , allImports, moduleImports, localBindings, allLocalBindings , allEntities, qualElemTopEnv ) where import Control.Arrow (second) import qualified Data.Map as Map (Map, empty, insert, findWithDefault, lookup, toList) import Curry.Base.Ident import Base.Messages (internalError) class Entity a where origName :: a -> QualIdent merge :: a -> a -> Maybe a merge x y | origName x == origName y = Just x | otherwise = Nothing data Source = Local | Import [ModuleIdent] deriving (Eq, Show) -- |Top level environment 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) -- local helper entities :: QualIdent -> Map.Map QualIdent [(Source, a)] -> [(Source, a)] entities = Map.findWithDefault [] -- |Empty 'TopEnv' emptyTopEnv :: TopEnv a emptyTopEnv = TopEnv Map.empty -- |Insert an 'Entity' into a 'TopEnv' as a predefined 'Entity' predefTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a predefTopEnv k v (TopEnv env) = case Map.lookup k env of Just _ -> internalError $ "TopEnv.predefTopEnv " ++ show k Nothing -> TopEnv $ Map.insert k [(Import [], v)] env -- |Insert an 'Entity' as unqualified into a 'TopEnv' importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a importTopEnv m x y env = addImport m (qualify x) y env -- |Insert an 'Entity' as qualified into a 'TopEnv' qualImportTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a qualImportTopEnv m x y env = addImport m (qualifyWith m x) y env -- local helper addImport :: Entity a => ModuleIdent -> QualIdent -> a -> TopEnv a -> TopEnv a addImport m k v (TopEnv env) = TopEnv $ Map.insert k (mergeImport v (entities k env)) env where mergeImport :: Entity a => a -> [(Source, a)] -> [(Source, a)] mergeImport y [] = [(Import [m], y)] mergeImport y (loc@(Local , _) : xs) = loc : mergeImport y xs mergeImport y (imp@(Import ms, y') : xs) = case merge y y' of Just y'' -> (Import (m : ms), y'') : xs Nothing -> imp : mergeImport y xs bindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a bindTopEnv x y env = qualBindTopEnv (qualify x) y env qualBindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a qualBindTopEnv x y (TopEnv env) = TopEnv $ Map.insert x (bindLocal y (entities x env)) env where bindLocal y' ys | null [ y'' | (Local, y'') <- ys ] = (Local, y') : ys | otherwise = internalError $ "qualBindTopEnv " ++ show x rebindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a rebindTopEnv = qualRebindTopEnv . qualify qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a qualRebindTopEnv x y (TopEnv env) = TopEnv $ Map.insert x (rebindLocal (entities x env)) env where rebindLocal [] = internalError $ "TopEnv.qualRebindTopEnv " ++ show x rebindLocal ((Local, _) : ys) = (Local, y) : ys rebindLocal (imported : ys) = imported : rebindLocal ys unbindTopEnv :: Ident -> TopEnv a -> TopEnv a unbindTopEnv x (TopEnv env) = TopEnv $ Map.insert x' (unbindLocal (entities x' env)) env where x' = qualify x unbindLocal [] = internalError $ "TopEnv.unbindTopEnv " ++ show x unbindLocal ((Local, _) : ys) = ys unbindLocal (imported : ys) = imported : unbindLocal ys lookupTopEnv :: Ident -> TopEnv a -> [a] lookupTopEnv = qualLookupTopEnv . qualify qualLookupTopEnv :: QualIdent -> TopEnv a -> [a] qualLookupTopEnv x (TopEnv env) = map snd (entities x env) allImports :: TopEnv a -> [(QualIdent, a)] allImports (TopEnv env) = [ (x, y) | (x, ys) <- Map.toList env, (Import _, y) <- ys ] unqualBindings :: TopEnv a -> [(Ident, (Source, a))] unqualBindings (TopEnv env) = [ (x', y) | (x, ys) <- filter (not . isQualified . fst) (Map.toList env) , let x' = unqualify x, y <- ys] moduleImports :: ModuleIdent -> TopEnv a -> [(Ident, a)] moduleImports m env = [(x, y) | (x, (Import ms, y)) <- unqualBindings env, m `elem` ms] localBindings :: TopEnv a -> [(Ident, a)] localBindings env = [ (x, y) | (x, (Local, y)) <- unqualBindings env ] allLocalBindings :: TopEnv a -> [(QualIdent, a)] allLocalBindings (TopEnv env) = [ (x, y) | (x, ys) <- Map.toList env , (Local, y) <- ys ] allEntities :: TopEnv a -> [a] allEntities (TopEnv env) = [ y | (_, ys) <- Map.toList env, (_, y) <- ys] qualElemTopEnv :: QualIdent -> TopEnv a -> Bool qualElemTopEnv x env = not (null (qualLookupTopEnv x env)) curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/TypeSubst.hs000066400000000000000000000074671302651311700264330ustar00rootroot00000000000000{- | Module : $Header$ Description : Type substitution Copyright : (c) 2003 Wolfgang Lux License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module implements substitutions on types. -} module Base.TypeSubst ( module Base.TypeSubst, idSubst, singleSubst, bindSubst, compose ) where import Data.List (nub) import Base.Messages (internalError) import Base.Subst import Base.TopEnv import Base.Types import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC) import Env.Value (ValueInfo (..)) type TypeSubst = Subst Int Type class SubstType a where subst :: TypeSubst -> a -> a bindVar :: Int -> Type -> TypeSubst -> TypeSubst bindVar tv ty = compose (bindSubst tv ty idSubst) substVar :: TypeSubst -> Int -> Type substVar = substVar' TypeVariable subst instance SubstType Type where subst sigma (TypeConstructor tc tys) = TypeConstructor tc (map (subst sigma) tys) subst sigma (TypeVariable tv) = substVar sigma tv subst sigma (TypeConstrained tys tv) = case substVar sigma tv of TypeVariable tv' -> TypeConstrained tys tv' ty -> ty subst sigma (TypeArrow ty1 ty2) = TypeArrow (subst sigma ty1) (subst sigma ty2) subst _ ts@(TypeSkolem _) = ts instance SubstType TypeScheme where subst sigma (ForAll n ty) = ForAll n (subst (foldr unbindSubst sigma [0..n-1]) ty) instance SubstType ExistTypeScheme where subst sigma (ForAllExist n n' ty) = ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty) instance SubstType ValueInfo where subst _ dc@(DataConstructor _ _ _ _) = dc subst _ nc@(NewtypeConstructor _ _ _) = nc subst theta (Value v a ty) = Value v a (subst theta ty) subst theta (Label l r ty) = Label l r (subst theta ty) instance SubstType a => SubstType (TopEnv a) where subst = fmap . subst -- Expand all type synonyms in a type expandType :: TCEnv -> Type -> Type expandType tcEnv (TypeConstructor tc tys) = case qualLookupTC tc tcEnv of [DataType tc' _ _] -> TypeConstructor tc' tys' [RenamingType tc' _ _] -> TypeConstructor tc' tys' [AliasType _ _ ty] -> expandAliasType tys' ty _ -> internalError $ "Desugar.expandType " ++ show tc where tys' = map (expandType tcEnv) tys expandType _ tv@(TypeVariable _) = tv expandType _ tc@(TypeConstrained _ _) = tc expandType tcEnv (TypeArrow ty1 ty2) = TypeArrow (expandType tcEnv ty1) (expandType tcEnv ty2) expandType _ ts@(TypeSkolem _) = ts -- The function 'expandAliasType' expands all occurrences of a -- type synonym in a type. After the expansion we have to reassign the -- type indices for all type variables. Otherwise, expanding a type -- synonym like type Pair' a b = (b,a) could break the invariant -- that the universally quantified type variables are assigned indices in -- the order of their occurrence. This is handled by the function -- 'normalize'. expandAliasType :: [Type] -> Type -> Type expandAliasType tys (TypeConstructor tc tys') = TypeConstructor tc (map (expandAliasType tys) tys') expandAliasType tys (TypeVariable n) | n >= 0 = tys !! n | otherwise = TypeVariable n expandAliasType _ (TypeConstrained tys n) = TypeConstrained tys n expandAliasType tys (TypeArrow ty1 ty2) = TypeArrow (expandAliasType tys ty1) (expandAliasType tys ty2) expandAliasType _ tsk@(TypeSkolem _) = tsk normalize :: Type -> Type normalize ty = expandAliasType [TypeVariable (occur tv) | tv <- [0 ..]] ty where tvs = zip (nub (filter (>= 0) (typeVars ty))) [0 ..] occur tv = case lookup tv tvs of Just t -> t Nothing -> error "Base.TypeSubst.normalize" curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/Types.hs000066400000000000000000000232621302651311700255640ustar00rootroot00000000000000{- | Module : $Header$ Description : Internal representation of types Copyright : (c) 2002 - 2004 Wolfgang Lux Martin Engelke 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module modules provides the definitions for the internal representation of types in the compiler. -} -- TODO: Use MultiParamTypeClasses ? module Base.Types ( -- * Representation of Types Type (..), isArrowType, arrowArity, arrowArgs, arrowBase, arrowUnapply , typeVars, typeConstrs, typeSkolems, equTypes, qualifyType, unqualifyType -- * Representation of Data Constructors , DataConstr (..), constrIdent, constrTypes, recLabels, recLabelTypes , tupleData -- * Representation of Quantification , TypeScheme (..), ExistTypeScheme (..), monoType, polyType -- * Predefined types , unitType, boolType, charType, intType, floatType, stringType , listType, ioType, tupleType, typeVar, predefTypes ) where import Curry.Base.Ident -- A type is either a type variable, an application of a type constructor -- to a list of arguments, or an arrow type. The 'TypeConstrained' -- case is used for representing type variables that are restricted to a -- particular set of types. At present, this is used for typing -- integer literals, which are restricted to types 'Int' and -- 'Float'. If the type is not restricted, it defaults to the first type -- from the constraint list. -- The case 'TypeSkolem' is used for handling skolem types, which -- result from the use of existentially quantified data constructors. -- Type variables are represented with deBruijn style indices. Universally -- quantified type variables are assigned indices in the order of their -- occurrence in the type from left to right. This leads to a canonical -- representation of types where alpha-equivalence of two types -- coincides with equality of the representation. -- Note that even though 'TypeConstrained' variables use indices -- as well, these variables must never be quantified. data Type = TypeVariable Int | TypeConstructor QualIdent [Type] | TypeArrow Type Type | TypeConstrained [Type] Int | TypeSkolem Int deriving (Eq, Show) -- The function 'isArrowType' checks whether a type is a function -- type t_1 -> t_2 -> ... -> t_n . The function 'arrowArity' computes the arity -- n of a function type, 'arrowArgs' computes the types t_1 ... t_n-1 -- and 'arrowBase' returns the type t_n. isArrowType :: Type -> Bool isArrowType (TypeArrow _ _) = True isArrowType _ = False arrowArity :: Type -> Int arrowArity (TypeArrow _ ty) = 1 + arrowArity ty arrowArity _ = 0 arrowArgs :: Type -> [Type] arrowArgs (TypeArrow ty1 ty2) = ty1 : arrowArgs ty2 arrowArgs _ = [] arrowBase :: Type -> Type arrowBase (TypeArrow _ ty) = arrowBase ty arrowBase ty = ty arrowUnapply :: Type -> ([Type], Type) arrowUnapply (TypeArrow ty1 ty2) = (ty1 : tys, ty) where (tys, ty) = arrowUnapply ty2 arrowUnapply ty = ([], ty) -- The functions 'typeVars', 'typeConstrs', 'typeSkolems' return a list of all -- type variables, type constructors, or skolems occurring in a type t, -- respectively. Note that 'TypeConstrained' variables are not included in the -- set of type variables because they cannot be generalized. typeVars :: Type -> [Int] typeVars ty = vars ty [] where vars (TypeConstructor _ tys) tvs = foldr vars tvs tys vars (TypeVariable tv) tvs = tv : tvs vars (TypeConstrained _ _) tvs = tvs vars (TypeArrow ty1 ty2) tvs = vars ty1 (vars ty2 tvs) vars (TypeSkolem _) tvs = tvs typeConstrs :: Type -> [QualIdent] typeConstrs ty = constrs ty [] where constrs (TypeConstructor tc tys) tcs = tc : foldr constrs tcs tys constrs (TypeVariable _) tcs = tcs constrs (TypeConstrained _ _) tcs = tcs constrs (TypeArrow ty1 ty2) tcs = constrs ty1 (constrs ty2 tcs) constrs (TypeSkolem _) tcs = tcs typeSkolems :: Type -> [Int] typeSkolems ty = skolems ty [] where skolems (TypeConstructor _ tys) sks = foldr skolems sks tys skolems (TypeVariable _) sks = sks skolems (TypeConstrained _ _) sks = sks skolems (TypeArrow ty1 ty2) sks = skolems ty1 (skolems ty2 sks) skolems (TypeSkolem k) sks = k : sks -- The function 'equTypes' computes whether two types are equal modulo -- renaming of type variables. equTypes :: Type -> Type -> Bool equTypes t1 t2 = fst (equ [] t1 t2) where -- @is@ is an AssocList of type variable indices equ is (TypeConstructor qid1 ts1) (TypeConstructor qid2 ts2) | qid1 == qid2 = equs is ts1 ts2 | otherwise = (False, is) equ is (TypeVariable i1) (TypeVariable i2) = equVar is i1 i2 equ is (TypeConstrained ts1 i1) (TypeConstrained ts2 i2) = let (res , is1) = equs is ts1 ts2 (res2, is2) = equVar is1 i1 i2 in (res && res2, is2) equ is (TypeArrow tf1 tt1) (TypeArrow tf2 tt2) = let (res1, is1) = equ is tf1 tf2 (res2, is2) = equ is1 tt1 tt2 in (res1 && res2, is2) equ is (TypeSkolem i1) (TypeSkolem i2) = equVar is i1 i2 equ is _ _ = (False, is) equVar is i1 i2 = case lookup i1 is of Nothing -> (True, (i1, i2) : is) Just i2' -> (i2 == i2', is) equs is [] [] = (True , is) equs is (t1':ts1) (t2':ts2) = let (res1, is1) = equ is t1' t2' (res2, is2) = equs is1 ts1 ts2 in (res1 && res2, is2) equs is _ _ = (False, is) -- The functions 'qualifyType' and 'unqualifyType' add/remove the -- qualification with a module identifier for type constructors. qualifyType :: ModuleIdent -> Type -> Type qualifyType m (TypeConstructor tc tys) | isTupleId tc' = tupleType tys' | tc' == unitId && n == 0 = unitType | tc' == listId && n == 1 = listType (head tys') | otherwise = TypeConstructor (qualQualify m tc) tys' where n = length tys' tc' = unqualify tc tys' = map (qualifyType m) tys qualifyType _ var@(TypeVariable _) = var qualifyType m (TypeConstrained tys tv) = TypeConstrained (map (qualifyType m) tys) tv qualifyType m (TypeArrow ty1 ty2) = TypeArrow (qualifyType m ty1) (qualifyType m ty2) qualifyType _ skol@(TypeSkolem _) = skol unqualifyType :: ModuleIdent -> Type -> Type unqualifyType m (TypeConstructor tc tys) = TypeConstructor (qualUnqualify m tc) (map (unqualifyType m) tys) unqualifyType _ var@(TypeVariable _) = var unqualifyType m (TypeConstrained tys tv) = TypeConstrained (map (unqualifyType m) tys) tv unqualifyType m (TypeArrow ty1 ty2) = TypeArrow (unqualifyType m ty1) (unqualifyType m ty2) unqualifyType _ skol@(TypeSkolem _) = skol -- The type 'DataConstr' is used to represent value or record constructors -- introduced by data or newtype declarations. data DataConstr = DataConstr Ident Int [Type] | RecordConstr Ident Int [Ident] [Type] deriving (Eq, Show) constrIdent :: DataConstr -> Ident constrIdent (DataConstr c _ _) = c constrIdent (RecordConstr c _ _ _) = c constrTypes :: DataConstr -> [Type] constrTypes (DataConstr _ _ ty) = ty constrTypes (RecordConstr _ _ _ ty) = ty recLabels :: DataConstr -> [Ident] recLabels (DataConstr _ _ _) = [] recLabels (RecordConstr _ _ ls _) = ls recLabelTypes :: DataConstr -> [Type] recLabelTypes (DataConstr _ _ _) = [] recLabelTypes (RecordConstr _ _ _ tys) = tys -- We support two kinds of quantifications of types here, universally -- quantified type schemes (forall alpha . tau(alpha)) and universally -- and existentially quantified type schemes -- (forall alpha exists eta . tau(alpha,eta)). In both, quantified type -- variables are assigned ascending indices starting from 0. Therefore it -- is sufficient to record the numbers of quantified type variables in -- the 'ForAll' and 'ForAllExist' constructors. In case of -- the latter, the first of the two numbers is the number of universally -- quantified variables and the second the number of existentially -- quantified variables. data TypeScheme = ForAll Int Type deriving (Eq, Show) data ExistTypeScheme = ForAllExist Int Int Type deriving (Eq, Show) -- The functions 'monoType' and 'polyType' translate a type tau into a -- monomorphic type scheme and a polymorphic type scheme, respectively. -- 'polyType' assumes that all universally quantified variables in the type are -- assigned indices starting with 0 and does not renumber the variables. monoType :: Type -> TypeScheme monoType ty = ForAll 0 ty polyType :: Type -> TypeScheme polyType ty = ForAll (maximum (-1 : typeVars ty) + 1) ty -- There are a few predefined types: unitType :: Type unitType = primType qUnitId [] boolType :: Type boolType = primType qBoolId [] charType :: Type charType = primType qCharId [] intType :: Type intType = primType qIntId [] floatType :: Type floatType = primType qFloatId [] stringType :: Type stringType = listType charType listType :: Type -> Type listType ty = primType qListId [ty] ioType :: Type -> Type ioType ty = primType qIOId [ty] tupleType :: [Type] -> Type tupleType tys = primType (qTupleId (length tys)) tys typeVar :: Int -> Type typeVar = TypeVariable primType :: QualIdent -> [Type] -> Type primType = TypeConstructor -- . qualifyWith preludeMIdent predefTypes :: [(Type, [DataConstr])] predefTypes = let a = typeVar 0 in [ (unitType , [ DataConstr unitId 0 [] ]) , (listType a, [ DataConstr nilId 0 [] , DataConstr consId 0 [a, listType a] ]) ] tupleData :: [DataConstr] tupleData = [DataConstr (tupleId n) n (take n tvs) | n <- [2 ..]] where tvs = map typeVar [0 ..] curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/Typing.hs000066400000000000000000000331151302651311700257300ustar00rootroot00000000000000{- | Module : $Header$ Description : Type computation of Curry expressions Copyright : (c) 2003 - 2006 Wolfgang Lux 2014 - 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable -} module Base.Typing (Typeable (..)) where import Control.Monad import qualified Control.Monad.State as S (State, evalState, gets, modify) import Curry.Base.Ident import Curry.Syntax import Base.Messages (internalError) import Base.TopEnv import Base.Types import Base.TypeSubst import Base.Utils (foldr2) import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) -- During the transformation of Curry source code into the intermediate -- language, the compiler has to recompute the types of expressions. This -- is simpler than type checking because the types of all variables are -- known. Yet, the compiler still must handle functions and constructors -- with polymorphic types and instantiate their type schemes using fresh -- type variables. Since all types computed by 'typeOf' are monomorphic, -- we can use type variables with non-negative offsets for the instantiation -- of type schemes here without risk of name conflicts. -- Using non-negative offsets also makes it easy to distinguish these -- fresh variables from free type variables introduced during type -- inference, which must be regarded as constants here. -- However, using non-negative offsets for fresh type variables gives -- rise to two problems when those types are entered back into the type -- environment, e.g., while introducing auxiliary variables during -- desugaring. The first is that those type variables now appear to be -- universally quantified variables, but with indices greater than the -- number of quantified type variables (To be precise, this can -- happen only for auxiliary variables, which have monomorphic types, -- whereas auxiliary functions will be assigned polymorphic types and -- these type variables will be properly quantified. However, in this -- case the assigned types may be too general.). -- This results in an internal error (Prelude.!!: index too large) -- whenever such a type is instantiated. -- The second problem is that there may be inadvertent name captures -- because computeType always uses indices starting at 0 for the fresh -- type variables. In order to avoid these problems, 'computeType' renames -- all type variables with non-negative offsets after the final type has -- been computed, using negative indices below the one with the smallest -- value occurring in the type environment. Computing the minimum index -- of all type variables in the type environment seems prohibitively -- inefficient. However, recall that, thanks to laziness, the minimum is -- computed only when the final type contains any type variables with -- non-negative indices. This happens, for instance, 36 times while -- compiling the prelude (for 159 evaluated applications of 'typeOf') and -- only twice while compiling the standard IO module (for 21 applications -- of 'typeOf') (These numbers were obtained for version 0.9.9.). -- A careful reader will note that inadvertent name captures are still -- possible if one computes the types of two or more auxiliary variables -- before actually entering their types into the environment. Therefore, -- make sure that you enter the types of these auxiliary variables -- immediately into the type environment, unless you are sure that those -- types cannot contain fresh type variables. One such case are the free -- variables of a goal. -- TODO: In the long run, this module should be made obsolete by adding -- attributes to the abstract syntax tree -- e.g., along the lines of -- Chap.~6 in~\cite{PeytonJonesLester92:Book} -- and returning an -- abstract syntax tree attributed with type information together with -- the type environment from type inference. This also would allow -- getting rid of the identifiers in the representation of integer -- literals, which are used in order to implement overloading of -- integer constants. -- TODO: When computing the type of an expression with a type signature -- make use of the annotation instead of recomputing its type. In order -- to do this, we must either ensure that the types are properly -- qualified and expanded or we need access to the type constructor -- environment. data TcState = TcState { valueEnv :: ValueEnv , typeSubst :: TypeSubst , nextId :: Int } type TCM = S.State TcState getValueEnv :: TCM ValueEnv getValueEnv = S.gets valueEnv getTypeSubst :: TCM TypeSubst getTypeSubst = S.gets typeSubst modifyTypeSubst :: (TypeSubst -> TypeSubst) -> TCM () modifyTypeSubst f = S.modify $ \s -> s { typeSubst = f $ typeSubst s } getNextId :: TCM Int getNextId = do nid <- S.gets nextId S.modify $ \ s -> s { nextId = succ nid } return nid run :: TCM a -> ValueEnv -> a run m tyEnv = S.evalState m initState where initState = TcState tyEnv idSubst 0 class Typeable a where typeOf :: ValueEnv -> a -> Type instance Typeable Type where typeOf _ ty = ty instance Typeable Ident where typeOf = computeType identType instance Typeable Pattern where typeOf = computeType argType instance Typeable Expression where typeOf = computeType exprType instance Typeable Rhs where typeOf = computeType rhsType computeType :: (a -> TCM Type) -> ValueEnv -> a -> Type computeType f tyEnv x = normalize (run doComputeType tyEnv) where doComputeType = do ty <- f x theta <- getTypeSubst return (fixTypeVars tyEnv (subst theta ty)) fixTypeVars :: ValueEnv -> Type -> Type fixTypeVars tyEnv ty = subst (foldr2 bindSubst idSubst tvs tvs') ty where tvs = filter (>= 0) (typeVars ty) tvs' = map TypeVariable [n - 1,n - 2 ..] n = minimum (0 : concatMap typeVars tys) tys = [ty1 | (_,Value _ _ (ForAll _ ty1)) <- localBindings tyEnv] identType :: Ident -> TCM Type identType x = do tyEnv <- getValueEnv instUniv (varType x tyEnv) litType :: Literal -> TCM Type litType (Char _ _) = return charType litType (Int v _) = identType v litType (Float _ _) = return floatType litType (String _ _) = return stringType argType :: Pattern -> TCM Type argType (LiteralPattern l) = litType l argType (NegativePattern _ l) = litType l argType (VariablePattern v) = identType v argType (ConstructorPattern c ts) = do tyEnv <- getValueEnv ty <- instUnivExist (constrType c tyEnv) tys <- mapM argType ts unifyList (init (flatten ty)) tys return (last (flatten ty)) where flatten (TypeArrow ty1 ty2) = ty1 : flatten ty2 flatten ty = [ty] argType (InfixPattern t1 op t2) = argType (ConstructorPattern op [t1,t2]) argType (ParenPattern t) = argType t argType (RecordPattern c fs) = do tyEnv <- getValueEnv ty <- liftM arrowBase $ instUnivExist $ constrType c tyEnv mapM_ (fieldType argType ty) fs return ty argType (TuplePattern _ ts) | null ts = return unitType | otherwise = liftM tupleType $ mapM argType ts argType (ListPattern _ ts) = freshTypeVar >>= flip elemType ts where elemType ty [] = return (listType ty) elemType ty (t:ts1) = argType t >>= unify ty >> elemType ty ts1 argType (AsPattern v _) = argType (VariablePattern v) argType (LazyPattern _ t) = argType t argType (FunctionPattern f ts) = do tyEnv <- getValueEnv ty <- instUniv (funType f tyEnv) tys <- mapM argType ts unifyList (init (flatten ty)) tys return (last (flatten ty)) where flatten (TypeArrow ty1 ty2) = ty1 : flatten ty2 flatten ty = [ty] argType (InfixFuncPattern t1 op t2) = argType (FunctionPattern op [t1,t2]) exprType :: Expression -> TCM Type exprType (Literal l) = litType l exprType (Variable v) = do tyEnv <- getValueEnv instUniv (funType v tyEnv) exprType (Constructor c) = do tyEnv <- getValueEnv instUnivExist (constrType c tyEnv) exprType (Typed e _) = exprType e exprType (Paren e) = exprType e exprType (Record c fs) = do tyEnv <- getValueEnv ty <- liftM arrowBase $ instUnivExist $ constrType c tyEnv mapM_ (fieldType exprType ty) fs return ty exprType (RecordUpdate e fs) = do ty <- exprType e mapM_ (fieldType exprType ty) fs return ty exprType (Tuple _ es) | null es = return unitType | otherwise = liftM tupleType $ mapM exprType es exprType (List _ es) = freshTypeVar >>= flip elemType es where elemType ty [] = return (listType ty) elemType ty (e:es1) = exprType e >>= unify ty >> elemType ty es1 exprType (ListCompr _ e _) = liftM listType $ exprType e exprType (EnumFrom _) = return (listType intType) exprType (EnumFromThen _ _) = return (listType intType) exprType (EnumFromTo _ _) = return (listType intType) exprType (EnumFromThenTo _ _ _) = return (listType intType) exprType (UnaryMinus _ e) = exprType e exprType (Apply e1 e2) = do (ty1,ty2) <- exprType e1 >>= unifyArrow exprType e2 >>= unify ty1 return ty2 exprType (InfixApply e1 op e2) = do (ty1,ty2,ty3) <- exprType (infixOp op) >>= unifyArrow2 exprType e1 >>= unify ty1 exprType e2 >>= unify ty2 return ty3 exprType (LeftSection e op) = do (ty1,ty2,ty3) <- exprType (infixOp op) >>= unifyArrow2 exprType e >>= unify ty1 return (TypeArrow ty2 ty3) exprType (RightSection op e) = do (ty1,ty2,ty3) <- exprType (infixOp op) >>= unifyArrow2 exprType e >>= unify ty2 return (TypeArrow ty1 ty3) exprType (Lambda _ args e) = do tys <- mapM argType args ty <- exprType e return (foldr TypeArrow ty tys) exprType (Let _ e) = exprType e exprType (Do _ e) = exprType e exprType (IfThenElse _ e1 e2 e3) = do exprType e1 >>= unify boolType ty2 <- exprType e2 ty3 <- exprType e3 unify ty2 ty3 return ty3 exprType (Case _ _ _ alts) = freshTypeVar >>= flip altType alts where altType ty [] = return ty altType ty (Alt _ _ rhs:alts1) = rhsType rhs >>= unify ty >> altType ty alts1 rhsType :: Rhs -> TCM Type rhsType (SimpleRhs _ e _) = exprType e rhsType (GuardedRhs es _) = freshTypeVar >>= flip condExprType es where condExprType ty [] = return ty condExprType ty (CondExpr _ _ e:es1) = exprType e >>= unify ty >> condExprType ty es1 fieldType :: (a -> TCM Type) -> Type -> Field a -> TCM Type fieldType tcheck ty (Field _ l x) = do tyEnv <- getValueEnv TypeArrow ty1 ty2 <- instUniv (labelType l tyEnv) unify ty ty1 lty <- tcheck x unify ty2 lty return lty -- In order to avoid name conflicts with non-generalized type variables -- in a type we instantiate quantified type variables using non-negative -- offsets here. freshTypeVar :: TCM Type freshTypeVar = TypeVariable `liftM` getNextId instType :: Int -> Type -> TCM Type instType n ty = do tys <- replicateM n freshTypeVar return (expandAliasType tys ty) instUniv :: TypeScheme -> TCM Type instUniv (ForAll n ty) = instType n ty instUnivExist :: ExistTypeScheme -> TCM Type instUnivExist (ForAllExist n n' ty) = instType (n + n') ty -- When unifying two types, the non-generalized variables, i.e., -- variables with negative offsets, must not be substituted. Otherwise, -- the unification algorithm is identical to the one used by the type -- checker. unify :: Type -> Type -> TCM () unify ty1 ty2 = do theta <- getTypeSubst let ty1' = subst theta ty1 ty2' = subst theta ty2 modifyTypeSubst $ unifyTypes ty1' ty2' unifyList :: [Type] -> [Type] -> TCM () unifyList tys1 tys2 = zipWithM_ unify tys1 tys2 unifyArrow :: Type -> TCM (Type,Type) unifyArrow ty = do theta <- getTypeSubst case subst theta ty of TypeVariable tv | tv >= 0 -> do ty1 <- freshTypeVar ty2 <- freshTypeVar modifyTypeSubst (bindVar tv (TypeArrow ty1 ty2)) return (ty1,ty2) TypeArrow ty1 ty2 -> return (ty1,ty2) ty' -> internalError ("Base.Typing.unifyArrow (" ++ show ty' ++ ")") unifyArrow2 :: Type -> TCM (Type,Type,Type) unifyArrow2 ty = do (ty1,ty2) <- unifyArrow ty (ty21,ty22) <- unifyArrow ty2 return (ty1,ty21,ty22) unifyTypes :: Type -> Type -> TypeSubst -> TypeSubst unifyTypes (TypeVariable tv1) (TypeVariable tv2) theta | tv1 == tv2 = theta unifyTypes (TypeVariable tv) ty theta | tv >= 0 = bindVar tv ty theta unifyTypes ty (TypeVariable tv) theta | tv >= 0 = bindVar tv ty theta unifyTypes (TypeConstructor tc1 tys1) (TypeConstructor tc2 tys2) theta | tc1 == tc2 = foldr2 unifyTypes theta tys1 tys2 unifyTypes (TypeConstrained _ tv1) (TypeConstrained _ tv2) theta | tv1 == tv2 = theta unifyTypes (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) theta = unifyTypes ty11 ty21 (unifyTypes ty12 ty22 theta) unifyTypes (TypeSkolem k1) (TypeSkolem k2) theta | k1 == k2 = theta unifyTypes ty1 ty2 _ = internalError $ "Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")" -- The functions 'constrType', 'varType', and 'funType' are used for computing -- the type of constructors, pattern variables, and variables. -- TODO: These functions should be shared with the type checker. constrType :: QualIdent -> ValueEnv -> ExistTypeScheme constrType c tyEnv = case qualLookupValue c tyEnv of [DataConstructor _ _ _ sigma] -> sigma [NewtypeConstructor _ _ sigma] -> sigma _ -> internalError $ "Base.Typing.constrType: " ++ show c varType :: Ident -> ValueEnv -> TypeScheme varType v tyEnv = case lookupValue v tyEnv of [Value _ _ sigma] -> sigma [Label _ _ sigma] -> sigma _ -> internalError $ "Base.Typing.varType: " ++ show v funType :: QualIdent -> ValueEnv -> TypeScheme funType f tyEnv = case qualLookupValue f tyEnv of [Value _ _ sigma] -> sigma [Label _ _ sigma] -> sigma _ -> internalError $ "Base.Typing.funType: " ++ show f labelType :: QualIdent -> ValueEnv -> TypeScheme labelType l tyEnv = case qualLookupValue l tyEnv of [Label _ _ sigma] -> sigma _ -> internalError $ "Base.Typing.labelType: " ++ show l curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Base/Utils.hs000066400000000000000000000050471302651311700255610ustar00rootroot00000000000000{- | Module : $Header$ Description : Auxiliary functions Copyright : (c) 2001 - 2003 Wolfgang Lux 2011 - 2015 Björn Peemöler License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable The module Utils provides a few simple functions that are commonly used in the compiler, but not implemented in the Haskell Prelude or standard library. -} module Base.Utils ( (++!), foldr2, mapAccumM, findDouble, concatMapM, findMultiples ) where import Data.List (partition) infixr 5 ++! -- The function (++!) is variant of the list concatenation operator (++) -- that ignores the second argument if the first is a non-empty list. -- When lists are used to encode non-determinism in Haskell, -- this operator has the same effect as the cut operator in Prolog, -- hence the ! in the name. (++!) :: [a] -> [a] -> [a] xs ++! ys = if null xs then ys else xs -- Fold operations with two arguments lists can be defined using -- zip and foldl or foldr, resp. Our definitions are unfolded for -- efficiency reasons. -- foldl2 :: (a -> b -> c -> a) -> a -> [b] -> [c] -> a -- foldl2 _ z [] _ = z -- foldl2 _ z _ [] = z -- foldl2 f z (x : xs) (y : ys) = foldl2 f (f z x y) xs ys foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c foldr2 _ z [] _ = z foldr2 _ z _ [] = z foldr2 f z (x : xs) (y : ys) = f x y (foldr2 f z xs ys) -- The function 'mapAccumM' is a generalization of mapAccumL to monads -- like foldM is for foldl. mapAccumM :: Monad m => (a -> b -> m (a, c)) -> a -> [b] -> m (a, [c]) mapAccumM _ s [] = return (s, []) mapAccumM f s (x : xs) = do (s' , y ) <- f s x (s'', ys) <- mapAccumM f s' xs return (s'', y : ys) -- The function 'concatMapM' is a generalization of concatMap to monads -- like foldM is for foldl. concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = mapM f xs >>= return . concat -- The function '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. findDouble :: Eq a => [a] -> Maybe a findDouble [] = Nothing findDouble (x : xs) | x `elem` xs = Just x | otherwise = findDouble xs findMultiples :: Eq a => [a] -> [[a]] findMultiples [] = [] findMultiples (x : xs) | null same = multiples | otherwise = (x : same) : multiples where (same, other) = partition (==x) xs multiples = findMultiples other curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks.hs000066400000000000000000000101471302651311700250040ustar00rootroot00000000000000{- | Module : $Header$ Description : Different checks on a Curry module Copyright : (c) 2011 - 2013, Björn Peemöller License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module subsumes the different checks to be performed on a Curry module during compilation, e.g. type checking. -} module Checks where import qualified Checks.InterfaceCheck as IC (interfaceCheck) import qualified Checks.ImportSyntaxCheck as ISC (importCheck) import qualified Checks.ExportCheck as EC (exportCheck, expandExports) import qualified Checks.KindCheck as KC (kindCheck) import qualified Checks.PrecCheck as PC (precCheck) import qualified Checks.SyntaxCheck as SC (syntaxCheck) import qualified Checks.TypeCheck as TC (typeCheck) import qualified Checks.WarnCheck as WC (warnCheck) import Curry.Base.Monad import Curry.Syntax (Module (..), Interface (..), ImportSpec) import Base.Messages import CompilerEnv import CompilerOpts type Check m a = Options -> CompEnv a -> CYT m (CompEnv a) interfaceCheck :: Monad m => Check m Interface interfaceCheck _ (env, intf) | null msgs = ok (env, intf) | otherwise = failMessages msgs where msgs = IC.interfaceCheck (opPrecEnv env) (tyConsEnv env) (valueEnv env) intf importCheck :: Monad m => Interface -> Maybe ImportSpec -> CYT m (Maybe ImportSpec) importCheck intf is | null msgs = ok is' | otherwise = failMessages msgs where (is', msgs) = ISC.importCheck intf is -- |Check the kinds of type definitions and signatures. -- -- * Declarations: Nullary type constructors and type variables are -- disambiguated -- * Environment: remains unchanged kindCheck :: Monad m => Check m Module kindCheck _ (env, mdl) | null msgs = ok (env, mdl') | otherwise = failMessages msgs where (mdl', msgs) = KC.kindCheck (tyConsEnv env) mdl -- |Check for a correct syntax. -- -- * Declarations: Nullary data constructors and variables are -- disambiguated, variables are renamed -- * Environment: remains unchanged syntaxCheck :: Monad m => Check m Module syntaxCheck opts (env, mdl) | null msgs = ok (env { extensions = exts }, mdl') | otherwise = failMessages msgs where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env) mdl -- |Check the precedences of infix operators. -- -- * Declarations: Expressions are reordered according to the specified -- precedences -- * Environment: The operator precedence environment is updated precCheck :: Monad m => Check m Module precCheck _ (env, Module ps m es is ds) | null msgs = ok (env { opPrecEnv = pEnv' }, Module ps m es is ds') | otherwise = failMessages msgs where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds -- |Apply the correct typing of the module. -- The declarations remain unchanged; the type constructor and value -- environments are updated. typeCheck :: Monad m => Check m Module typeCheck _ (env, mdl@(Module _ _ _ _ ds)) | null msgs = ok (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl) | otherwise = failMessages msgs where (tcEnv', tyEnv', msgs) = TC.typeCheck (moduleIdent env) (tyConsEnv env) (valueEnv env) ds -- |Check the export specification exportCheck :: Monad m => Check m Module exportCheck _ (env, mdl@(Module _ _ es _ _)) | null msgs = ok (env, mdl) | otherwise = failMessages msgs where msgs = EC.exportCheck (moduleIdent env) (aliasEnv env) (tyConsEnv env) (valueEnv env) es -- |Check the export specification expandExports :: Monad m => Options -> CompEnv Module -> m (CompEnv Module) expandExports _ (env, Module ps m es is ds) = return (env, Module ps m (Just es') is ds) where es' = EC.expandExports (moduleIdent env) (aliasEnv env) (tyConsEnv env) (valueEnv env) es -- |Check for warnings. warnCheck :: Options -> CompilerEnv -> Module -> [Message] warnCheck opts env mdl = WC.warnCheck (optWarnOpts opts) (aliasEnv env) (valueEnv env) (tyConsEnv env) mdl curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/000077500000000000000000000000001302651311700244455ustar00rootroot00000000000000curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/ExportCheck.hs000066400000000000000000000443211302651311700272240ustar00rootroot00000000000000{- | Module : $Header$ Description : Check the export specification of a module Copyright : (c) 1999 - 2004 Wolfgang Lux 2011 - 2016 Björn Peemöller 2015 - 2016 Yannik Potdevin License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module implements a check and expansion of the export specification. Any errors in the specification are reported, and if there are no errors, the specification is expanded. The expansion does the following: * If there is no export specification, a specification exporting the entire module is generated. * Otherwise, (re)exports of modules are replaced by an export of all respective entities. * The export of a type with all constructors and fields is replaced by an enumeration of all constructors and fields. * The export of types without sub-entities is extended with an empty list of sub-entities. -} {-# LANGUAGE CPP #-} module Checks.ExportCheck (exportCheck, expandExports) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad (unless) import qualified Control.Monad.State as S (State, runState, gets, modify) import Data.List (nub, union) import qualified Data.Map as Map (Map, elems, empty, insert , insertWith, lookup, toList) import Data.Maybe (fromMaybe) import qualified Data.Set as Set (Set, empty, fromList, insert , member, toList) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Syntax import Base.Messages (Message, internalError, posMessage) import Base.TopEnv (allEntities, origName, localBindings, moduleImports) import Base.Types ( DataConstr (..), ExistTypeScheme (..), Type (..) , TypeScheme (..), arrowBase, constrIdent, recLabels) import Base.Utils (findMultiples) import Env.ModuleAlias (AliasEnv) import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTCUnique) import Env.Value (ValueEnv, ValueInfo (..), qualLookupValueUnique) currentModuleName :: String currentModuleName = "Checks.ExportCheck" -- --------------------------------------------------------------------------- -- Check and expansion of the export statement -- --------------------------------------------------------------------------- expandExports :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> ExportSpec expandExports m aEnv tcEnv tyEnv spec = Exporting (exportPos spec) es where exportPos (Just (Exporting p _)) = p exportPos Nothing = NoPos es = expand m aEnv tcEnv tyEnv spec exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Message] exportCheck m aEnv tcEnv tyEnv spec = case check m aEnv tcEnv tyEnv spec of [] -> checkNonUniqueness $ expand m aEnv tcEnv tyEnv spec ms -> ms -- ----------------------------------------------------------------------------- -- Export Check Monad -- ----------------------------------------------------------------------------- data ECState = ECState { moduleIdent :: ModuleIdent , importedMods :: Set.Set ModuleIdent , tyConsEnv :: TCEnv , valueEnv :: ValueEnv , errors :: [Message] } type ECM a = S.State ECState a runECM :: ECM a -> ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> (a, [Message]) runECM ecm m aEnv tcEnv tyEnv = let (a, s') = S.runState ecm initState in (a, reverse $ errors s') where initState = ECState m imported tcEnv tyEnv [] imported = Set.fromList (Map.elems aEnv) getModuleIdent :: ECM ModuleIdent getModuleIdent = S.gets moduleIdent getImportedModules :: ECM (Set.Set ModuleIdent) getImportedModules = S.gets importedMods getTyConsEnv :: ECM TCEnv getTyConsEnv = S.gets tyConsEnv getValueEnv :: ECM ValueEnv getValueEnv = S.gets valueEnv report :: Message -> ECM () report err = S.modify (\ s -> s { errors = err : errors s }) ok :: ECM () ok = return () -- ----------------------------------------------------------------------------- -- Check -- ----------------------------------------------------------------------------- check :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Message] check m aEnv tcEnv tyEnv spec = snd $ runECM (checkSpec spec) m aEnv tcEnv tyEnv -- |Check export specification. checkSpec :: Maybe ExportSpec -> ECM () checkSpec (Just (Exporting _ es)) = mapM_ checkExport es checkSpec Nothing = ok -- |Check single export. checkExport :: Export -> ECM () checkExport (Export x ) = checkThing x checkExport (ExportTypeWith tc cs) = checkTypeWith tc cs checkExport (ExportTypeAll tc ) = checkTypeAll tc checkExport (ExportModule em ) = checkModule em -- |Check export of type constructor / function checkThing :: QualIdent -> ECM () checkThing tc = do m <- getModuleIdent tcEnv <- getTyConsEnv case qualLookupTCUnique m tc tcEnv of [] -> checkThing' tc Nothing [t] -> checkThing' tc (Just [ExportTypeWith (origName t) []]) ts -> report (errAmbiguousType tc ts) -- |Expand export of data cons / function checkThing' :: QualIdent -> Maybe [Export] -> ECM () checkThing' f tcExport = do m <- getModuleIdent tyEnv <- getValueEnv case qualLookupValueUnique m f tyEnv of [] -> justTcOr errUndefinedName [v] -> case v of Value _ _ _ -> ok Label _ _ _ -> report $ errOutsideTypeLabel f (getTc v) _ -> justTcOr $ flip errOutsideTypeConstructor (getTc v) fs -> report (errAmbiguousName f fs) where justTcOr errFun = maybe (report $ errFun f) (const ok) tcExport getTc (DataConstructor _ _ _ (ForAllExist _ _ ty)) = getTc' ty getTc (NewtypeConstructor _ _ (ForAllExist _ _ ty)) = getTc' ty getTc (Label _ _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))) = tc getTc err = internalError $ currentModuleName ++ ".checkThing'.getTc: " ++ show err getTc' ty = let (TypeConstructor tc _) = arrowBase ty in tc checkTypeWith :: QualIdent -> [Ident] -> ECM () checkTypeWith tc xs = do m <- getModuleIdent tcEnv <- getTyConsEnv case qualLookupTCUnique m tc tcEnv of [] -> report (errUndefinedType tc) [DataType _ _ cs] -> mapM_ (checkElement (visibleElems cs )) xs' [RenamingType _ _ c] -> mapM_ (checkElement (visibleElems [c])) xs' [_] -> report (errNonDataType tc) ts -> report (errAmbiguousType tc ts) where xs' = nub xs -- check if given identifier is constructor or label of type tc checkElement cs' c = unless (c `elem` cs') $ report $ errUndefinedElement tc c -- |Check type constructor with all data constructors and record labels. checkTypeAll :: QualIdent -> ECM () checkTypeAll tc = do m <- getModuleIdent tcEnv <- getTyConsEnv case qualLookupTCUnique m tc tcEnv of [] -> report (errUndefinedType tc) [DataType _ _ _] -> ok [RenamingType _ _ _] -> ok [_] -> report (errNonDataType tc) ts -> report (errAmbiguousType tc ts) checkModule :: ModuleIdent -> ECM () checkModule em = do isLocal <- (em ==) <$> getModuleIdent isForeign <- (Set.member em) <$> getImportedModules unless (isLocal || isForeign) $ report $ errModuleNotImported em -- Check whether two entities of the same kind (type or constructor/function) -- share the same unqualified name, which is not allowed since they could -- not be uniquely resolved at their usage. -- For instance, consider the following module -- @ -- module M (Bool, Prelude.Bool) where -- data Bool = False | True -- @ -- If this export would be allowed, in a module @M1@ as follows -- @ -- module M1 where -- import M (Bool) -- @ -- the type @Bool@ could not be resolved uniquely to its definition. -- Naturally, the same applies for constructors or functions. checkNonUniqueness :: [Export] -> [Message] checkNonUniqueness es = map errMultipleType (findMultiples types ) ++ map errMultipleName (findMultiples values) where types = [ unqualify tc | ExportTypeWith tc _ <- es ] values = [ c | ExportTypeWith _ cs <- es, c <- cs ] ++ [ unqualify f | Export f <- es ] -- ----------------------------------------------------------------------------- -- Expansion -- ----------------------------------------------------------------------------- expand :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Export] expand m aEnv tcEnv tyEnv spec = fst $ runECM ((joinExports . canonExports tcEnv) <$> expandSpec spec) m aEnv tcEnv tyEnv -- While checking all export specifications, the compiler expands -- specifications of the form @T(..)@ into @T(C_1,...,C_m,l_1,...,l_n)@, -- where @C_1,...,C_m@ are the data constructors of type @T@ and @l_1,...,l_n@ -- its field labels, and replaces an export specification -- @module M@ by specifications for all entities which are defined -- in module @M@ and imported into the current module with their -- unqualified name. In order to distinguish exported type constructors -- from exported functions, the former are translated into the equivalent -- form @T()@. Note that the export specification @x@ may -- export a type constructor @x@ /and/ a global function -- @x@ at the same time. -- -- /Note:/ This frontend allows redeclaration and export of imported -- identifiers. -- |Expand export specification expandSpec :: Maybe ExportSpec -> ECM [Export] expandSpec (Just (Exporting _ es)) = concat <$> mapM expandExport es expandSpec Nothing = expandLocalModule -- |Expand single export expandExport :: Export -> ECM [Export] expandExport (Export x) = expandThing x expandExport (ExportTypeWith tc cs) = expandTypeWith tc cs expandExport (ExportTypeAll tc) = expandTypeAll tc expandExport (ExportModule em) = expandModule em -- |Expand export of type constructor / function expandThing :: QualIdent -> ECM [Export] expandThing tc = do m <- getModuleIdent tcEnv <- getTyConsEnv case qualLookupTCUnique m tc tcEnv of [] -> expandThing' tc Nothing [t] -> expandThing' tc (Just [ExportTypeWith (origName t @> tc) []]) err -> internalError $ currentModuleName ++ ".expandThing: " ++ show err -- |Expand export of data cons / function expandThing' :: QualIdent -> Maybe [Export] -> ECM [Export] expandThing' f tcExport = do m <- getModuleIdent tyEnv <- getValueEnv case qualLookupValueUnique m f tyEnv of [Value f' _ _] -> return $ Export (f' @> f) : fromMaybe [] tcExport _ -> return $ fromMaybe [] tcExport -- |Expand type constructor with explicit data constructors and record labels expandTypeWith :: QualIdent -> [Ident] -> ECM [Export] expandTypeWith tc xs = do m <- getModuleIdent tcEnv <- getTyConsEnv case qualLookupTCUnique m tc tcEnv of [t] -> return [ExportTypeWith (origName t @> tc) $ nub xs] err -> internalError $ currentModuleName ++ ".expandTypeWith: " ++ show err -- |Expand type constructor with all data constructors and record labels expandTypeAll :: QualIdent -> ECM [Export] expandTypeAll tc = do m <- getModuleIdent tcEnv <- getTyConsEnv case qualLookupTCUnique m tc tcEnv of [t] -> return [exportType t] err -> internalError $ currentModuleName ++ ".expandTypeAll: " ++ show err expandModule :: ModuleIdent -> ECM [Export] expandModule em = do isLocal <- (em ==) <$> getModuleIdent isForeign <- (Set.member em) <$> getImportedModules locals <- if isLocal then expandLocalModule else return [] foreigns <- if isForeign then expandImportedModule em else return [] return $ locals ++ foreigns expandLocalModule :: ECM [Export] expandLocalModule = do tcEnv <- getTyConsEnv tyEnv <- getValueEnv return $ [ exportType t | (_, t) <- localBindings tcEnv ] ++ [ Export f' | (f, Value f' _ _) <- localBindings tyEnv, hasGlobalScope f ] ++ [ Export l' | (l, Label l' _ _) <- localBindings tyEnv, hasGlobalScope l ] -- |Expand a module export expandImportedModule :: ModuleIdent -> ECM [Export] expandImportedModule m = do tcEnv <- getTyConsEnv tyEnv <- getValueEnv return $ [exportType t | (_, t) <- moduleImports m tcEnv] ++ [Export f | (_, Value f _ _) <- moduleImports m tyEnv] ++ [Export l | (_, Label l _ _) <- moduleImports m tyEnv] exportType :: TypeInfo -> Export exportType t = ExportTypeWith tc xs where tc = origName t xs = elements t -- ----------------------------------------------------------------------------- -- Canonicalization and joining of exports -- ----------------------------------------------------------------------------- -- In contrast to Haskell, the export of field labels and record constructors -- without their types is NOT allowed. -- Thus, given the declaration @data T a = C { l :: a }@ -- the label @l@ and the constructor @C@ can only be exported together with the -- type @T@, i.e., @(T(C,l))@. -- Since record update operations are desugared to case expressions matching the -- corresponding constructors of the record, the export of a label without its -- type could result in a type error, when it is used for an update operation in -- another module. canonExports :: TCEnv -> [Export] -> [Export] canonExports tcEnv es = map (canonExport (canonLabels tcEnv es)) es canonExport :: Map.Map QualIdent Export -> Export -> Export canonExport ls (Export x) = fromMaybe (Export x) (Map.lookup x ls) canonExport _ (ExportTypeWith tc xs) = ExportTypeWith tc xs canonExport _ e = internalError $ currentModuleName ++ ".canonExport: " ++ show e canonLabels :: TCEnv -> [Export] -> Map.Map QualIdent Export canonLabels tcEnv es = foldr bindLabels Map.empty (allEntities tcEnv) where tcs = [tc | ExportTypeWith tc _ <- es] bindLabels t ls | tc' `elem` tcs = foldr (bindLabel tc') ls (elements t) | otherwise = ls where tc' = origName t bindLabel tc x = Map.insert (qualifyLike tc x) (ExportTypeWith tc [x]) -- The expanded list of exported entities may contain duplicates. These -- are removed by the function joinExports. In particular, this -- function removes any field labels from the list of exported values -- which are also exported along with their types. joinExports :: [Export] -> [Export] joinExports es = [ExportTypeWith tc cs | (tc, cs) <- joinedTypes] ++ [Export f | f <- joinedFuncs] where joinedTypes = Map.toList $ foldr joinType Map.empty es joinedFuncs = Set.toList $ foldr joinFun Set.empty es joinType :: Export -> Map.Map QualIdent [Ident] -> Map.Map QualIdent [Ident] joinType (Export _) tcs = tcs joinType (ExportTypeWith tc cs) tcs = Map.insertWith union tc cs tcs joinType export _ = internalError $ currentModuleName ++ ".joinType: " ++ show export joinFun :: Export -> Set.Set QualIdent -> Set.Set QualIdent joinFun (Export f) fs = f `Set.insert` fs joinFun (ExportTypeWith _ _) fs = fs joinFun export _ = internalError $ currentModuleName ++ ".joinFun: " ++ show export -- --------------------------------------------------------------------------- -- Auxiliary definitions -- --------------------------------------------------------------------------- elements :: TypeInfo -> [Ident] elements (DataType _ _ cs) = visibleElems cs elements (RenamingType _ _ c) = visibleElems [c] elements (AliasType _ _ _) = [] -- get visible constructor and label identifiers for given constructor visibleElems :: [DataConstr] -> [Ident] visibleElems cs = map constrIdent cs ++ (nub (concatMap recLabels cs)) -- --------------------------------------------------------------------------- -- Error messages -- --------------------------------------------------------------------------- errAmbiguousName :: QualIdent -> [ValueInfo] -> Message errAmbiguousName x vs = errAmbiguous "name" x (map origName vs) errAmbiguousType :: QualIdent -> [TypeInfo] -> Message errAmbiguousType tc tcs = errAmbiguous "type" tc (map origName tcs) errAmbiguous :: String -> QualIdent -> [QualIdent] -> Message errAmbiguous what qn qns = posMessage qn $ text "Ambiguous" <+> text what <+> text (escQualName qn) $+$ text "It could refer to:" $+$ nest 2 (vcat (map (text . escQualName) qns)) errModuleNotImported :: ModuleIdent -> Message errModuleNotImported m = posMessage m $ hsep $ map text ["Module", escModuleName m, "not imported"] errMultipleName :: [Ident] -> Message errMultipleName = errMultiple "name" errMultipleType :: [Ident] -> Message errMultipleType = errMultiple "type" errMultiple :: String -> [Ident] -> Message errMultiple _ [] = internalError $ currentModuleName ++ ".errMultiple: empty list" errMultiple what (i:is) = posMessage i $ text "Multiple exports of" <+> text what <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat (map showPos (i:is))) where showPos = text . showLine . idPosition errNonDataType :: QualIdent -> Message errNonDataType tc = posMessage tc $ hsep $ map text [escQualName tc, "is not a data type"] errOutsideTypeConstructor :: QualIdent -> QualIdent -> Message errOutsideTypeConstructor c tc = errOutsideTypeExport "Data constructor" c tc errOutsideTypeLabel :: QualIdent -> QualIdent -> Message errOutsideTypeLabel l tc = errOutsideTypeExport "Label" l tc errOutsideTypeExport :: String -> QualIdent -> QualIdent -> Message errOutsideTypeExport what q tc = posMessage q $ text what <+> text (escQualName q) <+> text "outside type export in export list" $+$ text "Use `" <> text (qualName tc) <+> parens (text (qualName q)) <> text "' instead" errUndefinedElement :: QualIdent -> Ident -> Message errUndefinedElement tc c = posMessage c $ hsep $ map text [ escName c, "is not a constructor or label of type", escQualName tc ] errUndefinedName :: QualIdent -> Message errUndefinedName = errUndefined "name" errUndefinedType :: QualIdent -> Message errUndefinedType = errUndefined "type" errUndefined :: String -> QualIdent -> Message errUndefined what tc = posMessage tc $ hsep $ map text ["Undefined", what, escQualName tc, "in export list"] curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/ImportSyntaxCheck.hs000066400000000000000000000223311302651311700304210ustar00rootroot00000000000000{- | Module : $Header$ Description : Checking import specifications Copyright : (c) 2016 Jan Tikovsky License : BSD-3-clause Maintainer : jrt@informatik.uni-kiel.de Stability : experimental Portability : portable This module provides the function 'importCheck' to check and expand the import specifications of all import declarations. -} module Checks.ImportSyntaxCheck(importCheck) where import Control.Monad (liftM, unless) import qualified Control.Monad.State as S (State, gets, modify, runState) import Data.List (nub, union) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Curry.Base.Ident import Curry.Base.Pretty import Curry.Syntax import Base.Messages import Base.TopEnv importCheck :: Interface -> Maybe ImportSpec -> (Maybe ImportSpec, [Message]) importCheck (Interface m _ ds) is = runExpand (expandSpecs is) m mTCEnv mTyEnv where mTCEnv = intfEnv types ds mTyEnv = intfEnv values ds data ITypeInfo = Data QualIdent [Ident] | Alias QualIdent deriving Show instance Entity ITypeInfo where origName (Data tc _) = tc origName (Alias tc) = tc merge (Data tc1 cs1) (Data tc2 cs2) | tc1 == tc2 && (null cs1 || null cs2 || cs1 == cs2) = Just $ Data tc1 (if null cs1 then cs2 else cs1) merge l@(Alias tc1) (Alias tc2) | tc1 == tc2 = Just l merge _ _ = Nothing data IValueInfo = Constr QualIdent | Var QualIdent [QualIdent] deriving Show instance Entity IValueInfo where origName (Constr c) = c origName (Var x _) = x merge (Constr c1) (Constr c2) | c1 == c2 = Just (Constr c1) merge (Var x1 cs1) (Var x2 cs2) | x1 == x2 = Just (Var x1 (cs1 `union` cs2)) merge _ _ = Nothing intfEnv :: Entity a => (IDecl -> [a]) -> [IDecl] -> IdentMap a intfEnv idents ds = foldr bindId Map.empty (concatMap idents ds) where bindId x = Map.insert (unqualify (origName x)) x types :: IDecl -> [ITypeInfo] types (IDataDecl _ tc _ cs hs) = [Data tc (filter (`notElem` hs) xs)] where xs = map constrId cs ++ nub (concatMap recordLabels cs) types (INewtypeDecl _ tc _ nc hs) = [Data tc (filter (`notElem` hs) xs)] where xs = nconstrId nc : nrecordLabels nc types (ITypeDecl _ tc _ _) = [Alias tc] types _ = [] values :: IDecl -> [IValueInfo] values (IDataDecl _ tc _ cs hs) = cidents tc (map constrId cs) hs ++ lidents tc [(l, lconstrs cs l) | l <- nub (concatMap recordLabels cs)] hs where lconstrs cons l = [constrId c | c <- cons, l `elem` recordLabels c] values (INewtypeDecl _ tc _ nc hs) = cidents tc [nconstrId nc] hs ++ lidents tc [(l, [c]) | NewRecordDecl _ _ c (l, _) <- [nc]] hs values (IFunctionDecl _ f _ _) = [Var f []] values _ = [] cidents :: QualIdent -> [Ident] -> [Ident] -> [IValueInfo] cidents tc cs hs = [Constr (qualifyLike tc c) | c <- cs, c `notElem` hs] lidents :: QualIdent -> [(Ident, [Ident])] -> [Ident] -> [IValueInfo] lidents tc ls hs = [ Var (qualifyLike tc l) (map (qualifyLike tc) cs) | (l, cs) <- ls, l `notElem` hs ] -- --------------------------------------------------------------------------- -- Expansion of the import specification -- --------------------------------------------------------------------------- -- After the environments have been initialized, the optional import -- specifications can be checked. There are two kinds of import -- specifications, a ``normal'' one, which names the entities that shall -- be imported, and a hiding specification, which lists those entities -- that shall not be imported. -- -- There is a subtle difference between both kinds of -- specifications: While it is not allowed to list a data constructor -- outside of its type in a ``normal'' specification, it is allowed to -- hide a data constructor explicitly. E.g., if module \texttt{A} exports -- the data type \texttt{T} with constructor \texttt{C}, the data -- constructor can be imported with one of the two specifications -- -- import A (T(C)) -- import A (T(..)) -- -- but can be hidden in three different ways: -- -- import A hiding (C) -- import A hiding (T (C)) -- import A hiding (T (..)) -- -- The functions \texttt{expandImport} and \texttt{expandHiding} check -- that all entities in an import specification are actually exported -- from the module. In addition, all imports of type constructors are -- changed into a \texttt{T()} specification and explicit imports for the -- data constructors are added. type IdentMap = Map.Map Ident type ExpTCEnv = IdentMap ITypeInfo type ExpValueEnv = IdentMap IValueInfo data ExpandState = ExpandState { expModIdent :: ModuleIdent , expTCEnv :: ExpTCEnv , expValueEnv :: ExpValueEnv , errors :: [Message] } type ExpandM a = S.State ExpandState a getModuleIdent :: ExpandM ModuleIdent getModuleIdent = S.gets expModIdent getTyConsEnv :: ExpandM ExpTCEnv getTyConsEnv = S.gets expTCEnv getValueEnv :: ExpandM ExpValueEnv getValueEnv = S.gets expValueEnv report :: Message -> ExpandM () report msg = S.modify $ \ s -> s { errors = msg : errors s } runExpand :: ExpandM a -> ModuleIdent -> ExpTCEnv -> ExpValueEnv -> (a, [Message]) runExpand expand m tcEnv tyEnv = let (r, s) = S.runState expand (ExpandState m tcEnv tyEnv []) in (r, reverse $ errors s) expandSpecs :: Maybe ImportSpec -> ExpandM (Maybe ImportSpec) expandSpecs Nothing = return Nothing expandSpecs (Just (Importing p is)) = (Just . Importing p . concat) `liftM` mapM expandImport is expandSpecs (Just (Hiding p is)) = (Just . Hiding p . concat) `liftM` mapM expandHiding is expandImport :: Import -> ExpandM [Import] expandImport (Import x) = expandThing x expandImport (ImportTypeWith tc cs) = (:[]) `liftM` expandTypeWith tc cs expandImport (ImportTypeAll tc) = (:[]) `liftM` expandTypeAll tc expandHiding :: Import -> ExpandM [Import] expandHiding (Import x) = expandHide x expandHiding (ImportTypeWith tc cs) = (:[]) `liftM` expandTypeWith tc cs expandHiding (ImportTypeAll tc) = (:[]) `liftM` expandTypeAll tc -- try to expand as type constructor expandThing :: Ident -> ExpandM [Import] expandThing tc = do tcEnv <- getTyConsEnv case Map.lookup tc tcEnv of Just _ -> expandThing' tc $ Just [ImportTypeWith tc []] Nothing -> expandThing' tc Nothing -- try to expand as function / data constructor expandThing' :: Ident -> Maybe [Import] -> ExpandM [Import] expandThing' f tcImport = do m <- getModuleIdent tyEnv <- getValueEnv expand m f (Map.lookup f tyEnv) tcImport where expand :: ModuleIdent -> Ident -> Maybe IValueInfo -> Maybe [Import] -> ExpandM [Import] expand m e Nothing Nothing = report (errUndefinedEntity m e) >> return [] expand _ _ Nothing (Just tc) = return tc expand m e (Just v) maybeTc | isConstr v = case maybeTc of Nothing -> report (errImportDataConstr m e) >> return [] Just tc -> return tc | otherwise = return [Import e] isConstr (Constr _) = True isConstr (Var _ _) = False -- try to hide as type constructor expandHide :: Ident -> ExpandM [Import] expandHide tc = do tcEnv <- getTyConsEnv case Map.lookup tc tcEnv of Just _ -> expandHide' tc $ Just [ImportTypeWith tc []] Nothing -> expandHide' tc Nothing -- try to hide as function / data constructor expandHide' :: Ident -> Maybe [Import] -> ExpandM [Import] expandHide' f tcImport = do m <- getModuleIdent tyEnv <- getValueEnv case Map.lookup f tyEnv of Just _ -> return $ Import f : fromMaybe [] tcImport Nothing -> case tcImport of Nothing -> report (errUndefinedEntity m f) >> return [] Just tc -> return tc expandTypeWith :: Ident -> [Ident] -> ExpandM Import expandTypeWith tc cs = do m <- getModuleIdent tcEnv <- getTyConsEnv ImportTypeWith tc `liftM` case Map.lookup tc tcEnv of Just (Data _ xs) -> mapM (checkElement xs) cs Just (Alias _) -> report (errNonDataType tc) >> return [] Nothing -> report (errUndefinedEntity m tc) >> return [] where -- check if given identifier is constructor or label of type tc checkElement cs' c = do unless (c `elem` cs') $ report $ errUndefinedElement tc c return c expandTypeAll :: Ident -> ExpandM Import expandTypeAll tc = do m <- getModuleIdent tcEnv <- getTyConsEnv ImportTypeWith tc `liftM` case Map.lookup tc tcEnv of Just (Data _ xs) -> return xs Just (Alias _) -> report (errNonDataType tc) >> return [] Nothing -> report (errUndefinedEntity m tc) >> return [] -- error messages errUndefinedElement :: Ident -> Ident -> Message errUndefinedElement tc c = posMessage c $ hsep $ map text [ idName c, "is not a constructor or label of type ", idName tc ] errUndefinedEntity :: ModuleIdent -> Ident -> Message errUndefinedEntity m x = posMessage x $ hsep $ map text [ "Module", moduleName m, "does not export", idName x ] errNonDataType :: Ident -> Message errNonDataType tc = posMessage tc $ hsep $ map text [ idName tc, "is not a data type" ] errImportDataConstr :: ModuleIdent -> Ident -> Message errImportDataConstr _ c = posMessage c $ hsep $ map text [ "Explicit import for data constructor", idName c ] curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/InterfaceCheck.hs000066400000000000000000000226571302651311700276530ustar00rootroot00000000000000{- | Module : $Header$ Description : Checks consistency of interface files Copyright : (c) 2000 - 2007 Wolfgang Lux 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable Interface files include declarations of all entities that are exported by the module, but defined in another module. Since these declarations can become inconsistent if client modules are not recompiled properly, the compiler checks that all imported declarations in an interface agree with their original definitions. One may ask why we include imported declarations at all, if the compiler always has to compare those declarations with the original definitions. The main reason for this is that it helps to avoid unnecessary recompilations of client modules. As an example, consider the three modules: module A where { data T = C } module B(T(..)) where { import A } module C where { import B; f = C } where module B could be considered as a public interface of module A, which restricts access to type A.T and its constructor C. The client module C imports this type via the public interface B. If now module A is changed by adding a definition of a new global function module A where { data T = C; f = C } module B must be recompiled because A's interface is changed. On the other hand, module C need not be recompiled because the change in A does not affect B's interface. By including the declaration of type A.T in B's interface, the compiler can trivially check that B's interface remains unchanged and therefore the client module C is not recompiled. Another reason for including imported declarations in interfaces is that the compiler in principle could avoid loading interfaces of modules that are imported only indirectly, which would save processing time and allow distributing binary packages of a library with a public interface module only. However, this has not been implemented yet. -} module Checks.InterfaceCheck (interfaceCheck) where import Control.Monad (unless) import qualified Control.Monad.State as S import Data.Maybe (fromMaybe) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Syntax import Base.CurryTypes import Base.Messages (Message, posMessage, internalError) import Base.TopEnv import Base.Types import Env.OpPrec import Env.TypeConstructor import Env.Value data ICState = ICState { moduleIdent :: ModuleIdent , precEnv :: OpPrecEnv , tyConsEnv :: TCEnv , valueEnv :: ValueEnv , errors :: [Message] } type IC = S.State ICState getModuleIdent :: IC ModuleIdent getModuleIdent = S.gets moduleIdent getPrecEnv :: IC OpPrecEnv getPrecEnv = S.gets precEnv getTCEnv :: IC TCEnv getTCEnv = S.gets tyConsEnv getValueEnv :: IC ValueEnv getValueEnv = S.gets valueEnv -- |Report a syntax error report :: Message -> IC () report msg = S.modify $ \ s -> s { errors = msg : errors s } ok :: IC () ok = return () interfaceCheck :: OpPrecEnv -> TCEnv -> ValueEnv -> Interface -> [Message] interfaceCheck pEnv tcEnv tyEnv (Interface m _ ds) = reverse (errors s) where s = S.execState (mapM_ checkImport ds) (ICState m pEnv tcEnv tyEnv []) checkImport :: IDecl -> IC () checkImport (IInfixDecl p fix pr op) = checkPrecInfo check p op where check (PrecInfo op' (OpPrec fix' pr')) = op == op' && fix == fix' && pr == pr' checkImport (HidingDataDecl p tc tvs) = checkTypeInfo "hidden data type" check p tc where check (DataType tc' n' _) | tc == tc' && length tvs == n' = Just ok check (RenamingType tc' n' _) | tc == tc' && length tvs == n' = Just ok check _ = Nothing checkImport (IDataDecl p tc tvs cs _) = checkTypeInfo "data type" check p tc where check (DataType tc' n' cs') | tc == tc' && length tvs == n' && (null cs || map constrId cs == map constrIdent cs') = Just (mapM_ (checkConstrImport tc tvs) cs) check (RenamingType tc' n' _) | tc == tc' && length tvs == n' && null cs = Just ok check _ = Nothing checkImport (INewtypeDecl p tc tvs nc _) = checkTypeInfo "newtype" check p tc where check (RenamingType tc' n' nc') | tc == tc' && length tvs == n' && nconstrId nc == constrIdent nc' = Just (checkNewConstrImport tc tvs nc) check _ = Nothing checkImport (ITypeDecl p tc tvs ty) = do m <- getModuleIdent let check (AliasType tc' n' ty') | tc == tc' && length tvs == n' && toQualType m tvs ty == ty' = Just ok check _ = Nothing checkTypeInfo "synonym type" check p tc checkImport (IFunctionDecl p f n ty) = do m <- getModuleIdent let check (Value f' n' (ForAll _ ty')) = f == f' && n' == n && toQualType m [] ty == ty' check _ = False checkValueInfo "function" check p f checkConstrImport :: QualIdent -> [Ident] -> ConstrDecl -> IC () checkConstrImport tc tvs (ConstrDecl p evs c tys) = do m <- getModuleIdent let qc = qualifyLike tc c checkConstr (DataConstructor c' _ _ (ForAllExist uqvs eqvs ty')) = qc == c' && length evs == eqvs && length tvs == uqvs && toQualTypes m tvs tys == arrowArgs ty' checkConstr _ = False checkValueInfo "data constructor" checkConstr p qc checkConstrImport tc tvs (ConOpDecl p evs ty1 op ty2) = do m <- getModuleIdent let qc = qualifyLike tc op checkConstr (DataConstructor c' _ _ (ForAllExist uqvs eqvs ty')) = qc == c' && length evs == eqvs && length tvs == uqvs && toQualTypes m tvs [ty1,ty2] == arrowArgs ty' checkConstr _ = False checkValueInfo "data constructor" checkConstr p qc checkConstrImport tc tvs (RecordDecl p evs c fs) = do m <- getModuleIdent let qc = qualifyLike tc c (ls, tys) = unzip [(l, ty) | FieldDecl _ labels ty <- fs, l <- labels] checkConstr (DataConstructor c' _ ls' (ForAllExist uqvs eqvs ty')) = qc == c' && length evs == eqvs && length tvs == uqvs && ls == ls' && toQualTypes m tvs tys == arrowArgs ty' checkConstr _ = False checkValueInfo "data constructor" checkConstr p qc checkNewConstrImport :: QualIdent -> [Ident] -> NewConstrDecl -> IC () checkNewConstrImport tc tvs (NewConstrDecl p evs c ty) = do m <- getModuleIdent let qc = qualifyLike tc c checkNewConstr (NewtypeConstructor c' _ (ForAllExist uqvs eqvs ty')) = qc == c' && length evs == eqvs && length tvs == uqvs && toQualType m tvs ty == head (arrowArgs ty') checkNewConstr _ = False checkValueInfo "newtype constructor" checkNewConstr p qc checkNewConstrImport tc tvs (NewRecordDecl p evs c (l, ty)) = do m <- getModuleIdent let qc = qualifyLike tc c checkNewConstr (NewtypeConstructor c' l' (ForAllExist uqvs eqvs ty')) = qc == c' && length evs == eqvs && length tvs == uqvs && l == l' && toQualType m tvs ty == head (arrowArgs ty') checkNewConstr _ = False checkValueInfo "newtype constructor" checkNewConstr p qc checkPrecInfo :: (PrecInfo -> Bool) -> Position -> QualIdent -> IC () checkPrecInfo check p op = do pEnv <- getPrecEnv let checkInfo m op' = case qualLookupTopEnv op pEnv of [] -> report $ errNoPrecedence p m op' [prec] -> unless (check prec) (report $ errImportConflict p "precedence" m op') _ -> internalError "checkPrecInfo" checkImported checkInfo op checkTypeInfo :: String -> (TypeInfo -> Maybe (IC ())) -> Position -> QualIdent -> IC () checkTypeInfo what check p tc = do tcEnv <- getTCEnv let checkInfo m tc' = case qualLookupTopEnv tc tcEnv of [] -> report $ errNotExported p what m tc' [ti] -> fromMaybe (report $ errImportConflict p what m tc') (check ti) _ -> internalError "checkTypeInfo" checkImported checkInfo tc checkValueInfo :: String -> (ValueInfo -> Bool) -> Position -> QualIdent -> IC () checkValueInfo what check p x = do tyEnv <- getValueEnv let checkInfo m x' = case qualLookupTopEnv x tyEnv of [] -> report $ errNotExported p what m x' [vi] -> unless (check vi) (report $ errImportConflict p what m x') _ -> internalError "checkValueInfo" checkImported checkInfo x checkImported :: (ModuleIdent -> Ident -> IC ()) -> QualIdent -> IC () checkImported _ (QualIdent Nothing _) = ok checkImported f (QualIdent (Just m) x) = f m x -- --------------------------------------------------------------------------- -- Error messages -- --------------------------------------------------------------------------- errNotExported :: Position -> String -> ModuleIdent -> Ident -> Message errNotExported p what m x = posMessage p $ text "Inconsistent module interfaces" $+$ text "Module" <+> text (moduleName m) <+> text "does not export"<+> text what <+> text (escName x) errNoPrecedence :: Position -> ModuleIdent -> Ident -> Message errNoPrecedence p m x = posMessage p $ text "Inconsistent module interfaces" $+$ text "Module" <+> text (moduleName m) <+> text "does not define a precedence for" <+> text (escName x) errImportConflict :: Position -> String -> ModuleIdent -> Ident -> Message errImportConflict p what m x = posMessage p $ text "Inconsistent module interfaces" $+$ text "Declaration of" <+> text what <+> text (escName x) <+> text "does not match its definition in module" <+> text (moduleName m) curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/InterfaceSyntaxCheck.hs000066400000000000000000000170441302651311700310540ustar00rootroot00000000000000{- | Module : $Header$ Description : Checks interface declarations Copyright : (c) 2000 - 2007 Wolfgang Lux 2011 - 2015 Björn Peemöller 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable Similar to Curry source files, some post-processing has to be applied to parsed interface files. In particular, the compiler must disambiguate nullary type constructors and type variables. In addition, the compiler also checks that all type constructor applications are saturated. Since interface files are closed -- i.e., they include declarations of all entities which are defined in other modules -- the compiler can perform this check without reference to the global environments. -} module Checks.InterfaceSyntaxCheck (intfSyntaxCheck) where import Control.Monad (liftM, liftM2) import qualified Control.Monad.State as S import Data.List (nub, partition) import Base.Expr import Base.Messages (Message, posMessage, internalError) import Base.TopEnv import Base.Utils (findMultiples) import Env.TypeConstructor import Curry.Base.Ident import Curry.Base.Pretty import Curry.Syntax data ISCState = ISCState { typeEnv :: TypeEnv , errors :: [Message] } type ISC = S.State ISCState getTypeEnv :: ISC TypeEnv getTypeEnv = S.gets typeEnv -- |Report a syntax error report :: Message -> ISC () report msg = S.modify $ \ s -> s { errors = msg : errors s } intfSyntaxCheck :: Interface -> (Interface, [Message]) intfSyntaxCheck (Interface n is ds) = (Interface n is ds', reverse $ errors s') where (ds', s') = S.runState (mapM checkIDecl ds) (ISCState env []) env = foldr bindType (fmap typeKind initTCEnv) ds -- The compiler requires information about the arity of each defined type -- constructor as well as information whether the type constructor -- denotes an algebraic data type, a renaming type, or a type synonym. -- The latter must not occur in type expressions in interfaces. bindType :: IDecl -> TypeEnv -> TypeEnv bindType (IInfixDecl _ _ _ _) = id bindType (HidingDataDecl _ tc _) = qualBindTopEnv tc (Data tc []) bindType (IDataDecl _ tc _ cs _) = qualBindTopEnv tc (Data tc (map constrId cs)) bindType (INewtypeDecl _ tc _ nc _) = qualBindTopEnv tc (Data tc [nconstrId nc]) bindType (ITypeDecl _ tc _ _) = qualBindTopEnv tc (Alias tc) bindType (IFunctionDecl _ _ _ _) = id -- The checks applied to the interface are similar to those performed -- during syntax checking of type expressions. checkIDecl :: IDecl -> ISC IDecl checkIDecl (IInfixDecl p fix pr op) = return (IInfixDecl p fix pr op) checkIDecl (HidingDataDecl p tc tvs) = do checkTypeLhs tvs return (HidingDataDecl p tc tvs) checkIDecl (IDataDecl p tc tvs cs hs) = do checkTypeLhs tvs checkHidden tc (cons ++ labels) hs cs' <- mapM (checkConstrDecl tvs) cs return $ IDataDecl p tc tvs cs' hs where cons = map constrId cs labels = nub $ concatMap recordLabels cs checkIDecl (INewtypeDecl p tc tvs nc hs) = do checkTypeLhs tvs checkHidden tc (con : labels) hs nc' <- checkNewConstrDecl tvs nc return $ INewtypeDecl p tc tvs nc' hs where con = nconstrId nc labels = nrecordLabels nc checkIDecl (ITypeDecl p tc tvs ty) = do checkTypeLhs tvs liftM (ITypeDecl p tc tvs) (checkClosedType tvs ty) checkIDecl (IFunctionDecl p f n ty) = liftM (IFunctionDecl p f n) (checkType ty) checkHidden :: QualIdent -> [Ident] -> [Ident] -> ISC () checkHidden tc csls hs = mapM_ (report . errNoElement tc) $ nub $ filter (`notElem` csls) hs checkTypeLhs :: [Ident] -> ISC () checkTypeLhs tvs = do tyEnv <- getTypeEnv let (tcs, tvs') = partition isTypeConstr tvs isTypeConstr tv = not (null (lookupTopEnv tv tyEnv)) mapM_ (report . errNoVariable) (nub tcs) mapM_ (report . errNonLinear . head) (findMultiples tvs') checkConstrDecl :: [Ident] -> ConstrDecl -> ISC ConstrDecl checkConstrDecl tvs (ConstrDecl p evs c tys) = do checkTypeLhs evs liftM (ConstrDecl p evs c) (mapM (checkClosedType tvs') tys) where tvs' = evs ++ tvs checkConstrDecl tvs (ConOpDecl p evs ty1 op ty2) = do checkTypeLhs evs liftM2 (\t1 t2 -> ConOpDecl p evs t1 op t2) (checkClosedType tvs' ty1) (checkClosedType tvs' ty2) where tvs' = evs ++ tvs checkConstrDecl tvs (RecordDecl p evs c fs) = do checkTypeLhs evs liftM (RecordDecl p evs c) (mapM (checkFieldDecl tvs') fs) where tvs' = evs ++ tvs checkFieldDecl :: [Ident] -> FieldDecl -> ISC FieldDecl checkFieldDecl tvs (FieldDecl p ls ty) = liftM (FieldDecl p ls) (checkClosedType tvs ty) checkNewConstrDecl :: [Ident] -> NewConstrDecl -> ISC NewConstrDecl checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do checkTypeLhs evs liftM (NewConstrDecl p evs c) (checkClosedType tvs' ty) where tvs' = evs ++ tvs checkNewConstrDecl tvs (NewRecordDecl p evs c (l,ty)) = do checkTypeLhs evs ty' <- checkClosedType tvs' ty return $ NewRecordDecl p evs c (l,ty') where tvs' = evs ++ tvs checkClosedType :: [Ident] -> TypeExpr -> ISC TypeExpr checkClosedType tvs ty = do ty' <- checkType ty mapM_ (report . errUnboundVariable) (nub (filter (`notElem` tvs) (fv ty'))) return ty' checkType :: TypeExpr -> ISC TypeExpr checkType (ConstructorType tc tys) = checkTypeConstructor tc tys checkType (VariableType tv) = checkType (ConstructorType (qualify tv) []) checkType (TupleType tys) = liftM TupleType (mapM checkType tys) checkType (ListType ty) = liftM ListType (checkType ty) checkType (ArrowType ty1 ty2) = liftM2 ArrowType (checkType ty1) (checkType ty2) checkType (ParenType ty) = liftM ParenType (checkType ty) checkTypeConstructor :: QualIdent -> [TypeExpr] -> ISC TypeExpr checkTypeConstructor tc tys = do tyEnv <- getTypeEnv case qualLookupTopEnv tc tyEnv of [] | not (isQualified tc) && null tys -> return (VariableType (unqualify tc)) | otherwise -> do report (errUndefinedType tc) ConstructorType tc `liftM` mapM checkType tys [Data _ _] -> ConstructorType tc `liftM` mapM checkType tys [Alias _] -> do report (errBadTypeSynonym tc) ConstructorType tc `liftM` mapM checkType tys _ -> internalError "checkTypeConstructor" -- --------------------------------------------------------------------------- -- Error messages -- --------------------------------------------------------------------------- errUndefinedType :: QualIdent -> Message errUndefinedType tc = posMessage tc $ text "Undefined type" <+> text (qualName tc) errNonLinear :: Ident -> Message errNonLinear tv = posMessage tv $ hsep $ map text [ "Type variable", escName tv , "occurs more than once on left hand side of type declaration" ] errNoVariable :: Ident -> Message errNoVariable tv = posMessage tv $ hsep $ map text [ "Type constructor", escName tv , "used in left hand side of type declaration" ] errUnboundVariable :: Ident -> Message errUnboundVariable tv = posMessage tv $ text "Undefined type variable" <+> text (escName tv) errBadTypeSynonym :: QualIdent -> Message errBadTypeSynonym tc = posMessage tc $ text "Synonym type" <+> text (qualName tc) <+> text "in interface" errNoElement :: QualIdent -> Ident -> Message errNoElement tc x = posMessage tc $ hsep $ map text [ "Hidden constructor or label ", escName x , " is not defined for type ", qualName tc ] curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/KindCheck.hs000066400000000000000000000330141302651311700266250ustar00rootroot00000000000000{- | Module : $Header$ Description : Checks type definitions Copyright : (c) 2000 - 2007 Wolfgang Lux Martin Engelke Björn Peemöller 2014 - 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable After the source file has been parsed and all modules have been imported, the compiler first performs kind checking on all type definitions and signatures. Because Curry currently does not support type classes, kind checking is rather trivial. All types must be of first order kind (*), i.e., all type constructor applications must be saturated. During kind checking, this module will also disambiguate nullary type constructors and type variables which -- in contrast to Haskell -- is not possible on purely syntactic criteria. In addition it is checked that all type constructors and type variables occurring on the right hand side of a type declaration are actually defined and no identifier is defined more than once. -} {-# LANGUAGE CPP #-} module Checks.KindCheck (kindCheck) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif import Control.Monad (unless, when) import qualified Control.Monad.State as S (State, runState, gets, modify) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Syntax import Base.Messages (Message, posMessage, internalError) import Base.TopEnv import Base.Utils (findMultiples) import Env.TypeConstructor (TCEnv, tcArity) -- In order to check type constructor applications, the compiler -- maintains an environment containing the kind information for all type -- constructors. The function 'kindCheck' first initializes this -- environment by filtering out the arity of each type constructor from -- the imported type environment. Next, the arities of all locally -- defined type constructors are inserted into the environment, and, -- finally, the declarations are checked within this environment. kindCheck :: TCEnv -> Module -> (Module, [Message]) kindCheck tcEnv mdl@(Module _ m _ _ ds) = case findMultiples $ map typeConstr tds of [] -> runKCM (checkModule mdl) state tss -> (mdl, map errMultipleDeclaration tss) where tds = filter isTypeDecl ds kEnv = foldr (bindKind m) (fmap tcArity tcEnv) tds state = KCState m kEnv [] -- Kind Check Monad type KCM = S.State KCState -- |Internal state of the Kind Check data KCState = KCState { moduleIdent :: ModuleIdent , kindEnv :: KindEnv , errors :: [Message] } runKCM :: KCM a -> KCState -> (a, [Message]) runKCM kcm s = let (a, s') = S.runState kcm s in (a, reverse $ errors s') getModuleIdent :: KCM ModuleIdent getModuleIdent = S.gets moduleIdent getKindEnv :: KCM KindEnv getKindEnv = S.gets kindEnv report :: Message -> KCM () report err = S.modify (\ s -> s { errors = err : errors s }) -- The kind environment only needs to record the arity -- of each type constructor. type KindEnv = TopEnv Int bindKind :: ModuleIdent -> Decl -> KindEnv -> KindEnv bindKind m (DataDecl _ tc tvs _) = bindKind' m tc tvs bindKind m (NewtypeDecl _ tc tvs _) = bindKind' m tc tvs bindKind m (TypeDecl _ tc tvs _) = bindKind' m tc tvs bindKind _ _ = id bindKind' :: ModuleIdent -> Ident -> [Ident] -> KindEnv -> KindEnv bindKind' m tc tvs = bindTopEnv tc arity . qualBindTopEnv qtc arity where arity = length tvs qtc = qualifyWith m tc lookupKind :: Ident -> KindEnv -> [Int] lookupKind = lookupTopEnv qualLookupKind :: QualIdent -> KindEnv -> [Int] qualLookupKind = qualLookupTopEnv checkModule :: Module -> KCM Module checkModule (Module ps m es is ds) = Module ps m es is <$> mapM checkDecl ds -- When type declarations are checked, the compiler will allow anonymous -- type variables on the left hand side of the declaration, but not on -- the right hand side. Function and pattern declarations must be -- traversed because they can contain local type signatures. checkDecl :: Decl -> KCM Decl checkDecl (DataDecl p tc tvs cs) = do tvs' <- checkTypeLhs tvs cs' <- mapM (checkConstrDecl tvs') cs return $ DataDecl p tc tvs' cs' checkDecl (NewtypeDecl p tc tvs nc) = do tvs' <- checkTypeLhs tvs nc' <- checkNewConstrDecl tvs' nc return $ NewtypeDecl p tc tvs' nc' checkDecl (TypeDecl p tc tvs ty) = do tvs' <- checkTypeLhs tvs ty' <- checkClosedType tvs' ty return $ TypeDecl p tc tvs' ty' checkDecl (TypeSig p vs ty) = TypeSig p vs <$> checkType ty checkDecl (FunctionDecl p f eqs) = FunctionDecl p f <$> mapM checkEquation eqs checkDecl (PatternDecl p t rhs) = PatternDecl p t <$> checkRhs rhs checkDecl (ForeignDecl p cc ie f ty) = ForeignDecl p cc ie f <$> checkType ty checkDecl d = return d checkConstrDecl :: [Ident] -> ConstrDecl -> KCM ConstrDecl checkConstrDecl tvs (ConstrDecl p evs c tys) = do evs' <- checkTypeLhs evs tys' <- mapM (checkClosedType (evs' ++ tvs)) tys return $ ConstrDecl p evs' c tys' checkConstrDecl tvs (ConOpDecl p evs ty1 op ty2) = do evs' <- checkTypeLhs evs let tvs' = evs' ++ tvs ty1' <- checkClosedType tvs' ty1 ty2' <- checkClosedType tvs' ty2 return $ ConOpDecl p evs' ty1' op ty2' checkConstrDecl tvs (RecordDecl p evs c fs) = do evs' <- checkTypeLhs evs fs' <- mapM (checkFieldDecl (evs' ++ tvs)) fs return $ RecordDecl p evs' c fs' checkFieldDecl :: [Ident] -> FieldDecl -> KCM FieldDecl checkFieldDecl tvs (FieldDecl p ls ty) = FieldDecl p ls <$> checkClosedType tvs ty checkNewConstrDecl :: [Ident] -> NewConstrDecl -> KCM NewConstrDecl checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do evs' <- checkTypeLhs evs ty' <- checkClosedType (evs' ++ tvs) ty return $ NewConstrDecl p evs' c ty' checkNewConstrDecl tvs (NewRecordDecl p evs c (l, ty)) = do evs' <- checkTypeLhs evs ty' <- checkClosedType (evs' ++ tvs) ty return $ NewRecordDecl p evs' c (l, ty') -- |Check the left-hand-side of a type declaration for -- * Anonymous type variables are allowed -- * only type variables (no type constructors) -- * linearity checkTypeLhs :: [Ident] -> KCM [Ident] checkTypeLhs [] = return [] checkTypeLhs (tv : tvs) = do unless (isAnonId tv) $ do isTyCons <- (not . null . lookupKind tv) <$> getKindEnv when isTyCons $ report $ errNoVariable tv when (tv `elem` tvs) $ report $ errNonLinear tv (tv:) <$> checkTypeLhs tvs -- Checking expressions is rather straight forward. The compiler must -- only traverse the structure of expressions in order to find local -- declaration groups. checkEquation :: Equation -> KCM Equation checkEquation (Equation p lhs rhs) = Equation p lhs <$> checkRhs rhs checkRhs :: Rhs -> KCM Rhs checkRhs (SimpleRhs p e ds) = SimpleRhs p <$> checkExpr e <*> mapM checkDecl ds checkRhs (GuardedRhs es ds) = GuardedRhs <$> mapM checkCondExpr es <*> mapM checkDecl ds checkCondExpr :: CondExpr -> KCM CondExpr checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr g <*> checkExpr e checkExpr :: Expression -> KCM Expression checkExpr l@(Literal _) = return l checkExpr v@(Variable _) = return v checkExpr c@(Constructor _) = return c checkExpr (Paren e) = Paren <$> checkExpr e checkExpr (Typed e ty) = Typed <$> checkExpr e <*> checkType ty checkExpr (Record c fs) = Record c <$> mapM checkFieldExpr fs checkExpr (RecordUpdate e fs) = RecordUpdate <$> checkExpr e <*> mapM checkFieldExpr fs checkExpr (Tuple p es) = Tuple p <$> mapM checkExpr es checkExpr (List p es) = List p <$> mapM checkExpr es checkExpr (ListCompr p e qs) = ListCompr p <$> checkExpr e <*> mapM checkStmt qs checkExpr (EnumFrom e) = EnumFrom <$> checkExpr e checkExpr (EnumFromThen e1 e2) = EnumFromThen <$> checkExpr e1 <*> checkExpr e2 checkExpr (EnumFromTo e1 e2) = EnumFromTo <$> checkExpr e1 <*> checkExpr e2 checkExpr (EnumFromThenTo e1 e2 e3) = EnumFromThenTo <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3 checkExpr (UnaryMinus op e) = UnaryMinus op <$> checkExpr e checkExpr (Apply e1 e2) = Apply <$> checkExpr e1 <*> checkExpr e2 checkExpr (InfixApply e1 op e2) = (\f1 f2 -> InfixApply f1 op f2) <$> checkExpr e1 <*> checkExpr e2 checkExpr (LeftSection e op) = flip LeftSection op <$> checkExpr e checkExpr (RightSection op e) = RightSection op <$> checkExpr e checkExpr (Lambda r ts e) = Lambda r ts <$> checkExpr e checkExpr (Let ds e) = Let <$> mapM checkDecl ds <*> checkExpr e checkExpr (Do sts e) = Do <$> mapM checkStmt sts <*> checkExpr e checkExpr (IfThenElse r e1 e2 e3) = IfThenElse r <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3 checkExpr (Case r ct e alts) = Case r ct <$> checkExpr e <*> mapM checkAlt alts checkStmt :: Statement -> KCM Statement checkStmt (StmtExpr p e) = StmtExpr p <$> checkExpr e checkStmt (StmtBind p t e) = StmtBind p t <$> checkExpr e checkStmt (StmtDecl ds) = StmtDecl <$> mapM checkDecl ds checkAlt :: Alt -> KCM Alt checkAlt (Alt p t rhs) = Alt p t <$> checkRhs rhs checkFieldExpr :: Field Expression -> KCM (Field Expression) checkFieldExpr (Field p l e) = Field p l <$> checkExpr e -- The parser cannot distinguish unqualified nullary type constructors -- and type variables. Therefore, if the compiler finds an unbound -- identifier in a position where a type variable is admissible, it will -- interpret the identifier as such. checkClosedType :: [Ident] -> TypeExpr -> KCM TypeExpr checkClosedType tvs ty = do ty' <- checkType ty checkClosed tvs ty' return ty' checkType :: TypeExpr -> KCM TypeExpr checkType c@(ConstructorType tc tys) = do m <- getModuleIdent kEnv <- getKindEnv case qualLookupKind tc kEnv of [] | not (isQualified tc) && null tys -> return $ VariableType $ unqualify tc | otherwise -> report (errUndefinedType tc) >> return c [n] | n == n' -> ConstructorType tc <$> mapM checkType tys | otherwise -> report (errWrongArity tc n n') >> return c _ -> case qualLookupKind (qualQualify m tc) kEnv of [n] | n == n' -> ConstructorType tc <$> mapM checkType tys | otherwise -> report (errWrongArity tc n n') >> return c _ -> report (errAmbiguousType tc) >> return c where n' = length tys checkType v@(VariableType tv) | isAnonId tv = return v | otherwise = checkType $ ConstructorType (qualify tv) [] checkType (TupleType tys) = TupleType <$> mapM checkType tys checkType (ListType ty) = ListType <$> checkType ty checkType (ArrowType ty1 ty2) = ArrowType <$> checkType ty1 <*> checkType ty2 checkType (ParenType ty) = ParenType <$> checkType ty checkClosed :: [Ident] -> TypeExpr -> KCM () checkClosed tvs (ConstructorType _ tys) = mapM_ (checkClosed tvs) tys checkClosed tvs (VariableType tv) = do when (isAnonId tv || tv `notElem` tvs) $ report $ errUnboundVariable tv checkClosed tvs (TupleType tys) = mapM_ (checkClosed tvs) tys checkClosed tvs (ListType ty) = checkClosed tvs ty checkClosed tvs (ArrowType ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2] checkClosed tvs (ParenType ty) = checkClosed tvs ty -- --------------------------------------------------------------------------- -- Auxiliary definitions -- --------------------------------------------------------------------------- typeConstr :: Decl -> Ident typeConstr (DataDecl _ tc _ _) = tc typeConstr (NewtypeDecl _ tc _ _) = tc typeConstr (TypeDecl _ tc _ _) = tc typeConstr _ = internalError "KindCheck.typeConstr: no type declaration" -- --------------------------------------------------------------------------- -- Error messages: -- --------------------------------------------------------------------------- errUndefinedType :: QualIdent -> Message errUndefinedType tc = posMessage tc $ hsep $ map text ["Undefined type", qualName tc] errAmbiguousType :: QualIdent -> Message errAmbiguousType tc = posMessage tc $ hsep $ map text ["Ambiguous type", qualName tc] errMultipleDeclaration :: [Ident] -> Message errMultipleDeclaration [] = internalError "KindCheck.errMultipleDeclaration: empty list" errMultipleDeclaration (i:is) = posMessage i $ text "Multiple declarations for type" <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat (map showPos (i:is))) where showPos = text . showLine . idPosition errNonLinear :: Ident -> Message errNonLinear tv = posMessage tv $ hsep $ map text [ "Type variable", idName tv , "occurs more than once on left hand side of type declaration"] errNoVariable :: Ident -> Message errNoVariable tv = posMessage tv $ hsep $ map text [ "Type constructor", idName tv , "used in left hand side of type declaration"] errWrongArity :: QualIdent -> Int -> Int -> Message errWrongArity tc arity argc = posMessage tc $ text "Type constructor" <+> text (qualName tc) <+> text "expects" <+> text (arguments arity) <> comma <+> text "but is applied to" <+> text (show argc) where arguments 0 = "no arguments" arguments 1 = "1 argument" arguments n = show n ++ " arguments" errUnboundVariable :: Ident -> Message errUnboundVariable tv = posMessage tv $ hsep $ map text ["Unbound type variable", idName tv] curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/PrecCheck.hs000066400000000000000000000504061302651311700266350ustar00rootroot00000000000000{- | Module : $Header$ Description : Checks precedences of infix operators Copyright : (c) 2001 - 2004 Wolfgang Lux Martin Engelke Björn Peemöller 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable The parser does not know the relative precedences of infix operators and therefore parses them as if they all associate to the right and have the same precedence. After performing the definition checks, the compiler is going to process the infix applications in the module and rearrange infix applications according to the relative precedences of the operators involved. -} {-# LANGUAGE CPP #-} module Checks.PrecCheck (precCheck) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif import Control.Monad (unless, when) import qualified Control.Monad.State as S (State, runState, gets, modify) import Data.List (partition) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Syntax import Base.Expr import Base.Messages (Message, posMessage, internalError) import Base.Utils (findMultiples) import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP , mkPrec, qualLookupP) precCheck :: ModuleIdent -> OpPrecEnv -> [Decl] -> ([Decl], OpPrecEnv, [Message]) precCheck m pEnv decls = runPCM (checkDecls decls) initState where initState = PCState m pEnv [] data PCState = PCState { moduleIdent :: ModuleIdent , precEnv :: OpPrecEnv , errors :: [Message] } type PCM = S.State PCState -- the Prec Check Monad runPCM :: PCM a -> PCState -> (a, OpPrecEnv, [Message]) runPCM kcm s = let (a, s') = S.runState kcm s in (a, precEnv s', reverse $ errors s') getModuleIdent :: PCM ModuleIdent getModuleIdent = S.gets moduleIdent getPrecEnv :: PCM OpPrecEnv getPrecEnv = S.gets precEnv modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> PCM () modifyPrecEnv f = S.modify $ \ s -> s { precEnv = f $ precEnv s } withLocalPrecEnv :: PCM a -> PCM a withLocalPrecEnv act = do oldEnv <- getPrecEnv res <- act modifyPrecEnv $ const oldEnv return res report :: Message -> PCM () report err = S.modify (\ s -> s { errors = err : errors s }) -- For each declaration group, including the module-level, the compiler -- first checks that its fixity declarations contain no duplicates and -- that there is a corresponding value or constructor declaration in that -- group. The fixity declarations are then used for extending the -- imported precedence environment. bindPrecs :: [Decl] -> PCM () bindPrecs ds = case findMultiples opFixDecls of [] -> case filter (`notElem` bvs) opFixDecls of [] -> do m <- getModuleIdent modifyPrecEnv $ \ env -> foldr (bindPrec m) env fixDs ops -> mapM_ (report . errUndefinedOperator) ops opss -> mapM_ (report . errMultiplePrecedence) opss where (fixDs, nonFixDs) = partition isInfixDecl ds opFixDecls = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops ] bvs = concatMap boundValues nonFixDs bindPrec :: ModuleIdent -> Decl -> OpPrecEnv -> OpPrecEnv bindPrec m (InfixDecl _ fix mprec ops) pEnv | p == defaultP = pEnv | otherwise = foldr (flip (bindP m) p) pEnv ops where p = OpPrec fix (mkPrec mprec) bindPrec _ _ pEnv = pEnv boundValues :: Decl -> [Ident] boundValues (DataDecl _ _ _ cs) = [ v | c <- cs , v <- constrId c : recordLabels c] boundValues (NewtypeDecl _ _ _ nc) = nconstrId nc : nrecordLabels nc boundValues (FunctionDecl _ f _) = [f] boundValues (ForeignDecl _ _ _ f _) = [f] boundValues (ExternalDecl _ fs) = fs boundValues (PatternDecl _ t _) = bv t boundValues (FreeDecl _ vs) = vs boundValues _ = [] -- With the help of the precedence environment, the compiler checks all -- infix applications and sections in the program. This pass will modify -- the parse tree such that for a nested infix application the operator -- with the lowest precedence becomes the root and that two adjacent -- operators with the same precedence will not have conflicting -- associativities. Note that the top-level precedence environment has to -- be returned because it is needed for constructing the module's -- interface. checkDecls :: [Decl] -> PCM [Decl] checkDecls decls = bindPrecs decls >> mapM checkDecl decls checkDecl :: Decl -> PCM Decl checkDecl (FunctionDecl p f eqs) = FunctionDecl p f <$> mapM checkEquation eqs checkDecl (PatternDecl p t rhs) = PatternDecl p <$> checkPattern t <*> checkRhs rhs checkDecl d = return d checkEquation :: Equation -> PCM Equation checkEquation (Equation p lhs rhs) = Equation p <$> checkLhs lhs <*> checkRhs rhs checkLhs :: Lhs -> PCM Lhs checkLhs (FunLhs f ts) = FunLhs f <$> mapM checkPattern ts checkLhs (OpLhs t1 op t2) = flip OpLhs op <$> (checkPattern t1 >>= checkOpL op) <*> (checkPattern t2 >>= checkOpR op) checkLhs (ApLhs lhs ts) = ApLhs <$> checkLhs lhs <*> mapM checkPattern ts checkPattern :: Pattern -> PCM Pattern checkPattern l@(LiteralPattern _) = return l checkPattern n@(NegativePattern _ _) = return n checkPattern v@(VariablePattern _) = return v checkPattern (ConstructorPattern c ts) = ConstructorPattern c <$> mapM checkPattern ts checkPattern (InfixPattern t1 op t2) = do t1' <- checkPattern t1 t2' <- checkPattern t2 fixPrecT InfixPattern t1' op t2' checkPattern (ParenPattern t) = ParenPattern <$> checkPattern t checkPattern (TuplePattern p ts) = TuplePattern p <$> mapM checkPattern ts checkPattern (ListPattern p ts) = ListPattern p <$> mapM checkPattern ts checkPattern (AsPattern v t) = AsPattern v <$> checkPattern t checkPattern (LazyPattern p t) = LazyPattern p <$> checkPattern t checkPattern (FunctionPattern f ts) = FunctionPattern f <$> mapM checkPattern ts checkPattern (InfixFuncPattern t1 op t2) = do t1' <- checkPattern t1 t2' <- checkPattern t2 fixPrecT InfixFuncPattern t1' op t2' checkPattern (RecordPattern c fs) = RecordPattern c <$> mapM (checkField checkPattern) fs checkRhs :: Rhs -> PCM Rhs checkRhs (SimpleRhs p e ds) = withLocalPrecEnv $ flip (SimpleRhs p) <$> checkDecls ds <*> checkExpr e checkRhs (GuardedRhs es ds) = withLocalPrecEnv $ (flip GuardedRhs) <$> checkDecls ds <*> mapM checkCondExpr es checkCondExpr :: CondExpr -> PCM CondExpr checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr g <*> checkExpr e checkExpr :: Expression -> PCM Expression checkExpr l@(Literal _) = return l checkExpr v@(Variable _) = return v checkExpr c@(Constructor _) = return c checkExpr (Paren e) = Paren <$> checkExpr e checkExpr (Typed e ty) = flip Typed ty <$> checkExpr e checkExpr (Record c fs) = Record c <$> mapM (checkField checkExpr) fs checkExpr (RecordUpdate e fs) = RecordUpdate <$> (checkExpr e) <*> mapM (checkField checkExpr) fs checkExpr (Tuple p es) = Tuple p <$> mapM checkExpr es checkExpr (List p es) = List p <$> mapM checkExpr es checkExpr (ListCompr p e qs) = withLocalPrecEnv $ flip (ListCompr p) <$> mapM checkStmt qs <*> checkExpr e checkExpr (EnumFrom e) = EnumFrom <$> checkExpr e checkExpr (EnumFromThen e1 e2) = EnumFromThen <$> checkExpr e1 <*> checkExpr e2 checkExpr (EnumFromTo e1 e2) = EnumFromTo <$> checkExpr e1 <*> checkExpr e2 checkExpr (EnumFromThenTo e1 e2 e3) = EnumFromThenTo <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3 checkExpr (UnaryMinus op e) = UnaryMinus op <$> checkExpr e checkExpr (Apply e1 e2) = Apply <$> checkExpr e1 <*> checkExpr e2 checkExpr (InfixApply e1 op e2) = do e1' <- checkExpr e1 e2' <- checkExpr e2 fixPrec e1' op e2' checkExpr (LeftSection e op) = checkExpr e >>= checkLSection op checkExpr (RightSection op e) = checkExpr e >>= checkRSection op checkExpr (Lambda r ts e) = (Lambda r) <$> mapM checkPattern ts <*> checkExpr e checkExpr (Let ds e) = withLocalPrecEnv $ Let <$> checkDecls ds <*> checkExpr e checkExpr (Do sts e) = withLocalPrecEnv $ Do <$> mapM checkStmt sts <*> checkExpr e checkExpr (IfThenElse r e1 e2 e3) = IfThenElse r <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3 checkExpr (Case r ct e alts) = Case r ct <$> checkExpr e <*> mapM checkAlt alts checkStmt :: Statement -> PCM Statement checkStmt (StmtExpr p e) = StmtExpr p <$> checkExpr e checkStmt (StmtDecl ds) = StmtDecl <$> checkDecls ds checkStmt (StmtBind p t e) = StmtBind p <$> checkPattern t <*> checkExpr e checkAlt :: Alt -> PCM Alt checkAlt (Alt p t rhs) = Alt p <$> checkPattern t <*> checkRhs rhs checkField :: (a -> PCM a) -> Field a -> PCM (Field a) checkField check (Field p l x) = Field p l <$> check x -- The functions 'fixPrec', 'fixUPrec', and 'fixRPrec' check the relative -- precedences of adjacent infix operators in nested infix applications -- and unary negations. The expressions will be reordered such that the -- infix operator with the lowest precedence becomes the root of the -- expression. The functions rely on the fact that the parser constructs -- infix applications in a right-associative fashion, i.e., the left argument -- of an infix application will never be an infix application. In addition, -- a unary negation will never have an infix application as its argument. -- The function 'fixPrec' checks whether the left argument of an -- infix application is a unary negation and eventually reorders the -- expression if the precedence of the infix operator is higher than that -- of the negation. This will be done with the help of the function -- 'fixUPrec'. In any case, the function 'fixRPrec' is used for fixing the -- precedence of the infix operator and that of its right argument. -- Note that both arguments already have been checked before 'fixPrec' -- is called. fixPrec :: Expression -> InfixOp -> Expression -> PCM Expression fixPrec (UnaryMinus uop e1) op e2 = do OpPrec fix pr <- getOpPrec op if pr < 6 || pr == 6 && fix == InfixL then fixRPrec (UnaryMinus uop e1) op e2 else if pr > 6 then fixUPrec uop e1 op e2 else do report $ errAmbiguousParse "unary" (qualify uop) (opName op) return $ InfixApply (UnaryMinus uop e1) op e2 fixPrec e1 op e2 = fixRPrec e1 op e2 fixUPrec :: Ident -> Expression -> InfixOp -> Expression -> PCM Expression fixUPrec uop e1 op e2@(UnaryMinus _ _) = do report $ errAmbiguousParse "operator" (opName op) (qualify uop) return $ UnaryMinus uop (InfixApply e1 op e2) fixUPrec uop e1 op1 e'@(InfixApply e2 op2 e3) = do OpPrec fix2 pr2 <- getOpPrec op2 if pr2 < 6 || pr2 == 6 && fix2 == InfixL then do left <- fixUPrec uop e1 op1 e2 return $ InfixApply left op2 e3 else if pr2 > 6 then do op <- fixRPrec e1 op1 $ InfixApply e2 op2 e3 return $ UnaryMinus uop op else do report $ errAmbiguousParse "unary" (qualify uop) (opName op2) return $ InfixApply (UnaryMinus uop e1) op1 e' fixUPrec uop e1 op e2 = return $ UnaryMinus uop (InfixApply e1 op e2) fixRPrec :: Expression -> InfixOp -> Expression -> PCM Expression fixRPrec e1 op (UnaryMinus uop e2) = do OpPrec _ pr <- getOpPrec op unless (pr < 6) $ report $ errAmbiguousParse "operator" (opName op) (qualify uop) return $ InfixApply e1 op $ UnaryMinus uop e2 fixRPrec e1 op1 (InfixApply e2 op2 e3) = do OpPrec fix1 pr1 <- getOpPrec op1 OpPrec fix2 pr2 <- getOpPrec op2 if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR then return $ InfixApply e1 op1 $ InfixApply e2 op2 e3 else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL then do left <- fixPrec e1 op1 e2 return $ InfixApply left op2 e3 else do report $ errAmbiguousParse "operator" (opName op1) (opName op2) return $ InfixApply e1 op1 $ InfixApply e2 op2 e3 fixRPrec e1 op e2 = return $ InfixApply e1 op e2 -- The functions 'checkLSection' and 'checkRSection' are used for handling -- the precedences inside left and right sections. -- These functions only need to check that an infix operator occurring in -- the section has either a higher precedence than the section operator -- or both operators have the same precedence and are both left -- associative for a left section and right associative for a right -- section, respectively. checkLSection :: InfixOp -> Expression -> PCM Expression checkLSection op e@(UnaryMinus uop _) = do OpPrec fix pr <- getOpPrec op unless (pr < 6 || pr == 6 && fix == InfixL) $ report $ errAmbiguousParse "unary" (qualify uop) (opName op) return $ LeftSection e op checkLSection op1 e@(InfixApply _ op2 _) = do OpPrec fix1 pr1 <- getOpPrec op1 OpPrec fix2 pr2 <- getOpPrec op2 unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL) $ report $ errAmbiguousParse "operator" (opName op1) (opName op2) return $ LeftSection e op1 checkLSection op e = return $ LeftSection e op checkRSection :: InfixOp -> Expression -> PCM Expression checkRSection op e@(UnaryMinus uop _) = do OpPrec _ pr <- getOpPrec op unless (pr < 6) $ report $ errAmbiguousParse "unary" (qualify uop) (opName op) return $ RightSection op e checkRSection op1 e@(InfixApply _ op2 _) = do OpPrec fix1 pr1 <- getOpPrec op1 OpPrec fix2 pr2 <- getOpPrec op2 unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR) $ report $ errAmbiguousParse "operator" (opName op1) (opName op2) return $ RightSection op1 e checkRSection op e = return $ RightSection op e -- The functions 'fixPrecT' and 'fixRPrecT' check the relative precedences -- of adjacent infix operators in patterns. The patterns will be reordered -- such that the infix operator with the lowest precedence becomes the root -- of the term. The functions rely on the fact that the parser constructs -- infix patterns in a right-associative fashion, i.e., the left argument -- of an infix pattern will never be an infix pattern. The functions also -- check whether the left and right arguments of an infix pattern are negative -- literals. In this case, the negation must bind more tightly than the -- operator for the pattern to be accepted. fixPrecT :: (Pattern -> QualIdent -> Pattern -> Pattern) -> Pattern -> QualIdent -> Pattern -> PCM Pattern fixPrecT infixpatt t1@(NegativePattern uop _) op t2 = do OpPrec fix pr <- prec op <$> getPrecEnv unless (pr < 6 || pr == 6 && fix == InfixL) $ report $ errInvalidParse "unary operator" uop op fixRPrecT infixpatt t1 op t2 fixPrecT infixpatt t1 op t2 = fixRPrecT infixpatt t1 op t2 fixRPrecT :: (Pattern -> QualIdent -> Pattern -> Pattern) -> Pattern -> QualIdent -> Pattern -> PCM Pattern fixRPrecT infixpatt t1 op t2@(NegativePattern uop _) = do OpPrec _ pr <- prec op <$> getPrecEnv unless (pr < 6) $ report $ errInvalidParse "unary operator" uop op return $ infixpatt t1 op t2 fixRPrecT infixpatt t1 op1 (InfixPattern t2 op2 t3) = do OpPrec fix1 pr1 <- prec op1 <$> getPrecEnv OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR then return $ infixpatt t1 op1 (InfixPattern t2 op2 t3) else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL then do left <- fixPrecT infixpatt t1 op1 t2 return $ InfixPattern left op2 t3 else do report $ errAmbiguousParse "operator" op1 op2 return $ infixpatt t1 op1 (InfixPattern t2 op2 t3) fixRPrecT infixpatt t1 op1 (InfixFuncPattern t2 op2 t3) = do OpPrec fix1 pr1 <- prec op1 <$> getPrecEnv OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR then return $ infixpatt t1 op1 (InfixFuncPattern t2 op2 t3) else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL then do left <- fixPrecT infixpatt t1 op1 t2 return $ InfixFuncPattern left op2 t3 else do report $ errAmbiguousParse "operator" op1 op2 return $ infixpatt t1 op1 (InfixFuncPattern t2 op2 t3) fixRPrecT infixpatt t1 op t2 = return $ infixpatt t1 op t2 {-fixPrecT :: Position -> OpPrecEnv -> Pattern -> QualIdent -> Pattern -> Pattern fixPrecT p pEnv t1@(NegativePattern uop l) op t2 | pr < 6 || pr == 6 && fix == InfixL = fixRPrecT p pEnv t1 op t2 | otherwise = errorAt p $ errInvalidParse "unary" uop op where OpPrec fix pr = prec op pEnv fixPrecT p pEnv t1 op t2 = fixRPrecT p pEnv t1 op t2-} {-fixRPrecT :: Position -> OpPrecEnv -> Pattern -> QualIdent -> Pattern -> Pattern fixRPrecT p pEnv t1 op t2@(NegativePattern uop l) | pr < 6 = InfixPattern t1 op t2 | otherwise = errorAt p $ errInvalidParse "unary" uop op where OpPrec _ pr = prec op pEnv fixRPrecT p pEnv t1 op1 (InfixPattern t2 op2 t3) | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR = InfixPattern t1 op1 (InfixPattern t2 op2 t3) | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL = InfixPattern (fixPrecT p pEnv t1 op1 t2) op2 t3 | otherwise = errorAt p $ errAmbiguousParse "operator" op1 op2 where OpPrec fix1 pr1 = prec op1 pEnv OpPrec fix2 pr2 = prec op2 pEnv fixRPrecT _ _ t1 op t2 = InfixPattern t1 op t2-} -- The functions 'checkOpL' and 'checkOpR' check the left and right arguments -- of an operator declaration. If they are infix patterns they must bind -- more tightly than the operator, otherwise the left-hand side of the -- declaration is invalid. checkOpL :: Ident -> Pattern -> PCM Pattern checkOpL op t@(NegativePattern uop _) = do OpPrec fix pr <- prec (qualify op) <$> getPrecEnv unless (pr < 6 || pr == 6 && fix == InfixL) $ report $ errInvalidParse "unary operator" uop (qualify op) return t checkOpL op1 t@(InfixPattern _ op2 _) = do OpPrec fix1 pr1 <- prec (qualify op1) <$> getPrecEnv OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL) $ report $ errInvalidParse "operator" op1 op2 return t checkOpL _ t = return t checkOpR :: Ident -> Pattern -> PCM Pattern checkOpR op t@(NegativePattern uop _) = do OpPrec _ pr <- prec (qualify op) <$> getPrecEnv when (pr >= 6) $ report $ errInvalidParse "unary operator" uop (qualify op) return t checkOpR op1 t@(InfixPattern _ op2 _) = do OpPrec fix1 pr1 <- prec (qualify op1) <$> getPrecEnv OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR) $ report $ errInvalidParse "operator" op1 op2 return t checkOpR _ t = return t -- The functions 'opPrec' and 'prec' return the fixity and operator precedence -- of an entity. Even though precedence checking is performed after the -- renaming phase, we have to be prepared to see ambiguous identifiers here. -- This may happen while checking the root of an operator definition that -- shadows an imported definition. getOpPrec :: InfixOp -> PCM OpPrec getOpPrec op = opPrec op <$> getPrecEnv opPrec :: InfixOp -> OpPrecEnv -> OpPrec opPrec op = prec (opName op) prec :: QualIdent -> OpPrecEnv -> OpPrec prec op env = case qualLookupP op env of [] -> defaultP PrecInfo _ p : _ -> p -- --------------------------------------------------------------------------- -- Error messages -- --------------------------------------------------------------------------- errUndefinedOperator :: Ident -> Message errUndefinedOperator op = posMessage op $ hsep $ map text ["No definition for", escName op, "in this scope"] errMultiplePrecedence :: [Ident] -> Message errMultiplePrecedence [] = internalError "PrecCheck.errMultiplePrecedence: empty list" errMultiplePrecedence (op:ops) = posMessage op $ (hsep $ map text ["More than one fixity declaration for", escName op, "at"]) $+$ nest 2 (vcat (map (ppPosition . getPosition) (op:ops))) errInvalidParse :: String -> Ident -> QualIdent -> Message errInvalidParse what op1 op2 = posMessage op1 $ hsep $ map text [ "Invalid use of", what, escName op1, "with", escQualName op2, "in" , showLine $ qidPosition op2] errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message errAmbiguousParse what op1 op2 = posMessage op1 $ hsep $ map text ["Ambiguous use of", what, escQualName op1, "with", escQualName op2, "in" , showLine $ qidPosition op2] curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/SyntaxCheck.hs000066400000000000000000001523231302651311700272330ustar00rootroot00000000000000{- | Module : $Header$ Description : Syntax checks Copyright : (c) 1999 - 2004 Wolfgang Lux Martin Engelke Björn Peemöller 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable After the type declarations have been checked, the compiler performs a syntax check on the remaining declarations. This check disambiguates nullary data constructors and variables which -- in contrast to Haskell -- is not possible on purely syntactic criteria. In addition, this pass checks for undefined as well as ambiguous variables and constructors. In order to allow lifting of local definitions in later phases, all local variables are renamed by adding a key identifying their scope. Therefore, all variables defined in the same scope share the same key so that multiple definitions can be recognized. Finally, all (adjacent) equations of a function are merged into a single definition. -} {-# LANGUAGE CPP #-} module Checks.SyntaxCheck (syntaxCheck) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif import Control.Monad (unless, when) import qualified Control.Monad.State as S (State, runState, gets, modify) import Data.Function (on) import Data.List (insertBy, intersect, nub, nubBy , partition) import qualified Data.Map as Map (Map, empty, findWithDefault, fromList , insertWith, keys) import Data.Maybe (isJust, isNothing) import qualified Data.Set as Set (Set, empty, insert, member, singleton , union, toList) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Syntax import Curry.Syntax.Pretty (ppPattern) import Base.Expr import Base.Messages (Message, posMessage, internalError) import Base.NestEnv import Base.SCC (scc) import Base.Utils ((++!), findDouble, findMultiples) import Env.Value (ValueEnv, ValueInfo (..)) import CompilerOpts -- The syntax checking proceeds as follows. First, the compiler extracts -- information about all imported values and data constructors from the -- imported (type) environments. Next, the data constructors defined in -- the current module are entered into this environment. After this, -- all record labels are entered into the environment too. If a record -- identifier is already assigned to a constructor, then an error will be -- generated. Finally, all declarations are checked within the resulting -- environment. In addition, this process will also rename the local variables. syntaxCheck :: Options -> ValueEnv -> Module -> ((Module, [KnownExtension]), [Message]) syntaxCheck opts tyEnv mdl@(Module _ m _ _ ds) = case findMultiples $ concatMap constrs tds of [] -> case findMultiples (ls ++ fs) of [] -> runSC (checkModule mdl) state iss -> ((mdl, exts), map (errMultipleDeclarations m) iss) css -> ((mdl, exts), map errMultipleDataConstructor css) where tds = filter isTypeDecl ds vds = filter isValueDecl ds ls = nub $ concatMap recLabels tds fs = nub $ concatMap vars vds rEnv = globalEnv $ fmap renameInfo tyEnv state = initState exts m rEnv exts = optExtensions opts -- A global state transformer is used for generating fresh integer keys with -- which the variables are renamed. -- The state tracks the identifier of the current scope 'scopeId' as well as -- the next fresh identifier, which is used for introducing new scopes as well -- as renaming literals and underscore to disambiguate them. -- |Syntax check monad type SCM = S.State SCState -- |Internal state of the syntax check data SCState = SCState { extensions :: [KnownExtension] -- ^ Enabled language extensions , moduleIdent :: ModuleIdent -- ^ 'ModuleIdent' of the current module , renameEnv :: RenameEnv -- ^ Information store , scopeId :: Integer -- ^ Identifier for the current scope , nextId :: Integer -- ^ Next fresh identifier , funcDeps :: FuncDeps -- ^ Stores data about functions dependencies , errors :: [Message] -- ^ Syntactic errors in the module } -- |Initial syntax check state initState :: [KnownExtension] -> ModuleIdent -> RenameEnv -> SCState initState exts m rEnv = SCState exts m rEnv globalScopeId 1 noFuncDeps [] -- |Identifier for global (top-level) declarations globalScopeId :: Integer globalScopeId = idUnique (mkIdent "") -- |Run the syntax check monad runSC :: SCM a -> SCState -> (a, [Message]) runSC scm s = let (a, s') = S.runState scm s in (a, reverse $ errors s') -- |Check for an enabled extension hasExtension :: KnownExtension -> SCM Bool hasExtension ext = S.gets (elem ext . extensions) -- |Enable an additional 'Extension' to avoid redundant complaints about -- missing extensions enableExtension :: KnownExtension -> SCM () enableExtension e = S.modify $ \ s -> s { extensions = e : extensions s } -- |Retrieve all enabled extensions getExtensions :: SCM [KnownExtension] getExtensions = S.gets extensions -- |Retrieve the 'ModuleIdent' of the current module getModuleIdent :: SCM ModuleIdent getModuleIdent = S.gets moduleIdent -- |Retrieve the 'RenameEnv' getRenameEnv :: SCM RenameEnv getRenameEnv = S.gets renameEnv -- |Modify the 'RenameEnv' modifyRenameEnv :: (RenameEnv -> RenameEnv) -> SCM () modifyRenameEnv f = S.modify $ \ s -> s { renameEnv = f $ renameEnv s } -- |Retrieve the current scope identifier getScopeId :: SCM Integer getScopeId = S.gets scopeId -- |Create a new identifier and return it newId :: SCM Integer newId = do curId <- S.gets nextId S.modify $ \ s -> s { nextId = succ curId } return curId -- |Increase the nesting of the 'RenameEnv' to introduce a new local scope. -- This also increases the scope identifier. incNesting :: SCM () incNesting = do newScopeId <- newId S.modify $ \ s -> s { scopeId = newScopeId } modifyRenameEnv nestEnv withLocalEnv :: SCM a -> SCM a withLocalEnv act = do oldEnv <- getRenameEnv res <- act modifyRenameEnv $ const oldEnv return res -- |Perform an action in a nested scope (by creating a nested 'RenameEnv') -- and discard the nested 'RenameEnv' afterwards inNestedScope :: SCM a -> SCM a inNestedScope act = withLocalEnv (incNesting >> act) -- |Modify the `FuncDeps' modifyFuncDeps :: (FuncDeps -> FuncDeps) -> SCM () modifyFuncDeps f = S.modify $ \ s -> s { funcDeps = f $ funcDeps s } -- |Report a syntax error report :: Message -> SCM () report msg = S.modify $ \ s -> s { errors = msg : errors s } -- |Everything is checked ok :: SCM () ok = return () -- FuncDeps contains information to deal with dependencies between functions. -- This is used for checking whether functional patterns are cyclic. -- curGlobalFunc contains the identifier of the global function that is -- currently being checked, if any. -- data X = X -- f = let g = lookup 42 in g [1,2,3] -- While `X' is being checked `curGlobalFunc' should be `Nothing', -- while `lookup' is being checked is should be `f's identifier. -- globalDeps collects all dependencies (other functions) of global functions -- funcPats collects all functional patterns and the global function they're -- used in data FuncDeps = FuncDeps { curGlobalFunc :: Maybe QualIdent , globalDeps :: GlobalDeps , funcPats :: [(QualIdent, QualIdent)] } type GlobalDeps = Map.Map QualIdent (Set.Set QualIdent) -- |Initial state for FuncDeps noFuncDeps :: FuncDeps noFuncDeps = FuncDeps Nothing Map.empty [] -- |Perform an action inside a function, settìng `curGlobalFunc' to that function inFunc :: Ident -> SCM a -> SCM a inFunc i scm = do m <- getModuleIdent global <- isNothing <$> S.gets (curGlobalFunc . funcDeps) when global $ modifyFuncDeps $ \ fd -> fd { curGlobalFunc = Just (qualifyWith m i) } res <- scm when global $ modifyFuncDeps $ \ fd -> fd { curGlobalFunc = Nothing } return res -- |Add a dependency to `curGlobalFunction' addGlobalDep :: QualIdent -> SCM () addGlobalDep dep = do maybeF <- S.gets (curGlobalFunc . funcDeps) case maybeF of Nothing -> internalError "SyntaxCheck.addFuncPat: no global function set" Just f -> modifyFuncDeps $ \ fd -> fd { globalDeps = Map.insertWith (Set.union) f (Set.singleton dep) (globalDeps fd) } -- |Add a functional pattern to `curGlobalFunction' addFuncPat :: QualIdent -> SCM () addFuncPat fp = do maybeF <- S.gets (curGlobalFunc . funcDeps) case maybeF of Nothing -> internalError "SyntaxCheck.addFuncPat: no global function set" Just f -> modifyFuncDeps $ \ fd -> fd { funcPats = (fp, f) : funcPats fd } -- |Return dependencies of global functions getGlobalDeps :: SCM GlobalDeps getGlobalDeps = globalDeps <$> S.gets funcDeps -- |Return used functional patterns getFuncPats :: SCM [(QualIdent, QualIdent)] getFuncPats = funcPats <$> S.gets funcDeps -- A nested environment is used for recording information about the data -- constructors and variables in the module. For every data constructor -- its arity is saved. This is used for checking that all constructor -- applications in patterns are saturated. For local variables the -- environment records the new name of the variable after renaming. -- Global variables are recorded with qualified identifiers in order -- to distinguish multiply declared entities. -- Currently, records must explicitly be declared together with their labels. -- When constructing or updating a record, it is necessary to compute -- all its labels using just one of them. Thus for each label -- the record identifier and all its labels are entered into the environment -- Note: the function 'qualLookupVar' has been extended to allow the usage of -- the qualified list constructor (prelude.:). type RenameEnv = NestEnv RenameInfo data RenameInfo -- |Arity of data constructor = Constr QualIdent Int -- |Constructors of a record label | RecordLabel QualIdent [QualIdent] -- |Arity of global function | GlobalVar QualIdent Int -- |Arity of local function | LocalVar Ident Int deriving (Eq, Show) ppRenameInfo :: RenameInfo -> Doc ppRenameInfo (Constr qn _) = text (escQualName qn) ppRenameInfo (RecordLabel qn _) = text (escQualName qn) ppRenameInfo (GlobalVar qn _) = text (escQualName qn) ppRenameInfo (LocalVar n _) = text (escName n) -- Since record types are currently translated into data types, it is necessary -- to ensure that all identifiers for records and constructors are different. -- Furthermore, it is not allowed to declare a label more than once. renameInfo :: ValueInfo -> RenameInfo renameInfo (DataConstructor qid a _ _) = Constr qid a renameInfo (NewtypeConstructor qid _ _) = Constr qid 1 renameInfo (Value qid a _) = GlobalVar qid a renameInfo (Label qid cs _) = RecordLabel qid cs bindGlobal :: ModuleIdent -> Ident -> RenameInfo -> RenameEnv -> RenameEnv bindGlobal m c r = bindNestEnv c r . qualBindNestEnv (qualifyWith m c) r bindLocal :: Ident -> RenameInfo -> RenameEnv -> RenameEnv bindLocal = bindNestEnv -- ------------------------------------------------------------------------------ -- |Bind type constructor information and record label information bindTypeDecl :: Decl -> SCM () bindTypeDecl (DataDecl _ _ _ cs) = mapM_ bindConstr cs >> bindRecordLabels cs bindTypeDecl (NewtypeDecl _ _ _ nc) = bindNewConstr nc bindTypeDecl _ = return () bindConstr :: ConstrDecl -> SCM () bindConstr (ConstrDecl _ _ c tys) = do m <- getModuleIdent modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) $ length tys) bindConstr (ConOpDecl _ _ _ op _) = do m <- getModuleIdent modifyRenameEnv $ bindGlobal m op (Constr (qualifyWith m op) 2) bindConstr (RecordDecl _ _ c fs) = do m <- getModuleIdent modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) (length labels)) where labels = [l | FieldDecl _ ls _ <- fs, l <- ls] bindNewConstr :: NewConstrDecl -> SCM () bindNewConstr (NewConstrDecl _ _ c _) = do m <- getModuleIdent modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) 1) bindNewConstr (NewRecordDecl _ _ c (l,_)) = do m <- getModuleIdent bindRecordLabel (l, [c]) modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) 1) bindRecordLabels :: [ConstrDecl] -> SCM () bindRecordLabels cs = mapM_ bindRecordLabel [(l, constr l) | l <- nub (concatMap recordLabels cs)] where constr l = [constrId c | c <- cs, l `elem` recordLabels c] bindRecordLabel :: (Ident, [Ident]) -> SCM () bindRecordLabel (l, cs) = do m <- getModuleIdent new <- (null . lookupVar l) <$> getRenameEnv unless new $ report $ errDuplicateDefinition l modifyRenameEnv $ bindGlobal m l $ RecordLabel (qualifyWith m l) (map (qualifyWith m) cs) -- ------------------------------------------------------------------------------ -- |Bind a global function declaration in the 'RenameEnv' bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv bindFuncDecl _ (FunctionDecl _ _ []) _ = internalError "SyntaxCheck.bindFuncDecl: no equations" bindFuncDecl m (FunctionDecl _ f (eq:_)) env = let arty = length $ snd $ getFlatLhs eq in bindGlobal m f (GlobalVar (qualifyWith m f) arty) env bindFuncDecl m (ForeignDecl _ _ _ f ty) env = let arty = typeArity ty in bindGlobal m f (GlobalVar (qualifyWith m f) arty) env bindFuncDecl m (TypeSig _ fs ty) env = foldr bindTS env $ map (qualifyWith m) fs where bindTS qf env' | null $ qualLookupVar qf env' = bindGlobal m (unqualify qf) (GlobalVar qf (typeArity ty)) env' | otherwise = env' bindFuncDecl _ _ env = env -- ------------------------------------------------------------------------------ -- |Bind a local declaration (function, variables) in the 'RenameEnv' bindVarDecl :: Decl -> RenameEnv -> RenameEnv bindVarDecl (FunctionDecl _ f eqs) env | null eqs = internalError "SyntaxCheck.bindVarDecl: no equations" | otherwise = let arty = length $ snd $ getFlatLhs $ head eqs in bindLocal (unRenameIdent f) (LocalVar f arty) env bindVarDecl (PatternDecl _ t _) env = foldr bindVar env (bv t) bindVarDecl (FreeDecl _ vs) env = foldr bindVar env vs bindVarDecl _ env = env bindVar :: Ident -> RenameEnv -> RenameEnv bindVar v | isAnonId v = id | otherwise = bindLocal (unRenameIdent v) (LocalVar v 0) lookupVar :: Ident -> RenameEnv -> [RenameInfo] lookupVar v env = lookupNestEnv v env ++! lookupTupleConstr v qualLookupVar :: QualIdent -> RenameEnv -> [RenameInfo] qualLookupVar v env = qualLookupNestEnv v env ++! qualLookupListCons v env ++! lookupTupleConstr (unqualify v) lookupTupleConstr :: Ident -> [RenameInfo] lookupTupleConstr v | isTupleId v = let a = tupleArity v in [Constr (qualifyWith preludeMIdent $ tupleId a) a] | otherwise = [] qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo] qualLookupListCons v env | v == qualifyWith preludeMIdent consId = qualLookupNestEnv (qualify $ qidIdent v) env | otherwise = [] -- When a module is checked, the global declaration group is checked. The -- resulting renaming environment can be discarded. The same is true for -- a goal. Note that all declarations in the goal must be considered as -- local declarations. checkModule :: Module -> SCM (Module, [KnownExtension]) checkModule (Module ps m es is ds) = do mapM_ checkPragma ps mapM_ bindTypeDecl tds ds' <- (tds ++) <$> checkTopDecls vds checkFuncPatDeps exts <- getExtensions return (Module ps m es is ds', exts) where (tds, vds) = partition isTypeDecl ds checkPragma :: ModulePragma -> SCM () checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts checkPragma (OptionsPragma _ _ _) = ok checkExtension :: Extension -> SCM () checkExtension (KnownExtension _ e) = enableExtension e checkExtension (UnknownExtension p e) = report $ errUnknownExtension p e -- |Checks whether a function in a functional pattern contains cycles -- |(depends on its own global function) checkFuncPatDeps :: SCM () checkFuncPatDeps = do fps <- getFuncPats deps <- getGlobalDeps let levels = scc (:[]) (\k -> Set.toList (Map.findWithDefault (Set.empty) k deps)) (Map.keys deps) levelMap = Map.fromList [ (f, l) | (fs, l) <- zip levels [1 ..], f <- fs ] level f = Map.findWithDefault (0 :: Int) f levelMap mapM_ (checkFuncPatDep level) fps checkFuncPatDep :: Ord a => (QualIdent -> a) -> (QualIdent, QualIdent) -> SCM () checkFuncPatDep level (fp, f) = unless (level fp < level f) $ report $ errFuncPatCyclic fp f checkTopDecls :: [Decl] -> SCM [Decl] checkTopDecls ds = do m <- getModuleIdent checkDeclGroup (bindFuncDecl m) ds -- Each declaration group opens a new scope and uses a distinct key -- for renaming the variables in this scope. In a declaration group, -- first the left hand sides of all declarations are checked, next the -- compiler checks that there is a definition for every type signature -- and evaluation annotation in this group. Finally, the right hand sides -- are checked and adjacent equations for the same function are merged -- into a single definition. -- The function 'checkDeclLhs' also handles the case where a pattern -- declaration is recognized as a function declaration by the parser. -- This happens, e.g., for the declaration -- where Just x = y -- because the parser cannot distinguish nullary constructors and functions. -- Note that pattern declarations are not allowed on the top-level. checkDeclGroup :: (Decl -> RenameEnv -> RenameEnv) -> [Decl] -> SCM [Decl] checkDeclGroup bindDecl ds = do checkedLhs <- mapM checkDeclLhs $ sortFuncDecls ds joinEquations checkedLhs >>= checkDecls bindDecl checkDeclLhs :: Decl -> SCM Decl checkDeclLhs (InfixDecl p fix' pr ops) = InfixDecl p fix' <$> checkPrecedence p pr <*> mapM renameVar ops checkDeclLhs (TypeSig p vs ty) = (\vs' -> TypeSig p vs' ty) <$> mapM (checkVar "type signature") vs checkDeclLhs (FunctionDecl p f eqs) = inFunc f $ checkEquationsLhs p eqs checkDeclLhs (ForeignDecl p cc ie f ty) = (\f' -> ForeignDecl p cc ie f' ty) <$> checkVar "foreign declaration" f checkDeclLhs ( ExternalDecl p fs) = ExternalDecl p <$> mapM (checkVar "external declaration") fs checkDeclLhs (PatternDecl p t rhs) = (\t' -> PatternDecl p t' rhs) <$> checkPattern p t checkDeclLhs (FreeDecl p vs) = FreeDecl p <$> mapM (checkVar "free variables declaration") vs checkDeclLhs d = return d checkPrecedence :: Position -> Maybe Precedence -> SCM (Maybe Precedence) checkPrecedence _ Nothing = return Nothing checkPrecedence p (Just i) = do unless (0 <= i && i <= 9) $ report $ errPrecedenceOutOfRange p i return $ Just i checkVar :: String -> Ident -> SCM Ident checkVar _what v = do -- isDC <- S.gets (isDataConstr v . renameEnv) -- when isDC $ report $ nonVariable what v -- TODO Why is this disabled? renameVar v renameVar :: Ident -> SCM Ident renameVar v = renameIdent v <$> getScopeId checkEquationsLhs :: Position -> [Equation] -> SCM Decl checkEquationsLhs p [Equation p' lhs rhs] = do lhs' <- checkEqLhs p' lhs case lhs' of Left l -> return $ funDecl l Right r -> patDecl r >>= checkDeclLhs where funDecl (f, lhs') = FunctionDecl p f [Equation p' lhs' rhs] patDecl t = do k <- getScopeId when (k == globalScopeId) $ report $ errToplevelPattern p return $ PatternDecl p' t rhs checkEquationsLhs _ _ = internalError "SyntaxCheck.checkEquationsLhs" checkEqLhs :: Position -> Lhs -> SCM (Either (Ident, Lhs) Pattern) checkEqLhs p toplhs = do m <- getModuleIdent k <- getScopeId env <- getRenameEnv case toplhs of FunLhs f ts | not $ isDataConstr f env -> return left | k /= globalScopeId -> return right | null infos -> return left | otherwise -> do report $ errToplevelPattern p return right where f' = renameIdent f k infos = qualLookupVar (qualifyWith m f) env left = Left (f', FunLhs f' ts) right = Right $ ConstructorPattern (qualify f) ts OpLhs t1 op t2 | not $ isDataConstr op env -> return left | k /= globalScopeId -> return right | null infos -> return left | otherwise -> do report $ errToplevelPattern p return right where op' = renameIdent op k infos = qualLookupVar (qualifyWith m op) env left = Left (op', OpLhs t1 op' t2) right = checkOpLhs k env (infixPattern t1 (qualify op)) t2 infixPattern (InfixPattern t1' op1 t2') op2 t3 = InfixPattern t1' op1 (infixPattern t2' op2 t3) infixPattern t1' op1 t2' = InfixPattern t1' op1 t2' ApLhs lhs ts -> do checked <- checkEqLhs p lhs case checked of Left (f', lhs') -> return $ Left (f', ApLhs lhs' ts) r -> do report $ errNonVariable "curried definition" f return $ r where (f, _) = flatLhs lhs checkOpLhs :: Integer -> RenameEnv -> (Pattern -> Pattern) -> Pattern -> Either (Ident, Lhs) Pattern checkOpLhs k env f (InfixPattern t1 op t2) | isJust m || isDataConstr op' env = checkOpLhs k env (f . InfixPattern t1 op) t2 | otherwise = Left (op'', OpLhs (f t1) op'' t2) where (m,op') = (qidModule op, qidIdent op) op'' = renameIdent op' k checkOpLhs _ _ f t = Right (f t) -- -- --------------------------------------------------------------------------- joinEquations :: [Decl] -> SCM [Decl] joinEquations [] = return [] joinEquations (FunctionDecl p f eqs : FunctionDecl _ f' [eq] : ds) | f == f' = do when (getArity (head eqs) /= getArity eq) $ report $ errDifferentArity [f, f'] joinEquations (FunctionDecl p f (eqs ++ [eq]) : ds) where getArity = length . snd . getFlatLhs joinEquations (d : ds) = (d :) <$> joinEquations ds checkDecls :: (Decl -> RenameEnv -> RenameEnv) -> [Decl] -> SCM [Decl] checkDecls bindDecl ds = do let dblVar = findDouble bvs onJust (report . errDuplicateDefinition) dblVar let mulTys = findMultiples tys mapM_ (report . errDuplicateTypeSig) mulTys let missingTys = [f | ExternalDecl _ fs' <- ds, f <- fs', f `notElem` tys] mapM_ (report . errNoTypeSig) missingTys if isNothing dblVar && null mulTys && null missingTys then do modifyRenameEnv $ \env -> foldr bindDecl env (tds ++ vds) mapM (checkDeclRhs bvs) ds else return ds -- skip further checking where vds = filter isValueDecl ds tds = filter isTypeSig ds bvs = concatMap vars vds tys = concatMap vars tds onJust = maybe (return ()) -- -- --------------------------------------------------------------------------- checkDeclRhs :: [Ident] -> Decl -> SCM Decl checkDeclRhs _ (DataDecl p tc tvs cs) = DataDecl p tc tvs <$> mapM checkDeclLabels cs checkDeclRhs bvs (TypeSig p vs ty) = (\vs' -> TypeSig p vs' ty) <$> mapM (checkLocalVar bvs) vs checkDeclRhs _ (FunctionDecl p f eqs) = FunctionDecl p f <$> inFunc f (mapM checkEquation eqs) checkDeclRhs _ (PatternDecl p t rhs) = PatternDecl p t <$> checkRhs rhs checkDeclRhs _ d = return d checkDeclLabels :: ConstrDecl -> SCM ConstrDecl checkDeclLabels rd@(RecordDecl _ _ _ fs) = do onJust (report . errDuplicateLabel "declaration") (findDouble $ map qualify labels) return rd where onJust = maybe (return ()) labels = [l | FieldDecl _ ls _ <- fs, l <- ls] checkDeclLabels d = return d checkLocalVar :: [Ident] -> Ident -> SCM Ident checkLocalVar bvs v = do when (v `notElem` bvs) $ report $ errNoBody v return v checkEquation :: Equation -> SCM Equation checkEquation (Equation p lhs rhs) = inNestedScope $ do lhs' <- checkLhs p lhs >>= addBoundVariables False rhs' <- checkRhs rhs return $ Equation p lhs' rhs' checkLhs :: Position -> Lhs -> SCM Lhs checkLhs p (FunLhs f ts) = FunLhs f <$> mapM (checkPattern p) ts checkLhs p (OpLhs t1 op t2) = do let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2] unless (null wrongCalls) $ report $ errInfixWithoutParens (idPosition op) wrongCalls flip OpLhs op <$> checkPattern p t1 <*> checkPattern p t2 checkLhs p (ApLhs lhs ts) = ApLhs <$> checkLhs p lhs <*> mapM (checkPattern p) ts -- checkParen -- @param Aufrufende InfixFunktion -- @param Pattern -- @return Liste mit fehlerhaften Funktionsaufrufen checkParenPattern :: (Maybe QualIdent) -> Pattern -> [(QualIdent,QualIdent)] checkParenPattern _ (LiteralPattern _) = [] checkParenPattern _ (NegativePattern _ _) = [] checkParenPattern _ (VariablePattern _) = [] checkParenPattern _ (ConstructorPattern _ cs) = concatMap (checkParenPattern Nothing) cs checkParenPattern o (InfixPattern t1 op t2) = maybe [] (\c -> [(c, op)]) o ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2 checkParenPattern _ (ParenPattern t) = checkParenPattern Nothing t checkParenPattern _ (RecordPattern _ fs) = concatMap (\(Field _ _ t) -> checkParenPattern Nothing t) fs checkParenPattern _ (TuplePattern _ ts) = concatMap (checkParenPattern Nothing) ts checkParenPattern _ (ListPattern _ ts) = concatMap (checkParenPattern Nothing) ts checkParenPattern o (AsPattern _ t) = checkParenPattern o t checkParenPattern o (LazyPattern _ t) = checkParenPattern o t checkParenPattern _ (FunctionPattern _ ts) = concatMap (checkParenPattern Nothing) ts checkParenPattern o (InfixFuncPattern t1 op t2) = maybe [] (\c -> [(c, op)]) o ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2 checkPattern :: Position -> Pattern -> SCM Pattern checkPattern _ (LiteralPattern l) = LiteralPattern <$> renameLiteral l checkPattern _ (NegativePattern op l) = NegativePattern op <$> renameLiteral l checkPattern p (VariablePattern v) | isAnonId v = (VariablePattern . renameIdent v) <$> newId | otherwise = checkConstructorPattern p (qualify v) [] checkPattern p (ConstructorPattern c ts) = checkConstructorPattern p c ts checkPattern p (InfixPattern t1 op t2) = checkInfixPattern p t1 op t2 checkPattern p (ParenPattern t) = ParenPattern <$> checkPattern p t checkPattern p (RecordPattern c fs) = checkRecordPattern p c fs checkPattern p (TuplePattern pos ts) = TuplePattern pos <$> mapM (checkPattern p) ts checkPattern p (ListPattern pos ts) = ListPattern pos <$> mapM (checkPattern p) ts checkPattern p (AsPattern v t) = do AsPattern <$> checkVar "@ pattern" v <*> checkPattern p t checkPattern p (LazyPattern pos t) = do t' <- checkPattern p t banFPTerm "lazy pattern" p t' return (LazyPattern pos t') checkPattern _ (FunctionPattern _ _) = internalError $ "SyntaxCheck.checkPattern: function pattern not defined" checkPattern _ (InfixFuncPattern _ _ _) = internalError $ "SyntaxCheck.checkPattern: infix function pattern not defined" checkConstructorPattern :: Position -> QualIdent -> [Pattern] -> SCM Pattern checkConstructorPattern p c ts = do env <- getRenameEnv m <- getModuleIdent k <- getScopeId case qualLookupVar c env of [Constr _ n] -> processCons c n [r] -> processVarFun r k rs -> case qualLookupVar (qualQualify m c) env of [Constr _ n] -> processCons (qualQualify m c) n [r] -> processVarFun r k [] | null ts && not (isQualified c) -> return $ VariablePattern $ renameIdent (unqualify c) k | null rs -> do ts' <- mapM (checkPattern p) ts report $ errUndefinedData c return $ ConstructorPattern c ts' _ -> do ts' <- mapM (checkPattern p) ts report $ errAmbiguousData rs c return $ ConstructorPattern c ts' where n' = length ts processCons qc n = do when (n /= n') $ report $ errWrongArity c n n' ConstructorPattern qc <$> mapM (checkPattern p) ts processVarFun r k | null ts && not (isQualified c) = return $ VariablePattern $ renameIdent (unqualify c) k -- (varIdent r) k | otherwise = do let n = arity r checkFuncPatsExtension p checkFuncPatCall r c ts' <- mapM (checkPattern p) ts mapM_ (checkFPTerm p) ts' return $ if n' > n then let (ts1, ts2) = splitAt n ts' in genFuncPattAppl (FunctionPattern (qualVarIdent r) ts1) ts2 else FunctionPattern (qualVarIdent r) ts' checkInfixPattern :: Position -> Pattern -> QualIdent -> Pattern -> SCM Pattern checkInfixPattern p t1 op t2 = do m <- getModuleIdent env <- getRenameEnv case qualLookupVar op env of [Constr _ n] -> infixPattern op n [r] -> funcPattern r op rs -> case qualLookupVar (qualQualify m op) env of [Constr _ n] -> infixPattern (qualQualify m op) n [r] -> funcPattern r (qualQualify m op) rs' -> do if (null rs && null rs') then report $ errUndefinedData op else report $ errAmbiguousData rs op flip InfixPattern op <$> checkPattern p t1 <*> checkPattern p t2 where infixPattern qop n = do when (n /= 2) $ report $ errWrongArity op n 2 flip InfixPattern qop <$> checkPattern p t1 <*> checkPattern p t2 funcPattern r qop = do checkFuncPatsExtension p checkFuncPatCall r qop ts'@[t1',t2'] <- mapM (checkPattern p) [t1,t2] mapM_ (checkFPTerm p) ts' return $ InfixFuncPattern t1' qop t2' checkRecordPattern :: Position -> QualIdent -> [Field Pattern] -> SCM Pattern checkRecordPattern p c fs = do env <- getRenameEnv m <- getModuleIdent case qualLookupVar c env of [Constr c' _] -> processRecPat (Just c') fs rs -> case qualLookupVar (qualQualify m c) env of [Constr c' _] -> processRecPat (Just c') fs rs' -> if (null rs && null rs') then do report $ errUndefinedData c processRecPat Nothing fs else do report $ errAmbiguousData rs c processRecPat Nothing fs where processRecPat mcon fields = do fs' <- mapM (checkField (checkPattern p)) fields checkFieldLabels "pattern" p mcon fs' return $ RecordPattern c fs' checkFuncPatCall :: RenameInfo -> QualIdent -> SCM () checkFuncPatCall r f = case r of GlobalVar dep _ -> do addGlobalDep dep addFuncPat (dep @> f) _ -> report $ errFuncPatNotGlobal f -- Note: process decls first checkRhs :: Rhs -> SCM Rhs checkRhs (SimpleRhs p e ds) = inNestedScope $ flip (SimpleRhs p) <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e checkRhs (GuardedRhs es ds) = inNestedScope $ flip GuardedRhs <$> checkDeclGroup bindVarDecl ds <*> mapM checkCondExpr es checkCondExpr :: CondExpr -> SCM CondExpr checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr p g <*> checkExpr p e checkExpr :: Position -> Expression -> SCM Expression checkExpr _ (Literal l) = Literal <$> renameLiteral l checkExpr _ (Variable v) = checkVariable v checkExpr _ (Constructor c) = checkVariable c checkExpr p (Paren e) = Paren <$> checkExpr p e checkExpr p (Typed e ty) = flip Typed ty <$> checkExpr p e checkExpr p (Record c fs) = checkRecordExpr p c fs checkExpr p (RecordUpdate e fs) = checkRecordUpdExpr p e fs checkExpr p (Tuple pos es) = Tuple pos <$> mapM (checkExpr p) es checkExpr p (List pos es) = List pos <$> mapM (checkExpr p) es checkExpr p (ListCompr pos e qs) = withLocalEnv $ flip (ListCompr pos) <$> -- Note: must be flipped to insert qs into RenameEnv first mapM (checkStatement "list comprehension" p) qs <*> checkExpr p e checkExpr p (EnumFrom e) = EnumFrom <$> checkExpr p e checkExpr p (EnumFromThen e1 e2) = EnumFromThen <$> checkExpr p e1 <*> checkExpr p e2 checkExpr p (EnumFromTo e1 e2) = EnumFromTo <$> checkExpr p e1 <*> checkExpr p e2 checkExpr p (EnumFromThenTo e1 e2 e3) = EnumFromThenTo <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3 checkExpr p (UnaryMinus op e) = UnaryMinus op <$> checkExpr p e checkExpr p (Apply e1 e2) = Apply <$> checkExpr p e1 <*> checkExpr p e2 checkExpr p (InfixApply e1 op e2) = InfixApply <$> checkExpr p e1 <*> checkOp op <*> checkExpr p e2 checkExpr p (LeftSection e op) = LeftSection <$> checkExpr p e <*> checkOp op checkExpr p (RightSection op e) = RightSection <$> checkOp op <*> checkExpr p e checkExpr p (Lambda r ts e) = inNestedScope $ checkLambda p r ts e checkExpr p (Let ds e) = inNestedScope $ Let <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e checkExpr p (Do sts e) = withLocalEnv $ Do <$> mapM (checkStatement "do sequence" p) sts <*> checkExpr p e checkExpr p (IfThenElse r e1 e2 e3) = IfThenElse r <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3 checkExpr p (Case r ct e alts) = Case r ct <$> checkExpr p e <*> mapM checkAlt alts checkLambda :: Position -> SrcRef -> [Pattern] -> Expression -> SCM Expression checkLambda p r ts e = case findMultiples (bvNoAnon ts) of [] -> do ts' <- mapM (bindPattern "lambda expression" p) ts Lambda r ts' <$> checkExpr p e errVars -> do mapM_ (report . errDuplicateVariables) errVars let nubTs = nubBy (\t1 t2 -> (not . null) (on intersect bvNoAnon t1 t2)) ts mapM_ (bindPattern "lambda expression" p) nubTs Lambda r ts <$> checkExpr p e where bvNoAnon t = filter (not . isAnonId) $ bv t checkVariable :: QualIdent -> SCM Expression checkVariable v -- anonymous free variable | isAnonId (unqualify v) = do checkAnonFreeVarsExtension $ qidPosition v (\n -> Variable $ updQualIdent id (flip renameIdent n) v) <$> newId -- return $ Variable v -- normal variable | otherwise = do env <- getRenameEnv case qualLookupVar v env of [] -> do report $ errUndefinedVariable v return $ Variable v [Constr _ _] -> return $ Constructor v [GlobalVar f _] -> addGlobalDep f >> return (Variable v) [LocalVar v' _] -> return $ Variable $ qualify v' @> v [RecordLabel _ _] -> return $ Variable v rs -> do m <- getModuleIdent case qualLookupVar (qualQualify m v) env of [] -> do report $ errAmbiguousIdent rs v return $ Variable v [Constr _ _] -> return $ Constructor v [GlobalVar f _] -> addGlobalDep f >> return (Variable v) [LocalVar v' _] -> return $ Variable $ qualify v' @> v [RecordLabel _ _] -> return $ Variable v rs' -> do report $ errAmbiguousIdent rs' v return $ Variable v checkRecordExpr :: Position -> QualIdent -> [Field Expression] -> SCM Expression checkRecordExpr _ c [] = do m <- getModuleIdent env <- getRenameEnv case qualLookupVar c env of [Constr _ _] -> return $ Record c [] rs -> case qualLookupVar (qualQualify m c) env of [Constr _ _] -> return $ Record c [] rs' -> if (null rs && null rs') then do report $ errUndefinedData c return $ Record c [] else do report $ errAmbiguousData rs c return $ Record c [] checkRecordExpr p c fs = checkExpr p (RecordUpdate (Constructor c) fs) checkRecordUpdExpr :: Position -> Expression -> [Field Expression] -> SCM Expression checkRecordUpdExpr p e fs = do e' <- checkExpr p e fs' <- mapM (checkField (checkExpr p)) fs case e' of Constructor c -> do checkFieldLabels "construction" p (Just c) fs' return $ Record c fs' _ -> do checkFieldLabels "update" p Nothing fs' return $ RecordUpdate e' fs' -- * Because patterns or decls eventually introduce new variables, the -- scope has to be nested one level. -- * Because statements are processed list-wise, inNestedEnv can not be -- used as this nesting must be visible to following statements. checkStatement :: String -> Position -> Statement -> SCM Statement checkStatement _ p (StmtExpr pos e) = StmtExpr pos <$> checkExpr p e checkStatement s p (StmtBind pos t e) = flip (StmtBind pos) <$> checkExpr p e <*> (incNesting >> bindPattern s p t) checkStatement _ _ (StmtDecl ds) = StmtDecl <$> (incNesting >> checkDeclGroup bindVarDecl ds) bindPattern :: String -> Position -> Pattern -> SCM Pattern bindPattern s p t = do t' <- checkPattern p t banFPTerm s p t' addBoundVariables True t' banFPTerm :: String -> Position -> Pattern -> SCM () banFPTerm _ _ (LiteralPattern _) = ok banFPTerm _ _ (NegativePattern _ _) = ok banFPTerm _ _ (VariablePattern _) = ok banFPTerm s p (ConstructorPattern _ ts) = mapM_ (banFPTerm s p) ts banFPTerm s p (InfixPattern t1 _ t2) = mapM_ (banFPTerm s p) [t1, t2] banFPTerm s p (ParenPattern t) = banFPTerm s p t banFPTerm s p (RecordPattern _ fs) = mapM_ banFPTermField fs where banFPTermField (Field _ _ x) = banFPTerm s p x banFPTerm s p (TuplePattern _ ts) = mapM_ (banFPTerm s p) ts banFPTerm s p (ListPattern _ ts) = mapM_ (banFPTerm s p) ts banFPTerm s p (AsPattern _ t) = banFPTerm s p t banFPTerm s p (LazyPattern _ t) = banFPTerm s p t banFPTerm s p pat@(FunctionPattern _ _) = report $ errUnsupportedFuncPattern s p pat banFPTerm s p pat@(InfixFuncPattern _ _ _) = report $ errUnsupportedFuncPattern s p pat checkOp :: InfixOp -> SCM InfixOp checkOp op = do env <- getRenameEnv case qualLookupVar v env of [] -> report (errUndefinedVariable v) >> return op [Constr _ _] -> return $ InfixConstr v [GlobalVar f _] -> addGlobalDep f >> return (InfixOp v) [LocalVar v' _] -> return $ InfixOp $ qualify v' rs -> do m <- getModuleIdent case qualLookupVar (qualQualify m v) env of [] -> report (errAmbiguousIdent rs v) >> return op [Constr _ _] -> return $ InfixConstr v [GlobalVar f _] -> addGlobalDep f >> return (InfixOp v) [LocalVar v' _] -> return $ InfixOp $ qualify v' rs' -> report (errAmbiguousIdent rs' v) >> return op where v = opName op checkAlt :: Alt -> SCM Alt checkAlt (Alt p t rhs) = inNestedScope $ Alt p <$> bindPattern "case expression" p t <*> checkRhs rhs addBoundVariables :: (QuantExpr t) => Bool -> t -> SCM t addBoundVariables checkDuplicates ts = do when checkDuplicates $ mapM_ (report . errDuplicateVariables) (findMultiples bvs) modifyRenameEnv $ \ env -> foldr bindVar env (nub bvs) return ts where bvs = bv ts -- For record patterns and expressions the compiler checks that all field -- labels belong to the pattern or expression's constructor. For record -- update expressions, the compiler checks that there is at least one -- constructor which has all the specified field labels. In addition, the -- compiler always checks that no field label occurs twice. Field labels -- are always looked up in the global environment since they cannot be -- shadowed by local variables (cf.\ Sect.~3.15.1 of the revised -- Haskell'98 report~\cite{PeytonJones03:Haskell}). checkFieldLabels :: String -> Position -> Maybe QualIdent -> [Field a] -> SCM () checkFieldLabels what p c fs = do mapM checkFieldLabel ls' >>= checkLabels p c ls' onJust (report . errDuplicateLabel what) (findDouble ls) where ls = [l | Field _ l _ <- fs] ls' = nub ls onJust = maybe (return ()) checkFieldLabel :: QualIdent -> SCM [QualIdent] checkFieldLabel l = do m <- getModuleIdent env <- getRenameEnv case qualLookupVar l env of [RecordLabel _ cs] -> processLabel cs rs -> case qualLookupVar (qualQualify m l) env of [RecordLabel _ cs] -> processLabel cs rs' -> if (null rs && null rs') then do report $ errUndefinedLabel l return [] else do report $ errAmbiguousIdent rs (qualQualify m l) return [] where processLabel cs' = do when (null cs') $ report $ errUndefinedLabel l return cs' checkLabels :: Position -> Maybe QualIdent -> [QualIdent] -> [[QualIdent]] -> SCM () checkLabels _ (Just c) ls css = do env <- getRenameEnv case qualLookupVar c env of [Constr c' _] -> mapM_ (report . errNoLabel c) [l | (l, cs) <- zip ls css, c' `notElem` cs] _ -> internalError $ "Checks.SyntaxCheck.checkLabels: " ++ show c checkLabels p Nothing ls css = when (null (foldr1 intersect css)) $ report $ errNoCommonCons p ls checkField :: (a -> SCM a) -> Field a -> SCM (Field a) checkField check (Field p l x) = Field p l <$> check x -- --------------------------------------------------------------------------- -- Auxiliary definitions -- --------------------------------------------------------------------------- constrs :: Decl -> [Ident] constrs (DataDecl _ _ _ cs) = map constrId cs constrs (NewtypeDecl _ _ _ nc) = [nconstrId nc] constrs _ = [] vars :: Decl -> [Ident] vars (TypeSig _ fs _) = fs vars (FunctionDecl _ f _) = [f] vars (ForeignDecl _ _ _ f _) = [f] vars (ExternalDecl _ fs) = fs vars (PatternDecl _ t _) = bv t vars (FreeDecl _ vs) = vs vars _ = [] recLabels :: Decl -> [Ident] recLabels (DataDecl _ _ _ cs) = concatMap recordLabels cs recLabels (NewtypeDecl _ _ _ nc) = nrecordLabels nc recLabels _ = [] renameLiteral :: Literal -> SCM Literal renameLiteral (Int v i) = (flip Int i . renameIdent v) <$> newId renameLiteral l = return l -- Since the compiler expects all rules of the same function to be together, -- it is necessary to sort the list of declarations. sortFuncDecls :: [Decl] -> [Decl] sortFuncDecls decls = sortFD Set.empty [] decls where sortFD _ res [] = reverse res sortFD env res (decl : decls') = case decl of FunctionDecl _ ident _ | ident `Set.member` env -> sortFD env (insertBy cmpFuncDecl decl res) decls' | otherwise -> sortFD (Set.insert ident env) (decl:res) decls' _ -> sortFD env (decl:res) decls' cmpFuncDecl :: Decl -> Decl -> Ordering cmpFuncDecl (FunctionDecl _ id1 _) (FunctionDecl _ id2 _) | id1 == id2 = EQ | otherwise = GT cmpFuncDecl _ _ = GT -- Due to the lack of a capitalization convention in Curry, it is -- possible that an identifier may ambiguously refer to a data -- constructor and a function provided that both are imported from some -- other module. When checking whether an identifier denotes a -- constructor there are two options with regard to ambiguous -- identifiers: -- * Handle the identifier as a data constructor if at least one of -- the imported names is a data constructor. -- * Handle the identifier as a data constructor only if all imported -- entities are data constructors. -- We choose the first possibility here because in the second case a -- redefinition of a constructor can magically become possible if a -- function with the same name is imported. It seems better to warn -- the user about the fact that the identifier is ambiguous. isDataConstr :: Ident -> RenameEnv -> Bool isDataConstr v = any isConstr . lookupVar v . globalEnv . toplevelEnv isConstr :: RenameInfo -> Bool isConstr (Constr _ _) = True isConstr (GlobalVar _ _) = False isConstr (LocalVar _ _) = False isConstr (RecordLabel _ _) = False isLabel :: RenameInfo -> Bool isLabel (Constr _ _) = False isLabel (GlobalVar _ _) = False isLabel (LocalVar _ _) = False isLabel (RecordLabel _ _) = True -- varIdent :: RenameInfo -> Ident -- varIdent (GlobalVar _ v) = unqualify v -- varIdent (LocalVar _ v) = v -- varIdent _ = internalError "SyntaxCheck.varIdent: no variable" qualVarIdent :: RenameInfo -> QualIdent qualVarIdent (GlobalVar v _) = v qualVarIdent (LocalVar v _) = qualify v qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: no variable" arity :: RenameInfo -> Int arity (Constr _ n) = n arity (GlobalVar _ n) = n arity (LocalVar _ n) = n arity (RecordLabel _ _) = 1 -- Unlike expressions, constructor terms have no possibility to represent -- over-applications in functional patterns. Therefore it is necessary to -- transform them to nested function patterns using the prelude function -- apply. E.g., the function pattern (id id 10) is transformed to -- (apply (id id) 10). genFuncPattAppl :: Pattern -> [Pattern] -> Pattern genFuncPattAppl term [] = term genFuncPattAppl term (t:ts) = FunctionPattern qApplyId [genFuncPattAppl term ts, t] where qApplyId = qualifyWith preludeMIdent (mkIdent "apply") checkFPTerm :: Position -> Pattern -> SCM () checkFPTerm _ (LiteralPattern _) = ok checkFPTerm _ (NegativePattern _ _) = ok checkFPTerm _ (VariablePattern _) = ok checkFPTerm p (ConstructorPattern _ ts) = mapM_ (checkFPTerm p) ts checkFPTerm p (InfixPattern t1 _ t2) = mapM_ (checkFPTerm p) [t1, t2] checkFPTerm p (ParenPattern t) = checkFPTerm p t checkFPTerm p (TuplePattern _ ts) = mapM_ (checkFPTerm p) ts checkFPTerm p (ListPattern _ ts) = mapM_ (checkFPTerm p) ts checkFPTerm p (AsPattern _ t) = checkFPTerm p t checkFPTerm p t@(LazyPattern _ _) = report $ errUnsupportedFPTerm "Lazy" p t checkFPTerm p (RecordPattern _ fs) = mapM_ (checkFPTerm p) [ t | Field _ _ t <- fs ] checkFPTerm _ (FunctionPattern _ _) = ok -- do not check again checkFPTerm _ (InfixFuncPattern _ _ _) = ok -- do not check again -- --------------------------------------------------------------------------- -- Miscellaneous functions -- --------------------------------------------------------------------------- checkFuncPatsExtension :: Position -> SCM () checkFuncPatsExtension p = checkUsedExtension p "Functional Patterns" FunctionalPatterns checkAnonFreeVarsExtension :: Position -> SCM () checkAnonFreeVarsExtension p = checkUsedExtension p "Anonymous free variables" AnonFreeVars checkUsedExtension :: Position -> String -> KnownExtension -> SCM () checkUsedExtension pos msg ext = do enabled <- hasExtension ext unless enabled $ do report $ errMissingLanguageExtension pos msg ext enableExtension ext -- to avoid multiple warnings typeArity :: TypeExpr -> Int typeArity (ArrowType _ t2) = 1 + typeArity t2 typeArity _ = 0 getFlatLhs :: Equation -> (Ident, [Pattern]) getFlatLhs (Equation _ lhs _) = flatLhs lhs -- --------------------------------------------------------------------------- -- Error messages -- --------------------------------------------------------------------------- errUnsupportedFPTerm :: String -> Position -> Pattern -> Message errUnsupportedFPTerm s p pat = posMessage p $ text s <+> text "patterns are not supported inside a functional pattern." $+$ ppPattern 0 pat errUnsupportedFuncPattern :: String -> Position -> Pattern -> Message errUnsupportedFuncPattern s p pat = posMessage p $ text "Functional patterns are not supported inside a" <+> text s <> dot $+$ ppPattern 0 pat errFuncPatNotGlobal :: QualIdent -> Message errFuncPatNotGlobal f = posMessage f $ hsep $ map text ["Function", escQualName f, "in functional pattern is not global"] errFuncPatCyclic :: QualIdent -> QualIdent -> Message errFuncPatCyclic fp f = posMessage fp $ hsep $ map text [ "Function", escName $ unqualify fp, "used in functional pattern depends on" , escName $ unqualify f, " causing a cyclic dependency"] errPrecedenceOutOfRange :: Position -> Integer -> Message errPrecedenceOutOfRange p i = posMessage p $ hsep $ map text ["Precedence out of range:", show i] errUndefinedVariable :: QualIdent -> Message errUndefinedVariable v = posMessage v $ hsep $ map text [escQualName v, "is undefined"] errUndefinedData :: QualIdent -> Message errUndefinedData c = posMessage c $ hsep $ map text ["Undefined data constructor", escQualName c] errUndefinedLabel :: QualIdent -> Message errUndefinedLabel l = posMessage l $ hsep $ map text ["Undefined record label", escQualName l] errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message errAmbiguousIdent rs qn | any isConstr rs = errAmbiguousData rs qn | any isLabel rs = errAmbiguousLabel rs qn | otherwise = errAmbiguous "variable" rs qn errAmbiguousData :: [RenameInfo] -> QualIdent -> Message errAmbiguousData = errAmbiguous "data constructor" errAmbiguousLabel :: [RenameInfo] -> QualIdent -> Message errAmbiguousLabel = errAmbiguous "field label" errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message errAmbiguous what rs qn = posMessage qn $ text "Ambiguous" <+> text what <+> text (escQualName qn) $+$ text "It could refer to:" $+$ nest 2 (vcat (map ppRenameInfo rs)) errDuplicateDefinition :: Ident -> Message errDuplicateDefinition v = posMessage v $ hsep $ map text ["More than one definition for", escName v] errDuplicateVariables :: [Ident] -> Message errDuplicateVariables [] = internalError "SyntaxCheck.errDuplicateVariables: empty list" errDuplicateVariables (v:vs) = posMessage v $ text (escName v) <+> text "occurs more than one in pattern at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (v:vs))) errMultipleDataConstructor :: [Ident] -> Message errMultipleDataConstructor [] = internalError "SyntaxCheck.errMultipleDataDeclaration: empty list" errMultipleDataConstructor (i:is) = posMessage i $ text "Multiple definitions for data/record constructor" <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is))) errMultipleDeclarations :: ModuleIdent -> [Ident] -> Message errMultipleDeclarations _ [] = internalError "SyntaxCheck.errMultipleDeclarations: empty list" errMultipleDeclarations m (i:is) = posMessage i $ text "Multiple declarations of" <+> text (escQualName (qualifyWith m i)) $+$ text "Declared at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is))) errDuplicateTypeSig :: [Ident] -> Message errDuplicateTypeSig [] = internalError "SyntaxCheck.errDuplicateTypeSig: empty list" errDuplicateTypeSig (v:vs) = posMessage v $ text "More than one type signature for" <+> text (escName v) <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (v:vs))) errDuplicateLabel :: String -> QualIdent -> Message errDuplicateLabel what l = posMessage l $ hsep $ map text ["Field label", escQualName l, "occurs more than once in record", what] errNonVariable :: String -> Ident -> Message errNonVariable what c = posMessage c $ hsep $ map text ["Data constructor", escName c, "in left hand side of", what] errNoBody :: Ident -> Message errNoBody v = posMessage v $ hsep $ map text ["No body for", escName v] errNoCommonCons :: Position -> [QualIdent] -> Message errNoCommonCons p ls = posMessage p $ text "No constructor has all of these fields:" $+$ nest 2 (vcat (map (text . escQualName) ls)) errNoLabel :: QualIdent -> QualIdent -> Message errNoLabel c l = posMessage l $ hsep $ map text [escQualName l, "is not a field label of constructor", escQualName c] errNoTypeSig :: Ident -> Message errNoTypeSig f = posMessage f $ hsep $ map text ["No type signature for external function", escName f] errToplevelPattern :: Position -> Message errToplevelPattern p = posMessage p $ text "Pattern declaration not allowed at top-level" errDifferentArity :: [Ident] -> Message errDifferentArity [] = internalError "SyntaxCheck.errDifferentArity: empty list" errDifferentArity (i:is) = posMessage i $ text "Equations for" <+> text (escName i) <+> text "have different arities" <+> text "at:" $+$ nest 2 (vcat (map (ppPosition . getPosition) (i:is))) errWrongArity :: QualIdent -> Int -> Int -> Message errWrongArity c arity' argc = posMessage c $ hsep (map text ["Data constructor", escQualName c, "expects", arguments arity']) <> comma <+> text "but is applied to" <+> text (show argc) where arguments 0 = "no arguments" arguments 1 = "1 argument" arguments n = show n ++ " arguments" errUnknownExtension :: Position -> String -> Message errUnknownExtension p e = posMessage p $ text "Unknown language extension:" <+> text e errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message errMissingLanguageExtension p what ext = posMessage p $ text what <+> text "are not supported in standard Curry." $+$ nest 2 (text "Use flag -e or -X" <> text (show ext) <+> text "to enable this extension.") errInfixWithoutParens :: Position -> [(QualIdent, QualIdent)] -> Message errInfixWithoutParens p calls = posMessage p $ text "Missing parens in infix patterns:" $+$ vcat (map showCall calls) where showCall (q1, q2) = showWithPos q1 <+> text "calls" <+> showWithPos q2 showWithPos q = text (qualName q) <+> parens (text $ showLine $ qidPosition q) curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/TypeCheck.hs000066400000000000000000001357401302651311700266720ustar00rootroot00000000000000{- | Module : $Header$ Description : Type checking Curry programs Copyright : (c) 1999 - 2004 Wolfgang Lux Martin Engelke 2011 - 2015 Björn Peemöller 2014 - 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module implements the type checker of the Curry compiler. The type checker is invoked after the syntactic correctness of the program has been verified. Local variables have been renamed already. Thus the compiler can maintain a flat type environment (which is necessary in order to pass the type information to later phases of the compiler). The type checker now checks the correct typing of all expressions and also verifies that the type signatures given by the user match the inferred types. The type checker uses the algorithm by Damas and Milner (1982) for inferring the types of unannotated declarations, but allows for polymorphic recursion when a type annotation is present. -} {-# LANGUAGE CPP #-} module Checks.TypeCheck (typeCheck) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif import Control.Monad (replicateM, unless) import qualified Control.Monad.State as S (State, execState, gets, modify) import Data.List (nub, nubBy, partition) import qualified Data.Map as Map (Map, delete, empty, insert, lookup) import Data.Maybe (fromMaybe) import qualified Data.Set as Set (Set, fromList, member, notMember, unions) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Syntax import Curry.Syntax.Pretty import Base.CurryTypes (toType, toTypes, ppType, ppTypeScheme) import Base.Expr import Base.Messages (Message, posMessage, internalError) import Base.SCC import Base.TopEnv import Base.Types import Base.TypeSubst hiding (expandType) import Base.Utils (foldr2) import Env.TypeConstructor (TCEnv, TypeInfo (..), bindTypeInfo, qualLookupTC) import Env.Value ( ValueEnv, ValueInfo (..), bindFun, rebindFun , bindGlobalInfo, lookupValue, qualLookupValue ) infixl 5 $-$ ($-$) :: Doc -> Doc -> Doc x $-$ y = x $$ space $$ y -- Type checking proceeds as follows. First, the type constructor -- environment is initialized by adding all types defined in the current -- module. Next, the types of all data constructors and field labels -- are entered into the type environment and then a type inference -- for all function and value definitions is performed. -- The type checker returns the resulting type constructor and type -- environments. typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv, ValueEnv, [Message]) typeCheck m tcEnv tyEnv decls = execTCM check initState where check = checkTypeSynonyms m tds &&> checkDecls checkDecls = do bindTypes tds bindConstrs mapM_ checkFieldLabel tds &&> bindLabels tcDecls vds (tds, vds) = partition isTypeDecl decls initState = TcState m tcEnv tyEnv idSubst emptySigEnv 0 [] -- The type checker makes use of a state monad in order to maintain the type -- environment, the current substitution, and a counter which is used for -- generating fresh type variables. data TcState = TcState { moduleIdent :: ModuleIdent -- read only , tyConsEnv :: TCEnv , valueEnv :: ValueEnv , typeSubst :: TypeSubst , sigEnv :: SigEnv , nextId :: Int -- automatic counter , errors :: [Message] } type TCM = S.State TcState getModuleIdent :: TCM ModuleIdent getModuleIdent = S.gets moduleIdent getTyConsEnv :: TCM TCEnv getTyConsEnv = S.gets tyConsEnv setTyConsEnv :: TCEnv -> TCM () setTyConsEnv tcEnv = S.modify $ \ s -> s { tyConsEnv = tcEnv } getValueEnv :: TCM ValueEnv getValueEnv = S.gets valueEnv modifyValueEnv :: (ValueEnv -> ValueEnv) -> TCM () modifyValueEnv f = S.modify $ \ s -> s { valueEnv = f $ valueEnv s } getTypeSubst :: TCM TypeSubst getTypeSubst = S.gets typeSubst modifyTypeSubst :: (TypeSubst -> TypeSubst) -> TCM () modifyTypeSubst f = S.modify $ \ s -> s { typeSubst = f $ typeSubst s } getSigEnv :: TCM SigEnv getSigEnv = S.gets sigEnv modifySigEnv :: (SigEnv -> SigEnv) -> TCM () modifySigEnv f = S.modify $ \ s -> s { sigEnv = f $ sigEnv s } getNextId :: TCM Int getNextId = do nid <- S.gets nextId S.modify $ \ s -> s { nextId = succ nid } return nid report :: Message -> TCM () report err = S.modify $ \ s -> s { errors = err : errors s } (&&>) :: TCM () -> TCM () -> TCM () pre &&> suf = do errs <- pre >> S.gets errors if null errs then suf else return () execTCM :: TCM a -> TcState -> (TCEnv, ValueEnv, [Message]) execTCM tcm s = let s' = S.execState tcm s in ( tyConsEnv s' , typeSubst s' `subst` valueEnv s' , reverse $ errors s' ) -- Defining Types: -- Before type checking starts, the types defined in the local module -- have to be entered into the type constructor environment. All type -- synonyms occurring in the definitions are fully expanded (except for -- record types) and all type constructors are qualified with the name -- of the module in which they are defined. This is possible because -- Curry does not allow (mutually) recursive type synonyms. -- In order to simplify the expansion of type synonyms, the compiler -- first performs a dependency analysis on the type definitions. -- This also makes it easy to identify (mutually) recursive synonyms. -- Note that 'bindTC' is passed the final type constructor environment in -- order to handle the expansion of type synonyms. This does not lead to a -- termination problem because 'checkTypeDecls' already has checked that there -- are no recursive type synonyms. -- We have to be careful with existentially quantified type variables for -- data constructors. An existentially quantified type variable may -- shadow a universally quantified variable from the left hand side of -- the type declaration. In order to avoid wrong indices being assigned -- to these variables, we replace all shadowed variables in the left hand -- side by anonId before passing them to 'expandMonoType' and -- 'expandMonoTypes', respectively. checkTypeSynonyms :: ModuleIdent -> [Decl] -> TCM () checkTypeSynonyms m = mapM_ (checkTypeDecls m) . scc bound free where bound (DataDecl _ tc _ _) = [tc] bound (NewtypeDecl _ tc _ _) = [tc] bound (TypeDecl _ tc _ _) = [tc] bound _ = [] free (DataDecl _ _ _ _) = [] free (NewtypeDecl _ _ _ _) = [] free (TypeDecl _ _ _ ty) = ft m ty [] free _ = [] checkTypeDecls :: ModuleIdent -> [Decl] -> TCM () checkTypeDecls _ [] = internalError "TypeCheck.checkTypeDecls: empty list" checkTypeDecls _ [DataDecl _ _ _ _] = return () checkTypeDecls _ [NewtypeDecl _ _ _ _] = return () checkTypeDecls m [TypeDecl _ tc _ ty] | tc `elem` ft m ty [] = report $ errRecursiveTypes [tc] | otherwise = return () checkTypeDecls _ (TypeDecl _ tc _ _ : ds) = report $ errRecursiveTypes $ tc : [tc' | TypeDecl _ tc' _ _ <- ds] checkTypeDecls _ _ = internalError "TypeCheck.checkTypeDecls: no type synonym" ft :: ModuleIdent -> TypeExpr -> [Ident] -> [Ident] ft m (ConstructorType tc tys) tcs = maybe id (:) (localIdent m tc) (foldr (ft m) tcs tys) ft _ (VariableType _) tcs = tcs ft m (TupleType tys) tcs = foldr (ft m) tcs tys ft m (ListType ty) tcs = ft m ty tcs ft m (ArrowType ty1 ty2) tcs = ft m ty1 $ ft m ty2 $ tcs ft m (ParenType ty) tcs = ft m ty tcs -- When a field label occurs in more than one constructor declaration of -- a data type, the compiler ensures that the label is defined -- consistently, i.e. both occurrences have the same type. In addition, -- the compiler ensures that no existentially quantified type variable occurs -- in the type of a field label because such type variables necessarily escape -- their scope with the type of the record selection function associated with -- the field label. checkFieldLabel :: Decl -> TCM () checkFieldLabel (DataDecl _ _ tvs cs) = do ls' <- mapM (tcFieldLabel tvs) labels mapM_ tcFieldLabels (groupLabels ls') where labels = [(l, p, ty) | RecordDecl _ _ _ fs <- cs, FieldDecl p ls ty <- fs, l <- ls] checkFieldLabel (NewtypeDecl _ _ tvs (NewRecordDecl p _ _ (l,ty))) = do _ <- tcFieldLabel tvs (l, p, ty) return () checkFieldLabel _ = return () tcFieldLabel :: [Ident] -> (Ident, Position, TypeExpr) -> TCM (Ident, Position, Type) tcFieldLabel tvs (l, p, ty) = do m <- getModuleIdent tcEnv <- getTyConsEnv let ForAll n ty' = polyType $ expandMonoType' m tcEnv tvs ty what = text "record selection" if n <= length tvs then return (l, p, ty') else do report $ errSkolemEscapingScope p m what ty' return (l, p, ty') groupLabels :: Eq a => [(a,b,c)] -> [(a,b,[c])] groupLabels [] = [] groupLabels ((x,y,z):xyzs) = (x,y,z:map thrd3 xyzs') : groupLabels xyzs'' where (xyzs',xyzs'') = partition ((x ==) . fst3) xyzs fst3 (a,_,_) = a thrd3 (_,_,c) = c tcFieldLabels :: (Ident, Position, [Type]) -> TCM () tcFieldLabels (_,_,[]) = return () tcFieldLabels (l,p,ty:tys) = do m <- getModuleIdent unless (null (filter (ty /=) tys)) $ report $ errIncompatibleLabelTypes p m l ty (head tys) -- The type constructor environment 'tcEnv' maintains all types -- in fully expanded form. bindTypes :: [Decl] -> TCM () bindTypes ds = do m <- getModuleIdent tcEnv <- getTyConsEnv let tcEnv' = foldr (bindTC m tcEnv') tcEnv ds setTyConsEnv tcEnv' bindTC :: ModuleIdent -> TCEnv -> Decl -> TCEnv -> TCEnv bindTC m tcEnv (DataDecl _ tc tvs cs) = bindTypeInfo DataType m tc tvs (map mkData cs) where mkData (ConstrDecl _ evs c tys) = mkData' evs c tys mkData (ConOpDecl _ evs ty1 op ty2) = mkData' evs op [ty1, ty2] mkData (RecordDecl _ evs c fs) = let (labels, tys) = unzip [(l ,ty) | FieldDecl _ ls ty <- fs, l <- ls] in mkRec evs c labels tys mkData' evs c tys = DataConstr c (length evs) $ expandMonoTypes m tcEnv (cleanTVars tvs evs) tys mkRec evs c ls tys = RecordConstr c (length evs) ls $ expandMonoTypes m tcEnv (cleanTVars tvs evs) tys bindTC m tcEnv (NewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) = bindTypeInfo RenamingType m tc tvs (DataConstr c (length evs) [ty']) where ty' = expandMonoType' m tcEnv (cleanTVars tvs evs) ty bindTC m tcEnv (NewtypeDecl _ tc tvs (NewRecordDecl _ evs c (l, ty))) = bindTypeInfo RenamingType m tc tvs (RecordConstr c (length evs) [l] [ty']) where ty' = expandMonoType' m tcEnv (cleanTVars tvs evs) ty bindTC m tcEnv (TypeDecl _ tc tvs ty) = bindTypeInfo AliasType m tc tvs (expandMonoType' m tcEnv tvs ty) bindTC _ _ _ = id cleanTVars :: [Ident] -> [Ident] -> [Ident] cleanTVars tvs evs = [if tv `elem` evs then anonId else tv | tv <- tvs] -- Defining Data Constructors: -- In the next step, the types of all data constructors are entered into -- the type environment using the information just entered into the type -- constructor environment. Thus, we can be sure that all type variables -- have been properly renamed and all type synonyms are already expanded. bindConstrs :: TCM () bindConstrs = do m <- getModuleIdent tcEnv <- getTyConsEnv modifyValueEnv $ bindConstrs' m tcEnv bindConstrs' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv bindConstrs' m tcEnv tyEnv = foldr (bindData . snd) tyEnv $ localBindings tcEnv where bindData (DataType tc n cs) tyEnv' = foldr (bindConstr m n (constrType' tc n)) tyEnv' cs bindData (RenamingType tc n c) tyEnv' = bindNewConstr m n (constrType' tc n) c tyEnv' bindData (AliasType _ _ _) tyEnv' = tyEnv' bindConstr m' n ty (DataConstr c n' tys) = bindGlobalInfo (\qc tyScheme -> DataConstructor qc arity ls tyScheme) m' c (ForAllExist n n' (foldr TypeArrow ty tys)) where arity = length tys ls = replicate arity anonId bindConstr m' n ty (RecordConstr c n' ls tys) = bindGlobalInfo (\qc tyScheme -> DataConstructor qc arity ls tyScheme) m' c (ForAllExist n n' (foldr TypeArrow ty tys)) where arity = length tys bindNewConstr m' n cty (DataConstr c n' [lty]) = bindGlobalInfo (\qc tyScheme -> NewtypeConstructor qc anonId tyScheme) m' c (ForAllExist n n' (TypeArrow lty cty)) bindNewConstr m' n cty (RecordConstr c n' [l] [lty]) = bindGlobalInfo (\qc tyScheme -> NewtypeConstructor qc l tyScheme) m' c (ForAllExist n n' (TypeArrow lty cty)) bindNewConstr _ _ _ _ = internalError "TypeCheck.bindConstrs: newtype with illegal constructors" constrType' tc n = TypeConstructor tc $ map TypeVariable [0 .. n - 1] -- Defining Field Labels: -- Next the types of all field labels are added to the type environment. -- Since we use the type constructor environment again, -- we can be sure that all type variables have been properly renamed -- and all type synonyms are already expanded. bindLabels :: TCM () bindLabels = do m <- getModuleIdent tcEnv <- getTyConsEnv modifyValueEnv $ bindLabels' m tcEnv bindLabels' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv bindLabels' m tcEnv tyEnv = foldr (bindData . snd) tyEnv $ localBindings tcEnv where bindData (DataType tc n cs) tyEnv' = foldr (bindLabel m n (constrType' tc n)) tyEnv' $ nubBy sameLabel clabels where labels = zip (concatMap recLabels cs) (concatMap recLabelTypes cs) clabels = [(l, constr l, ty) | (l, ty) <- labels] constr l = map (qualifyLike tc) $ [constrIdent c | c <- cs, l `elem` recLabels c] sameLabel (l1,_,_) (l2,_,_) = l1 == l2 bindData (RenamingType tc n (RecordConstr c _ [l] [lty])) tyEnv' = bindLabel m n (constrType' tc n) (l, [qc], lty) tyEnv' where qc = qualifyLike tc c bindData (RenamingType _ _ (RecordConstr _ _ _ _)) _ = internalError $ "Checks.TypeCheck.bindLabels: RenamingType with more than one record label" bindData (RenamingType _ _ (DataConstr _ _ _)) tyEnv' = tyEnv' bindData (AliasType _ _ _) tyEnv' = tyEnv' bindLabel m' n ty (l, lcs, lty) = bindGlobalInfo (\qc tyScheme -> Label qc lcs tyScheme) m' l (ForAll n (TypeArrow ty lty)) constrType' tc n = TypeConstructor tc $ map TypeVariable [0 .. n - 1] -- Type Signatures: -- The type checker collects type signatures in a flat environment. All -- anonymous variables occurring in a signature are replaced by fresh -- names. However, the type is not expanded so that the signature is -- available for use in the error message that is printed when the -- inferred type is less general than the signature. type SigEnv = Map.Map Ident TypeExpr emptySigEnv :: SigEnv emptySigEnv = Map.empty unbindTypeSig :: Ident -> SigEnv -> SigEnv unbindTypeSig = Map.delete bindTypeSig :: Ident -> TypeExpr -> SigEnv -> SigEnv bindTypeSig = Map.insert bindTypeSigs :: Decl -> SigEnv -> SigEnv bindTypeSigs (TypeSig _ vs ty) env = foldr (flip bindTypeSig (nameSigType ty)) env vs bindTypeSigs _ env = env lookupTypeSig :: Ident -> SigEnv -> Maybe TypeExpr lookupTypeSig = Map.lookup qualLookupTypeSig :: ModuleIdent -> QualIdent -> SigEnv -> Maybe TypeExpr qualLookupTypeSig m f sigs = localIdent m f >>= flip lookupTypeSig sigs nameSigType :: TypeExpr -> TypeExpr nameSigType ty = fst $ nameType ty $ filter (`notElem` fv ty) identSupply nameTypes :: [TypeExpr] -> [Ident] -> ([TypeExpr], [Ident]) nameTypes [] tvs = ([] , tvs ) nameTypes (ty : tys) tvs = (ty' : tys', tvs'') where (ty' , tvs' ) = nameType ty tvs (tys', tvs'') = nameTypes tys tvs' nameType :: TypeExpr -> [Ident] -> (TypeExpr, [Ident]) nameType (ConstructorType tc tys) tvs = (ConstructorType tc tys', tvs') where (tys', tvs') = nameTypes tys tvs nameType (VariableType tv) (tv' : tvs) | isAnonId tv = (VariableType tv', tvs ) | otherwise = (VariableType tv , tv' : tvs) nameType (TupleType tys) tvs = (TupleType tys', tvs') where (tys', tvs') = nameTypes tys tvs nameType (ListType ty) tvs = (ListType ty', tvs') where (ty', tvs') = nameType ty tvs nameType (ArrowType ty1 ty2) tvs = (ArrowType ty1' ty2', tvs'') where (ty1', tvs' ) = nameType ty1 tvs (ty2', tvs'') = nameType ty2 tvs' nameType (VariableType _) [] = internalError "TypeCheck.nameType: empty ident list" nameType (ParenType ty) tvs = (ParenType ty', tvs') where (ty', tvs') = nameType ty tvs -- Type Inference: -- Before type checking a group of declarations, a dependency analysis is -- performed and the declaration group is eventually transformed into -- nested declaration groups which are checked separately. Within each -- declaration group, first the left hand sides of all declarations are -- typed. Next, the right hand sides of the declarations are typed in the -- extended type environment. Finally, the types for the left and right -- hand sides are unified and the types of all defined functions are -- generalized. The generalization step will also check that the type -- signatures given by the user match the inferred types. -- Argument and result types of foreign functions using the ccall calling -- convention are restricted to the basic types Bool, Char, Int, and Float. -- In addition, IO t is a legitimate result type when t is either one of the -- basic types or (). -- TODO: Extend the set of legitimate types to match the types admitted -- by the Haskell Foreign Function Interface Addendum. tcDecls :: [Decl] -> TCM () tcDecls ds = do m <- getModuleIdent oldSig <- getSigEnv modifySigEnv $ \ sigs -> foldr bindTypeSigs sigs ods mapM_ tcDeclGroup $ scc bv (qfv m) vds modifySigEnv (const oldSig) where (vds, ods) = partition isValueDecl ds tcDeclGroup :: [Decl] -> TCM () tcDeclGroup [ForeignDecl _ _ _ f ty] = tcForeign f ty tcDeclGroup [ExternalDecl _ fs] = mapM_ tcExternal fs tcDeclGroup [FreeDecl _ vs] = mapM_ tcFree vs tcDeclGroup ds = do tyEnv0 <- getValueEnv tysLhs <- mapM tcDeclLhs ds tysRhs <- mapM (tcDeclRhs tyEnv0) ds sequence_ (zipWith3 unifyDecl ds tysLhs tysRhs) theta <- getTypeSubst mapM_ (genDecl (fvEnv (subst theta tyEnv0)) theta) ds --tcDeclGroup m tcEnv _ [ForeignDecl p cc _ f ty] = -- tcForeign m tcEnv p cc f ty --tcForeign :: ModuleIdent -> TCEnv -> Position -> CallConv -> Ident -- -> TypeExpr -> TCM () --tcForeign m tcEnv p cc f ty = -- S.modify (bindFun m f (checkForeignType cc (expandPolyType tcEnv ty))) -- where checkForeignType CallConvPrimitive ty = ty -- checkForeignType CallConvCCall (ForAll n ty) = -- ForAll n (checkCCallType ty) -- checkCCallType (TypeArrow ty1 ty2) -- | isCArgType ty1 = TypeArrow ty1 (checkCCallType ty2) -- | otherwise = errorAt p (invalidCType "argument" m ty1) -- checkCCallType ty -- | isCResultType ty = ty -- | otherwise = errorAt p (invalidCType "result" m ty) -- isCArgType (TypeConstructor tc []) = tc `elem` basicTypeId -- isCArgType _ = False -- isCResultType (TypeConstructor tc []) = tc `elem` basicTypeId -- isCResultType (TypeConstructor tc [ty]) = -- tc == qIOId && (ty == unitType || isCArgType ty) -- isCResultType _ = False -- basicTypeId = [qBoolId,qCharId,qIntId,qFloatId] tcForeign :: Ident -> TypeExpr -> TCM () tcForeign f ty = do m <- getModuleIdent tySc@(ForAll _ ty') <- expandPolyType ty modifyValueEnv $ bindFun m f (arrowArity ty') tySc tcExternal :: Ident -> TCM () tcExternal f = do sigs <- getSigEnv case lookupTypeSig f sigs of Nothing -> internalError "TypeCheck.tcExternal" Just ty -> tcForeign f ty tcFree :: Ident -> TCM () tcFree v = do sigs <- getSigEnv ty <- case lookupTypeSig v sigs of Nothing -> freshTypeVar Just t -> do ForAll n ty' <- expandPolyType t if (n == 0) then return ty' else do -- because of error aggregation, we have to fix -- the corrupt information report $ errPolymorphicFreeVar v modifySigEnv $ unbindTypeSig v freshTypeVar m <- getModuleIdent modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty tcDeclLhs :: Decl -> TCM Type tcDeclLhs (FunctionDecl _ f _) = tcFunDecl f tcDeclLhs (PatternDecl p t _) = tcPattern p t tcDeclLhs _ = internalError "TypeCheck.tcDeclLhs: no pattern match" tcFunDecl :: Ident -> TCM Type tcFunDecl v = do sigs <- getSigEnv m <- getModuleIdent ty <- case lookupTypeSig v sigs of Nothing -> freshTypeVar Just t -> expandPolyType t >>= inst modifyValueEnv $ bindFun m v (arrowArity ty) (monoType ty) return ty tcDeclRhs :: ValueEnv -> Decl -> TCM Type tcDeclRhs tyEnv0 (FunctionDecl _ f (eq:eqs)) = do tcEquation tyEnv0 eq >>= flip tcEqns eqs where tcEqns ty [] = return ty tcEqns ty (eq1@(Equation p _ _):eqs1) = do tcEquation tyEnv0 eq1 >>= unify p "equation" (ppDecl (FunctionDecl p f [eq1])) ty >> tcEqns ty eqs1 tcDeclRhs tyEnv0 (PatternDecl _ _ rhs) = tcRhs tyEnv0 rhs tcDeclRhs _ _ = internalError "TypeCheck.tcDeclRhs: no pattern match" unifyDecl :: Decl -> Type -> Type -> TCM () unifyDecl (FunctionDecl p f _) = unify p "function binding" (text "Function:" <+> ppIdent f) unifyDecl (PatternDecl p t _) = unify p "pattern binding" (ppPattern 0 t) unifyDecl _ = internalError "TypeCheck.unifyDecl: no pattern match" -- In Curry we cannot generalize the types of let-bound variables because -- they can refer to logic variables. Without this monomorphism -- restriction unsound code like -- -- bug = x =:= 1 & x =:= 'a' -- where x :: a -- x = fresh -- fresh :: a -- fresh = x where x free -- -- could be written. Note that fresh has the polymorphic type -- forall alpha . alpha. This is correct because fresh is a -- function and therefore returns a different variable at each -- invocation. -- The code in 'genVar' below also verifies that the inferred type -- for a variable or function matches the type declared in a type -- signature. As the declared type is already used for assigning an initial -- type to a variable when it is used, the inferred type can only be more -- specific. Therefore, if the inferred type does not match the type -- signature the declared type must be too general. genDecl :: Set.Set Int -> TypeSubst -> Decl -> TCM () genDecl lvs theta (FunctionDecl _ f (Equation _ lhs _ : _)) = genVar True lvs theta arity f where arity = Just $ length $ snd $ flatLhs lhs genDecl lvs theta (PatternDecl _ t _) = mapM_ (genVar False lvs theta Nothing) (bv t) genDecl _ _ _ = internalError "TypeCheck.genDecl: no pattern match" genVar :: Bool -> Set.Set Int -> TypeSubst -> Maybe Int -> Ident -> TCM () genVar poly lvs theta ma v = do sigs <- getSigEnv m <- getModuleIdent tyEnv <- getValueEnv let sigma = genType poly $ subst theta $ varType v tyEnv arity = fromMaybe (varArity v tyEnv) ma case lookupTypeSig v sigs of Nothing -> modifyValueEnv $ rebindFun m v arity sigma Just sigTy -> do sigma' <- expandPolyType sigTy unless (eqTyScheme sigma sigma') $ report $ errTypeSigTooGeneral (idPosition v) m what sigTy sigma modifyValueEnv $ rebindFun m v arity sigma where what = text (if poly then "Function:" else "Variable:") <+> ppIdent v genType poly' (ForAll n ty) | n > 0 = internalError $ "TypeCheck.genVar: " ++ showLine (idPosition v) ++ show v ++ " :: " ++ show ty | poly' = gen lvs ty | otherwise = monoType ty eqTyScheme (ForAll _ t1) (ForAll _ t2) = equTypes t1 t2 tcEquation :: ValueEnv -> Equation -> TCM Type tcEquation tyEnv0 (Equation p lhs rhs) = do tys <- mapM (tcPattern p) ts ty <- tcRhs tyEnv0 rhs checkSkolems p (text "Function: " <+> ppIdent f) tyEnv0 (foldr TypeArrow ty tys) where (f, ts) = flatLhs lhs tcLiteral :: Literal -> TCM Type tcLiteral (Char _ _) = return charType tcLiteral (Int v _) = do --return intType m <- getModuleIdent ty <- freshConstrained [intType, floatType] modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty return ty tcLiteral (Float _ _) = return floatType tcLiteral (String _ _) = return stringType tcPattern :: Position -> Pattern -> TCM Type tcPattern _ (LiteralPattern l) = tcLiteral l tcPattern _ (NegativePattern _ l) = tcLiteral l tcPattern _ (VariablePattern v) = do sigs <- getSigEnv ty <- case lookupTypeSig v sigs of Nothing -> freshTypeVar Just t -> expandPolyType t >>= inst tyEnv <- getValueEnv m <- getModuleIdent maybe (modifyValueEnv (bindFun m v (arrowArity ty) (monoType ty)) >> return ty) (\ (ForAll _ t) -> return t) (sureVarType v tyEnv) tcPattern p t@(ConstructorPattern c ts) = do m <- getModuleIdent tyEnv <- getValueEnv ty <- skol $ constrType m c tyEnv unifyArgs (ppPattern 0 t) ts ty where unifyArgs _ [] ty = return ty unifyArgs doc (t1:ts1) (TypeArrow ty1 ty2) = do ty' <- tcPattern p t1 unify p "pattern" (doc $-$ text "Term:" <+> ppPattern 0 t1) ty1 ty' unifyArgs doc ts1 ty2 unifyArgs _ _ _ = internalError "TypeCheck.tcPattern" tcPattern p (InfixPattern t1 op t2) = tcPattern p $ ConstructorPattern op [t1, t2] tcPattern p (ParenPattern t) = tcPattern p t tcPattern _ r@(RecordPattern c fs) = do m <- getModuleIdent tyEnv <- getValueEnv ty <- arrowBase <$> skol (constrType m c tyEnv) mapM_ (tcField tcPattern "pattern" doc ty) fs return ty where doc t1 = ppPattern 0 r $-$ text "Term:" <+> ppPattern 0 t1 tcPattern p (TuplePattern _ ts) | null ts = return unitType | otherwise = tupleType <$> mapM (tcPattern p) ts tcPattern p t@(ListPattern _ ts) = freshTypeVar >>= flip (tcElems (ppPattern 0 t)) ts where tcElems _ ty [] = return (listType ty) tcElems doc ty (t1:ts1) = do ty' <- tcPattern p t1 unify p "pattern" (doc $-$ text "Term:" <+> ppPattern 0 t1) ty ty' tcElems doc ty ts1 tcPattern p t@(AsPattern v t') = do ty1 <- tcPattern p (VariablePattern v) ty2 <- tcPattern p t' unify p "pattern" (ppPattern 0 t) ty1 ty2 return ty1 tcPattern p (LazyPattern _ t) = tcPattern p t tcPattern p t@(FunctionPattern f ts) = do m <- getModuleIdent tyEnv <- getValueEnv ty <- inst (funType m f tyEnv) unifyArgs (ppPattern 0 t) ts ty where unifyArgs _ [] ty = return ty unifyArgs doc (t1:ts1) ty@(TypeVariable _) = do (a, b) <- tcArrow p "function pattern" doc ty ty' <- tcPattern p t1 unify p "function pattern" (doc $-$ text "Term:" <+> ppPattern 0 t1) ty' a unifyArgs doc ts1 b unifyArgs doc (t1:ts1) (TypeArrow ty1 ty2) = do ty' <- tcPattern p t1 unify p "function pattern" (doc $-$ text "Term:" <+> ppPattern 0 t1) ty1 ty' unifyArgs doc ts1 ty2 unifyArgs _ _ ty = internalError $ "TypeCheck.tcPattern: " ++ show ty tcPattern p (InfixFuncPattern t1 op t2) = tcPattern p $ FunctionPattern op [t1, t2] tcRhs ::ValueEnv -> Rhs -> TCM Type tcRhs tyEnv0 (SimpleRhs p e ds) = do tcDecls ds ty <- tcExpr p e checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty tcRhs tyEnv0 (GuardedRhs es ds) = do tcDecls ds tcCondExprs tyEnv0 es tcCondExprs :: ValueEnv -> [CondExpr] -> TCM Type tcCondExprs tyEnv0 es = do let gty = boolType -- the type of conditions ty <- freshTypeVar mapM_ (tcCondExpr gty ty) es return ty where tcCondExpr gty ty (CondExpr p g e) = do tcExpr p g >>= unify p "guard" (ppExpr 0 g) gty tcExpr p e >>= checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 >>= unify p "guarded expression" (ppExpr 0 e) ty tcExpr :: Position -> Expression -> TCM Type tcExpr _ (Literal l) = tcLiteral l tcExpr _ (Variable v) | isAnonId v' = do -- anonymous free variable m <- getModuleIdent ty <- freshTypeVar modifyValueEnv $ bindFun m v' (arrowArity ty) $ monoType ty return ty | otherwise = do sigs <- getSigEnv m <- getModuleIdent case qualLookupTypeSig m v sigs of Just ty -> expandPolyType ty >>= inst Nothing -> getValueEnv >>= inst . funType m v where v' = unqualify v tcExpr _ (Constructor c) = do m <- getModuleIdent getValueEnv >>= instExist . constrType m c tcExpr p (Typed e sig) = do m <- getModuleIdent tyEnv0 <- getValueEnv ty <- tcExpr p e sigma' <- expandPolyType sig' inst sigma' >>= flip (unify p "explicitly typed expression" (ppExpr 0 e)) ty theta <- getTypeSubst let sigma = gen (fvEnv (subst theta tyEnv0)) (subst theta ty) unless (sigma == sigma') $ report $ errTypeSigTooGeneral p m (text "Expression:" <+> ppExpr 0 e) sig' sigma return ty where sig' = nameSigType sig tcExpr p (Paren e) = tcExpr p e tcExpr _ r@(Record c fs) = do m <- getModuleIdent tyEnv <- getValueEnv ty <- arrowBase <$> instExist (constrType m c tyEnv) mapM_ (tcField tcExpr "construction" doc ty) fs return ty where doc e1 = ppExpr 0 r $-$ text "Term:" <+> ppExpr 0 e1 tcExpr p r@(RecordUpdate e fs) = do ty <- tcExpr p e mapM_ (tcField tcExpr "update" doc ty) fs return ty where doc e1 = ppExpr 0 r $-$ text "Term:" <+> ppExpr 0 e1 tcExpr p (Tuple _ es) | null es = return unitType | otherwise = tupleType <$> mapM (tcExpr p) es tcExpr p e@(List _ es) = freshTypeVar >>= tcElems (ppExpr 0 e) es where tcElems _ [] ty = return (listType ty) tcElems doc (e1:es1) ty = tcExpr p e1 >>= unify p "expression" (doc $-$ text "Term:" <+> ppExpr 0 e1) ty >> tcElems doc es1 ty tcExpr p (ListCompr _ e qs) = do tyEnv0 <- getValueEnv mapM_ (tcQual p) qs ty <- tcExpr p e checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 (listType ty) tcExpr p e@(EnumFrom e1) = do tcEnum p e e1 return (listType intType) tcExpr p e@(EnumFromThen e1 e2) = do mapM_ (tcEnum p e) [e1, e2] return (listType intType) tcExpr p e@(EnumFromTo e1 e2) = do mapM_ (tcEnum p e) [e1, e2] return (listType intType) tcExpr p e@(EnumFromThenTo e1 e2 e3) = do mapM_ (tcEnum p e) [e1, e2, e3] return (listType intType) tcExpr p e@(UnaryMinus op e1) = do opTy <- opType op ty1 <- tcExpr p e1 unify p "unary negation" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) opTy ty1 return ty1 where opType op' | op' == minusId = freshConstrained [intType,floatType] | op' == fminusId = return floatType | otherwise = internalError $ "TypeCheck.tcExpr unary " ++ idName op' tcExpr p e@(Apply e1 e2) = do ty1 <- tcExpr p e1 ty2 <- tcExpr p e2 (alpha,beta) <- tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) ty1 unify p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) alpha ty2 return beta tcExpr p e@(InfixApply e1 op e2) = do opTy <- tcExpr p (infixOp op) ty1 <- tcExpr p e1 ty2 <- tcExpr p e2 (alpha,beta,gamma) <- tcBinary p "infix application" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) opTy unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) alpha ty1 unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) beta ty2 return gamma tcExpr p e@(LeftSection e1 op) = do opTy <- tcExpr p (infixOp op) ty1 <- tcExpr p e1 (alpha,beta) <- tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) opTy unify p "left section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) alpha ty1 return beta tcExpr p e@(RightSection op e1) = do opTy <- tcExpr p (infixOp op) ty1 <- tcExpr p e1 (alpha,beta,gamma) <- tcBinary p "right section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) opTy unify p "right section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) beta ty1 return (TypeArrow alpha gamma) tcExpr p expr@(Lambda _ ts e) = do tyEnv0 <- getValueEnv tys <- mapM (tcPattern p) ts ty <- tcExpr p e checkSkolems p (text "Expression:" <+> ppExpr 0 expr) tyEnv0 (foldr TypeArrow ty tys) tcExpr p (Let ds e) = do tyEnv0 <- getValueEnv tcDecls ds ty <- tcExpr p e checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty tcExpr p (Do sts e) = do tyEnv0 <- getValueEnv mapM_ (tcStmt p) sts alpha <- freshTypeVar ty <- tcExpr p e unify p "statement" (ppExpr 0 e) (ioType alpha) ty checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty tcExpr p e@(IfThenElse _ e1 e2 e3) = do ty1 <- tcExpr p e1 unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) boolType ty1 ty2 <- tcExpr p e2 ty3 <- tcExpr p e3 unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3) ty2 ty3 return ty3 tcExpr p (Case _ _ e alts) = do tyEnv0 <- getValueEnv ty <- tcExpr p e alpha <- freshTypeVar tcAlts tyEnv0 ty alpha alts where tcAlts _ _ ty [] = return ty tcAlts tyEnv0 ty1 ty2 (alt1:alts1) = do tcAlt (ppAlt alt1) tyEnv0 ty1 ty2 alt1 tcAlts tyEnv0 ty1 ty2 alts1 tcAlt doc tyEnv0 ty1 ty2 (Alt p1 t rhs) = do ty' <- tcPattern p1 t unify p1 "case pattern" (doc $-$ text "Term:" <+> ppPattern 0 t) ty1 ty' tcRhs tyEnv0 rhs >>= unify p1 "case branch" doc ty2 tcEnum :: Position -> Expression -> Expression -> TCM () tcEnum p e e1 = do ty1 <- tcExpr p e1 unify p "arithmetic sequence" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1 tcQual :: Position -> Statement -> TCM () tcQual p (StmtExpr _ e) = tcExpr p e >>= unify p "guard" (ppExpr 0 e) boolType tcQual p q@(StmtBind _ t e) = do ty1 <- tcPattern p t ty2 <- tcExpr p e unify p "generator" (ppStmt q $-$ text "Term:" <+> ppExpr 0 e) (listType ty1) ty2 tcQual _ (StmtDecl ds) = tcDecls ds tcStmt ::Position -> Statement -> TCM () tcStmt p (StmtExpr _ e) = do alpha <- freshTypeVar ty <- tcExpr p e unify p "statement" (ppExpr 0 e) (ioType alpha) ty tcStmt p st@(StmtBind _ t e) = do ty1 <- tcPattern p t ty2 <- tcExpr p e unify p "statement" (ppStmt st $-$ text "Term:" <+> ppExpr 0 e) (ioType ty1) ty2 tcStmt _ (StmtDecl ds) = tcDecls ds tcField :: (Position -> a -> TCM Type) -> String -> (a -> Doc) -> Type -> Field a -> TCM Type tcField tcheck what doc ty (Field p l x) = do m <- getModuleIdent tyEnv <- getValueEnv TypeArrow ty1 ty2 <- inst (labelType m l tyEnv) unify p "field label" empty ty ty1 lty <- tcheck p x unify p ("record " ++ what) (doc x) ty2 lty return lty -- The function 'tcArrow' checks that its argument can be used as -- an arrow type a -> b and returns the pair (a,b). tcArrow :: Position -> String -> Doc -> Type -> TCM (Type, Type) tcArrow p what doc ty = do theta <- getTypeSubst unaryArrow (subst theta ty) where unaryArrow (TypeArrow ty1 ty2) = return (ty1, ty2) unaryArrow (TypeVariable tv) = do alpha <- freshTypeVar beta <- freshTypeVar modifyTypeSubst $ bindVar tv $ TypeArrow alpha beta return (alpha, beta) unaryArrow ty' = do m <- getModuleIdent report $ errNonFunctionType p what doc m ty' (,) <$> freshTypeVar <*> freshTypeVar -- The function 'tcBinary' checks that its argument can be used as an arrow type -- a -> b -> c and returns the triple (a,b,c). tcBinary :: Position -> String -> Doc -> Type -> TCM (Type, Type, Type) tcBinary p what doc ty = tcArrow p what doc ty >>= uncurry binaryArrow where binaryArrow ty1 (TypeArrow ty2 ty3) = return (ty1, ty2, ty3) binaryArrow ty1 (TypeVariable tv) = do beta <- freshTypeVar gamma <- freshTypeVar modifyTypeSubst $ bindVar tv $ TypeArrow beta gamma return (ty1, beta, gamma) binaryArrow ty1 ty2 = do m <- getModuleIdent report $ errNonBinaryOp p what doc m (TypeArrow ty1 ty2) (,,) <$> return ty1 <*> freshTypeVar <*> freshTypeVar -- Unification: The unification uses Robinson's algorithm. unify :: Position -> String -> Doc -> Type -> Type -> TCM () unify p what doc ty1 ty2 = do theta <- getTypeSubst let ty1' = subst theta ty1 let ty2' = subst theta ty2 m <- getModuleIdent case unifyTypes m ty1' ty2' of Left reason -> report $ errTypeMismatch p what doc m ty1' ty2' reason Right sigma -> modifyTypeSubst (compose sigma) unifyTypes :: ModuleIdent -> Type -> Type -> Either Doc TypeSubst unifyTypes _ (TypeVariable tv1) (TypeVariable tv2) | tv1 == tv2 = Right idSubst | otherwise = Right (singleSubst tv1 (TypeVariable tv2)) unifyTypes m (TypeVariable tv) ty | tv `elem` typeVars ty = Left (errRecursiveType m tv ty) | otherwise = Right (singleSubst tv ty) unifyTypes m ty (TypeVariable tv) | tv `elem` typeVars ty = Left (errRecursiveType m tv ty) | otherwise = Right (singleSubst tv ty) unifyTypes _ (TypeConstrained tys1 tv1) (TypeConstrained tys2 tv2) | tv1 == tv2 = Right idSubst | tys1 == tys2 = Right (singleSubst tv1 (TypeConstrained tys2 tv2)) unifyTypes m (TypeConstrained tys tv) ty = foldr (choose . unifyTypes m ty) (Left (errIncompatibleTypes m ty (head tys))) tys where choose (Left _) theta' = theta' choose (Right theta) _ = Right (bindSubst tv ty theta) unifyTypes m ty (TypeConstrained tys tv) = foldr (choose . unifyTypes m ty) (Left (errIncompatibleTypes m ty (head tys))) tys where choose (Left _) theta' = theta' choose (Right theta) _ = Right (bindSubst tv ty theta) unifyTypes m (TypeConstructor tc1 tys1) (TypeConstructor tc2 tys2) | tc1 == tc2 = unifyTypeLists m tys1 tys2 unifyTypes m (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) = unifyTypeLists m [ty11, ty12] [ty21, ty22] unifyTypes _ (TypeSkolem k1) (TypeSkolem k2) | k1 == k2 = Right idSubst unifyTypes m ty1 ty2 = Left (errIncompatibleTypes m ty1 ty2) unifyTypeLists :: ModuleIdent -> [Type] -> [Type] -> Either Doc TypeSubst unifyTypeLists _ [] _ = Right idSubst unifyTypeLists _ _ [] = Right idSubst unifyTypeLists m (ty1 : tys1) (ty2 : tys2) = either Left unifyTypesTheta (unifyTypeLists m tys1 tys2) where unifyTypesTheta theta = either Left (Right . flip compose theta) (unifyTypes m (subst theta ty1) (subst theta ty2)) -- For each declaration group, the type checker has to ensure that no -- skolem type escapes its scope. checkSkolems :: Position -> Doc -> ValueEnv -> Type -> TCM Type checkSkolems p what tyEnv ty = do m <- getModuleIdent theta <- getTypeSubst let ty' = subst theta ty fs = fsEnv $ subst theta tyEnv unless (all (`Set.member` fs) $ typeSkolems ty') $ report $ errSkolemEscapingScope p m what ty' return ty' -- Instantiation and Generalization: -- We use negative offsets for fresh type variables. fresh :: (Int -> a) -> TCM a fresh f = f <$> getNextId freshVar :: (Int -> a) -> TCM a freshVar f = fresh $ \ n -> f (- n - 1) freshTypeVar :: TCM Type freshTypeVar = freshVar TypeVariable freshConstrained :: [Type] -> TCM Type freshConstrained = freshVar . TypeConstrained freshSkolem :: TCM Type freshSkolem = fresh TypeSkolem inst :: TypeScheme -> TCM Type inst (ForAll n ty) = do tys <- replicateM n freshTypeVar return $ expandAliasType tys ty instExist :: ExistTypeScheme -> TCM Type instExist (ForAllExist n n' ty) = do tys <- replicateM (n + n') freshTypeVar return $ expandAliasType tys ty skol :: ExistTypeScheme -> TCM Type skol (ForAllExist n n' ty) = do tys <- replicateM n freshTypeVar tys' <- replicateM n' freshSkolem return $ expandAliasType (tys ++ tys') ty gen :: Set.Set Int -> Type -> TypeScheme gen gvs ty = ForAll (length tvs) (subst (foldr2 bindSubst idSubst tvs tvs') ty) where tvs = [tv | tv <- nub (typeVars ty), tv `Set.notMember` gvs] tvs' = map TypeVariable [0 ..] -- Auxiliary Functions: -- The functions 'constrType', 'varType', and 'funType' are used to retrieve -- the type of constructors, pattern variables, and variables in expressions, -- respectively, from the type environment. Because the syntactical correctness -- has already been verified by the syntax checker, none of these functions -- should fail. -- Note that 'varType' can handle ambiguous identifiers and returns the first -- available type. This function is used for looking up the type of an -- identifier on the left hand side of a rule where it unambiguously refers -- to the local definition. constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme constrType m c tyEnv = case qualLookupValue c tyEnv of [DataConstructor _ _ _ sigma] -> sigma [NewtypeConstructor _ _ sigma] -> sigma _ -> case qualLookupValue (qualQualify m c) tyEnv of [DataConstructor _ _ _ sigma] -> sigma [NewtypeConstructor _ _ sigma] -> sigma _ -> internalError $ "TypeCheck.constrType " ++ show c varArity :: Ident -> ValueEnv -> Int varArity v tyEnv = case lookupValue v tyEnv of Value _ a _ : _ -> a _ -> internalError $ "TypeCheck.varArity " ++ show v varType :: Ident -> ValueEnv -> TypeScheme varType v tyEnv = case lookupValue v tyEnv of Value _ _ sigma : _ -> sigma _ -> internalError $ "TypeCheck.varType " ++ show v sureVarType :: Ident -> ValueEnv -> Maybe TypeScheme sureVarType v tyEnv = case lookupValue v tyEnv of Value _ _ sigma : _ -> Just sigma _ -> Nothing funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme funType m f tyEnv = case qualLookupValue f tyEnv of [Value _ _ sigma] -> sigma [Label _ _ sigma] -> sigma _ -> case qualLookupValue (qualQualify m f) tyEnv of [Value _ _ sigma] -> sigma [Label _ _ sigma] -> sigma _ -> internalError $ "TypeCheck.funType " ++ show f ++ ", more precisely " ++ show (unqualify f) labelType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme labelType m l tyEnv = case qualLookupValue l tyEnv of [Label _ _ sigma] -> sigma _ -> case qualLookupValue ql tyEnv of [Label _ _ sigma] -> sigma _ -> internalError $ "TypeCheck.labelType " ++ show ql ++ ", more precisely " ++ show l where ql = qualQualify m l -- The function 'expandType' expands all type synonyms in a type -- and also qualifies all type constructors with the name of the module -- in which the type was defined. expandPolyType :: TypeExpr -> TCM TypeScheme expandPolyType ty = (polyType . normalize) <$> expandMonoType [] ty expandMonoType :: [Ident] -> TypeExpr -> TCM Type expandMonoType tvs ty = do m <- getModuleIdent tcEnv <- getTyConsEnv return $ expandMonoType' m tcEnv tvs ty expandMonoType' :: ModuleIdent -> TCEnv -> [Ident] -> TypeExpr -> Type expandMonoType' m tcEnv tvs ty = expandType m tcEnv (toType tvs ty) expandMonoTypes :: ModuleIdent -> TCEnv -> [Ident] -> [TypeExpr] -> [Type] expandMonoTypes m tcEnv tvs tys = map (expandType m tcEnv) (toTypes tvs tys) expandType :: ModuleIdent -> TCEnv -> Type -> Type expandType m tcEnv (TypeConstructor tc tys) = case qualLookupTC tc tcEnv of [DataType tc' _ _] -> TypeConstructor tc' tys' [RenamingType tc' _ _] -> TypeConstructor tc' tys' [AliasType _ _ ty] -> expandAliasType tys' ty _ -> case qualLookupTC (qualQualify m tc) tcEnv of [DataType tc' _ _ ] -> TypeConstructor tc' tys' [RenamingType tc' _ _ ] -> TypeConstructor tc' tys' [AliasType _ _ ty] -> expandAliasType tys' ty _ -> internalError $ "TypeCheck.expandType " ++ show tc where tys' = map (expandType m tcEnv) tys expandType _ _ tv@(TypeVariable _) = tv expandType _ _ tc@(TypeConstrained _ _) = tc expandType m tcEnv (TypeArrow ty1 ty2) = TypeArrow (expandType m tcEnv ty1) (expandType m tcEnv ty2) expandType _ _ ts@(TypeSkolem _) = ts -- The functions 'fvEnv' and 'fsEnv' compute the set of free type variables -- and free skolems of a type environment, respectively. We ignore the types -- of data constructors here because we know that they are closed. fvEnv :: ValueEnv -> Set.Set Int fvEnv tyEnv = Set.fromList [tv | ty <- localTypes tyEnv, tv <- typeVars ty, tv < 0] fsEnv :: ValueEnv -> Set.Set Int fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes localTypes :: ValueEnv -> [Type] localTypes tyEnv = [ty | (_, Value _ _ (ForAll _ ty)) <- localBindings tyEnv] -- --------------------------------------------------------------------------- -- Error functions -- --------------------------------------------------------------------------- errRecursiveTypes :: [Ident] -> Message errRecursiveTypes [] = internalError "TypeCheck.recursiveTypes: empty list" errRecursiveTypes [tc] = posMessage tc $ hsep $ map text ["Recursive synonym type", idName tc] errRecursiveTypes (tc : tcs) = posMessage tc $ text "Recursive synonym types" <+> text (idName tc) <+> types empty tcs where types _ [] = empty types comm [tc1] = comm <+> text "and" <+> text (idName tc1) <+> parens (text $ showLine $ idPosition tc1) types _ (tc1:tcs1) = comma <+> text (idName tc1) <+> parens (text $ showLine $ idPosition tc1) <> types comma tcs1 errPolymorphicFreeVar :: Ident -> Message errPolymorphicFreeVar v = posMessage v $ hsep $ map text ["Free variable", idName v, "has a polymorphic type"] errTypeSigTooGeneral :: Position -> ModuleIdent -> Doc -> TypeExpr -> TypeScheme -> Message errTypeSigTooGeneral p m what ty sigma = posMessage p $ vcat [ text "Type signature too general", what , text "Inferred type:" <+> ppTypeScheme m sigma , text "Type signature:" <+> ppTypeExpr 0 ty ] errNonFunctionType :: Position -> String -> Doc -> ModuleIdent -> Type -> Message errNonFunctionType p what doc m ty = posMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Type:" <+> ppType m ty , text "Cannot be applied" ] errNonBinaryOp :: Position -> String -> Doc -> ModuleIdent -> Type -> Message errNonBinaryOp p what doc m ty = posMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Type:" <+> ppType m ty , text "Cannot be used as binary operator" ] errTypeMismatch :: Position -> String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> Message errTypeMismatch p what doc m ty1 ty2 reason = posMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Inferred type:" <+> ppType m ty2 , text "Expected type:" <+> ppType m ty1 , reason ] errSkolemEscapingScope :: Position -> ModuleIdent -> Doc -> Type -> Message errSkolemEscapingScope p m what ty = posMessage p $ vcat [ text "Existential type escapes out of its scope" , what, text "Type:" <+> ppType m ty ] errRecursiveType :: ModuleIdent -> Int -> Type -> Doc errRecursiveType m tv ty = errIncompatibleTypes m (TypeVariable tv) ty errIncompatibleTypes :: ModuleIdent -> Type -> Type -> Doc errIncompatibleTypes m ty1 ty2 = sep [ text "Types" <+> ppType m ty1 , nest 2 $ text "and" <+> ppType m ty2 , text "are incompatible" ] errIncompatibleLabelTypes :: Position -> ModuleIdent -> Ident -> Type -> Type -> Message errIncompatibleLabelTypes p m l ty1 ty2 = posMessage p $ sep [ text "Labeled types" <+> ppIdent l <+> text "::" <+> ppType m ty1 , nest 10 $ text "and" <+> ppIdent l <+> text "::" <+> ppType m ty2 , text "are incompatible" ] curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/Checks/WarnCheck.hs000066400000000000000000001253331302651311700266550ustar00rootroot00000000000000{- | Module : $Header$ Description : Checks for irregular code Copyright : (c) 2006 Martin Engelke 2011 - 2014 Björn Peemöller 2014 - 2015 Jan Tikovsky License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module searches for potentially irregular code and generates warning messages. -} module Checks.WarnCheck (warnCheck) where import Control.Monad (filterM, foldM_, guard, liftM, liftM2, when, unless) import Control.Monad.State.Strict (State, execState, gets, modify) import qualified Data.IntSet as IntSet (IntSet, empty, insert, notMember, singleton, union, unions) import qualified Data.Map as Map (empty, insert, lookup) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.List (intersect, intersectBy, nub, sort, unionBy) import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty import Curry.Syntax import Curry.Syntax.Pretty (ppPattern, ppExpr, ppIdent) import Base.CurryTypes (ppTypeScheme) import Base.Messages (Message, posMessage, internalError) import Base.NestEnv ( NestEnv, emptyEnv, localNestEnv, nestEnv, unnestEnv , qualBindNestEnv, qualInLocalNestEnv, qualLookupNestEnv , qualModifyNestEnv) import Base.Types import Base.Utils (findMultiples) import Env.ModuleAlias import Env.TypeConstructor (TCEnv, TypeInfo (..), lookupTC, qualLookupTC) import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) import CompilerOpts -- Find potentially incorrect code in a Curry program and generate warnings -- for the following issues: -- - multiply imported modules, multiply imported/hidden values -- - unreferenced variables -- - shadowing variables -- - idle case alternatives -- - overlapping case alternatives -- - non-adjacent function rules warnCheck :: WarnOpts -> AliasEnv -> ValueEnv -> TCEnv -> Module -> [Message] warnCheck opts aEnv valEnv tcEnv (Module _ mid es is ds) = runOn (initWcState mid aEnv valEnv tcEnv (wnWarnFlags opts)) $ do checkImports is checkDeclGroup ds checkExports es checkMissingTypeSignatures ds checkModuleAlias is type ScopeEnv = NestEnv IdInfo -- Current state of generating warnings data WcState = WcState { moduleId :: ModuleIdent , scope :: ScopeEnv , aliasEnv :: AliasEnv , valueEnv :: ValueEnv , tyConsEnv :: TCEnv , warnFlags :: [WarnFlag] , warnings :: [Message] } -- The monadic representation of the state allows the usage of monadic -- syntax (do expression) for dealing easier and safer with its -- contents. type WCM = State WcState initWcState :: ModuleIdent -> AliasEnv -> ValueEnv -> TCEnv -> [WarnFlag] -> WcState initWcState mid ae ve te wf = WcState mid emptyEnv ae ve te wf [] getModuleIdent :: WCM ModuleIdent getModuleIdent = gets moduleId modifyScope :: (ScopeEnv -> ScopeEnv) -> WCM () modifyScope f = modify $ \s -> s { scope = f $ scope s } warnFor :: WarnFlag -> WCM () -> WCM () warnFor f act = do warn <- gets $ \s -> f `elem` warnFlags s when warn act report :: Message -> WCM () report w = modify $ \ s -> s { warnings = w : warnings s } unAlias :: QualIdent -> WCM QualIdent unAlias q = do aEnv <- gets aliasEnv case qidModule q of Nothing -> return q Just m -> case Map.lookup m aEnv of Nothing -> return q Just m' -> return $ qualifyWith m' (unqualify q) ok :: WCM () ok = return () -- |Run a 'WCM' action and return the list of messages runOn :: WcState -> WCM a -> [Message] runOn s f = sort $ warnings $ execState f s -- --------------------------------------------------------------------------- -- checkExports -- --------------------------------------------------------------------------- checkExports :: Maybe ExportSpec -> WCM () -- TODO checks checkExports Nothing = ok checkExports (Just (Exporting _ exports)) = do mapM_ visitExport exports reportUnusedGlobalVars where visitExport (Export qid) = visitQId qid visitExport _ = ok -- --------------------------------------------------------------------------- -- checkImports -- --------------------------------------------------------------------------- -- Check import declarations for multiply imported modules and multiply -- imported/hidden values. -- The function uses a map of the already imported or hidden entities to -- collect the entities throughout multiple import statements. checkImports :: [ImportDecl] -> WCM () checkImports = warnFor WarnMultipleImports . foldM_ checkImport Map.empty where checkImport env (ImportDecl pos mid _ _ spec) = case Map.lookup mid env of Nothing -> setImportSpec env mid $ fromImpSpec spec Just ishs -> checkImportSpec env pos mid ishs spec checkImportSpec env _ mid (_, _) Nothing = do report $ warnMultiplyImportedModule mid return env checkImportSpec env _ mid (is, hs) (Just (Importing _ is')) | null is && any (`notElem` hs) is' = do report $ warnMultiplyImportedModule mid setImportSpec env mid (is', hs) | null iis = setImportSpec env mid (is' ++ is, hs) | otherwise = do mapM_ (report . (warnMultiplyImportedSymbol mid) . impName) iis setImportSpec env mid (unionBy cmpImport is' is, hs) where iis = intersectBy cmpImport is' is checkImportSpec env _ mid (is, hs) (Just (Hiding _ hs')) | null ihs = setImportSpec env mid (is, hs' ++ hs) | otherwise = do mapM_ (report . (warnMultiplyHiddenSymbol mid) . impName) ihs setImportSpec env mid (is, unionBy cmpImport hs' hs) where ihs = intersectBy cmpImport hs' hs fromImpSpec Nothing = ([], []) fromImpSpec (Just (Importing _ is)) = (is, []) fromImpSpec (Just (Hiding _ hs)) = ([], hs) setImportSpec env mid ishs = return $ Map.insert mid ishs env cmpImport (ImportTypeWith id1 cs1) (ImportTypeWith id2 cs2) = id1 == id2 && null (intersect cs1 cs2) cmpImport i1 i2 = (impName i1) == (impName i2) impName (Import v) = v impName (ImportTypeAll t) = t impName (ImportTypeWith t _) = t warnMultiplyImportedModule :: ModuleIdent -> Message warnMultiplyImportedModule mid = posMessage mid $ hsep $ map text ["Module", moduleName mid, "is imported more than once"] warnMultiplyImportedSymbol :: ModuleIdent -> Ident -> Message warnMultiplyImportedSymbol mid ident = posMessage ident $ hsep $ map text [ "Symbol", escName ident, "from module", moduleName mid , "is imported more than once" ] warnMultiplyHiddenSymbol :: ModuleIdent -> Ident -> Message warnMultiplyHiddenSymbol mid ident = posMessage ident $ hsep $ map text [ "Symbol", escName ident, "from module", moduleName mid , "is hidden more than once" ] -- --------------------------------------------------------------------------- -- checkDeclGroup -- --------------------------------------------------------------------------- checkDeclGroup :: [Decl] -> WCM () checkDeclGroup ds = do mapM_ insertDecl ds mapM_ checkDecl ds checkRuleAdjacency ds checkLocalDeclGroup :: [Decl] -> WCM () checkLocalDeclGroup ds = do mapM_ checkLocalDecl ds checkDeclGroup ds -- --------------------------------------------------------------------------- -- Find function rules which are disjoined -- --------------------------------------------------------------------------- checkRuleAdjacency :: [Decl] -> WCM () checkRuleAdjacency decls = warnFor WarnDisjoinedRules $ foldM_ check (mkIdent "", Map.empty) decls where check (prevId, env) (FunctionDecl p f _) = do cons <- isConsId f if cons || prevId == f then return (f, env) else case Map.lookup f env of Nothing -> return (f, Map.insert f p env) Just p' -> do report $ warnDisjoinedFunctionRules f p' return (f, env) check (_ , env) _ = return (mkIdent "", env) warnDisjoinedFunctionRules :: Ident -> Position -> Message warnDisjoinedFunctionRules ident pos = posMessage ident $ hsep (map text [ "Rules for function", escName ident, "are disjoined" ]) <+> parens (text "first occurrence at" <+> text (showLine pos)) checkDecl :: Decl -> WCM () checkDecl (DataDecl _ _ vs cs) = inNestedScope $ do mapM_ insertTypeVar vs mapM_ checkConstrDecl cs reportUnusedTypeVars vs checkDecl (TypeDecl _ _ vs ty) = inNestedScope $ do mapM_ insertTypeVar vs checkTypeExpr ty reportUnusedTypeVars vs checkDecl (FunctionDecl p f eqs) = checkFunctionDecl p f eqs checkDecl (PatternDecl _ p rhs) = checkPattern p >> checkRhs rhs checkDecl _ = ok checkConstrDecl :: ConstrDecl -> WCM () checkConstrDecl (ConstrDecl _ _ c tys) = do visitId c mapM_ checkTypeExpr tys checkConstrDecl (ConOpDecl _ _ ty1 op ty2) = do visitId op mapM_ checkTypeExpr [ty1, ty2] checkConstrDecl (RecordDecl _ _ c fs) = do visitId c mapM_ checkTypeExpr tys where tys = [ty | FieldDecl _ _ ty <- fs] checkTypeExpr :: TypeExpr -> WCM () checkTypeExpr (ConstructorType qid tys) = do visitQTypeId qid mapM_ checkTypeExpr tys checkTypeExpr (VariableType v) = visitTypeId v checkTypeExpr (TupleType tys) = mapM_ checkTypeExpr tys checkTypeExpr (ListType ty) = checkTypeExpr ty checkTypeExpr (ArrowType ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2] checkTypeExpr (ParenType ty) = checkTypeExpr ty -- Checks locally declared identifiers (i.e. functions and logic variables) -- for shadowing checkLocalDecl :: Decl -> WCM () checkLocalDecl (FunctionDecl _ f _) = checkShadowing f checkLocalDecl (FreeDecl _ vs) = mapM_ checkShadowing vs checkLocalDecl (PatternDecl _ p _) = checkPattern p checkLocalDecl _ = ok checkFunctionDecl :: Position -> Ident -> [Equation] -> WCM () checkFunctionDecl _ _ [] = ok checkFunctionDecl p f eqs = inNestedScope $ do mapM_ checkEquation eqs checkFunctionPatternMatch p f eqs checkFunctionPatternMatch :: Position -> Ident -> [Equation] -> WCM () checkFunctionPatternMatch p f eqs = do let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ warnMissingPattern p ("an equation for " ++ escName f) nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $ warnNondetOverlapping p ("Function " ++ escName f) -- Check an equation for warnings. -- This is done in a seperate scope as the left-hand-side may introduce -- new variables. checkEquation :: Equation -> WCM () checkEquation (Equation _ lhs rhs) = inNestedScope $ do checkLhs lhs checkRhs rhs reportUnusedVars checkLhs :: Lhs -> WCM () checkLhs (FunLhs _ ts) = do mapM_ checkPattern ts mapM_ (insertPattern False) ts checkLhs (OpLhs t1 op t2) = checkLhs (FunLhs op [t1, t2]) checkLhs (ApLhs lhs ts) = do checkLhs lhs mapM_ checkPattern ts mapM_ (insertPattern False) ts checkPattern :: Pattern -> WCM () checkPattern (VariablePattern v) = checkShadowing v checkPattern (ConstructorPattern _ ps) = mapM_ checkPattern ps checkPattern (InfixPattern p1 f p2) = checkPattern (ConstructorPattern f [p1, p2]) checkPattern (ParenPattern p) = checkPattern p checkPattern (RecordPattern _ fs) = mapM_ (checkField checkPattern) fs checkPattern (TuplePattern _ ps) = mapM_ checkPattern ps checkPattern (ListPattern _ ps) = mapM_ checkPattern ps checkPattern (AsPattern v p) = checkShadowing v >> checkPattern p checkPattern (LazyPattern _ p) = checkPattern p checkPattern (FunctionPattern _ ps) = mapM_ checkPattern ps checkPattern (InfixFuncPattern p1 f p2) = checkPattern (FunctionPattern f [p1, p2]) checkPattern _ = ok -- Check the right-hand-side of an equation. -- Because local declarations may introduce new variables, we need -- another scope nesting. checkRhs :: Rhs -> WCM () checkRhs (SimpleRhs _ e ds) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars checkRhs (GuardedRhs ce ds) = inNestedScope $ do checkLocalDeclGroup ds mapM_ checkCondExpr ce reportUnusedVars checkCondExpr :: CondExpr -> WCM () checkCondExpr (CondExpr _ c e) = checkExpr c >> checkExpr e checkExpr :: Expression -> WCM () checkExpr (Variable v) = visitQId v checkExpr (Paren e) = checkExpr e checkExpr (Typed e _) = checkExpr e checkExpr (Record _ fs) = mapM_ (checkField checkExpr) fs checkExpr (RecordUpdate e fs) = do checkExpr e mapM_ (checkField checkExpr) fs checkExpr (Tuple _ es) = mapM_ checkExpr es checkExpr (List _ es) = mapM_ checkExpr es checkExpr (ListCompr _ e sts) = checkStatements sts e checkExpr (EnumFrom e) = checkExpr e checkExpr (EnumFromThen e1 e2) = mapM_ checkExpr [e1, e2] checkExpr (EnumFromTo e1 e2) = mapM_ checkExpr [e1, e2] checkExpr (EnumFromThenTo e1 e2 e3) = mapM_ checkExpr [e1, e2, e3] checkExpr (UnaryMinus _ e) = checkExpr e checkExpr (Apply e1 e2) = mapM_ checkExpr [e1, e2] checkExpr (InfixApply e1 op e2) = do visitQId (opName op) mapM_ checkExpr [e1, e2] checkExpr (LeftSection e _) = checkExpr e checkExpr (RightSection _ e) = checkExpr e checkExpr (Lambda _ ps e) = inNestedScope $ do mapM_ checkPattern ps mapM_ (insertPattern False) ps checkExpr e reportUnusedVars checkExpr (Let ds e) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars checkExpr (Do sts e) = checkStatements sts e checkExpr (IfThenElse _ e1 e2 e3) = mapM_ checkExpr [e1, e2, e3] checkExpr (Case _ ct e alts) = do checkExpr e mapM_ checkAlt alts checkCaseAlts ct alts checkExpr _ = ok checkStatements :: [Statement] -> Expression -> WCM () checkStatements [] e = checkExpr e checkStatements (s:ss) e = inNestedScope $ do checkStatement s >> checkStatements ss e reportUnusedVars checkStatement :: Statement -> WCM () checkStatement (StmtExpr _ e) = checkExpr e checkStatement (StmtDecl ds) = checkLocalDeclGroup ds checkStatement (StmtBind _ p e) = do checkPattern p >> insertPattern False p checkExpr e checkAlt :: Alt -> WCM () checkAlt (Alt _ p rhs) = inNestedScope $ do checkPattern p >> insertPattern False p checkRhs rhs reportUnusedVars checkField :: (a -> WCM ()) -> Field a -> WCM () checkField check (Field _ _ x) = check x -- ----------------------------------------------------------------------------- -- Check for missing type signatures -- ----------------------------------------------------------------------------- -- |Check if every top-level function has an accompanying type signature. -- For external function declarations, this check is already performed -- during syntax checking. checkMissingTypeSignatures :: [Decl] -> WCM () checkMissingTypeSignatures ds = warnFor WarnMissingSignatures $ do let typedFs = [f | TypeSig _ fs _ <- ds, f <- fs] untypedFs = [f | FunctionDecl _ f _ <- ds, f `notElem` typedFs] unless (null untypedFs) $ do mid <- getModuleIdent tyScs <- mapM getTyScheme untypedFs mapM_ report $ zipWith (warnMissingTypeSignature mid) untypedFs tyScs getTyScheme :: Ident -> WCM TypeScheme getTyScheme q = do m <- getModuleIdent tyEnv <- gets valueEnv return $ case qualLookupValue (qualifyWith m q) tyEnv of [Value _ _ tys] -> tys _ -> internalError $ "Checks.WarnCheck.getTyScheme: " ++ show q warnMissingTypeSignature :: ModuleIdent -> Ident -> TypeScheme -> Message warnMissingTypeSignature mid i tys = posMessage i $ fsep [ text "Top-level binding with no type signature:" , nest 2 $ text (showIdent i) <+> text "::" <+> ppTypeScheme mid tys ] -- ----------------------------------------------------------------------------- -- Check for overlapping module alias names -- ----------------------------------------------------------------------------- -- check if module aliases in import declarations overlap with the module name -- or another module alias checkModuleAlias :: [ImportDecl] -> WCM () checkModuleAlias is = do mid <- getModuleIdent let alias = catMaybes [a | ImportDecl _ _ _ a _ <- is] modClash = [a | a <- alias, a == mid] aliasClash = findMultiples alias unless (null modClash) $ mapM_ (report . warnModuleNameClash) modClash unless (null aliasClash) $ mapM_ (report . warnAliasNameClash ) aliasClash warnModuleNameClash :: ModuleIdent -> Message warnModuleNameClash mid = posMessage mid $ hsep $ map text ["The module alias", escModuleName mid , "overlaps with the current module name"] warnAliasNameClash :: [ModuleIdent] -> Message warnAliasNameClash [] = internalError "WarnCheck.warnAliasNameClash: empty list" warnAliasNameClash mids = posMessage (head mids) $ text "Overlapping module aliases" $+$ nest 2 (vcat (map myppAlias mids)) where myppAlias mid@(ModuleIdent pos _) = ppLine pos <> text ":" <+> text (escModuleName mid) -- ----------------------------------------------------------------------------- -- Check for overlapping/unreachable and non-exhaustive case alternatives -- ----------------------------------------------------------------------------- checkCaseAlts :: CaseType -> [Alt] -> WCM () checkCaseAlts _ [] = ok checkCaseAlts ct alts@(Alt p _ _ : _) = do let pats = map (\(Alt _ pat _) -> [pat]) alts (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats case ct of Flex -> do unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ warnMissingPattern p "an fcase alternative" nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $ warnNondetOverlapping p "An fcase expression" Rigid -> do unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ warnMissingPattern p "a case alternative" nonExhaustive unless (null overlapped) $ warnFor WarnOverlapping $ report $ warnUnreachablePattern p overlapped -- ----------------------------------------------------------------------------- -- Check for non-exhaustive and overlapping patterns. -- For an example, consider the following function definition: -- @ -- f [True] = 0 -- f (False:_) = 1 -- @ -- In this declaration, the following patterns are not matched: -- @ -- [] _ -- (True:_:_) -- @ -- This is identified and reported by the following code,, both for pattern -- matching in function declarations and (f)case expressions. -- ----------------------------------------------------------------------------- checkPatternMatching :: [[Pattern]] -> WCM ([ExhaustivePats], [[Pattern]], Bool) checkPatternMatching pats = do -- 1. We simplify the patterns by removing syntactic sugar temporarily -- for a simpler implementation. simplePats <- mapM (mapM simplifyPat) pats -- 2. We compute missing and used pattern matching alternatives (missing, used, nondet) <- processEqs (zip [1..] simplePats) -- 3. If any, we report the missing patterns, whereby we re-add the syntactic -- sugar removed in step (1) for a more precise output. nonExhaustive <- mapM tidyExhaustivePats missing let overlap = [ eqn | (i, eqn) <- zip [1..] pats, i `IntSet.notMember` used] return (nonExhaustive , overlap, nondet) -- |Simplify a 'Pattern' until it only consists of -- * Variables -- * Integer, Float or Char literals -- * Constructors -- All other patterns like as-patterns, list patterns and alike are desugared. simplifyPat :: Pattern -> WCM Pattern simplifyPat p@(LiteralPattern l) = return $ case l of String r s -> simplifyListPattern $ map (LiteralPattern . Char r) s _ -> p simplifyPat (NegativePattern _ l) = return $ LiteralPattern (negateLit l) where negateLit (Int i n) = Int i (-n) negateLit (Float r d) = Float r (-d) negateLit x = x simplifyPat v@(VariablePattern _) = return v simplifyPat (ConstructorPattern c ps) = ConstructorPattern c `liftM` mapM simplifyPat ps simplifyPat (InfixPattern p1 c p2) = ConstructorPattern c `liftM` mapM simplifyPat [p1, p2] simplifyPat (ParenPattern p) = simplifyPat p simplifyPat (RecordPattern c fs) = do (_, ls) <- getAllLabels c let ps = map (getPattern (map field2Tuple fs)) ls simplifyPat (ConstructorPattern c ps) where getPattern fs' l' = fromMaybe (VariablePattern anonId) (lookup l' [(unqualify l, p) | (l, p) <- fs']) simplifyPat (TuplePattern _ ps) | null ps = return $ ConstructorPattern qUnitId [] | otherwise = ConstructorPattern (qTupleId (length ps)) `liftM` mapM simplifyPat ps simplifyPat (ListPattern _ ps) = simplifyListPattern `liftM` mapM simplifyPat ps simplifyPat (AsPattern _ p) = simplifyPat p simplifyPat (LazyPattern _ _) = return $ VariablePattern anonId simplifyPat (FunctionPattern _ _) = return $ VariablePattern anonId simplifyPat (InfixFuncPattern _ _ _) = return $ VariablePattern anonId getAllLabels :: QualIdent -> WCM (QualIdent, [Ident]) getAllLabels c = do tyEnv <- gets valueEnv case qualLookupValue c tyEnv of [DataConstructor qc _ ls _] -> return (qc, ls) _ -> internalError $ "Checks.WarnCheck.getAllLabels: " ++ show c -- |Create a simplified list pattern by applying @:@ and @[]@. simplifyListPattern :: [Pattern] -> Pattern simplifyListPattern = foldr (\p1 p2 -> ConstructorPattern qConsId [p1, p2]) (ConstructorPattern qNilId []) -- |'ExhaustivePats' describes those pattern missing for an exhaustive -- pattern matching, where a value can be thought of as a missing equation. -- The first component contains the unmatched patterns, while the second -- pattern contains an identifier and the literals matched for this identifier. -- -- This is necessary when checking literal patterns because of the sheer -- number of possible patterns. Missing literals are therefore converted -- into the form @ ... x ... with x `notElem` [l1, ..., ln]@. type EqnPats = [Pattern] type EqnNo = Int type EqnInfo = (EqnNo, EqnPats) type ExhaustivePats = (EqnPats, [(Ident, [Literal])]) type EqnSet = IntSet.IntSet -- |Compute the missing pattern by inspecting the first patterns and -- categorize them as literal, constructor or variable patterns. processEqs :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processEqs [] = return ([], IntSet.empty, False) processEqs eqs@((n, ps):_) | null ps = return ([], IntSet.singleton n, length eqs > 1) | any isLitPat firstPats = processLits eqs | any isConPat firstPats = processCons eqs | all isVarPat firstPats = processVars eqs | otherwise = internalError "Checks.WarnCheck.processEqs" where firstPats = map firstPat eqs -- |Literal patterns are checked by extracting the matched literals -- and constructing a pattern for any missing case. processLits :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processLits [] = error "WarnCheck.processLits" processLits qs@(q:_) = do -- Check any patterns starting with the literals used (missing1, used1, nd1) <- processUsedLits usedLits qs if null defaults then return $ (defaultPat : missing1, used1, nd1) else do -- Missing patterns for the default alternatives (missing2, used2, nd2) <- processEqs defaults return ( [ (wildPat : ps, cs) | (ps, cs) <- missing2 ] ++ missing1 , IntSet.union used1 used2, nd1 || nd2 ) where -- The literals occurring in the patterns usedLits = nub $ concatMap (getLit . firstPat) qs -- default alternatives (variable pattern) defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for all non-matched literals defaultPat = ( VariablePattern newVar : replicate (length (snd q) - 1) wildPat , [(newVar, usedLits)]) newVar = mkIdent "x" -- |Construct exhaustive patterns starting with the used literals processUsedLits :: [Literal] -> [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processUsedLits lits qs = do (eps, idxs, nds) <- unzip3 `liftM` mapM process lits return (concat eps, IntSet.unions idxs, or nds) where process lit = do let qs' = [shiftPat q | q <- qs, isVarLit lit (firstPat q)] ovlp = length qs' > 1 (missing, used, nd) <- processEqs qs' return (map (\(xs, ys) -> (LiteralPattern lit : xs, ys)) missing, used, nd && ovlp) -- |Constructor patterns are checked by extracting the matched constructors -- and constructing a pattern for any missing case. processCons :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processCons [] = error "WarnCheck.processCons" processCons qs@(q:_) = do -- Compute any missing patterns starting with the used constructors (missing1, used1, nd) <- processUsedCons used_cons qs -- Determine unused constructors unused <- getUnusedCons (map fst used_cons) if null unused then return (missing1, used1, nd) else if null defaults then return $ (map defaultPat unused ++ missing1, used1, nd) else do -- Missing patterns for the default alternatives (missing2, used2, nd2) <- processEqs defaults return ( [ (mkPattern c : ps, cs) | c <- unused, (ps, cs) <- missing2 ] ++ missing1 , IntSet.union used1 used2, nd || nd2) where -- used constructors (occurring in a pattern) used_cons = nub $ concatMap (getCon . firstPat) qs -- default alternatives (variable pattern) defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for a non-matched constructors defaultPat c = (mkPattern c : replicate (length (snd q) - 1) wildPat, []) mkPattern c = ConstructorPattern (qualifyLike (fst $ head used_cons) (constrIdent c)) (replicate (length $ constrTypes c) wildPat) -- |Construct exhaustive patterns starting with the used constructors processUsedCons :: [(QualIdent, Int)] -> [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processUsedCons cons qs = do (eps, idxs, nds) <- unzip3 `liftM` mapM process cons return (concat eps, IntSet.unions idxs, or nds) where process (c, a) = do let qs' = [ removeFirstCon c a q | q <- qs , isVarCon c (firstPat q)] ovlp = length qs' > 1 (missing, used, nd) <- processEqs qs' return (map (\(xs, ys) -> (makeCon c a xs, ys)) missing, used, nd && ovlp) makeCon c a ps = let (args, rest) = splitAt a ps in ConstructorPattern c args : rest removeFirstCon c a (n, p:ps) | isVarPat p = (n, replicate a wildPat ++ ps) | isCon c p = (n, patArgs p ++ ps) removeFirstCon _ _ _ = internalError "Checks.WarnCheck.removeFirstCon" -- |Variable patterns are exhaustive, so they are checked by simply -- checking the following patterns. processVars :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool) processVars [] = error "WarnCheck.processVars" processVars eqs@((n, _) : _) = do let ovlp = length eqs > 1 (missing, used, nd) <- processEqs (map shiftPat eqs) return ( map (\(xs, ys) -> (wildPat : xs, ys)) missing , IntSet.insert n used, nd && ovlp) -- |Return the constructors of a type not contained in the list of constructors. getUnusedCons :: [QualIdent] -> WCM [DataConstr] getUnusedCons [] = internalError "Checks.WarnCheck.getUnusedCons" getUnusedCons qs@(q:_) = do allCons <- getConTy q >>= getTyCons q . arrowBase return [ c | c <- allCons, (constrIdent c) `notElem` map unqualify qs] -- |Retrieve the type of a given constructor. getConTy :: QualIdent -> WCM Type getConTy q = do tyEnv <- gets valueEnv tcEnv <- gets tyConsEnv case qualLookupValue q tyEnv of [DataConstructor _ _ _ (ForAllExist _ _ ty)] -> return ty [NewtypeConstructor _ _ (ForAllExist _ _ ty)] -> return ty _ -> case qualLookupTC q tcEnv of [AliasType _ _ ty] -> return ty _ -> internalError $ "Checks.WarnCheck.getConTy: " ++ show q -- |Retrieve all constructors of a given type. getTyCons :: QualIdent -> Type -> WCM [DataConstr] getTyCons _ (TypeConstructor tc _) = do tc' <- unAlias tc tcEnv <- gets tyConsEnv return $ case lookupTC (unqualify tc) tcEnv of [DataType _ _ cs] -> cs [RenamingType _ _ nc] -> [nc] _ -> case qualLookupTC tc' tcEnv of [DataType _ _ cs] -> cs [RenamingType _ _ nc] -> [nc] err -> internalError $ "Checks.WarnCheck.getTyCons: " ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv getTyCons _ _ = internalError "Checks.WarnCheck.getTyCons" -- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'. tidyExhaustivePats :: ExhaustivePats -> WCM ExhaustivePats tidyExhaustivePats (xs, ys) = mapM tidyPat xs >>= \xs' -> return (xs', ys) -- |Resugar a pattern previously desugared at 'simplifyPat', i.e. -- * Convert a tuple constructor pattern into a tuple pattern -- * Convert a list constructor pattern representing a finite list -- into a list pattern tidyPat :: Pattern -> WCM Pattern tidyPat p@(LiteralPattern _) = return p tidyPat p@(VariablePattern _) = return p tidyPat p@(ConstructorPattern c ps) | c == qUnitId && null ps = return $ TuplePattern noRef [] | isQTupleId c = TuplePattern noRef `liftM` mapM tidyPat ps | c == qConsId && isFiniteList p = ListPattern [] `liftM` mapM tidyPat (unwrapFinite p) | c == qConsId = unwrapInfinite p | otherwise = ConstructorPattern c `liftM` mapM tidyPat ps where isFiniteList (ConstructorPattern d [] ) = d == qNilId isFiniteList (ConstructorPattern d [_, e2]) | d == qConsId = isFiniteList e2 isFiniteList _ = False unwrapFinite (ConstructorPattern _ [] ) = [] unwrapFinite (ConstructorPattern _ [p1,p2]) = p1 : unwrapFinite p2 unwrapFinite pat = internalError $ "WarnCheck.tidyPat.unwrapFinite: " ++ show pat unwrapInfinite (ConstructorPattern d [p1,p2]) = liftM2 (flip InfixPattern d) (tidyPat p1) (unwrapInfinite p2) unwrapInfinite p0 = return p0 tidyPat p = internalError $ "Checks.WarnCheck.tidyPat: " ++ show p -- |Get the first pattern of a list. firstPat :: EqnInfo -> Pattern firstPat (_, [] ) = internalError "Checks.WarnCheck.firstPat: empty list" firstPat (_, (p:_)) = p -- |Drop the first pattern of a list. shiftPat :: EqnInfo -> EqnInfo shiftPat (_, [] ) = internalError "Checks.WarnCheck.shiftPat: empty list" shiftPat (n, (_:ps)) = (n, ps) -- |Wildcard pattern. wildPat :: Pattern wildPat = VariablePattern anonId -- |Retrieve any literal out of a pattern. getLit :: Pattern -> [Literal] getLit (LiteralPattern l) = [l] getLit _ = [] -- |Retrieve the constructor name and its arity for a pattern. getCon :: Pattern -> [(QualIdent, Int)] getCon (ConstructorPattern c ps) = [(c, length ps)] getCon _ = [] -- |Is a pattern a variable or literal pattern? isVarLit :: Literal -> Pattern -> Bool isVarLit l p = isVarPat p || isLit l p -- |Is a pattern a variable or a constructor pattern with the given constructor? isVarCon :: QualIdent -> Pattern -> Bool isVarCon c p = isVarPat p || isCon c p -- |Is a pattern a pattern matching for the given constructor? isCon :: QualIdent -> Pattern -> Bool isCon c (ConstructorPattern d _) = c == d isCon _ _ = False -- |Is a pattern a pattern matching for the given literal? isLit :: Literal -> Pattern -> Bool isLit l (LiteralPattern m) = l == m isLit _ _ = False -- |Is a pattern a literal pattern? isLitPat :: Pattern -> Bool isLitPat (LiteralPattern _) = True isLitPat _ = False -- |Is a pattern a variable pattern? isVarPat :: Pattern -> Bool isVarPat (VariablePattern _) = True isVarPat _ = False -- |Is a pattern a constructor pattern? isConPat :: Pattern -> Bool isConPat (ConstructorPattern _ _) = True isConPat _ = False -- |Retrieve the arguments of a pattern. patArgs :: Pattern -> [Pattern] patArgs (ConstructorPattern _ ps) = ps patArgs _ = [] -- |Warning message for non-exhaustive patterns. -- To shorten the output only the first 'maxPattern' are printed, -- additional pattern are abbreviated by dots. warnMissingPattern :: Position -> String -> [ExhaustivePats] -> Message warnMissingPattern p loc pats = posMessage p $ text "Pattern matches are non-exhaustive" $+$ text "In" <+> text loc <> char ':' $+$ nest 2 (text "Patterns not matched:" $+$ nest 2 (vcat (ppExPats pats))) where ppExPats ps | length ps > maxPattern = ppPats ++ [text "..."] | otherwise = ppPats where ppPats = map ppExPat (take maxPattern ps) ppExPat (ps, cs) | null cs = ppPats | otherwise = ppPats <+> text "with" <+> hsep (map ppCons cs) where ppPats = hsep (map (ppPattern 2) ps) ppCons (i, lits) = ppIdent i <+> text "`notElem`" <+> ppExpr 0 (List [] (map Literal lits)) -- |Warning message for unreachable patterns. -- To shorten the output only the first 'maxPattern' are printed, -- additional pattern are abbreviated by dots. warnUnreachablePattern :: Position -> [[Pattern]] -> Message warnUnreachablePattern p pats = posMessage p $ text "Pattern matches are unreachable" $+$ text "In a case alternative:" $+$ nest 2 (vcat (ppExPats pats) <+> text "->" <+> text "...") where ppExPats ps | length ps > maxPattern = ppPats ++ [text "..."] | otherwise = ppPats where ppPats = map ppPat (take maxPattern ps) ppPat ps = hsep (map (ppPattern 2) ps) -- |Maximum number of missing patterns to be shown. maxPattern :: Int maxPattern = 4 warnNondetOverlapping :: Position -> String -> Message warnNondetOverlapping p loc = posMessage p $ text loc <+> text "is non-deterministic due to overlapping rules" -- ----------------------------------------------------------------------------- checkShadowing :: Ident -> WCM () checkShadowing x = warnFor WarnNameShadowing $ shadowsVar x >>= maybe ok (report . warnShadowing x) reportUnusedVars :: WCM () reportUnusedVars = reportAllUnusedVars WarnUnusedBindings reportUnusedGlobalVars :: WCM () reportUnusedGlobalVars = reportAllUnusedVars WarnUnusedGlobalBindings reportAllUnusedVars :: WarnFlag -> WCM () reportAllUnusedVars wFlag = warnFor wFlag $ do unused <- returnUnrefVars unless (null unused) $ mapM_ report $ map warnUnrefVar unused reportUnusedTypeVars :: [Ident] -> WCM () reportUnusedTypeVars vs = warnFor WarnUnusedBindings $ do unused <- filterM isUnrefTypeVar vs unless (null unused) $ mapM_ report $ map warnUnrefTypeVar unused -- --------------------------------------------------------------------------- -- For detecting unreferenced variables, the following functions update the -- current check state by adding identifiers occuring in declaration left hand -- sides. insertDecl :: Decl -> WCM () insertDecl (DataDecl _ d _ cs) = do insertTypeConsId d mapM_ insertConstrDecl cs insertDecl (TypeDecl _ t _ ty) = do insertTypeConsId t insertTypeExpr ty insertDecl (FunctionDecl _ f _) = do cons <- isConsId f unless cons $ insertVar f insertDecl (ForeignDecl _ _ _ f _) = insertVar f insertDecl (ExternalDecl _ vs) = mapM_ insertVar vs insertDecl (PatternDecl _ p _) = insertPattern False p insertDecl (FreeDecl _ vs) = mapM_ insertVar vs insertDecl _ = ok insertTypeExpr :: TypeExpr -> WCM () insertTypeExpr (VariableType _) = ok insertTypeExpr (ConstructorType _ tys) = mapM_ insertTypeExpr tys insertTypeExpr (TupleType tys) = mapM_ insertTypeExpr tys insertTypeExpr (ListType ty) = insertTypeExpr ty insertTypeExpr (ArrowType ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2] insertTypeExpr (ParenType ty) = insertTypeExpr ty insertConstrDecl :: ConstrDecl -> WCM () insertConstrDecl (ConstrDecl _ _ c _) = insertConsId c insertConstrDecl (ConOpDecl _ _ _ op _) = insertConsId op insertConstrDecl (RecordDecl _ _ c _) = insertConsId c -- 'fp' indicates whether 'checkPattern' deals with the arguments -- of a function pattern or not. -- Since function patterns are not recognized before syntax check, it is -- necessary to determine whether a constructor pattern represents a -- constructor or a function. insertPattern :: Bool -> Pattern -> WCM () insertPattern fp (VariablePattern v) = do cons <- isConsId v unless cons $ do var <- isVarId v if and [fp, var, not (isAnonId v)] then visitId v else insertVar v insertPattern fp (ConstructorPattern c ps) = do cons <- isQualConsId c mapM_ (insertPattern (not cons || fp)) ps insertPattern fp (InfixPattern p1 c p2) = insertPattern fp (ConstructorPattern c [p1, p2]) insertPattern fp (ParenPattern p) = insertPattern fp p insertPattern fp (RecordPattern _ fs) = mapM_ (insertFieldPattern fp) fs insertPattern fp (TuplePattern _ ps) = mapM_ (insertPattern fp) ps insertPattern fp (ListPattern _ ps) = mapM_ (insertPattern fp) ps insertPattern fp (AsPattern v p) = insertVar v >> insertPattern fp p insertPattern fp (LazyPattern _ p) = insertPattern fp p insertPattern _ (FunctionPattern f ps) = do visitQId f mapM_ (insertPattern True) ps insertPattern _ (InfixFuncPattern p1 f p2) = insertPattern True (FunctionPattern f [p1, p2]) insertPattern _ _ = ok insertFieldPattern :: Bool -> Field Pattern -> WCM () insertFieldPattern fp (Field _ _ p) = insertPattern fp p -- --------------------------------------------------------------------------- -- Data type for distinguishing identifiers as either (type) constructors or -- (type) variables (including functions). data IdInfo = ConsInfo -- ^ Constructor | VarInfo Ident Bool -- ^ Variable with original definition (for position) -- and used flag deriving Show isVariable :: IdInfo -> Bool isVariable (VarInfo _ _) = True isVariable _ = False getVariable :: IdInfo -> Maybe Ident getVariable (VarInfo v _) = Just v getVariable _ = Nothing isConstructor :: IdInfo -> Bool isConstructor ConsInfo = True isConstructor _ = False variableVisited :: IdInfo -> Bool variableVisited (VarInfo _ v) = v variableVisited _ = True visitVariable :: IdInfo -> IdInfo visitVariable (VarInfo v _) = VarInfo v True visitVariable info = info insertScope :: QualIdent -> IdInfo -> WCM () insertScope qid info = modifyScope $ qualBindNestEnv qid info insertVar :: Ident -> WCM () insertVar v = unless (isAnonId v) $ do known <- isKnownVar v if known then visitId v else insertScope (commonId v) (VarInfo v False) insertTypeVar :: Ident -> WCM () insertTypeVar v = unless (isAnonId v) $ insertScope (typeId v) (VarInfo v False) insertConsId :: Ident -> WCM () insertConsId c = insertScope (commonId c) ConsInfo insertTypeConsId :: Ident -> WCM () insertTypeConsId c = insertScope (typeId c) ConsInfo isVarId :: Ident -> WCM Bool isVarId v = gets (isVar $ commonId v) isConsId :: Ident -> WCM Bool isConsId c = gets (isCons $ qualify c) isQualConsId :: QualIdent -> WCM Bool isQualConsId qid = gets (isCons qid) shadowsVar :: Ident -> WCM (Maybe Ident) shadowsVar v = gets (shadows $ commonId v) where shadows :: QualIdent -> WcState -> Maybe Ident shadows qid s = do guard $ not (qualInLocalNestEnv qid sc) info <- listToMaybe $ qualLookupNestEnv qid sc getVariable info where sc = scope s visitId :: Ident -> WCM () visitId v = modifyScope (qualModifyNestEnv visitVariable (commonId v)) visitQId :: QualIdent -> WCM () visitQId v = do mid <- getModuleIdent maybe ok visitId (localIdent mid v) visitTypeId :: Ident -> WCM () visitTypeId v = modifyScope (qualModifyNestEnv visitVariable (typeId v)) visitQTypeId :: QualIdent -> WCM () visitQTypeId v = do mid <- getModuleIdent maybe ok visitTypeId (localIdent mid v) isKnownVar :: Ident -> WCM Bool isKnownVar v = gets $ \s -> isKnown s (commonId v) isUnrefTypeVar :: Ident -> WCM Bool isUnrefTypeVar v = gets (\s -> isUnref s (typeId v)) returnUnrefVars :: WCM [Ident] returnUnrefVars = gets (\s -> let ids = map fst (localNestEnv (scope s)) unrefs = filter (isUnref s . qualify) ids in unrefs ) inNestedScope :: WCM a -> WCM () inNestedScope m = beginScope >> m >> endScope beginScope :: WCM () beginScope = modifyScope nestEnv endScope :: WCM () endScope = modifyScope unnestEnv ------------------------------------------------------------------------------ isKnown :: WcState -> QualIdent -> Bool isKnown s qid = qualInLocalNestEnv qid (scope s) isUnref :: WcState -> QualIdent -> Bool isUnref s qid = let sc = scope s in (any (not . variableVisited) (qualLookupNestEnv qid sc)) && qualInLocalNestEnv qid sc isVar :: QualIdent -> WcState -> Bool isVar qid s = maybe (isAnonId (unqualify qid)) isVariable (listToMaybe (qualLookupNestEnv qid (scope s))) isCons :: QualIdent -> WcState -> Bool isCons qid s = maybe (isImportedCons s qid) isConstructor (listToMaybe (qualLookupNestEnv qid (scope s))) where isImportedCons s' qid' = case qualLookupValue qid' (valueEnv s') of (DataConstructor _ _ _ _) : _ -> True (NewtypeConstructor _ _ _) : _ -> True _ -> False -- Since type identifiers and normal identifiers (e.g. functions, variables -- or constructors) don't share the same namespace, it is necessary -- to distinguish them in the scope environment of the check state. -- For this reason type identifiers are annotated with 1 and normal -- identifiers are annotated with 0. commonId :: Ident -> QualIdent commonId = qualify . unRenameIdent typeId :: Ident -> QualIdent typeId = qualify . flip renameIdent 1 -- --------------------------------------------------------------------------- -- Warnings messages -- --------------------------------------------------------------------------- warnUnrefTypeVar :: Ident -> Message warnUnrefTypeVar v = posMessage v $ hsep $ map text [ "Unreferenced type variable", escName v ] warnUnrefVar :: Ident -> Message warnUnrefVar v = posMessage v $ hsep $ map text [ "Unused declaration of variable", escName v ] warnShadowing :: Ident -> Ident -> Message warnShadowing x v = posMessage x $ text "Shadowing symbol" <+> text (escName x) <> comma <+> text "bound at:" <+> ppPosition (getPosition v) curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/CompilerEnv.hs000066400000000000000000000064271302651311700260350ustar00rootroot00000000000000{- | Module : $Header$ Description : Environment containing the module's information Copyright : (c) 2011 - 2015 Björn Peemöller License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module defines the compilation environment for a single module, containing the information needed throughout the compilation process. -} module CompilerEnv where import qualified Data.Map as Map (Map, keys, toList) import Curry.Base.Ident (ModuleIdent, moduleName) import Curry.Base.Pretty import Curry.Base.Span (Span) import Curry.Syntax import Base.TopEnv (allLocalBindings) import Env.Interface import Env.ModuleAlias (AliasEnv, initAliasEnv) import Env.OpPrec import Env.TypeConstructor import Env.Value type CompEnv a = (CompilerEnv, a) -- |A compiler environment contains information about the module currently -- compiled. The information is updated during the different stages of -- compilation. data CompilerEnv = CompilerEnv { moduleIdent :: ModuleIdent -- ^ identifier of the module , filePath :: FilePath -- ^ 'FilePath' of compilation target , extensions :: [KnownExtension] -- ^ enabled language extensions , tokens :: [(Span, Token)] -- ^ token list of module , interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces , aliasEnv :: AliasEnv -- ^ aliases for imported modules , tyConsEnv :: TCEnv -- ^ type constructors , valueEnv :: ValueEnv -- ^ functions and data constructors , opPrecEnv :: OpPrecEnv -- ^ operator precedences } -- |Initial 'CompilerEnv' initCompilerEnv :: ModuleIdent -> CompilerEnv initCompilerEnv mid = CompilerEnv { moduleIdent = mid , filePath = [] , extensions = [] , tokens = [] , interfaceEnv = initInterfaceEnv , aliasEnv = initAliasEnv , tyConsEnv = initTCEnv , valueEnv = initDCEnv , opPrecEnv = initOpPrecEnv } -- |Show the 'CompilerEnv' showCompilerEnv :: CompilerEnv -> String showCompilerEnv env = show $ vcat [ header "Module Identifier " $ text $ moduleName $ moduleIdent env , header "FilePath" $ text $ filePath env , header "Language Extensions" $ text $ show $ extensions env , header "Interfaces " $ hcat $ punctuate comma $ map (text . moduleName) $ Map.keys $ interfaceEnv env , header "Module Aliases " $ ppMap $ aliasEnv env , header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env , header "Type Constructors " $ ppAL $ allLocalBindings $ tyConsEnv env , header "Values " $ ppAL $ allLocalBindings $ valueEnv env ] where header hdr content = hang (text hdr <+> colon) 4 content -- |Pretty print a 'Map' ppMap :: (Show a, Show b) => Map.Map a b -> Doc ppMap = ppAL . Map.toList -- |Pretty print an association list ppAL :: (Show a, Show b) => [(a, b)] -> Doc ppAL xs = vcat $ map (\(a,b) -> text (pad a keyWidth) <+> equals <+> text b) showXs where showXs = map (\(a,b) -> (show a, show b)) xs keyWidth = maximum (0 : map (length .fst) showXs) pad s n = take n (s ++ repeat ' ') curry-frontend-v0.4.2-8d20a558ca2967d0f5b4acfd160daa686d26e55b/src/CompilerOpts.hs000066400000000000000000000454521302651311700262330ustar00rootroot00000000000000{- | Module : $Header$ Description : Compiler options Copyright : (c) 2005 Martin Engelke 2007 Sebastian Fischer 2011 - 2016 Björn Peemöller License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module defines data structures holding options for the compilation of Curry programs, and utility functions for printing help information as well as parsing the command line arguments. -} module CompilerOpts ( Options (..), PrepOpts (..), WarnOpts (..), DebugOpts (..) , CymakeMode (..), Verbosity (..), TargetType (..) , WarnFlag (..), KnownExtension (..), DumpLevel (..), dumpLevel , defaultOptions, defaultPrepOpts, defaultWarnOpts, defaultDebugOpts , getCompilerOpts, updateOpts, usage ) where import Data.List (intercalate, nub) import Data.Maybe (isJust) import System.Console.GetOpt import System.Environment (getArgs, getProgName) import System.FilePath (addTrailingPathSeparator, normalise, splitSearchPath) import Curry.Files.Filenames (currySubdir) import Curry.Syntax.Extension -- ----------------------------------------------------------------------------- -- Option data structures -- ----------------------------------------------------------------------------- -- |Compiler options data Options = Options -- general { optMode :: CymakeMode -- ^ modus operandi , optVerbosity :: Verbosity -- ^ verbosity level -- compilation , optForce :: Bool -- ^ force (re-)compilation of target , optLibraryPaths :: [FilePath] -- ^ directories to search in -- for libraries , optImportPaths :: [FilePath] -- ^ directories to search in -- for imports , optHtmlDir :: Maybe FilePath -- ^ output directory for HTML , optUseSubdir :: Bool -- ^ use subdir for output? , optInterface :: Bool -- ^ create a FlatCurry interface file? , optPrepOpts :: PrepOpts -- ^ preprocessor options , optWarnOpts :: WarnOpts -- ^ warning options , optTargetTypes :: [TargetType] -- ^ what to generate , optExtensions :: [KnownExtension] -- ^ enabled language extensions , optDebugOpts :: DebugOpts -- ^ debug options } deriving Show -- |Preprocessor options data PrepOpts = PrepOpts { ppPreprocess :: Bool -- ^ apply custom preprocessor , ppCmd :: String -- ^ preprocessor command , ppOpts :: [String] -- ^ preprocessor options } deriving Show -- |Warning options data WarnOpts = WarnOpts { wnWarn :: Bool -- ^ show warnings? (legacy option) , wnWarnFlags :: [WarnFlag] -- ^ Warnings flags (see below) , wnWarnAsError :: Bool -- ^ Should warnings be treated as errors? } deriving Show -- |Debug options data DebugOpts = DebugOpts { dbDumpLevels :: [DumpLevel] -- ^ dump levels , dbDumpEnv :: Bool -- ^ dump compilation environment , dbDumpRaw :: Bool -- ^ dump data structure } deriving Show -- | Default compiler options defaultOptions :: Options defaultOptions = Options { optMode = ModeMake , optVerbosity = VerbStatus , optForce = False , optLibraryPaths = [] , optImportPaths = [] , optHtmlDir = Nothing , optUseSubdir = True , optInterface = True , optPrepOpts = defaultPrepOpts , optWarnOpts = defaultWarnOpts , optTargetTypes = [] , optExtensions = [] , optDebugOpts = defaultDebugOpts } -- | Default preprocessor options defaultPrepOpts :: PrepOpts defaultPrepOpts = PrepOpts { ppPreprocess = False , ppCmd = "" , ppOpts = [] } -- | Default warning options defaultWarnOpts :: WarnOpts defaultWarnOpts = WarnOpts { wnWarn = True , wnWarnFlags = stdWarnFlags , wnWarnAsError = False } -- | Default dump options defaultDebugOpts :: DebugOpts defaultDebugOpts = DebugOpts { dbDumpLevels = [] , dbDumpEnv = False , dbDumpRaw = False } -- |Modus operandi of the program data CymakeMode = ModeHelp -- ^ Show help information and exit | ModeVersion -- ^ Show version and exit | ModeNumericVersion -- ^ Show numeric version, suitable for later processing | ModeMake -- ^ Compile with dependencies deriving (Eq, Show) -- |Verbosity level data Verbosity = VerbQuiet -- ^ be quiet | VerbStatus -- ^ show status of compilation deriving (Eq, Ord, Show) -- |Description and flag of verbosities verbosities :: [(Verbosity, String, String)] verbosities = [ ( VerbQuiet , "0", "quiet" ) , ( VerbStatus, "1", "status") ] -- |Type of the target file data TargetType = Tokens -- ^ Source code tokens | Parsed -- ^ Parsed source code | FlatCurry -- ^ FlatCurry | ExtendedFlatCurry -- ^ Extended FlatCurry | AbstractCurry -- ^ AbstractCurry | UntypedAbstractCurry -- ^ Untyped AbstractCurry | Html -- ^ HTML documentation deriving (Eq, Show) -- |Warnings flags data WarnFlag = WarnMultipleImports -- ^ Warn for multiple imports | WarnDisjoinedRules -- ^ Warn for disjoined function rules | WarnUnusedGlobalBindings -- ^ Warn for unused global bindings | WarnUnusedBindings -- ^ Warn for unused local bindings | WarnNameShadowing -- ^ Warn for name shadowing | WarnOverlapping -- ^ Warn for overlapping rules/alternatives | WarnIncompletePatterns -- ^ Warn for incomplete pattern matching | WarnMissingSignatures -- ^ Warn for missing type signatures deriving (Eq, Bounded, Enum, Show) -- |Warning flags enabled by default stdWarnFlags :: [WarnFlag] stdWarnFlags = [ WarnMultipleImports , WarnDisjoinedRules --, WarnUnusedGlobalBindings , WarnUnusedBindings , WarnNameShadowing , WarnOverlapping , WarnIncompletePatterns, WarnMissingSignatures ] -- |Description and flag of warnings flags warnFlags :: [(WarnFlag, String, String)] warnFlags = [ ( WarnMultipleImports , "multiple-imports" , "multiple imports" ) , ( WarnDisjoinedRules , "disjoined-rules" , "disjoined function rules" ) , ( WarnUnusedGlobalBindings, "unused-global-bindings" , "unused bindings" ) , ( WarnUnusedBindings , "unused-bindings" , "unused bindings" ) , ( WarnNameShadowing , "name-shadowing" , "name shadowing" ) , ( WarnOverlapping , "overlapping" , "overlapping function rules" ) , ( WarnIncompletePatterns , "incomplete-patterns" , "incomplete pattern matching") , ( WarnMissingSignatures , "missing-signatures" , "missing type signatures" ) ] -- |Dump level data DumpLevel = DumpParsed -- ^ dump source code after parsing | DumpKindChecked -- ^ dump source code after kind checking | DumpSyntaxChecked -- ^ dump source code after syntax checking | DumpPrecChecked -- ^ dump source code after precedence checking | DumpTypeChecked -- ^ dump source code after type checking | DumpExportChecked -- ^ dump source code after export checking | DumpQualified -- ^ dump source after qualification | DumpDesugared -- ^ dump source after desugaring | DumpSimplified -- ^ dump source after simplification | DumpLifted -- ^ dump source after lambda-lifting | DumpTranslated -- ^ dump IL code after translation | DumpCaseCompleted -- ^ dump IL code after case completion | DumpFlatCurry -- ^ dump FlatCurry code (pretty-printed) deriving (Eq, Bounded, Enum, Show) -- |Description and flag of dump levels dumpLevel :: [(DumpLevel, String, String)] dumpLevel = [ (DumpParsed , "dump-parse", "parsing" ) , (DumpKindChecked , "dump-kc" , "kind checking" ) , (DumpSyntaxChecked, "dump-sc" , "syntax checking" ) , (DumpPrecChecked , "dump-pc" , "precedence checking" ) , (DumpTypeChecked , "dump-tc" , "type checking" ) , (DumpExportChecked, "dump-ec" , "export checking" ) , (DumpQualified , "dump-qual" , "qualification" ) , (DumpDesugared , "dump-ds" , "desugaring" ) , (DumpLifted , "dump-lift" , "lifting" ) , (DumpSimplified , "dump-simpl", "simplification" ) , (DumpTranslated , "dump-trans", "pattern matching compilation") , (DumpCaseCompleted, "dump-cc" , "case completion" ) , (DumpFlatCurry , "dump-flat" , "translation into FlatCurry" ) ] -- |Description and flag of language extensions extensions :: [(KnownExtension, String, String)] extensions = [ ( AnonFreeVars , "AnonFreeVars" , "enable anonymous free variables" ) , ( FunctionalPatterns, "FunctionalPatterns" , "enable functional patterns" ) , ( NegativeLiterals , "NegativeLiterals" , "desugar negated literals as negative literal") , ( NoImplicitPrelude , "NoImplicitPrelude" , "do not implicitly import the Prelude") ] -- ----------------------------------------------------------------------------- -- Parsing of the command line options. -- -- Because some flags require additional arguments, the structure is slightly -- more complicated to enable malformed arguments to be reported. -- ----------------------------------------------------------------------------- -- |Instead of just returning the resulting 'Options' structure, we also -- collect errors from arguments passed to specific options. type OptErr = (Options, [String]) -- |An 'OptErrTable' consists of a list of entries of the following form: -- * a flag to be recognized on the command line -- * an explanation text for the usage information -- * a modification funtion adjusting the options structure -- The type is parametric about the option's type to adjust. type OptErrTable opt = [(String, String, opt -> opt)] onOpts :: (Options -> Options) -> OptErr -> OptErr onOpts f (opts, errs) = (f opts, errs) onPrepOpts :: (PrepOpts -> PrepOpts) -> OptErr -> OptErr onPrepOpts f (opts, errs) = (opts { optPrepOpts = f (optPrepOpts opts) }, errs) onWarnOpts :: (WarnOpts -> WarnOpts) -> OptErr -> OptErr onWarnOpts f (opts, errs) = (opts { optWarnOpts = f (optWarnOpts opts) }, errs) onDebugOpts :: (DebugOpts -> DebugOpts) -> OptErr -> OptErr onDebugOpts f (opts, errs) = (opts { optDebugOpts = f (optDebugOpts opts) }, errs) withArg :: ((opt -> opt) -> OptErr -> OptErr) -> (String -> opt -> opt) -> String -> OptErr -> OptErr withArg lift f arg = lift (f arg) addErr :: String -> OptErr -> OptErr addErr err (opts, errs) = (opts, errs ++ [err]) mkOptDescr :: ((opt -> opt) -> OptErr -> OptErr) -> String -> [String] -> String -> String -> OptErrTable opt -> OptDescr (OptErr -> OptErr) mkOptDescr lift flags longFlags arg what tbl = Option flags longFlags (ReqArg (parseOptErr lift what tbl) arg) ("set " ++ what ++ " `" ++ arg ++ "', where `" ++ arg ++ "' is one of\n" ++ renderOptErrTable tbl) parseOptErr :: ((opt -> opt) -> OptErr -> OptErr) -> String -> OptErrTable opt -> String -> OptErr -> OptErr parseOptErr lift what table opt = case lookup3 opt table of Just f -> lift f Nothing -> addErr $ "unrecognized " ++ what ++ '`' : opt ++ "'\n" where lookup3 _ [] = Nothing lookup3 k ((k', _, v2) : kvs) | k == k' = Just v2 | otherwise = lookup3 k kvs renderOptErrTable :: OptErrTable opt -> String renderOptErrTable ds = intercalate "\n" $ map (\(k, d, _) -> " " ++ rpad maxLen k ++ ": " ++ d) ds where maxLen = maximum $ map (\(k, _, _) -> length k) ds rpad n x = x ++ replicate (n - length x) ' ' -- | All available compiler options options :: [OptDescr (OptErr -> OptErr)] options = -- modus operandi [ Option "h?" ["help"] (NoArg (onOpts $ \ opts -> opts { optMode = ModeHelp })) "display this help and exit" , Option "V" ["version"] (NoArg (onOpts $ \ opts -> opts { optMode = ModeVersion })) "show the version number and exit" , Option "" ["numeric-version"] (NoArg (onOpts $ \ opts -> opts { optMode = ModeNumericVersion })) "show the numeric version number and exit" -- verbosity , mkOptDescr onOpts "v" ["verbosity"] "n" "verbosity level" verbDescriptions , Option "q" ["no-verb"] (NoArg (onOpts $ \ opts -> opts { optVerbosity = VerbQuiet } )) "set verbosity level to quiet" -- compilation , Option "f" ["force"] (NoArg (onOpts $ \ opts -> opts { optForce = True })) "force compilation of target file" , Option "P" ["lib-dir"] (ReqArg (withArg onOpts $ \ arg opts -> opts { optLibraryPaths = nub $ optLibraryPaths opts ++ splitSearchPath arg}) "dir[:dir]") "search for libraries in dir[:dir]" , Option "i" ["import-dir"] (ReqArg (withArg onOpts $ \ arg opts -> opts { optImportPaths = nub $ optImportPaths opts ++ map (normalise . addTrailingPathSeparator) (splitSearchPath arg) }) "dir[:dir]") "search for imports in dir[:dir]" , Option [] ["htmldir"] (ReqArg (withArg onOpts $ \ arg opts -> opts { optHtmlDir = Just arg }) "dir") "write HTML documentation into directory `dir'" , Option "" ["no-subdir"] (NoArg (onOpts $ \ opts -> opts { optUseSubdir = False })) ("disable writing to `" ++ currySubdir ++ "' subdirectory") , Option "" ["no-intf"] (NoArg (onOpts $ \ opts -> opts { optInterface = False })) "do not create an interface file" -- legacy warning flags , Option "" ["no-warn"] (NoArg (onWarnOpts $ \ opts -> opts { wnWarn = False })) "do not print warnings" , Option "" ["no-overlap-warn"] (NoArg (onWarnOpts $ \ opts -> opts {wnWarnFlags = addFlag WarnOverlapping (wnWarnFlags opts) })) "do not print warnings for overlapping rules" -- target types , targetOption Tokens "tokens" "generate token stream" , targetOption Parsed "parse-only" "generate source representation" , targetOption FlatCurry "flat" "generate FlatCurry code" , targetOption ExtendedFlatCurry "extended-flat" "generate FlatCurry code with source references" , targetOption AbstractCurry "acy" "generate typed AbstractCurry" , targetOption UntypedAbstractCurry "uacy" "generate untyped AbstractCurry" , targetOption Html "html" "generate html documentation" , Option "F" [] (NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True })) "use custom preprocessor" , Option "" ["pgmF"] (ReqArg (withArg onPrepOpts $ \ arg opts -> opts { ppCmd = arg}) "cmd") "execute preprocessor command " , Option "" ["optF"] (ReqArg (withArg onPrepOpts $ \ arg opts -> opts { ppOpts = ppOpts opts ++ [arg]}) "option") "execute preprocessor with option